;;; -*- Mode: Lisp; Syntax: Common-lisp; Package: (PSEUDOSCHEME :USE (LISP) :SHADOW (+ - * / ASSOC CASE ERROR EVAL LAMBDA LET LET* LOOP MAKE-STRING MAP MEMBER NIL PEEK-CHAR PRINT READ READ-CHAR T WRITE)) -*-

;;; Written by Jonathan Rees, summer & fall 1986
;;;   with help from Eric Benson, Kent Pitman, and John Ramsdell.
;;; There is a separate docuemntation file, please read it.

(in-package 'pseudoscheme :use '(lisp))

(shadow '(
          + - * /
          assoc
	  case
	  error
	  eval
          lambda
	  let
	  let*
	  loop					;Symbolics Rel 7 loses
          make-string
          map
          member
	  nil
	  peek-char
	  print
          read
          read-char
	  t
          write
          ))

(export '(
	  declare-pseudoscheme-package
	  in-package
	  use-package
	  export         
	  import
	  provide        
	  require        
	  shadow         
	  trace untrace
	  compile-file
	  convert-arglist
	  describe
	  ed
	  scheme
	  ))

(eval-when (lisp:eval load compile)
(defconstant nil  lisp:nil)
(defconstant t	  lisp:t)
(defconstant else lisp:t)

(defparameter *preprocess?* nil)  ;set to t after bootstrap is complete
)

(eval-when (lisp:eval load compile)
(defun sharp-T-read-macro (stream subchar arg)
  #-Symbolics (declare (ignore stream subchar arg))
  #+Symbolics (progn stream subchar arg)
  t)

(defun sharp-F-read-macro (stream subchar arg)
  #-Symbolics (declare (ignore stream subchar arg))
  #+Symbolics (progn stream subchar arg)
  nil)

(defvar cl-sharp-sharp
	#+Symbolics #'(lisp:lambda (&rest ignore) (error "Symbolics loses"))
	#-Symbolics (get-dispatch-macro-character #\# #\#))

(defun sharp-sharp-read-macro (stream subchar arg)
  (cond (arg (funcall cl-sharp-sharp stream subchar arg))
	(t 'lisp:*)))

(set-dispatch-macro-character #\# #\# #'sharp-sharp-read-macro)
(set-dispatch-macro-character #\# #\T #'sharp-T-read-macro)
(set-dispatch-macro-character #\# #\F #'sharp-F-read-macro)

;;; Generally useful utility:

(defun concatenate-symbol (&rest things)
  (values (intern (apply #'concatenate 'string
                         (mapcar #'(lisp:lambda (thing)
                                     (if (numberp thing)
                                         (with-output-to-string (s) (princ thing s))
                                         (string thing)))
                                 things)))))

(defparameter concatenate-symbol #'concatenate-symbol)

;;; Implementing Scheme global variables well is not at all easy.

#|

For each global variable, we keep track of a "reference history"
and its current "definition method".

The reference history is some subset of the following keywords:
  :variable        x
  :setq            (setq x ...)
  :set!-globally   (set!-globally x ...)
  :function	   (x ...)   at a point when definition status
			     was  :function
  :macro	   (x ...)   at a point when definition status
			     was  :macro

The definition method is one of:
  :variable   (setq x ...) / (defun x (&rest args) (apply x args))
  :constant   (defconstant x ...)
  :function   (defun x ...)	   / (setq x #'x)
  :macro      (defmacro x ...)	   / (setq x #'x[closed])

Here's how we use this information:

1. When we see a reference to variable x, we may generate either
   x or #'x.
      Correctness considerations:
        -- x is always correct.
	-- #'x is correct iff definition status isn't :macro.
      Efficiency considerations:
	-- x is always preferable to #'x.

2. When we see a call (x ...), we may generate either
   (x ...) or (funcall x ...).
      Correctness considerations:
        -- (funcall x ...) is always correct.
        -- (x ...) is correct iff method isn't :constant.
      Efficiency considerations:
        -- (funcall x ...) is preferable if status is :variable.
        -- (x ...) is preferable otherwise.

3. When we see an assignment (set! x ...), we may generate either
   (setq x ...) or (set!-globally x ...).
      Correctness considerations:
        -- We are quite screwed if status is :macro.
        -- setq is correct only if status is (and/or will be) :variable.
	-- set!-globally is always correct.
      Efficiency considerations:
        -- Want (setq x ...) if at all possible.

4. When we see (define x ...), we can generate any of the variants
   enumerated above.
      Correctness considerations:
        -- :variable is always correct,
	-- :function is correct iff [rhs is lambda and] :setq isn't in
	   history,
        -- :macro is correct iff [rhs is lambda and] :function and :setq
	   aren't in history.
      Efficiency considerations:
        -- :variable is never preferable (unless :setq is in history,
	   in which case it's forced).
	-- :macro is always preferable when it's correct and the function
	   body is small.

It is possible to get screwed by this mechanism, if you compile a file
under one set of assumptions and then load it where an incompatible set
is in effect.

|#

(defun use-method (var method)
  (cond
   ((and (eq method :function)
	 (lisp:member :setq (get var 'history)))
    (cerror "proceed as if everything was all right"
	    "(DEFINE ~S ...) is being implemented as (DEFUN ~S ...), but~
	   ~%some previously generated code assumed that it was OK to~
	   ~%implement (SET! ~S ...) as (SETQ ~S ...)."
	    var var var var))
   ((and (eq method :macro)
	 (lisp:member :function (get var 'history)))
    (cerror "proceed as if everything was all right"
	    "(DEFINE ~S ...) is being implemented as (DEFMACRO ~S ...), but~
	   ~%some code containing a call (~S ...) was compiled before this
	   ~%definition was seen."
	    var var var)))
  (setf (get var 'method) method))

(defun record-variable-usage (var usage)
  (lisp:let ((h (get var 'history)))
    (if (not (lisp:member usage h))
	(setf (get var 'history)
	      (cons usage h)))))

(use-method 't   :variable)
(use-method 'nil :variable)

(defun lexical-name (var)
  (or (get var 'lexical-name)  ;Speed hacque
      (lisp:let ((*package* (symbol-package var)))
	(lisp:let ((lex (concatenate-symbol "." var)))
	  (setf (get var 'lexical-name) lex)
	  lex))))
);nehw-lave

;;; Scheme names database

(eval-when (lisp:eval load compile)
(defmacro entry-type (entry) `(car ,entry))
(defmacro entry-name (entry) `(cadr ,entry))
(defmacro entry-dests (entry) `(caddr ,entry))
(defmacro entry-provision (entry) `(cadddr ,entry))

(defun inherit? (entry)
  (and (eq (entry-type entry) 'proc)
       (lisp:member (entry-provision entry) '(cl ~cl))))

(defun renaming? (entry)
  (lisp:let ((prov (entry-provision entry)))
    (and (eq (entry-type entry) 'proc)
	 (consp prov)
	 (lisp:member (car prov) '(=cl ~cl)))))
);nehw-lave

(defun set-up-database-entry (entry)
  (lisp:let ((name (entry-name entry)))
    (setf (get name 'scheme-info) entry)
    (cond ((inherit? entry)
	   ;; Inheriting from CL -- just set the value cell.
	   (if (and (boundp name)
		    (not (eq (symbol-value name)
			     (symbol-function name))))
	       (cerror "clobber the value that's already there"
		       "package pollution! -- ~s is bound"
		       name))
	   (use-method name :function))
	  ((renaming? entry)
	   (lisp:let ((src (cadr (entry-provision entry))))
	     (if (and (boundp name)
		      (not (eq (symbol-value name)
			       (symbol-function src))))
		 (cerror "clobber value that's already there"
			 "package pollution! -- ~s is bound"
			 name))
	     (if (and (fboundp name)
		      (not (macro-function name)))
		 (cerror "clobber function that's already there"
			 "package pollution! -- ~s is defined"
			 name))
	     (use-method name :macro))))
    (entry-name entry)))

;;; DEFMACRO is the most reliable way to get efficient compilation.
;;; PROCLAIM INLINE may lose.

(defmacro define-scheme-database (&body db)
  `(progn 'compile
          (defparameter scheme-names
	    (mapcar #'set-up-database-entry ',db))
          ;; Work around @#%$$% 3600 bug.
	  ,@(lisp:let ((names (mapcar #'(lisp:lambda (entry)
					  (entry-name entry))
				      db)))
	      (if (< (length names) #+Symbolics 200 #-Symbolics 1000000)
		  `((export ',names))
		  `((export ',(subseq names 0 200))
		    (export ',(subseq names 200)))))
          ,@(mapcan #'(lisp:lambda (entry)
			(lisp:let ((name (entry-name entry)))
			  (cond ((inherit? entry)
				 `((defparameter ,name #',name)))
				((renaming? entry)
				 (lisp:let ((src
					     (cadr (entry-provision entry))))
				   `((defmacro ,name (&rest x) `(,',src ,@x))
				     (defparameter ,name #',src))))
				(t '()))))
		    db)))

;;; Entries within each major category are in alphabetical order.
;;; "ps" stands for "pseudoscheme".
;;; "DESTS" is a list of the dialects to which this feature belongs:
;;;    E = essential subset of Revised^3 Scheme
;;;    R = non-essential Revised^3 Scheme
;;;    T = Yale Scheme
;;;    M = MIT Scheme
;;;    S = used in Abelson & Sussman

(define-scheme-database
;;(TYPE   NAME                         (DESTS) PROVIDED-BY)
  (random else			       (E T S) ps)
  (binding nil			       (R T S) ps)
  (binding t			       (R T S) ps)
  (binding the-empty-stream            (    S) ps)
  (binding user-initial-environment    (    S) ps)
  (syntax and                          (R T  ) CL)
  (syntax begin                        (E    ) ps)
  (syntax case                         (R T  ) ps)
  (syntax cond                         (E T S) CL)
  (syntax cons-stream                  (    S) ps)
  (syntax define                       (E T S) ps)
  (syntax define-macro                 (  T  ) ps)
  (syntax delay                        (R T S) ps)
  (syntax do                           (R T  ) CL)
  (syntax if                           (E T S) CL)
  (syntax lambda                       (E T S) ps)
  (syntax let                          (E    ) ps)
  (syntax let*                         (R T  ) ps)
  (syntax letrec                       (E    ) ps)
  (syntax or                           (R T  ) CL)
  (syntax quasiquote                   (R    ) ps)
  (syntax quote                        (E T S) CL)
  (syntax sequence                     (    S) (= begin))
  (syntax set!                         (E    ) ps)
  (syntax unquote		       (     ) ps)
  (syntax unquote-splicing	       (     ) ps)
  (proc *                              (R T  ) (=CL lisp:*))
  (proc +                              (R T  ) (=CL lisp:+))
  (proc -1+                            (  T S) (=CL 1-))
  (proc -                              (R T  ) (=CL lisp:-))
  (proc /                              (E T S) (=CL lisp:/))
  (proc 1+                             (  T S) CL)
  (proc <=                             (E T S) CL)
  (proc <                              (E T S) CL)
  (proc =                              (E T S) CL)
  (proc >=                             (E T S) CL)
  (proc >                              (E T S) CL)
  (proc abs                            (E T S) CL)
  (proc acos                           (R T  ) CL)
  (proc angle			       (R    ) (=CL phase))
  (proc append                         (E T  ) CL)
  (proc apply                          (E T  ) ~CL)
  (proc asin                           (R T  ) CL)
  (proc assoc                          (E   S) ps)
  (proc assq                           (E T S) ps)
  (proc assv                           (E    ) (=CL lisp:assoc))
  (proc atan                           (R    ) CL)
  (proc atom?                          (  T S) (=CL atom))  ;Yuck
  (proc boolean?                       (E T  ) ps)
  (proc caaaar                         (E T S) CL)
  (proc caaadr                         (E T S) CL)
  (proc caaar                          (E T S) CL)
  (proc caadar                         (E T S) CL)
  (proc caaddr                         (E T S) CL)
  (proc caadr                          (E T S) CL)
  (proc caar                           (E T S) CL)
  (proc cadaar                         (E T S) CL)
  (proc cadadr                         (E T S) CL)
  (proc cadar                          (E T S) CL)
  (proc caddar                         (E T S) CL)
  (proc cadddr                         (E T S) CL)
  (proc caddr                          (E T S) CL)
  (proc cadr                           (E T S) CL)
  (proc call-with-current-continuation (E    ) ps)
  (proc call-with-input-file           (E    ) ps)
  (proc call-with-output-file          (E    ) ps)
  (proc car                            (E T S) CL)
  (proc cdaaar                         (E T S) CL)
  (proc cdaadr                         (E T S) CL)
  (proc cdaar                          (E T S) CL)
  (proc cdadar                         (E T S) CL)
  (proc cdaddr                         (E T S) CL)
  (proc cdadr                          (E T S) CL)
  (proc cdar                           (E T S) CL)
  (proc cddaar                         (E T S) CL)
  (proc cddadr                         (E T S) CL)
  (proc cddar                          (E T S) CL)
  (proc cdddar                         (E T S) CL)
  (proc cddddr                         (E T S) CL)
  (proc cdddr                          (E T S) CL)
  (proc cddr                           (E T S) CL)
  (proc cdr                            (E T S) CL)
  (proc ceiling                        (R    ) ~CL)
  (proc char->integer                  (E    ) (=CL char-code))
  (proc char-alphabetic?               (R    ) (=CL alpha-char-p))
  (proc char-ci<=?                     (R    ) (=CL char-not-greaterp))
  (proc char-ci<?                      (R    ) (=CL char-lessp))
  (proc char-ci=?                      (R    ) (=CL char-equal))
  (proc char-ci>=?                     (R    ) (=CL char-not-lessp))
  (proc char-ci>?                      (R    ) (=CL char-greaterp))
  (proc char-downcase                  (R    ) CL)
  (proc char-lower-case?               (R    ) (=CL lower-case-p))
  (proc char-numeric?                  (R    ) (=CL digit-char-p))
  (proc char-ready?		       (R    ) ?)
  (proc char-upcase                    (R    ) CL)
  (proc char-upper-case?               (R    ) (=CL upper-case-p))
  (proc char-whitespace?               (R    ) ps)
  (proc char<=?                        (E    ) (=CL char<=))
  (proc char<?                         (E    ) (=CL char<))
  (proc char=?                         (E    ) (=CL char=))
  (proc char>=?                        (E    ) (=CL char>=))
  (proc char>?                         (E    ) (=CL char>))
  (proc char?                          (E T  ) (=CL characterp))
  (proc close-input-port	       (R    ) (=CL close))
  (proc close-output-port	       (R    ) (=CL close))
  (proc complex?                       (E    ) (=CL numberp))
  (proc cons                           (E T S) CL)
  (proc cons*                          (  T  ) (=CL list*))  ;For quasiquote
  (proc cos                            (R T S) CL)
  (proc current-input-port             (E    ) ps)
  (proc current-output-port            (E    ) ps)
  (proc denominator		       (R    ) CL)
  (proc display                        (R T  ) (~CL princ))
  (proc empty-stream?                  (    S) (=CL null))
  (proc eof-object?                    (E    ) ps)
  (proc eq?                            (E T S) (=CL eq))
  (proc equal?                         (E    ) (=CL equal))
  (proc eqv?                           (E    ) (=CL eql))
  (proc error                          (  T S) ps)
  (proc eval                           (  T S) ps)
  (proc even?                          (E T  ) (=CL evenp))
  (proc exact?                         (E    ) ps)
  (proc exact->inexact                 (R    ) -)
  (proc expt                           (R T S) CL)
  (proc exp                            (R T S) CL)
  (proc floor                          (R    ) ~CL)
  (proc for-each                       (R    ) (~CL mapc))
  (proc force                          (R   S) ps)
  (proc gcd                            (R   S) CL)
  (proc head                           (    S) (=CL car))
  (proc imag-part		       (R    ) (=CL imagpart))
  (proc inexact?                       (E    ) ps)
  (proc inexact->exact                 (R    ) -)
  (proc input-port?                    (E    ) ps)
  (proc integer->char                  (E    ) (=CL code-char))
  (proc integer?                       (E T  ) (=CL integerp))
  (proc last-pair                      (R    ) (=CL last))
  (proc lcm                            (R    ) CL)
  (proc length                         (E T S) CL)
  (proc list                           (E T S) CL)
  (proc list->string                   (E T  ) ps)
  (proc list->vector                   (E T  ) ps)
  (proc list-ref                       (R    ) ps)
  (proc list-tail                      (R    ) ps)
  (proc load                           (E T  ) ~CL)
  (proc log                            (R T  ) CL)
  (proc magnitude		       (R    ) (=CL abs))
  (proc make-polar		       (R    ) ps)
  (proc make-rectangular	       (R    ) (=CL complex))
  (proc make-string                    (E T S) ps)
  (proc make-vector                    (E T S) ps)
  (proc map                            (R T  ) (~CL mapcar))
  (proc max                            (E T S) CL)
  (proc member                         (E T S) ps)
  (proc memq                           (E T S) ps)
  (proc memv                           (E    ) (=CL lisp:member))
  (proc min                            (E T S) CL)
  (proc modulo                         (R    ) (=CL mod))
  (proc negative?                      (E    ) (=CL minusp))
  (proc newline                        (E T  ) (=CL terpri))
  (proc not                            (E T S) CL)
  (proc null?                          (E T S) (=CL null))
  (proc number->string                 (R    ) ps)
  (proc number?                        (E T S) (=CL numberp))
  (proc numerator		       (R    ) CL)
  (proc odd?                           (E T  ) (=CL oddp))
  (proc open-input-file		       (R    ) ps)
  (proc open-output-file	       (R    ) ps)
  (proc output-port?                   (E    ) ps)
  (proc pair?                          (E T  ) (=CL consp))
  (proc positive?                      (E T  ) (=CL plusp))
  (proc pp			       (  T M) ps)
  (proc princ                          (    S) ~CL)
  ;; PRINT is incompatible between T and S&ICP.
  (proc prin1                          (    S) CL)
  (proc procedure?		       (E    ) ps)
  (proc quotient                       (E T S) ps)
  (proc random                         (    M) CL)
  (proc rational?                      (E T  ) (=CL rationalp))
  (proc rationalize                    (R    ) CL)
  (proc read-char                      (E T  ) ps)
  (proc read                           (E T  ) ps)
  (proc real?                          (E T  ) ps)
  (proc real-part		       (R    ) (=CL realpart))
  (proc remainder                      (E T S) (=CL rem))
  (proc reverse                        (R T  ) CL)
  (proc round                          (R    ) ~CL)
  (proc set-car!                       (E    ) ps)
  (proc set-cdr!                       (E    ) ps)
  (proc sin                            (R   S) CL)
  (proc sqrt                           (R T S) CL)
  (proc string->list                   (E T  ) ps)
  (proc string->number                 (R T  ) ps)
  (proc string->symbol                 (R T  ) ps)
  (proc string-append                  (E T  ) ps)
  (proc string-ci<=?                   (R    ) (=CL string-not-greaterp))
  (proc string-ci<?                    (R    ) (=CL string-lessp))
  (proc string-ci=?                    (R    ) (=CL string-equal))
  (proc string-ci>=?                   (R    ) (=CL string-not-lessp))
  (proc string-ci>?                    (R    ) (=CL string-greaterp))
  (proc string-copy		       (R    ) (=CL copy-seq))
  (proc string-fill!		       (R    ) (=CL fill))
  (proc string-length                  (E T  ) (=CL length))
  (proc string-ref                     (E    ) (=CL char))
  (proc string-set!		       (R    ) ps)
  (proc string<=?                      (E    ) (=CL string<=))
  (proc string<?                       (E    ) (=CL string<))
  (proc string=?                       (E    ) (=CL string=))
  (proc string>=?                      (E    ) (=CL string>=))
  (proc string>?                       (E    ) (=CL string>))
  (proc string?                        (E T  ) (=CL stringp))
  (proc substring                      (E    ) (=CL subseq))
  (proc symbol->string                 (E T  ) (=CL symbol-name))
  (proc symbol?                        (E T  ) ps)
  (proc tail                           (    S) ps)
  (proc tan                            (R T  ) CL)
  (proc transcript-on		       (R T  ) (=CL dribble))
  (proc transcript-off		       (R T  ) (=CL dribble))
  (proc truncate                       (R    ) ~CL)
  (proc vector->list                   (E T  ) ps)
  (proc vector-fill!		       (R    ) (=CL fill))
  (proc vector-length                  (E T  ) (=CL length))
  (proc vector-ref                     (E   S) (=CL svref))
  (proc vector-set!                    (E   S) ps)
  (proc vector?                        (E T  ) ps)
  (proc vector                         (E T  ) CL)
  (proc with-input-from-file           (R    ) ps)
  (proc with-output-to-file            (R    ) ps)
  (proc write-char                     (E    ) CL)
  (proc write                          (R    ) (~CL prin1))
  (proc zero?                          (E T  ) (=CL zerop))
  )

;;; Code manipulation utilities.

(eval-when (lisp:eval load compile)

;;; Set up for the type syntax extension

(defun rest? (params)
  (and (not (null params))
       (or (not (consp params))
           (eq (car params) '&rest)
           (eq (car params) '&body))))

(defun end? (params) (null params))
(defun parameter-name (param) (if (consp param) (car param) param))
(defun rest-parameter (params)
  (if (consp params) (cadr params) params))
(defun named? (param) param)

(defun convert-arglist (params mode &optional (optional-or-key nil))
  (cond ((rest? params)
         (lisp:let* ((p (rest-parameter params))
		     (name (if (named? p)
			       (parameter-name p)
			       'ignore)))
           (ecase mode
             ((apply)
              (list (if (named? p) name ''())))
             ((no-rest)
              '())
             ((scheme-lambda)
              name)
             ((defmacro)			;wonderful hack
              `(,(if (string= (symbol-name name) "BODY") '&body '&rest) ,name))
             ((cl-lambda)
              `(&rest ,name))
	     ((the-args)
	      (if (named? p) (list name) '())))))
        ((end? params)
         (ecase mode
           ((apply) '('()))
           ((no-rest scheme-lambda defmacro cl-lambda the-args) '())))
        (t
         (lisp:let ((param (car params)))
           (cond ((lisp:member param '(&optional &key))
                  (ecase mode
                    ((defmacro cl-lambda) params)
                    ((apply no-rest scheme-lambda the-args)
                     ;; Gross approximation!!!
                     (convert-arglist (cdr params) mode param))))
                 (t
                  (cons (parameter-name param)
                        (convert-arglist (cdr params) mode optional-or-key))))))))

(defun lambda-expression? (exp)
  (and (consp exp) (eq (car exp) 'lambda)))

(defun definition? (exp)
  (and (consp exp) (eq (car exp) 'define)))

(defun undefinify (body)
  (do ((e body (cdr e))
       (d '()
	  (lisp:let ((pat (cadr (car e)))
		     (bod (cddr (car e))))
	    (cons (if (consp pat)
		      `(,(car pat) (lambda ,(cdr pat) ,@bod))
		      (cdr (car e)))
		  d))))
      ((or (null (cdr e))
	   (not (definition? (car e))))
       (if (null d)
	   body
	   `((letrec ,(reverse d) ,@e))))))

(defun beginify (forms)
  (if (null (cdr forms)) (car forms) `(begin ,@forms)))

(defun maybe-preprocess (exp)
  (if *preprocess?* (preprocess-top exp) exp))

;;; Prevents repeated preprocessing.

(defun prevent-preprocessing (forms)
  `(macrolet ((scheme-expression (&rest form) form))
     ,@forms))

(defvar *allow-possibly-incorrect-speed-hacks?* nil)

(defun *---*? (var)
  (lisp:let ((s (symbol-name var)))
    (and (>= (length s) 3)
	 (char= (aref s 0) #\*)
	 (char= (aref s (- (length s) 1)) #\*))))

);nehw-lave

;;; It would take a while to explain how this hack works.  Trust me.

(defmacro scheme-expression (-ignore- &rest form)
  #+Symbolics -ignore-
  #-Symbolics (declare (ignore -ignore-))
  (prevent-preprocessing (list (maybe-preprocess form))))


;;; Definition forms: DEFINE, DEFINE-MACRO
;;; These can only occur at top level (what about inside a BEGIN?).

;;; Must use DEFVAR to inhibit "not declared special" warnings.

(defmacro define (pat &body body)
  (if (consp pat)
      `(define ,(car pat) (lambda ,(cdr pat) ,@body))
      (lisp:let* ((var pat)
		  (val (maybe-preprocess (car body)))
		  (h (get var 'history)))
	(cond ((or (lisp:member :setq h)
		   (*---*? var))
	       `(define[variable] ,var ,val))
	      ((and *allow-possibly-incorrect-speed-hacks?*
		    (not (lisp:member :function h))
		    (not (lisp:member :set!-globally h))
		    (or (and (lambda-expression? val)
			     (not (complicated? val)))
			(and (symbolp val)
			     (lisp:member (get val 'method)
					  '(:macro :function)))))
	       `(define[subst] ,var ,val))
	      ((lambda-expression? val)
	       `(define[function] ,var ,val))
	      ((and *allow-possibly-incorrect-speed-hacks?*
		    (number? val))
	       `(define[constant] ,var ,val))
	      (t
	       `(define[variable] ,var ,val))))))

(defmacro define[function] (var (-ignore- vars . body))
  #-Symbolics (declare (ignore -ignore-))  #+Symbolics -ignore-
  (use-method var :function)
  `(progn 'compile
	  (use-method ',var :function)
	  (defvar ,var)
	  (defun ,var ,(convert-arglist vars 'cl-lambda)
	    (definition-body ,vars ,@body))
	  (setq ,var #',var)
	  ',var))

(defmacro define[variable] (var val)
  (use-method var :variable)
  `(progn 'compile
	  (use-method ',var :variable)
	  (defvar ,var)
	  (setq ,var ,(prevent-preprocessing (list val)))
	  (defun ,var (&rest args)
	    (apply ,var args))))

(defmacro define[constant] (var val)
  (use-method var :constant)
  `(progn 'compile
	  (use-method ',var :constant)
	  (defconstant ,var ,(prevent-preprocessing (list val)))))

(defmacro define[subst] (pat &body body)
  (if (consp pat)
      `(define[subst] ,(car pat) (lambda ,(cdr pat) ,@body))
      (lisp:let ((var pat)
		 (val (car body)))
	(use-method var :macro)
	(if (lambda-expression? (car body))
	    (lisp:let* ((vars (cadr val))
			(body-exp (if (null (cdddr val))
				      (caddr val)
				      `(progn ,@(cddr val))))
			(aux-var (concatenate-symbol var '[closed]))
			(the-vars (convert-arglist vars 'the-args)))
	      `(progn 'compile
		      (use-method ',var :macro)
		      (defmacro ,var ,(convert-arglist vars 'defmacro)
			,(if (null the-vars)
			     `',body-exp
			     `(sublis (mapcar #'cons
					      ',the-vars
					      (list ,@the-vars))
				      ',body-exp)))
		      (defvar ,var)
		      (defun ,aux-var ,(convert-arglist vars 'cl-lambda)
			(definition-body ,vars ,@(cddr val)))
		      (setq ,var #',aux-var)
		      ',var))
	    `(progn 'compile
		    (use-method ',var :macro)
		    (defmacro ,var (&rest args)
		      `(,',val ,@args))
		    (defparameter ,var
		      ,(prevent-preprocessing (list val))))))))

(defmacro define-macro (pat &body body)
  (lisp:let* ((name (car pat))
	      (kludge (maybe-preprocess `(lambda ,(cdr pat) ,@body)))
	      (bvl (cadr kludge))
	      (body (cddr kludge)))
    `(progn 'compile
	    (defmacro ,name ,(convert-arglist bvl 'defmacro)
	      ,@body)
	    (eval-when (lisp:eval load compile)
	      (setf (get ',name 'scheme-macro) t))
	    ',name)))

(defmacro definition-body (vars &body body)
  (prevent-preprocessing `((lambda-body ,vars ,@body))))


;;; Pass 2 of Scheme->CL translation is accomplished by a bunch of CL
;;; macros.

;;; Special forms are in alphabetical order

(defmacro define-pseudo-macro (pat &body body)
  (lisp:let* ((name (car pat))
	      (aux-name (lisp:let ((*package* (find-package 'pseudoscheme)))
			  (concatenate-symbol name '-aux))))
    `(progn 'compile
	    (setf (get ',name 'aux-name) ',aux-name)
            (defmacro ,name ,(convert-arglist (cdr pat) 'defmacro)
	      `(scheme-expression ,',aux-name ,',name
		       ,@(list* ,@(convert-arglist (cdr pat) 'apply))))
            (defmacro ,aux-name (-ignore- ,@(convert-arglist (cdr pat) 'defmacro))
	      #+Symbolics -ignore-
	      #-Symbolics (declare (ignore -ignore-))
	      ,@body))))

(defmacro begin (&rest forms)  ;Allow for (begin (define ...) ...)
  `(progn 'compile ,@forms))

(defmacro call (&rest args)
  `(funcall ,@args))

(defmacro jcall (&rest args)
  `(funcall ,@args))

(define-pseudo-macro (case test-object . body)
  `(lisp:case ,test-object
     ,@(mapcar #'(lisp:lambda (clause)
                   (if (eq (car clause) 'else)
                       `(otherwise ,@(cdr clause))
                       clause))
               body)))

(define-pseudo-macro (cons-stream hd tl)
  `(cons ,hd (delay ,tl)))

(define-pseudo-macro (delay exp)
  `(make-delay :thunk-or-value #'(lisp:lambda () ,exp)))

;;; We can't just define a LISP:LAMBDA macro, since the host Common Lisp
;;; might define one of its own that shouldn't be clobberred.  (This is
;;; the case on the 3600.)

(define-pseudo-macro (lambda vars . body)
  `#'(lisp:lambda ,(convert-arglist vars 'cl-lambda)
       (lambda-body ,vars ,@body)))

;;; Used by pass-1 output

(define-pseudo-macro (allow-function-references vars . body)
  (if (null vars)
      (beginify body)
      `(macrolet ,(mapcar #'(lisp:lambda (var)
			      `(,var (&rest args)
				`(call ,',var ,@args)))
			  vars)
	 ,@body)))

;;; Needed by top-level DEFINE; makes bodies of lambda-expressions
;;; prettier for GRINDEF etc.

(defmacro lambda-body (vars &body body)
  #-Symbolics
  (declare (ignore vars))
  (lisp:let* ((body (undefinify body))
	      #+Symbolics
	      (rest-var (if (atom vars) vars (cdr (last vars)))))
    #-Symbolics
    (beginify body)
    #+Symbolics
    (if rest-var
        `(lisp:let ((,rest-var (copy-list ,rest-var)))
            ,@body)
        (beginify body))))

(define-pseudo-macro (let specs . body)
  (cond ((or (null specs) (consp specs))
	 ;; Normal case
	 `(lisp:let ,specs ,@(undefinify body)))
	(t
	 ;; Named LET
	 (lisp:let ((tag specs)
		    (specs (car body))
		    (body (cdr body)))
	   `(,(if *preprocess?* 'letrec 'letrec[tagbody])
	     ;; If preprocessor is turned off, be optimistic.
	     ((,tag (lambda ,(mapcar #'car specs)
		      ,@body)))
	     (,tag ,@(mapcar #'cadr specs)))))))

(define-pseudo-macro (let* specs . body)
  (cond ((null specs) (beginify body))
	(t `(let (,(car specs))
	      (let* ,(cdr specs) ,@body)))))

;;; There are three kinds of LETREC.  In the absence of further
;;; information we assume the worst.

;;; 1. Most general case

(define-pseudo-macro (letrec specs . body)
  `(let ,(mapcar #'(lisp:lambda (spec) `(,(car spec) ':undefined))
		 specs)
     (allow-function-references ,(mapcar #'car specs)
       ,@(mapcar #'(lisp:lambda (spec) `(setq ,@spec)) specs)
       ,@(undefinify body))))

;;; 2. Somewhat less general; SET! and non-functional references not
;;; allowed.

(defmacro letrec[labels] (specs &body body)
  `(lisp:labels ,(mapcar #'(lisp:lambda (spec)
			     (lisp:let ((var (car spec))
					(val (cadr spec)))
			       (cond ((lambda-expression? val)
				      `(,var ,(convert-arglist (cadr val) 'cl-lambda)
					  (lambda-body ,@(cdr val))))
				     (t
				      (cerror "ignore it"
					      "losing LETREC spec - ~s"
					      spec)
				      `(,var (&rest foo) foo)))))
			 specs)
     ,@body))

;;; 3. This is the interesting case: the LETREC is really a loop.  This
;;; only works if all calls to all the procedures are at the same
;;; tail-recursion level.

(defmacro letrec[tagbody] (specs &body body)
  #-TAIL-RECURSION-WINS
  (lisp:let* ((number-of-registers
		(apply #'max (mapcar #'(lisp:lambda (spec)
					 (length (cadr (cadr spec))))
				     specs)))
	      (registers
		(do ((i 0 (lisp:+ i 1))
		     (regs '() (cons (gensym "REG-") regs)))
		    ((= i number-of-registers) (reverse regs))))
	      (block-name (gensym "LETREC-")))
    `(lisp:block ,block-name
       (lisp:let ,registers
	 (macrolet ,(mapcar #'(lisp:lambda (spec)
				(lisp:let ((tag (car spec))
					   (vars (cadr (cadr spec))))
				  `(,tag ,vars
				    `(progn (setq ,@(list ,@(mapcan #'(lisp:lambda (reg var)
									`(',reg ,var))
								    registers
								    vars)))
					    (go ,',tag)))))
			    specs)
	   (tagbody
	     (return-from ,block-name ,(beginify (undefinify body)))
	     ,@(mapcan #'(lisp:lambda (spec)
			   (list (car spec)
				 `(return-from ,block-name
				    (let ,(mapcar #'list (cadr (cadr spec)) registers)
				      ,@(undefinify (cddr (cadr spec)))))))
		       specs))))))
  #+TAIL-RECURSION-WINS
  `(letrec[labels] ,specs ,@body))

(define-pseudo-macro (sequence . forms)
  `(begin ,@forms))

;;; Note that SET! on lambda-bound variables won't work in
;;; unpreprocessed programs.

(define-pseudo-macro (set! var val)
  (lisp:let ((method (get var 'method)))
    (cond ((or (null method) (eq method :variable))
	   ;; Be optimistic.
	   (record-variable-usage var :setq)
	   `(setq ,var ,val))
	  (t
	   (when (eq method :macro)
	     (cerror "proceed as if everything was OK"
		     "(DEFINE ~S ...) was implemented as (DEFMACRO ~S ...),~
		    ~%but (SET! ~S ...) was encountered"
		     var var var))
	   (record-variable-usage var :set!-globally)
	   `(set!-globally ',var ,val)))))

(defun set!-globally (var val)
  (record-variable-usage var :set!-globally)
  (setf (symbol-value var) val)
  (if (procedure? val)
      (setf (symbol-function var) val)
      (setf (symbol-function var)
	    #'(lisp:lambda (&rest args)
		(apply var args))))
  t)

;;; quasiquote

(define-pseudo-macro (quasiquote x)
  (expand-quasiquote x 0))

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

(define-pseudo-macro (unquote-splicing 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 'unquote-splicing)
	 (cerror "act as if () had been seen instead of ,@<form>"
		 ",@ in illegal context - ,@~s"
		 arg))
	(else (cons 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)
	 (descend-quasiquote-pair x (1+ level)))
	((interesting-to-quasiquote? x 'unquote)
	 (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 'unquote-splicing)
	 (cond ((= level 0)
		(values 'unquote-splicing (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 'unquote-splicing)
	     ;; (,@mumble ...)
	     (cond ((and (eq cdr-mode 'quote) (null cdr-arg))
		    (values 'unquote
			    car-arg))
		   ((eq cdr-mode 'append)
		    (values 'append
			    (cons car-arg cdr-arg)))
		   (else
		    (values 'append
			    (list car-arg (finalize-quasiquote cdr-mode cdr-arg))))))
	    ((and (eq cdr-mode 'quote) (null cdr-arg))
	     (values 'list
		     (list (finalize-quasiquote car-mode car-arg))))
	    ((or (eq cdr-mode '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?
;;; YES.  Parameterize descend-quasiquote-pair.

(define (descend-quasiquote-vector x level)
  (let 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, unquote-splicing, list, cons*
	     (loop (- i 1)
		   (cons mode modes)
		   (cons arg args)
		   (or flag (not (eq mode 'quote))))))
	  ((not flag)
	   (values x 'quote))
	  ((lisp:member 'unquote-splicing modes)
	   (values 'list->vector
		   (list (cons 'append
			       (mapcar (lambda (mode arg)
					 (cond ((eq mode 'unquote-splicing) 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 (consp x)
       (eq (car x) marker)
       (consp (cdr x))
       (null (cddr x))))

;;;; Procedures

(defmacro define-pseudo (pat &body body)
  `(define ,pat ,@body))

(defmacro define-pseudo[subst] (pat &body body)
  `(define[subst] ,pat ,@body))

(define-pseudo[subst] (assq obj list)
  (lisp:assoc obj list :test #'eq))

(define-pseudo[subst] (assoc obj list)
  (lisp:assoc obj list :test #'equal))

(define-pseudo[subst] (boolean? obj)
  (or (eq obj t) (eq obj nil)))

(define-pseudo[subst] (call-with-current-continuation proc)
  (block current-continuation
	 (call proc #'(lisp:lambda (val)
			(return-from current-continuation val)))))

(define-pseudo[subst] (call-with-input-file string proc)
  (with-open-file (port string :direction :input)
    (call proc port)))

(define-pseudo[subst] (call-with-output-file string proc)
  (with-open-file (port string :direction :output)
    (call proc port)))

(define-pseudo (char-whitespace? char)
  (or (char= char #\space)
      (not (graphic-char-p char))))

(define-pseudo[subst] (current-input-port)
  *standard-input*)

(define-pseudo[subst] (current-output-port)
  *standard-output*)

(define-pseudo[subst] (eof-object? obj)
  (eq obj 'eof-object))

(define-pseudo (error . items)
  (apply #'cerror
	 "Return from the call to the ERROR procedure"
	 (apply #'concatenate
		'string
		"~a"
		(mapcar #'(lisp:lambda (item)
			    #-Symbolics (declare (ignore item))
			    #+Symbolics item
			    "~%~s")
			(cdr items)))
	 items))

#+LispM
(setf (get 'error :error-reporter) t)  ;Thanks to KMP

(define-pseudo (eval obj env)
  env
  (lisp:eval (prevent-preprocessing (list (preprocess-top obj)))))

(define-pseudo (exact? num)
  num
  nil)

(defstruct (delay (:print-function print-delay) (:predicate delay?))
  (forced-yet? nil)
  thunk-or-value)

(defun print-delay (obj stream escape?)
  #-Symbolics (declare (ignore escape?))
  #+Symbolics escape?
  (if (delay-forced-yet? obj)
      (format stream "#{Forced ~S}" (delay-thunk-or-value obj))
      (format stream "#{Delayed}")))

(define-pseudo (force obj)
  (cond ((delay? obj)
         (lisp:let ((tv (delay-thunk-or-value obj)))
           (cond ((delay-forced-yet? obj) tv)
                 (t (lisp:let ((val (funcall tv)))
                      (setf (delay-thunk-or-value obj) val)
                      (setf (delay-forced-yet? obj) t)
                      val)))))
        (t obj)))

(define-pseudo (inexact? num)
  num
  t)

(define-pseudo (input-port? obj)
  (and (streamp obj) (input-stream-p obj)))

(define-pseudo[subst] (list->string list)
  (coerce list 'string))

(defvar the-empty-vector '#())

(define-pseudo (list->vector l)
  (if (null l)
      the-empty-vector
      (coerce l 'vector)))

(define-pseudo[subst] (list-ref list n)
  (nth n list))

(define-pseudo[subst] (list-tail list n)
  (nthcdr n list))

(defvar the-empty-string "")

(define-pseudo[subst] (make-polar r th)
  (* r (cis th)))

(define-pseudo (make-string size
                            &optional fill)
  (cond ((= size 0) the-empty-string)
        (fill (lisp:make-string size :initial-element fill))
        (t (lisp:make-string size))))

(define-pseudo (make-vector size
                            &optional
                            (fill '*uninitialized-vector-element*))
  (if (= size 0)
      the-empty-vector
      (make-sequence 'vector size :initial-element fill)))

(define-pseudo[subst] (memq obj list)
  (lisp:member obj list :test #'eq))

(define-pseudo[subst] (member obj list)
  (lisp:member obj list :test #'equal))

(define-pseudo (number->string num format)
  (if (not (and (consp format) (string= (symbol-name (car format)) "HEUR")))
      (cerror "act as if the format was (HEUR)"
              "unimplemented format: (NUMBER->STRING '~s '~s)"
              num format))
  (write-to-string num))

(define-pseudo[subst] (open-input-file string)
  (open string :direction :in))

(define-pseudo[subst] (open-output-file string)
  (open string :direction :out))

(define-pseudo (output-port? obj)
  (and (streamp obj) (output-stream-p obj)))

(define-pseudo (pp obj &optional (port *standard-input*))
  (lisp:let ((*print-pretty* t))
    (format port "~&")
    (lisp:print obj port)
    (values)))

(defconstant closures-might-be-conses?
	     (consp (lisp:eval '#'(lisp:lambda (x) x))))

(define-pseudo (procedure? obj)
  (and (functionp obj)
       (not (symbolp obj))
       (and (not closures-might-be-conses?)
	    (not (consp obj)))))

(define-pseudo[subst] (quotient n1 n2)
  (values (truncate n1 n2)))

(define-pseudo (read &optional (port *standard-input*))
  (lisp:read port nil 'eof-object))

(define-pseudo (read-char &optional (port *standard-input*))
  (lisp:read-char port nil 'eof-object))

(define-pseudo (real? obj)
  (and (numberp obj) (not (complexp obj))))

(define-pseudo[subst] (set-car! pair obj)
  (setf (car pair) obj))

(define-pseudo[subst] (set-cdr! pair obj)
  (setf (cdr pair) obj))

(define-pseudo[subst] (string->list string)
  (coerce string 'list))

(define-pseudo (string->number string exactness radix)
  exactness
  (let ((*read-base* (case radix
		       ((b) 2)
		       ((o) 8)
		       ((d) 10)
		       ((x) 16)
		       (else (error "bad radix arg to STRING->NUMBER"
				    radix)))))
    (with-input-from-string (s string)
      (read s))))  ;very crude approximation

(define-pseudo[subst] (string->symbol string)
  (values (intern string)))

(define-pseudo (string-append . strings)
  (apply #'concatenate 'string strings))

(define-pseudo[subst] (string-set! s k obj)
  (setf (aref (the simple-string s) k) obj))

(define-pseudo (symbol? x)
  (and x (symbolp x) (not (eq x t))))

(define-pseudo[subst] (tail stream)
  (force (cdr stream)))

(define-pseudo the-empty-stream '())

(define-pseudo user-initial-environment nil)

(define-pseudo (vector? obj)
  (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, bolixlisp, etc.
       #+(or tops-20 symbolics vax)
       (not (typep obj 'structure))))

(define-pseudo[subst] (vector->list vec)
  (coerce vec 'list))

(define-pseudo[subst] (vector-set! vec k obj)
  (setf (svref vec k) obj))

(define-pseudo[subst] (with-input-from-file string thunk)
  (with-open-file (*standard-input* string :direction :input)
    (call thunk)))

(define-pseudo[subst] (with-output-to-file string thunk)
  (with-open-file (*standard-output* string :direction :output)
    (call thunk)))

;;; Pass 1: Scheme -> readable-CL         [preprocessor]
;;; Pass 2: readable-CL -> executable-CL  [macros]

;;; Preprocessor to allow for combinations whose cars aren't symbols.

;;; There's the potential for doing a lot of translations and
;;; optimizations in a Scheme->CL preprocessor, but the idea is that we
;;; want to as little translation as possible in order that
;;; pretty-printing and debugging can work as smoothly as possible.  Too
;;; much translation was the downfall of the previous Scheme-in-CL
;;; implementation: programs were impossible to debug.

;;; Be careful -- the output of the preprocessor is Common Lisp, not
;;; Scheme.  Don't call the preprocessor twice on a given piece of
;;; code.

;;;  - Global SET!'s must clobber the function cell, but local ones don't.
;;;  - Annotate binding constructs to say when MACROLET's are needed for
;;;    variables occurring in function position.
;;;  - Detect absence of SET! and do some rudimentary tail recursion
;;;    analysis for optimization of LETREC.

;;; The rudiments of global tail recursion processing are here (CALL vs.
;;; JCALL) but don't imagine that tail recursion can be easily added.
;;; Two reasons:
;;;  (1) JCALL isn't inserted in all the places it needs to be, and
;;;  (2) it might be inserted in some places where it shouldn't be (I'm
;;;	 not sure).

;;; Bindings
;;; For each variable, we want to know:
;;;  Does it occur in value position?
;;;  Does it occur in function position?
;;;    If so, does it appear with a consistent continuation?
;;;  Does it occur in a SET! ?
;;; ENV is a list of (name val? fun? set?).

(defstruct (binding
	      (:conc-name lisp:nil)
	      (:predicate lisp:nil)
	      (:copier lisp:nil)
	      (:constructor make-binding (old-name new-name)))
  old-name
  new-name
  (value-references? nil)
  (function-references? nil)
  (assigned? nil)
  (continuation-when-called nil))

(define[subst] (bind-var var new-var env)
  (cons (make-binding var new-var) env))

(define (lookup name env)
  (locally (declare (optimize (speed 3) (safety 0)))
    (find name env :key #'old-name)))

(define[subst] (set-value-references?! binding)
  (setf (value-references? binding) t))

(define[subst] (set-function-references?! binding)
  (setf (function-references? binding) t))

(define[subst] (set-assigned?! binding)
  (setf (assigned? binding) t))

(define (set-continuation-when-called! binding want-k)
  (let ((have-k (continuation-when-called binding)))
    (cond ((null? have-k)
	   (setf (continuation-when-called binding) want-k))
	  ((not (eq? have-k want-k))
	   (setf (continuation-when-called binding) 'inconsistent)))))

;;; Preprocessor starts here.

(define (preprocess-top exp)
  (preprocess exp '() '(value)))

(define (preprocess exp env k)
  (cond ((symbol? exp)
	 (let ((probe (lookup exp env)))
	   (cond ((not probe)
		  (record-variable-usage exp :variable)
		  exp)    ;Free (i.e. global) variable
		 (t
		  (set-value-references?! probe)
		  (new-name probe)))))
	((not (pair? exp)) exp)
	((not (symbol? (car exp)))
	 `(,(if (eq? (car k) 'return) 'jcall 'call)
	   ,@(preprocess-list exp env)))
	((get (car exp) 'scheme-macro)
	 (preprocess (macroexpand-1 exp) env k))
	(else
	 (case (car exp)
	   ((begin sequence)
	    `(,(car exp) ,@(preprocess-sequence (cdr exp) env k)))
	   ((case)
	    `(case ,(preprocess (cadr exp) env '(value))
	       ,@(map (lambda (clause)
			`(,(car clause) ,@(preprocess-sequence (cdr clause) env k)))
		      (cddr exp))))
	   ((cond)
	    `(cond ,@(map (lambda (clause)
			    (cons (preprocess (car clause) env '(value))
				  (if (null? (cdr clause))
				      '()
				      (preprocess-sequence (cdr clause) env k))))
			  (cdr exp))))
	   ((do)
	    (preprocess-do exp env k))
	   ((lambda)
	    (let* ((vars (convert-arglist (cadr exp) 'the-args))
		   (new-vars (lexical-names vars))
		   (env (bind-vars vars new-vars env))
		   (body (preprocess-body (cddr exp) vars env
					  (if (eq? (car k) 'letrec)
					      (cadr k)
					      '(return)))))
	      `(lambda ,(lexical-names (cadr exp))
		 ,@body)))
	   ((let)
	    (preprocess-let exp env k))
	   ((let*)
	    (preprocess-let* exp env k))
	   ((letrec)
	    (preprocess-letrec exp env k))
	   ((quasiquote)
	    (preprocess (expand-quasiquote (cadr exp) 0) env k))
	   ((quote) exp)
	   ((set!)
	    (let* ((var (cadr exp))
		   (val (preprocess (caddr exp) env exp))
		   (probe (lookup var env)))
	      (cond (probe
		     (set-assigned?! probe)    ;assigned
		     `(setq ,(new-name probe) ,val))
		    (else
		     `(set! ,var ,val)))))
	   ((if)
	    `(if ,(preprocess (cadr exp) env '(value))
		 ,@(map (lambda (exp) (preprocess exp env k))
			(cddr exp))))
	   ((and or)
	    `(,(car exp)
	      ,@(if (null? (cdr exp))
		    '()
		    (preprocess-sequence (cdr exp) env k))))
	   ((cons-stream delay)
	    `(,(car exp) ,@(preprocess-list exp env)))
	   ((macrolet progn function lisp:let lisp:let* define setq call jcall)
	    (cerror "use the expression without preprocessing it"
		    "bogus input for Scheme->CL preprocessor -- ~s"
		    exp)
	    exp)
	   (else
	    (let* ((var (car exp))
		   (probe (lookup var env))
		   (args (preprocess-list (cdr exp) env)))
	      (cond (probe
		     (set-function-references?! probe)
		     (set-continuation-when-called! probe k)
		     `(,(new-name probe) ,@args))
		    ((or (memq (get var 'method) '(:variable :constant))
			 (memq :setq (get var 'history)))
		     (record-variable-usage var :variable)
		     `(,(if (eq? (car k) 'return) 'jcall 'call)
		       ,var ,@args))
		    (t
		     (if (eq? (get var 'method) :macro)
			 (record-variable-usage var :macro)
			 (record-variable-usage var :function))
		     `(,var ,@args)))))))))

(define (preprocess-let exp env k)
  (if (symbol? (cadr exp))
      (let ((tag (cadr exp))
	    (bindings (caddr exp)))
	(preprocess `(letrec ((,tag (lambda ,(map car bindings)
				      ,@(cdddr exp))))
		       (,tag ,@(map cadr bindings)))
		    env k))
      (let* ((vars (map car (cadr exp)))
	     (new-vars (lexical-names vars))
	     (bindings (preprocess-bindings (cadr exp) new-vars env))
	     (env (bind-vars vars new-vars env))
	     (body (preprocess-body (cddr exp) vars env k)))
	`(let ,bindings ,@body))))

(define (preprocess-bindings bindings new-vars env)
  (map (lambda (spec new-var)
	 `(,new-var ,(preprocess (cadr spec) env '(value))))
       bindings
       new-vars))

(define (preprocess-let* exp env k)
  (let loop ((old (cadr exp))
	     (new '())
	     (vars '())
	     (env env))
    (if (null? old)
	`(let* ,(reverse new)
	   ,@(preprocess-body (cddr exp) vars env k))
	(let* ((var (caar old))
	       (new-var (lexical-name var)))
	  (loop (cdr old)
		(cons (cons new-var
			    (preprocess-region (cdar old) vars env '(value)))
		      new)
		(cons var vars)
		(bind-var var new-var env))))))


;;; For an input expression (letrec ((f (arg) f-body)) body) we can generate
;;; any of three possible outputs.  In order of decreasing generality:
;;; 
;;; 	 Pass-1 (preproc.)	  Pass-2 output (macroexpansion)
;;;         output
;;; 
;;; 1.   (letrec ...)	          (let ((f :undefined))
;;; 				    (allow-function-references (f)
;;; 				      (setq f #'(lambda ...))
;;; 				      ...))
;;; 
;;; 2.	 (letrec[labels] ...)     (labels ((f ...)) ...)
;;; 
;;; 3.   (letrec[tagbody] ...)    (let ((reg))
;;;				    (tagbody ... f ... (setq reg ...) (go f) ...))

(define (preprocess-letrec exp env k)
  (let* ((vars (map car (cadr exp)))
	 (new-vars (lexical-names vars))
	 (env (bind-vars vars new-vars env))
	 (unique (list 'letrec-return))
	 (binding-cont  (list 'letrec unique))
	 (bindings (map (lambda (spec new-var)
			  `(,new-var ,(preprocess (cadr spec) env binding-cont)))
			(cadr exp)
			new-vars))
	 (body (preprocess-sequence (undefinify (cddr exp)) env unique))
	 (type
	   (cond ((null? bindings) 'let)
		 ((not (and (every (lambda (var)
				     (let ((z (lookup var env)))
				       ;; All refs are function refs.
				       (and (not (value-references? z))
					    (not (assigned? z)))))
				   vars)
			    (every (lambda (binding) (lambda-expression? (cadr binding)))
				   bindings)))
		  'letrec)
		 ((every (lambda (var) 
			   (let ((z (lookup var env)))
			     (eq? (continuation-when-called z) unique)))
			 vars)
		  (for-each (lambda (var)
			      (let ((z (lookup var env)))
				;; Permit nested lops
				(set-continuation-when-called! z k)))
			    vars)
		  'letrec[tagbody])
		 (else
		  `letrec[labels]))))
    `(,type ,bindings ,@body)))

(define (preprocess-do exp env k)
  (let* ((specs (cadr exp))
	 (vars (map car specs))
	 (new-vars (lexical-names vars))
	 (new-env (bind-vars vars new-vars env))
	 (end (caddr exp)))
    `(do ,(map (lambda (spec new-var)
		 `(,new-var
		   ,(preprocess (cadr spec) env '(value))
		   ,@(if (null? (cddr spec))
			 '()
			 (preprocess-region (cddr spec)
					    vars
					    new-env
					    '(value)))))
	       specs
	       new-vars)
	 (,@(preprocess-region (list (car end)) vars new-env '(value))
	  ,@(preprocess-region (cdr end) vars new-env k))
       ,@(if (null? (cdddr exp))
	     '()
	     (preprocess-region (cdddr exp) vars new-env '(ignore))))))

(define (preprocess-sequence exp-list env k)
  (cond ((null? (cdr exp-list))
	 (list (preprocess (car exp-list) env k)))
	(else
	 ;; Continuation can't be IGNORE -- this routine is also used
	 ;; by AND, OR, and DO
	 (cons (preprocess (car exp-list) env '(value))
	       (preprocess-sequence (cdr exp-list) env k)))))

(define (preprocess-list exp-list env)
  (map (lambda (exp) (preprocess exp env '(value)))
       exp-list))

(define (preprocess-body body vars env k)
  (preprocess-region (undefinify body) vars env k))

;;; Allow function references to VARS within the sequence BODY.
;;; The output is never a longer list than the input.

(define (preprocess-region body vars env k)
  (let* ((body (preprocess-sequence body env k))  ;side-affects env
	 (vars (function-vars vars env)))
    (if vars
	`((allow-function-references ,(convert-arglist vars 'no-rest)
	    ,@body))
	body)))

(define (function-vars vars env)
  (do ((v vars (cdr v))
       (f '() ;; A VAX LISP bug prevents the use of LET here.
	      (lisp:let ((z (lookup (car v) env)))
		(if (function-references? z)
		    (cons (new-name z) f)
		    f))))
      ((null? v) f)))

(define (lexical-names vars)			;deal with dotted
  (cond ((pair? vars)
	 (cons (lexical-name (car vars))
	       (lexical-names (cdr vars))))
	((symbol? vars) (lexical-name vars))
	(else vars)))

(define (bind-vars vars new-vars env)
  (do ((vars vars (cdr vars))
       (new-vars new-vars (cdr new-vars))
       (env env (bind-var (car vars) (car new-vars) env)))
      ((null? vars) env)))

;;; Gross kludge for guessing when it's OK to substitute.

(define (proper-list? thing)
  (or (null? thing)
      (and (pair? thing)
	   (null? (cdr (last-pair thing))))))

(define (complicated? lambda-exp)
  (let ((vars (cadr lambda-exp))
	(body (cddr lambda-exp))
	(var-count 0))
    (or (not (proper-list? vars))
	(letrec ((count
		  (lambda (exp)
		    (cond ((pair? exp)
			   (do ((n 0 (+ n (count (car l))))
				(l exp (cdr l)))
			       ((null? l) n)))
			  ((memq exp vars)
			   (set! var-count (+ var-count 1)))
			  (t 1)))))
	  (or (> (count body) 10)
	      (> var-count (length vars)))))))



;;; Adapted from OZ:<DAM.PROVER>METAP.LISP.2.  Thanks to DAM for
;;; figuring this out.

#+Symbolics
(progn 'compile
(setf (get 'define              'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-macro        'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-pseudo       'zwei:definition-function-spec-type) 'defun)
(setf (get 'define-pseudo-macro 'zwei:definition-function-spec-type) 'defun)

;The value of the property ZWEI:DEFINITION-FUNCTION-SPEC-FINDER
;should be a function which takes the ZWEI point after the definition
;symbol (e.g. DEFINE) and returns the point at the begining of the fspec.
;See the function ZWEI:GET-DEFINITION-FUNCTION-SPEC

;DEFINE-FSPEC-FINDER goes forward to the begining of the next atom.
;This means skipping white space and left parenthesis.

(defun define-fspec-finder (bp)
  (zwei:forward-over (cons (if (numberp (car zwei:*whitespace-chars*))
			       40.
			       #\()
			   zwei:*whitespace-chars*)
		     bp))
(setf (get 'define              'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-macro        'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-pseudo       'zwei:definition-function-spec-finder) #'define-fspec-finder)
(setf (get 'define-pseudo-macro 'zwei:definition-function-spec-finder) #'define-fspec-finder)
)


#+Symbolics (zl:setq-standard-value si:*prinarray* t)
#-Symbolics (setq *print-array* t)

(defun quasiquote-read-macro (stream c)
  #+Symbolics c #-Symbolics (declare (ignore c))
  (list 'quasiquote (lisp:read stream t nil t)))

(defun unquote-read-macro (stream c)
  #+Symbolics c #-Symbolics (declare (ignore c))
  (list (lisp:let ((following-char
		     (lisp:peek-char nil stream nil stream t)))
	  (cond ((char= following-char #\@)
		 (read-char stream)
		 'unquote-splicing)
		(t 'unquote)))
	(lisp:read stream t nil t)))

(set-macro-character #\` #'quasiquote-read-macro)
(set-macro-character #\, #'unquote-read-macro)

#+Symbolics             ;This stuff still doesn't make PP work.
(progn 'compile
(zl:defprop quasiquote grind-quasiquote si:grind-macro)
(defun grind-quasiquote (exp loc) loc
  (si:gtyo #.(zl:character (char-code #\`)))
  (si:grind-form (cadr exp) (zl:locf (cadr exp))))
(zl:defprop unquote grind-unquote si:grind-macro)
(defun grind-unquote (exp loc) loc
  (si:gtyo #.(zl:character (char-code #\,)))
  (si:grind-form (cadr exp) (zl:locf (cadr exp))))
(zl:defprop unquote-splicing grind-unquote-splicing si:grind-macro)
(defun grind-unquote-splicing (exp loc) loc
  (si:gtyo #.(zl:character (char-code #\,)))
  (si:gtyo #.(zl:character (char-code #\@)))
  (si:grind-form (cadr exp) (zl:locf (cadr exp))))
)

#+(and VAX VMS)
(progn 'compile
(system::define-list-print-function quasiquote (list stream)
  (declare (list list))
  (if (= (length list) 2)
      (format stream "`~W" (second list))
      (format stream "~1!~@{~W~^ ~:_~}~." list)))

(system::define-list-print-function unquote (list stream)
  (declare (list list))
  (if (= (length list) 2)
      (format stream ",~W" (second list))
      (format stream "~1!~@{~W~^ ~:_~}~." list)))

(system::define-list-print-function unquote-splicing (list stream)
  (declare (list list))
  (if (= (length list) 2)
      (format stream ",@~W" (second list))
      (format stream "~1!~@{~W~^ ~:_~}~." list)))
);ngorp

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

#+Symbolics
(lisp:let ((type (zl:string *scheme-source-file-type*)))
  (cond ((not (lisp: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

;;; 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*))

;;;

(defun declare-pseudoscheme-package (pkg)
  #-Symbolics (declare (ignore pkg))
  #+Symbolics (pushnew (if (packagep pkg) pkg (find-package pkg))
                       si:*reasonable-packages*)
  t)

(defun scheme ()
  #+Symbolics
  (zl:setq-standard-value zl:package (find-package 'scheme))
  #-Symbolics
  (set! *package* (find-package 'scheme))
  'scheme)

(setq *preprocess?* t)

(provide "pseudoscheme")

(in-package 'scheme :use '(pseudoscheme))
(declare-pseudoscheme-package 'scheme)