RABBIT.scm

;;- -*-scheme-*-
;;; rabbit compiler

;;- This is the source code to the RABBIT Scheme compiler, by Guy Steele,
;;- taken from the Indiana Scheme repository and annotated by me, Darius
;;- Bacon.  I converted it from all-uppercase to all-lowercase and
;;- reindented it with Emacs for better readability.  I've added the
;;- comments starting with either ;- or ;*.  Other comments are by Steele.
;;- The ;- comments were things I'd figured out, while ;* denoted things
;;- for me to look into.  (Sometimes I didn't bother to type in the answer 
;;- to ;* questions, since these notes were mainly for my own benefit and
;;- no one else's, at the time.)  I also made a few other cosmetic changes
;;- to the code, like changing |foo| to "foo" so that Emacs's indenting/coloring
;;- would understand things.

;;- I went to the trouble of annotating this for the sake of understanding
;;- it.  The primary source, which you should read first, is:

;;- Guy Lewis Steele, Jr.. "RABBIT: A Compiler for SCHEME". Masters
;;- Thesis. MIT AI Lab. AI Lab Technical Report AITR-474. May 1978.
;;- Available at http://library.readscheme.org/page1.html

;;- If I'd had access to that thesis way back when, I wouldn't have had to
;;- do this.  Hell, if I'd *known* he had detailed page-by-page notes on
;;- the code in there, I would have gone to the trouble of ordering a
;;- bound copy or something.  Oh, well -- at least I found a few bugs this
;;- way.  Perhaps some others of these notes here will also be of
;;- interest.


;;- Some archaisms in the version of Scheme used and compiled:
;;- (block exp ...) for (begin exp ...)
;;- (labels ...) for (letrec ...)
;;- (catch var exp ...) for (call/cc (lambda (var) exp ...))
;;- (set (quote var) exp) for (set! var exp) where var is global
;;- (aset (quote var) exp) for (set! var exp) where var is local
;;- nil is both false and the empty list.
;;- Assumes (car nil) = (cdr nil) = nil.
;;- (lambda vars body name) suggests a runtime name of NAME for the function.
;;-   (The value of the function is the expression BODY.)

;;- Constructs used in the target language (MACLISP):
;;- prog
;;- go
;;- return
;;- progn
;;- cond
;;- setq
;;- ((lambda ...) ...)
;;- data-manipulation primitives
;;- cons car cdr rplaca rplacd -- used to construct environments

;;- PROG is never nested; there is only a single, outer PROG.
;;- RETURN is used only in (RETURN NIL) to exit that PROG.

;;- LAMBDA is used mainly to implement parallel assignment.
;;- Also for trivial applications of trivial functions.

;;- Maclisp has a zillion different kinds of distinguished function
;;- objects (expr, subr, lsubr, etc., etc.)  Scheme compiled functions are
;;- represented by a CBETA.

;;- CBETAs use registers: **CONT** **ONE** **TWO** ... **EIGHT** to pass
;;- the continuation and the arguments.  If there are more than 8
;;- arguments, then they are all passed as a list in **ONE** and the
;;- remaining argument registers are ignored.

;;- To call a function, put its function object in **FUN**, its arguments
;;- as described above, and the number of args in **NARGS**.  Then return
;;- control to the function-dispatcher.

;;- If the function is a continuation, you needn't set **CONT** or **NARGS**
;;- since it takes just one, ordinary, argument.

;;- A CBETA form looks like this: (CBETA code-address . environment)
;;- The function dispatcher (``UUO handler'') puts the environment in **ENV**
;;- and then transfers to code-address.  When the dispatcher gets control back
;;- it expects things set up for the next call, as described above.

;;- For functions compiled by RABBIT, the environment field above consists
;;- of a prog-tag followed by the `real' environment (a list of variable values).
;;- So the code-address is constant within a given module.

;;- There's a set of ``memory locations'' -11- -12- -13- ... used locally
;;- within each module.  RABBIT outputs a maclisp declaration of which
;;- ones get used for each function.  The only other variables in the
;;- target code are globals explicitly referenced by the user.

;;- ``LABELS-closed functions can also be treated in this way, [call to it
;;- from a known call site can just lop off a prefix of the current 
;;- environment] if one closes all the functions in the same way (which
;;- RABBIT presently does, but this is not always desirable.)''

;;- ``Debunking the Expensive Procedure Call Myth'' is AI Memo 443.



(declare (fasload (quux) schmac))
(declare (macros t) (newio t))
(declare (defun displace (x y) y))

;;- All functions defined in this file.

(declare (special 
	  empty trivfn gentemp genflush gen-global-name print-warning addprop delprop setprop
	  adjoin union intersect remove setdiff pairlis compile pass1-analyze test-compile
	  nodify alphatize alpha-atom alpha-lambda alpha-if alpha-aset alpha-catch
	  alpha-labels alpha-labels-defn alpha-block macro-expand alpha-combination
	  env-analyze triv-analyze triv-analyze-fn-p effs-analyze effs-union effs-analyze-if
	  effs-analyze-combination check-combination-peffs erase-nodes meta-evaluate
	  meta-if-fudge meta-combination-trivfn meta-combination-lambda subst-candidate
	  reanalyze1 effs-intersect effectless effectless-except-cons passable
	  meta-substitute copy-code copy-nodes cnodify convert make-return convert-lambda-fm
	  convert-if convert-aset convert-catch convert-labels convert-combination
	  cenv-analyze cenv-triv-analyze cenv-ccombination-analyze bind-analyze refd-vars
	  bind-analyze-clambda bind-analyze-continuation bind-analyze-cif bind-analyze-caset
	  bind-analyze-clabels bind-analyze-return bind-analyze-ccombination
	  bind-ccombination-analyze depth-analyze filter-closerefs close-analyze compilate
	  deprognify1 temploc envcarcdr regslist set-up-asetvars comp-body produce-if
	  produce-aset produce-labels produce-lambda-combination produce-trivfn-combination
	  produce-trivfn-combination-continuation produce-trivfn-combination-cvariable
	  produce-combination produce-combination-variable adjust-knownfn-cenv
	  produce-continuation-return produce-return produce-return-1 lambdacate psetqify
	  psetqify-method-2 psetqify-method-3 psetq-args psetq-args-env psetq-temps
	  mapanalyze analyze analyze-clambda analyze-continuation analyze-cif analyze-clabels
	  analyze-ccombination analyze-return lookupicate cons-closerefs output-aset
	  condicate decarcdrate trivialize triv-lambdacate compilate-one-function
	  compilate-loop used-templocs remark-on map-user-names comfile transduce
	  process-form process-define-form process-definition cleanup sexprfy csexprfy
	  check-number-of-args dumpit stats reset-stats init-rabbit))

;;- Global variables used in this file.

(declare (special 
	  *empty* *gentempnum* *gentemplist* *global-gen-prefix* *error-count* *error-list*
	  *test* *testing* *optimize* *reanalyze* *substitute* *fudge* *new-fudge*
	  *single-subst* *lambda-subst* *flush-args* *stat-vars* *dead-count* *fudge-count*
	  *fold-count* *flush-count* *convert-count* *subst-count* *deprognify-count*
	  *lambda-body-subst* *lambda-body-subst-try-count* *lambda-body-subst-success-count*
	  *check-peffs* **cont+arg-regs** **env+cont+arg-regs** **argument-registers**
	  **number-of-arg-regs** *buffer-random-forms* *displace-sw*))

;;- A number of the parameters above aren't defined in this file --
;;- **cont+arg-regs** **env+cont+arg-regs** **argument-registers** **number-of-arg-regs**

(proclaim (*expr print-short)
	  (set' *buffer-random-forms* nil))

(set' *stat-vars* '(*dead-count* *fudge-count* *fold-count* *flush-count* *convert-count*
		    *subst-count* *deprognify-count* *lambda-body-subst-try-count*
		    *lambda-body-subst-success-count*))

(declare (/@define define "scheme function")) ;declarations for listing program
(declare (/@define defmac "maclisp macro"))
(declare (/@define schmac "pdp-10 scheme macro"))
(declare (/@define macro "scheme macro"))

;;- *EMPTY* tags uninitialized slots in structures.

(cond ((not (boundp '*empty*))
       (set' *empty* (list '*empty*))))

(define empty
  (lambda (x) (eq x *empty*)))


;;- True iff SYM is globally bound to a primitive procedure in the initial environment.
;;- (Assignments to such bindings are prohibited.)

(define trivfn
  (lambda (sym)
    (getl sym '(expr subr lsubr *expr *lexpr))))


(defmac increment (x) `(aset' ,x (+ ,x 1)))

;;- Make a symbol that's the catenation of the args.

(defmac catenate args
  `(implode (append ,@(mapcar '(lambda (x)
				 (cond ((or (atom x) (not (eq (car x) 'quote)))
					`(exploden ,x))
				       (t `(quote ,(exploden (cadr x))))))
			      args))))


(cond ((not (boundp '*gentempnum*))
       (set' *gentempnum* 0)))

(cond ((not (boundp '*gentemplist*))
       (set' *gentemplist* nil)))

;;- Return a fresh symbol starting with X.

(define gentemp
  (lambda (x)
    (block (increment *gentempnum*)
	   (let ((sym (catenate x '"-" *gentempnum*)))
	     (aset' *gentemplist* (cons sym *gentemplist*)) sym))))

;;- Remove all gentemp symbols from the Maclisp obarray.

(define genflush
  (lambda ()
    (block (amapc remob *gentemplist*)
	   (aset' *gentemplist* nil))))

(define gen-global-name
  (lambda () (gentemp *global-gen-prefix*)))

(set' *global-gen-prefix* '"?")

(defmac warn (msg . stuff)
  `(print-warning ',msg (list ,@stuff)))

(define print-warning
  (lambda (msg stuff)
    (block (increment *error-count*)
	   (aset' *error-list* (cons (cons msg stuff) *error-list*))
	   (tyo 7 (symeval 'tyo))	;bell
	   (terpri (symeval 'tyo))
	   (princ '";warning: " (symeval 'tyo))
	   (tyo 7 (symeval 'tyo))	;bell
	   (princ msg (symeval 'tyo))
	   (amapc print-short stuff))))

(defun print-short (x)
  ((lambda (prinlevel prinlength terpri)
     (terpri (symeval 'tyo))
     (princ '"; " (symeval 'tyo))
     (prin1 x (symeval 'tyo)))
   3 8 t))


;;- Prompt with MSG and return the response read.

(schmac ask (msg)
	`(block (terpri) (princ ',msg) (tyo 40) (read)))


(defmac sx (x) `(sprinter (sexprfy ,x nil))) ;debugging aid
(defmac csx (x) `(sprinter (csexprfy ,x))) ;debugging aid


;;- Restricted form of CASE with one symbol per clause, and error on non-match.

(defmac eqcase (obj . cases)
  `(cond ,@(mapcar '(lambda (case)
		      (or (atom (car case))
			  (error '"losing eqcase clause"))
		      `((eq ,obj ',(car case)) ,@(cdr case)))
		   cases)
	 (t (error '"losing eqcase" ,obj 'fail-act))))

(declare (/@define accessfn "access macro"))

;;- Structure macro help functions.

(defmac accessfn (name uvars fetch . put)
  ((lambda (vars cname)
     (do ((a vars (cdr a))
	  (b '*z* `(cdr ,b))
	  (c nil (cons `(car ,b) c)))
	 ((null a)
	  `(progn 'compile
		  (defmac ,name *z*
		    ((lambda ,(nreverse (cdr (reverse vars)))
		       ,fetch)
		     ,@(reverse (cdr c))))
		  (defmac ,cname *z*
		    ((lambda ,vars
		       ,(cond (put (car put))
			      (t ``(clobber ,,fetch
					    ,the-new-value))))
		     ,@(reverse c)))))))
   (cond (put uvars)
	 (t (append uvars '(the-new-value))))
   (catenate '"clobber-" name)))

(defmac clobber (x y)
  `(,(catenate '"clobber-" (car x)) ,@(cdr x) ,y))

(declare (/@define hunkfn "hunk access macro"))

(defmac hunkfn (name slot)
  `(accessfn ,name (the-hunk new-value)
	     `(cxr ,,slot ,the-hunk)
	     `(rplacx ,,slot ,the-hunk ,new-value)))

(declare (/@define deftype "data type"))

;;; slot 0 is always the property list, and slot 1 the hunk type.

(hunkfn type 1)

;;- Define a structure type.
;;- NAME is the type name (referred to as the hunk type, above).
;;- SLOTS is a list of slot names.
;;- SUPP is an optional subset of SLOTS that PRINT should ignore (I think).
;;- Uninitialized slots get set to *EMPTY*.

(defmac deftype (name slots supp)
  `(progn 'compile
	  (defmac ,(catenate '"cons-" name) kwds
	    (progn (do ((k kwds (cdr k)))
		       ((null k))
		     (or ,(cond ((cdr slots) `(memq (caar k) ',slots))
				(t `(eq (caar k) ',(car slots))))
			 (error ',(catenate '"invalid keyword argument to cons-"
					    name)
				(car k)
				'fail-act)))
		   `(hunk ',',name
			  ,@(do ((s ',slots (cdr s))
				 (x nil
				    (cons ((lambda (kwd)
					     (cond (kwd (car (last kwd)))
						   (t '*empty*)))
					   (assq (car s) kwds))
					  x)))
				((null s) (nreverse x)))
			  nil)))
	  (defmac ,(catenate '"alter-" name) (obj . kwds)
	    (progn (do ((k kwds (cdr k)))
		       ((null k))
		     (or ,(cond ((cdr slots) `(memq (caar k) ',slots))
				(t `(eq (caar k) ',(car slots))))
			 (error ',(catenate '"invalid keyword argument to alter-"
					    name)
				(car k)
				'fail-act)))
		   (do ((i (+ (length kwds) 1) (- i 1))
			(vars nil (cons (gensym) vars)))
		       ((= i 0)
			`((lambda ,vars
			    ,(blockify
			      (mapcar '(lambda (k v)
					 `(clobber (,(catenate ',name
							       '"\ " ;**
							       (car k))
						    (,(car vars)))
						   (,v)))
				      kwds
				      (cdr vars))))
			  (lambda () ,obj)
			  ,@(mapcar '(lambda (k) `(lambda () ,(car (last k))))
				    kwds))))))
	  ,@(do ((s slots (cdr s))
		 (n 2 (+ n 1))
		 (x nil (cons `(hunkfn ,(catenate name '"." (car s))
				       ,n)
			      x)))
		((null s) (nreverse x)))
	  (defprop ,name ,slots component-names)
	  (defprop ,name ,supp suppressed-component-names)
	  '(type ,name defined)))

;;; add to a property which is a list of things

(define addprop
  (lambda (sym val prop)
    (let ((l (get sym prop)))
      (if (not (memq val l))
	  (putprop sym (cons val l) prop)))))

;;; inverse of addprop

(define delprop
  (lambda (sym val prop)
    (putprop sym (delq val (get sym prop)) prop)))

;;; like putprop, but insist on not changing a value already there

(define setprop
  (lambda (sym val prop)
    (let ((l (getl sym (list prop))))
      (if (and l (not (eq val (cadr l))))
	  (error '"attempt to redefine a unique property"
		 (list 'setprop sym val prop)
		 'fail-act)
	  (putprop sym val prop)))))

;;; operations on sets, represented as lists

(define adjoin
  (lambda (x s)
    (if (memq x s) s (cons x s))))

(define union
  (lambda (x y)
    (do ((z y (cdr z))
	 (v x (adjoin (car z) v)))
	((null z) v))))

(define intersect
  (lambda (x y)
    (if (null x)
	nil
	(if (memq (car x) y)
	    (cons (car x) (intersect (cdr x) y))
	    (intersect (cdr x) y)))))

(define remove
  (lambda (x s)
    (if (null s)
	s
	(if (eq x (car s))
	    (cdr s)
	    ((lambda (y)
	       (if (eq y (cdr s)) s
		   (cons (car s) y)))
	     (remove x (cdr s)))))))

(define setdiff
  (lambda (x y)
    (do ((z x (cdr z))
	 (w nil (if (memq (car z) y)
		    w
		    (cons (car z) w))))
	((null z) w))))

(define pairlis
  (lambda (l1 l2 l)
    (do ((v l1 (cdr v))
	 (u l2 (cdr u))
	 (e l (cons (list (car v) (car u)) e)))
	((null v) e))))


;;- Compile one function from source, returning the object expression.
;;- SEE-CRUD is a debugging flag.  
;;- OPTIMIZE is T, MAYBE, or NIL.
;;- The pass structure is: 
;;-   arg-count check -> alpha convert and nodify -> (meta-evaluate | pass1-analyze)
;;-   -> cps -> {cenv,bind,depth,close}-analyze -> compilate-one-function.

;;- (pass1-analyze always gets done, since meta-evaluate also calls it.)

;;- Why do we do meta-evaluate on a non-cps representation?  Why not do everything
;;- with one representation?  Maybe it's because the tree language is noncommital
;;- about order of argument evaluation.

;;- It appears that top-level functions are compiled one at a time, with ones not
;;- seen yet assumed to possibly do anything.

(define compile
  (lambda (name lambda-exp see-crud optimize)
    (block (check-number-of-args name
				 (length (cadr lambda-exp))
				 t)
	   (let ((alpha-version (alphatize lambda-exp nil)))
	     (if (and see-crud (ask "see alpha-conversion?"))
		 (sx alpha-version))
	     (let ((opt (if (eq optimize 'maybe)
			    (ask "optimize?")
			    optimize)))
	       (let ((meta-version
		      (if opt
			  (meta-evaluate alpha-version)
			  (pass1-analyze alpha-version nil nil))))
		 (or (and (null (node.refs meta-version))
			  (null (node.asets meta-version)))
		     (error '"env-analyze lost - compile"
			    name
			    'fail-act))
		 (if (and see-crud opt (ask "see meta-evaluation?"))
		     (sx meta-version))
		 (let ((cps-version (convert meta-version nil (not (null opt)))))
		   (if (and see-crud (ask "see cps-conversion?"))
		       (csx cps-version))
		   (cenv-analyze cps-version nil nil)
		   (bind-analyze cps-version nil nil)
		   (depth-analyze cps-version 0)
		   (close-analyze cps-version nil)
		   (compilate-one-function cps-version name))))))))

;;- The meaning of REDO is explained in the comment for ENV-ANALYZE.

(define pass1-analyze
  (lambda (node redo opt)
    (block (env-analyze node redo)
	   (triv-analyze node redo)
	   (if opt (effs-analyze node redo))
	   node)))


(schmac cl (fnname) `(test-compile ',fnname))

(define test-compile
  (lambda (fnname)
    (let ((fn (get fnname 'scheme!function)))
      (cond (fn (aset' *testing* t)
		(aset' *test* nil)	;purely to release former garbage
		(aset' *error-count* 0)
		(aset' *error-list* nil)
		(aset' *test* (compile fnname fn t 'maybe))
		(sprinter *test*)
		`(,(if (zerop *error-count*) 'no *error-count*) errors))
	    (t `(,fnname not defined))))))

;;; alpha-conversion

;;; here we rename all variables, and convert the expression to an equivalent tree-like form
;;; with extra slots to be filled in later.  after this point, the new names are used for
;;; variables, and the user names are used only for error messages and the like.  the tree-like
;;; form will be used and augmented until it is converted to continuation-passing style.

;;; we also find all user-named lambda-forms and set up appropriate properties.
;;; the user can name a lambda-form by writing (lambda (x) body name).

;;- Also we check correctness of concrete syntax, and warn of argument-count mismatches
;;- in calls to known globally-bound procs.

;;- Somewhat oddly, we *don't* set the user-name property of variables in this phase.
;;- That's in env-analyze instead where all the other properties get set.

(deftype node (name sexpr env refs asets trivp effs affd peffs paffd metap substp form) (sexpr))
;name:		a gensym which names the node's value
;sexpr:		the s-expression which was alphatized to make this node
;		(used only for warning messages and debugging)
;env:		the environment of the node (used only for debugging)
;refs:		all variables bound above and referenced below or by the node
;asets:		all local variables seen in an aset below this node (a subset of refs)
;trivp: 	non-nil iff evaluation of this node is trivial
;effs:		set of side effects possibly occurring at this node or below
;affd:		set of side effects which can possibly affect this node or below
;peffs:		absolutely provable set of effs
;paffd:		absolutely provable set of affd
;metap:		non-nil iff this node has been examined by the meta-evaluator
;substp:	flag indicating whether meta-substitute actually made a substitution
;form:		one of the below types

;;- PEFFS and PAFFD are used only to warn the user about argument evaluation order
;;- dependencies.

(deftype constant (value))
;value:	the s-expression value of the constant

(deftype variable (var globalp))
;var:		the new unique name for the variable, generated by alphatize.
;		the user name and other information is on its property list.
;globalp:  	nil unless the variable is global (in which case var is the actual name)

;;* Why is globalp a property of the node instead of the variable?  
;;* Same question for aset.

(deftype lambda (uvars vars body))
;uvars:		the user names for the bound variables (strictly for debugging (see sexprfy))
;vars:		a list of the generated unique names for the bound variables
;body:		the node for the body of the lambda-expression

(deftype if (pred con alt))
;pred:		the node for the predicate
;con:		the node for the consequent
;alt:		the node for the alternative

(deftype aset (var body globalp))
;var:		the generated unique name for the aset variable
;body:		the node for the body of the aset
;globalp:  	nil unless the variable is global (in which case var is the actual name)

(deftype catch (uvar var body))
;uvar:		the user name for the bound variable (strictly for debugging (see sexprfy))
;var:		the generated unique name for the bound variable
;body:		the node for the body of the catch

(deftype labels (ufnvars fnvars fndefs body))
;ufnvars:  	the user names for the bound labels variables
;fnvars:  	a list of the generated unique names for the labels variables
;fndefs:  	a list of the nodes for the lambda-expressions
;body:		the node for the boy of the labels

(deftype combination (args warnp))
;args:		a list of the nodes for the arguments (the first is the function)
;warnp:		non-nil iff check-combination-peffs has detected a conflict in this combination

;;- We often special-case combinations with either a variable or a lambda for the 
;;- function.  ;;* elaborate on this

(define nodify
  (lambda (form sexpr env)
    (let ((n (cons-node (name = (gentemp 'node))
			(form = form)
			(sexpr = sexpr)
			(env = env)
			(metap = nil))))
      (putprop (node.name n) n 'node)
      n)))

;;; on node names these properties are created:
;;;	node		the corresponding node

;;- Concrete syntax:
;;- number | T | NIL
;;- var
;;- (quote sexpr)
;;- (lambda (var*) exp)   -- looks like . variables aren't allowed
;;- (if exp exp exp)      -- presumably maclisp car/cdr give nil subexpressions by default
;;- (aset (quote var) exp)
;;- (catch var exp)
;;- (labels (decl*) exp)
;;- where decl = (var exp) or (var (var*) exp+) or ((var var*) exp+)
;;- (block exp+)
;;- (<macro> sexpr*)
;;- (exp exp*)

;;- SEXPR may also be a node, or contain nodes at some level -- these are
;;- passed through unchanged.  This is a convenience so that source-level
;;- transformations can be expressed in concrete syntax in the code and
;;- then passed through alphatize -- see META-IF-FUDGE, for example.

(define alphatize
  (lambda (sexpr env)
    (cond ((atom sexpr)
	   (alpha-atom sexpr env))
	  ((hunkp sexpr)
	   (if (eq (type sexpr) 'node)
	       sexpr
	       (error '"peculiar hunk - alphatize" sexpr 'fail-act)))
	  ((eq (car sexpr) 'quote)
	   (nodify (cons-constant (value = (cadr sexpr))) sexpr env))
	  ((eq (car sexpr) 'lambda)
	   (alpha-lambda sexpr env))
	  ((eq (car sexpr) 'if)
	   (alpha-if sexpr env))
	  ((eq (car sexpr) 'aset)
	   (alpha-aset sexpr env))
	  ((eq (car sexpr) 'catch)
	   (alpha-catch sexpr env))
	  ((eq (car sexpr) 'labels)
	   (alpha-labels sexpr env))
	  ((eq (car sexpr) 'block)
	   (alpha-block sexpr env))
	  ((and (atom (car sexpr))
		(eq (get (car sexpr) 'aint) 'amacro))
	   (alphatize (macro-expand sexpr) env))
	  (t (alpha-combination sexpr env)))))

(define alpha-atom
  (lambda (sexpr env)
    (if (or (numberp sexpr) (null sexpr) (eq sexpr 't))
	(nodify (cons-constant (value = sexpr)) sexpr env)
	(let ((slot (assq sexpr env)))
	  (nodify (cons-variable (var = (if slot (cadr slot) sexpr))
				 (globalp = (null slot)))
		  sexpr
		  env)))))

(define alpha-lambda
  (lambda (sexpr env)
    (let ((vars (do ((i (length (cadr sexpr)) (- i 1))
		     (v nil (cons (gentemp 'var) v)))
		    ((= i 0) (nreverse v)))))
      (if (cdddr sexpr)
	  (warn "malformed lambda expression" sexpr))
      (nodify (cons-lambda (uvars = (append (cadr sexpr) nil))
			   ;;see meta-combination-lambda
			   ;;- i.e. UVARS is a copy because later it gets mutated
			   (vars = vars)
			   (body = (alphatize (caddr sexpr)
					      (pairlis (cadr sexpr)
						       vars
						       env))))
	      sexpr
	      env))))

(define alpha-if
  (lambda (sexpr env)
    (nodify (cons-if (pred = (alphatize (cadr sexpr) env))
		     (con = (alphatize (caddr sexpr) env))
		     (alt = (alphatize (cadddr sexpr) env)))
	    sexpr
	    env)))

(define alpha-aset
  (lambda (sexpr env)
    (let ((var (cond ((or (atom (cadr sexpr))
			  (not (eq (caadr sexpr) 'quote)))
		      (error '"can't compile non-quoted aset variable"
			     sexpr
			     'fail-act))
		     (t (cadadr sexpr)))))
      (let ((slot (assq var env)))
	(if (and (null slot) (trivfn var))
	    (error '"illegal to aset a maclisp primitive"
		   sexpr
		   'fail-act))
	(nodify (cons-aset (var = (if slot (cadr slot) var))
			   (globalp = (null slot))
			   (body = (alphatize (caddr sexpr) env)))
		sexpr
		env)))))

(define alpha-catch
  (lambda (sexpr env)
    (let ((var (gentemp 'catchvar)))
      (nodify (cons-catch (var = var)
			  (uvar = (cadr sexpr))
			  (body = (alphatize (caddr sexpr)
					     (cons (list (cadr sexpr) var)
						   env))))
	      sexpr
	      env))))

(define alpha-labels
  (lambda (sexpr env)
    (let ((ufnvars (amapcar (lambda (x)
			      (if (atom (car x))
				  (car x)
				  (caar x)))
			    (cadr sexpr))))
      (let ((fnvars (do ((i (length ufnvars) (- i 1))
			 (v nil (cons (gentemp 'fnvar) v)))
			((= i 0) (nreverse v)))))
	(let ((lenv (pairlis ufnvars fnvars env)))
	  (nodify (cons-labels (ufnvars = ufnvars)
			       (fnvars = fnvars)
			       (fndefs = (amapcar
					  (lambda (x)
					    (alpha-labels-defn x lenv))
					  (cadr sexpr)))
			       (body = (alphatize (caddr sexpr) lenv)))
		  sexpr
		  env))))))

;;* BLOCKIFY doesn't seem to be defined...
;;* but anyway the meaning is obvious.

(define alpha-labels-defn
  (lambda (ldef lenv)
    (alphatize (if (atom (car ldef))
		   (if (cddr ldef)
		       `(lambda ,(cadr ldef) ,(blockify (cddr ldef)))
		       (cadr ldef))
		   `(lambda ,(cdar ldef) ,(blockify (cdr ldef))))
	       lenv)))

;;- Since there's no BLOCK node type, we macroexpand it.

(define alpha-block
  (lambda (sexpr env)
    (cond ((null (cdr sexpr))
	   (warn "block with no forms"
		 `(env = ,(amapcar car env)))
	   (alphatize nil env))
	  (t (labels ((mung
		       (lambda (body)
			 (if (null (cdr body))
			     (car body)
			     `((lambda (a b) (b))
			       ,(car body)
			       (lambda () ,(mung (cdr body))))))))
	       (alphatize (mung (cdr sexpr)) env))))))

(define macro-expand
  (lambda (sexpr)
    (let ((m (getl (car sexpr) '(macro amacro smacro))))
      (if (null m)
	  (block (warn "missing macro definition" sexpr)
		 `(error '"undefined macro form" ',sexpr 'fail-act))
	  (eqcase (car m)
	    (macro (funcall (cadr m) sexpr))
	    (amacro (funcall (cadr m) sexpr))
	    (smacro ((symeval (cadr m)) sexpr)))))))

(define alpha-combination
  (lambda (sexpr env)
    (let ((n (nodify (cons-combination
		      (warnp = nil)
		      (args = (amapcar (lambda (x) (alphatize x env))
				       sexpr)))
		     sexpr
		     env)))
      (let ((m (node.form (car (combination.args (node.form n))))))
	(if (and (eq (type m) 'variable)
		 (variable.globalp m))
	    (check-number-of-args
	     (variable.var m)
	     (length (cdr (combination.args (node.form n))))
	     nil))
	n))))

;;; environment analysis.

;;; for nodes encountered we fill in:
;;;	refs
;;;	asets
;;; on variable names these properties are created:
;;;	binding		the node where the variable is bound
;;;	user-name	the user's name for the variable (where bound)
;;;	read-refs	variable nodes which read the variable
;;;	write-refs	aset nodes which set the variable

;;- The refs and asets slots only keep track of local variables,
;;- because globals could be set anywhere -- we have no closed-world
;;- assumption.

;;; normally, on recurring to a lower node we stop if the information
;;; is already there.  making the parameter `redothis` be `all` forces
;;; re-computation to all levels; making it `once` forces
;;; recomputation of this node but not of subnodes.

;;- This doesn't make use of any other analyses' results.

;;** need a list of all variable properties -- oh, see (cleanup)
;;- fn-side-effects
;;- fn-side-affected
;;- okay-to-fold
;;- binding

(define env-analyze
  (lambda (node redothis)
    (if (or redothis (empty (node.refs node)))
	(let ((fm (node.form node))
	      (redo (if (eq redothis 'all) 'all nil)))
	  (eqcase (type fm)
	    (constant
	     (alter-node node
			 (refs := nil)
			 (asets := nil)))
	    (variable
	     (addprop (variable.var fm) node 'read-refs)
	     (if (variable.globalp fm)
		 (setprop (variable.var fm) (variable.var fm) 'user-name))
	     (alter-node node
			 (refs := (and (not (variable.globalp fm))
				       (list (variable.var fm))))
			 (asets := nil)))
	    (lambda
	     (do ((v (lambda.vars fm) (cdr v))
		  (uv (lambda.uvars fm) (cdr uv)))
		 ((null v))
	       (setprop (car v) (car uv) 'user-name)
	       (setprop (car v) node 'binding))
	     (let ((b (lambda.body fm)))
	       (env-analyze b redo)
	       (alter-node node
			   (refs := (setdiff (node.refs b)
					     (lambda.vars fm)))
			   (asets := (setdiff (node.asets b)
					      (lambda.vars fm))))))
	    (if
	     (let ((pred (if.pred fm))
		   (con (if.con fm))
		   (alt (if.alt fm)))
	       (env-analyze pred redo)
	       (env-analyze con redo)
	       (env-analyze alt redo)
	       (alter-node node
			   (refs := (union (node.refs pred)
					   (union (node.refs con)
						  (node.refs alt))))
			   (asets := (union (node.asets pred)
					    (union (node.asets con)
						   (node.asets alt)))))))
	    (aset
	     (let ((b (aset.body fm))
		   (v (aset.var fm)))
	       (env-analyze b redo)
	       (addprop v node 'write-refs)
	       (if (aset.globalp fm)
		   (alter-node node
			       (refs := (node.refs b))
			       (asets := (node.asets b)))
		   (alter-node node
			       (refs := (adjoin v (node.refs b)))
			       (asets := (adjoin v (node.asets b)))))))
	    (catch
	     (let ((b (catch.body fm))
		   (v (catch.var fm)))
	       (setprop v (catch.uvar fm) 'user-name)
	       (setprop v node 'binding)
	       (env-analyze b redo)
	       (alter-node node
			   (refs := (remove v (node.refs b)))
			   (asets := (remove v (node.asets b))))))
	    (labels
	     (do ((v (labels.fnvars fm) (cdr v))
		  (uv (labels.ufnvars fm) (cdr uv))
		  (d (labels.fndefs fm) (cdr d))
		  (r nil (union r (node.refs (car d))))
		  (a nil (union a (node.asets (car d)))))
		 ((null v)
		  (let ((b (labels.body fm)))
		    (env-analyze b redo)
		    (alter-node node
				(refs := (setdiff
					  (union r (node.refs b))
					  (labels.fnvars fm)))
				(asets := (setdiff
					   (union a (node.asets b))
					   (labels.fnvars fm))))))
	       (setprop (car v) (car uv) 'user-name)
	       (setprop (car v) node 'binding)
	       (env-analyze (car d) redo)))
	    (combination
	     (let ((args (combination.args fm)))
	       (amapc (lambda (x) (env-analyze x redo)) args)
	       (do ((a args (cdr a))
		    (r nil (union r (node.refs (car a))))
		    (s nil (union s (node.asets (car a)))))
		   ((null a)
		    (alter-node node
				(refs := r)
				(asets := s)))))))))))

;;; triviality analysis

;;; for nodes encountered we fill in:
;;;	trivp

;;; a combination is trivial iff all arguments are trivial, and
;;; the function can be proved to be trivial.  we assume closures
;;; to be non-trivial in this context, so that the convert function
;;; will be forced to examine them.

;;- This doesn't make use of any other analyses' results.

(define triv-analyze
  (lambda (node redothis)
    (if (or redothis (empty (node.trivp node)))
	(let ((fm (node.form node))
	      (redo (if (eq redothis 'all) 'all nil)))
	  (eqcase (type fm)
	    (constant
	     (alter-node node (trivp := t)))
	    (variable
	     (alter-node node (trivp := t)))
	    (lambda
	     (triv-analyze (lambda.body fm) redo)
	     (alter-node node (trivp := nil)))
	    (if
	     (triv-analyze (if.pred fm) redo)
	     (triv-analyze (if.con fm) redo)
	     (triv-analyze (if.alt fm) redo)
	     (alter-node node
			 (trivp := (and (node.trivp (if.pred fm))
					(node.trivp (if.con fm))
					(node.trivp (if.alt fm))))))
	    (aset
	     (triv-analyze (aset.body fm) redo)
	     (alter-node node (trivp := (node.trivp (aset.body fm)))))
	    (catch
	     (triv-analyze (catch.body fm) redo)
	     (alter-node node (trivp := nil)))
	    (labels
	     (amapc (lambda (f) (triv-analyze f redo))
		    (labels.fndefs fm))
	     (triv-analyze (labels.body fm) redo)
	     (alter-node node (trivp := nil)))
	    (combination
	     (let ((args (combination.args fm)))
	       (triv-analyze (car args) redo)
	       (do ((a (cdr args) (cdr a))
		    (sw t (and sw (node.trivp (car a)))))
		   ((null a)
		    (alter-node node
				(trivp := (and sw
					       (triv-analyze-fn-p
						(car args))))))
		 (triv-analyze (car a) redo)))))))))

(define triv-analyze-fn-p
  (lambda (fn)
    (or (and (eq (type (node.form fn)) 'variable)
	     (trivfn (variable.var (node.form fn))))
	(and (eq (type (node.form fn)) 'lambda)
	     (node.trivp (lambda.body (node.form fn)))))))

;;; side-effects analysis
;;; for nodes encountered we fill in:  effs, affd, peffs, paffd
;;; a set of side effects may be either 'none or 'any, or a set.

;;* Why 'none instead of '()?
;;- GLS answers:
;;- My vague memory is that I used 'none rather than () for sets
;;- of effects because I was worried that () could be confused with
;;- "false" somehow.  I'm not sure that's a problem in the code as
;;- it actually stands, but maybe I had not yet invented *empty*.
;;- I forget.

;;- Possible effects/affects: setq (global), aset (local), cons, rplaca, rplacd, file

;;- Hypothesis: cons is never in affd.
;;- (except in that affd can by 'any)

;;- This uses the write-refs property computed by env-analyze.

(define effs-analyze
  (lambda (node redothis)
    (if (or redothis (empty (node.effs node)))
	(let ((fm (node.form node))
	      (redo (if (eq redothis 'all) 'all nil)))
	  (eqcase (type fm)
	    (constant
	     (alter-node node
			 (effs := 'none)
			 (affd := 'none)
			 (peffs := 'none)
			 (paffd := 'none)))
	    (variable
	     (let ((a (cond ((variable.globalp fm) '(setq))
			    ((get (variable.var fm) 'write-refs) '(aset))
			    (t 'none))))
	       (alter-node node
			   (effs := 'none)
			   (affd := a)
			   (peffs := 'none)
			   (paffd := a))))
	    (lambda
	     (effs-analyze (lambda.body fm) redo)
	     (alter-node node
			 (effs := '(cons))
			 (affd := nil)
			 (peffs := '(cons))
			 (paffd := nil)))
	    (if (effs-analyze-if node fm redo))
	    (aset
	     (effs-analyze (aset.body fm) redo)
	     (let ((aseteffs (if (aset.globalp fm)
				 '(setq)
				 '(aset))))
	       (alter-node node
			   (effs := (effs-union aseteffs
						(node.effs (aset.body fm))))
			   (affd := (node.affd (aset.body fm)))
			   (peffs := (effs-union aseteffs
						 (node.peffs (aset.body fm))))
			   (paffd := (node.paffd (aset.body fm))))))
	    (catch
	     (effs-analyze (catch.body fm) redo)
	     (alter-node node
			 (effs := (node.effs (catch.body fm)))
			 (affd := (node.affd (catch.body fm)))
			 (peffs := (node.peffs (catch.body fm)))
			 (paffd := (node.paffd (catch.body fm)))))
	    (labels
	     (amapc (lambda (f) (effs-analyze f redo))
		    (labels.fndefs fm))
	     (effs-analyze (labels.body fm) redo)
	     (alter-node node
			 (effs := (effs-union '(cons)
					      (node.effs (labels.body fm))))
			 (affd := (node.affd (labels.body fm)))
			 (peffs := (effs-union '(cons)
					       (node.peffs (labels.body fm))))
			 (paffd := (node.paffd (labels.body fm)))))
	    (combination
	     (effs-analyze-combination node fm redo)))))))

(define effs-union
  (lambda (a b)
    (cond ((eq a 'none) b)
	  ((eq b 'none) a)
	  ((eq a 'any) 'any)
	  ((eq b 'any) 'any)
	  (t (union a b)))))

;;- The below appears buggy: the peffs and paffd cases should be like
;;- peffs := (union pred-peffs (intersect con-peffs alt-peffs))
;;- instead of
;;- peffs := (union pred-peffs (union con-peffs alt-peffs))
;;- It's benign since no compiler decisions depend on peffs or paffd.

(define effs-analyze-if
  (lambda (node fm redo)
    (block (effs-analyze (if.pred fm) redo)
	   (effs-analyze (if.con fm) redo)
	   (effs-analyze (if.alt fm) redo)
	   (alter-node node
		       (effs := (effs-union (node.effs (if.pred fm))
					    (effs-union (node.effs (if.con fm))
							(node.effs (if.alt fm)))))
		       (affd := (effs-union (node.affd (if.pred fm))
					    (effs-union (node.affd (if.con fm))
							(node.affd (if.alt fm)))))
		       (peffs := (effs-union (node.peffs (if.pred fm))
					     (effs-union (node.peffs (if.con fm))
							 (node.peffs (if.alt fm)))))
		       (paffd := (effs-union (node.paffd (if.pred fm))
					     (effs-union (node.paffd (if.con fm))
							 (node.paffd (if.alt fm)))))))))

;;- *check-peffs* is true when the user wants to be warned of argument-evaluation-order
;;- dependencies in her code.

(set' *check-peffs* nil)

(define effs-analyze-combination
  (lambda (node fm redo)
    (let ((args (combination.args fm)))
      (effs-analyze (car args) redo)
      (do ((a (cdr args) (cdr a))
	   (ef 'none (effs-union ef (node.effs (car a))))
	   (af 'none (effs-union af (node.affd (car a))))
	   (pef 'none (effs-union pef (node.peffs (car a))))
	   (paf 'none (effs-union paf (node.paffd (car a)))))
	  ((null a)
	   (if *check-peffs* (check-combination-peffs fm))
	   (cond ((eq (type (node.form (car args))) 'variable)
		  (let ((v (variable.var (node.form (car args)))))
		    (let ((ve (get v 'fn-side-effects))
			  (va (get v 'fn-side-affected)))
		      (alter-node node
				  (effs := (if ve (effs-union ef ve) 'any))
				  (affd := (if va (effs-union af va) 'any))
				  (peffs := (effs-union pef ve))
				  (paffd := (effs-union paf va))))))
		 ((eq (type (node.form (car args))) 'lambda)
		  (let ((b (lambda.body (node.form (car args)))))
		    (alter-node node
				(effs := (effs-union ef (node.effs b)))
				(affd := (effs-union af (node.affd b)))
				(peffs := (effs-union pef (node.peffs b)))
				(paffd := (effs-union paf (node.paffd b))))))
		 (t (alter-node node
				(effs := 'any)
				(affd := 'any)
				(peffs := (effs-union pef
						      (node.peffs (car args))))
				(paffd := (effs-union paf
						      (node.paffd (car args))))))))
	(effs-analyze (car a) redo)))))

;;- Warn user of possible dependencies on argument-evaluation order,
;;- and record the warning in the node.  FM must be a combination.

(define check-combination-peffs
  (lambda (fm)
    (if (not (combination.warnp fm))
	(do ((a (combination.args fm) (cdr a)))
	    ((null a))
	  (do ((b (cdr a) (cdr b)))
	      ((null b))
	    (if (not (effectless (effs-intersect (node.peffs (car a))
						 (node.paffd (car b)))))
		(block (warn "co-argument may affect later one"
			     (node.sexpr (car a))
			     `(effects = ,(node.peffs (car a)))
			     (node.sexpr (car b))
			     `(affected by ,(node.paffd (car b))))
		       (alter-combination fm (warnp := t))))
	    (if (not (effectless (effs-intersect (node.peffs (car b))
						 (node.paffd (car a)))))
		(block (warn "co-argument may affect earlier one"
			     (node.sexpr (car b))
			     `(effects = ,(node.peffs (car b)))
			     (node.sexpr (car a))
			     `(affected by ,(node.paffd (car a))))
		       (alter-combination fm (warnp := t))))
	    (if (not (effectless-except-cons (effs-intersect (node.peffs (car a))
							     (node.peffs (car b)))))
		(block (warn "co-arguments may have interfering effects"
			     (node.sexpr (car a))
			     `(effects = ,(node.peffs (car a)))
			     (node.sexpr (car b))
			     `(effects = ,(node.peffs (car b))))
		       (alter-combination fm (warnp := t)))))))))

(defmac effdef (fn effs affd . fold)
  `(progn (defprop ,fn ,effs fn-side-effects)
	  (defprop ,fn ,affd fn-side-affected)
	  ,(and fold `(defprop ,fn t okay-to-fold))))

(declare (/@define effdef "side effects"))

(progn 'compile
       (effdef + none none)
       (effdef - none none)
       (effdef * none none)
       (effdef // none none)
       (effdef = none none)
       (effdef < none none)
       (effdef > none none)
       (effdef car none (rplaca))
       (effdef cdr none (rplacd))
       (effdef caar none (rplaca))
       (effdef cadr none (rplaca rplacd))
       (effdef cdar none (rplaca rplacd))
       (effdef cddr none (rplacd))
       (effdef caaar none (rplaca))
       (effdef caadr none (rplaca rplacd))
       (effdef cadar none (rplaca rplacd))
       (effdef caddr none (rplaca rplacd))
       (effdef cdaar none (rplaca rplacd))
       (effdef cdadr none (rplaca rplacd))
       (effdef cddar none (rplaca rplacd))
       (effdef cdddr none (rplacd))
       (effdef caaaar none (rplaca))
       (effdef caaadr none (rplaca rplacd))
       (effdef caadar none (rplaca rplacd))
       (effdef caaddr none (rplaca rplacd))
       (effdef cadaar none (rplaca rplacd))
       (effdef cadadr none (rplaca rplacd))
       (effdef caddar none (rplaca rplacd))
       (effdef cadddr none (rplaca rplacd))
       (effdef cdaaar none (rplaca rplacd))
       (effdef cdaadr none (rplaca rplacd))
       (effdef cdadar none (rplaca rplacd))
       (effdef cdaddr none (rplaca rplacd))
       (effdef cddaar none (rplaca rplacd))
       (effdef cddadr none (rplaca rplacd))
       (effdef cdddar none (rplaca rplacd))
       (effdef cddddr none (rplacd))
       (effdef cxr none (rplaca rplacd))
       (effdef rplaca (rplaca) none)
       (effdef rplacd (rplaca) none)
       (effdef rplacx (rplaca rplacd) none)
       (effdef eq none none)
       (effdef atom none none)
       (effdef numberp none none)
       (effdef typep none none)
       (effdef symbolp none none)
       (effdef hunkp none none)
       (effdef fixp none none)
       (effdef floatp none none)
       (effdef bigp none none)
       (effdef not none none)
       (effdef null none none)
       (effdef cons (cons) none)          ;;- A cons really is a kind of side effect,
       (effdef list (cons) none)          ;;- because pairs are mutable and eq-able.
       (effdef append (cons) (rplacd))
       (effdef memq none (rplaca rplacd) t)
       (effdef assq none (rplaca rplacd) t)
       (effdef print (file) (file rplaca rplacd))
       (effdef prin1 (file) (file rplaca rplacd))
       (effdef princ (file) (file rplaca rplacd))
       (effdef terpri (file) (file))
       (effdef tyo (file) (file))
       (effdef read any (file))        ;** Why is this ANY when the other I/O's aren't?
       (effdef tyi any (file))         ;** Maybe because of read macros?
       'side-effects-properties)

;;- The cons side-effect denotes any allocation that could be checked by eq?
;;- -- notably this includes closure construction.

;;; this routine is used to undo any pass 1 analysis on a node.

(defmac erase-node (node) `(erase-nodes ,node nil))
(defmac erase-all-nodes (node) `(erase-nodes ,node t))

(define erase-nodes
  (lambda (node allp)
    (let ((fm (node.form node)))
      (or (eq (type node) 'node)
	  (error '"cannot erase a non-node" node 'fail-act))
      (eqcase (type fm)
	(constant)
	(variable
	 (delprop (variable.var fm) node 'read-refs))
	(lambda
	 (if allp (erase-all-nodes (lambda.body fm)))
	 (if (not *testing*)
	     (amapc (lambda (v) (remprop v 'binding)) (lambda.vars fm))))
	(if (cond (allp (erase-all-nodes (if.pred fm))
			(erase-all-nodes (if.con fm))
			(erase-all-nodes (if.alt fm)))))
	(aset
	 (if allp (erase-all-nodes (aset.body fm)))
	 (delprop (aset.var fm) node 'write-refs))
	(catch
	 (if allp (erase-all-nodes (catch.body fm)))
	 (if (not *testing*)
	     (remprop (catch.var fm) 'binding)))
	(labels
	 (cond (allp (amapc (lambda (d) (erase-all-nodes d))
			    (labels.fndefs fm))
		     (erase-all-nodes (labels.body fm))))
	 (if (not *testing*)
	     (amapc (lambda (v) (remprop v 'binding)) (labels.fnvars fm))))
	(combination
	 (if allp (amapc (lambda (a) (erase-all-nodes a))
			 (combination.args fm)))))
      (if (not *testing*)
	  (remprop (node.name node) 'node)))))

;;; the value of meta-evaluate is the (possibly new) node resulting from the given one.

(set' *fudge* t)			;switch to control meta-if-fudge
(set' *dead-count* 0)			;count of dead-code eliminations

;;- Although meta-evaluate uses pass1 analysis results, you don't need to call
;;- pass1-analyze first because the reanalyze1 calls do the job.

;;- The transformations are:
;;- 1. (if constant con alt) => con or alt, depending on constant
;;- 2. others described with the following functions that perform them
;;-   (optimizations for: (if (if a b c) d e), (trivfn . args), ((lambda ...) . args))
;;- The pass1 analysis info gets updated after any transformations.

(define meta-evaluate
  (lambda (node)
    (if (node.metap node)
	node
	(let ((fm (node.form node)))
	  (eqcase (type fm)
	    (constant
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (variable
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (lambda
	     (alter-lambda fm (body := (meta-evaluate (lambda.body fm))))
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (if
	     (alter-if fm
		       (pred := (meta-evaluate (if.pred fm)))
		       (con := (meta-evaluate (if.con fm)))
		       (alt := (meta-evaluate (if.alt fm))))
	     (if (and *fudge* (eq (type (node.form (if.pred fm))) 'if))
		 (meta-if-fudge node)
		 (if (eq (type (node.form (if.pred fm))) 'constant)
		     (let ((con (if.con fm))
			   (alt (if.alt fm))
			   (val (constant.value (node.form (if.pred fm)))))
		       (erase-node node)
		       (erase-all-nodes (if.pred fm))
		       (increment *dead-count*)
		       (if val
			   (block (erase-all-nodes alt) con)
			   (block (erase-all-nodes con) alt)))
		     (block (reanalyze1 node)
			    (alter-node node (metap := t))))))
	    (aset
	     (alter-aset fm (body := (meta-evaluate (aset.body fm))))
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (catch
	     (alter-catch fm (body := (meta-evaluate (catch.body fm))))
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (labels
	     (do ((d (labels.fndefs fm) (cdr d)))
		 ((null d))
	       (rplaca d (meta-evaluate (car d))))
	     (alter-labels fm (body := (meta-evaluate (labels.body fm))))
	     (reanalyze1 node)
	     (alter-node node (metap := t)))
	    (combination
	     (let ((fn (node.form (car (combination.args fm)))))
	       (cond ((and (eq (type fn) 'variable)
			   (trivfn (variable.var fn)))
		      (meta-combination-trivfn node))
		     ((eq (type fn) 'lambda)
		      (meta-combination-lambda node))
		     (t (do ((a (combination.args fm) (cdr a)))
			    ((null a))
			  (rplaca a (meta-evaluate (car a))))
			(reanalyze1 node)
			(alter-node node (metap := t)))))))))))

;;; transform (if (if a b c) d e) into:
;;;    ((lambda (d1 e1)
;;;	        (if a (if b (d1) (e1)) (if c (d1) (e1))))
;;;     (lambda () d)
;;;     (lambda () e))

(set' *fudge-count* 0)			;count of if-fudges

(define meta-if-fudge
  (lambda (node)
    (let ((fm (node.form node)))
      (let ((pfm (node.form (if.pred fm))))
	(let ((n (alphatize (let ((convar (gentemp 'meta-con))
				  (altvar (gentemp 'meta-alt)))
			      `((lambda (,convar ,altvar)
				  (if ,(if.pred pfm)
				      (if ,(if.con pfm)
					  (,convar)
					  (,altvar))
				      (if ,(if.alt pfm)
					  (,convar)
					  (,altvar))))
				(lambda () ,(if.con fm))
				(lambda () ,(if.alt fm))))
			    (node.env node)))) ;doesn't matter
	  (erase-node node)
	  (erase-node (if.pred fm))
	  (increment *fudge-count*)
	  (meta-evaluate n))))))

;;; reduce a combination with a side-effect-less trivial
;;; function and constant arguments to a constant.

(set' *fold-count* 0)			;count of constant foldings

(define meta-combination-trivfn
  (lambda (node)
    (let ((fm (node.form node)))
      (let ((args (combination.args fm)))
	(rplaca args (meta-evaluate (car args)))
	(do ((a (cdr args) (cdr a))
	     (constp (let ((fnname (variable.var (node.form (car args)))))
		       (or (and (eq (get fnname 'fn-side-effects)
				    'none)
				(eq (get fnname 'fn-side-affected)
				    'none))
			   (get fnname 'okay-to-fold)))
		     (and constp (eq (type (node.form (car a))) 'constant))))
	    ((null a)
	     (cond (constp
		    (let ((val (apply (variable.var (node.form (car args)))
				      (amapcar (lambda (x)
						 (constant.value
						  (node.form x)))
					       (cdr args)))))
		      (erase-all-nodes node)
		      (increment *fold-count*)
		      (meta-evaluate (alphatize `(quote ,val) nil))))
		   (t (reanalyze1 node)
		      (alter-node node (metap := t)))))
	  (rplaca a (meta-evaluate (car a))))))))

(set' *flush-args* t)			;switch to control variable elimination
(set' *flush-count* 0)			;count of variables eliminated
(set' *convert-count* 0)		;count of full beta-conversions

;;- In ((lambda (v ...) body) arg ...)
;;-  - eliminate dead variables with side-effectless args
;;-  - if arg is a subst-candidate, substitute arg for v and eliminate v and arg
;;-  - if there are 0 v's, replace the whole node with BODY.

(define meta-combination-lambda
  (lambda (node)
    (let ((fm (node.form node)))
      (let ((args (combination.args fm)))
	(do ((a (cdr args) (cdr a)))
	    ((null a))
	  (rplaca a (meta-evaluate (car a)))
	  (alter-node (car a) (substp := nil)))
	(let ((fn (node.form (car args))))
	  (do ((v (lambda.vars fn) (cdr v))
	       (a (cdr args) (cdr a))
	       (b (meta-evaluate (lambda.body fn))
		  (if (subst-candidate (car a) (car v) b)
		      (meta-substitute (car a) (car v) b)
		      b)))
	      ((null v)
	       (alter-lambda fn (body := (meta-evaluate b)))
	       (do ((v (lambda.vars fn) (cdr v))
		    (a (cdr args) (cdr a)))
		   ((null a))
		 (if (and *flush-args*
			  (null (get (car v) 'read-refs))
			  (null (get (car v) 'write-refs))
			  (or (effectless-except-cons (node.effs (car a)))
			      (node.substp (car a))))
		     (block (if (or (memq v (node.refs (lambda.body fn)))
				    (memq v (node.asets (lambda.body fn))))
				(error '"reanalysis lost - meta-combination-lambda"
				       node
				       'fail-act))
			    (delq (car a) args)
			    (erase-all-nodes (car a))
			    (increment *flush-count*)
			    (alter-lambda fn
					  (vars := (delq (car v) (lambda.vars fn)))
					  (uvars := (delq (get (car v) 'user-name)
							  (lambda.uvars fn)))))))
	       (cond ((null (lambda.vars fn))
		      (or (null (cdr args))
			  (error '"too many args in meta-combination-lambda"
				 node
				 'fail-act))
		      (let ((bod (lambda.body fn)))
			(erase-node (car args))
			(erase-node node)
			(increment *convert-count*)
			bod))
		     (t (reanalyze1 (car args))
			(alter-node (car args) (metap := t))
			(reanalyze1 node)
			(alter-node node (metap := t)))))))))))

(set' *substitute* t)		;switch to control substitution
(set' *single-subst* t)		;switch to control substitution of expressions with side effects
(set' *lambda-subst* t)		;switch to control substitution of lambda-expressions

;;- In a subst-candidate pair (arg, var) with body bod, 
;;-   var is never assigned to, and arg is either singly referenced or
;;-   a constant or a variable or a lambda with a `simple' body --
;;-   simple here means a constant or variable or a combination all of
;;-   whose subexpressions are constants or variables, and with no more
;;-   arguments than parameters to the lambda. (I don't understand the
;;-   reason for that last requirement...  Maybe leaving it out would
;;-   sometimes fatten up closures too much?)
;;- (This assumes the above flags are all true.  Even if *single-subst* is 
;;- false a singly-referenced lambda is a candidate, regardless of the 
;;- simplicity of its body.)

;;- If the singly-referenced case seems wrong to you, that's because it is.
;;- (If the arg causes or depends on side-effects, they could happen out of
;;- order.)  But that's okay because META-SUBSTITUTE checks for that before
;;- performing any actual substitutions.

(define subst-candidate
  (lambda (arg var bod)
    (and *substitute*
	 (not (get var 'write-refs))	;be paranoid for now
	 (or (and *single-subst*
		  (null (cdr (get var 'read-refs))))
	     (memq (type (node.form arg)) '(constant variable))
	     (and *lambda-subst*
		  (eq (type (node.form arg)) 'lambda)
		  (or (null (cdr (get var 'read-refs)))
		      (let ((b (node.form (lambda.body (node.form arg)))))
			(or (memq (type b) '(constant variable))
			    (and (eq (type b) 'combination)
				 (not (> (length (cdr (combination.args b)))
					 (length (lambda.vars (node.form arg)))))
				 (do ((a (combination.args b) (cdr a))
				      (p t (and p (memq (type (node.form (car a)))
							'(constant variable)))))
				     ((null a) p)))))))))))

(define reanalyze1
  (lambda (node)
    (pass1-analyze node *reanalyze* t)))

(set' *reanalyze* 'once)       ;;- There are no other assignments to this.



;;; here we determine, for each variable node whose var is the one
;;; given, whether it is possible to substitute in for it; this is
;;; determined on the basis of side effects.  this is done by
;;; walking the program, stopping when a side-effect blocks it.
;;; a substitution is made iff is variable node is reached in the walk.

;;; there is a bug in this theory to the effect that a catch
;;; which returns multiply can cause an expression external
;;; to the catch to be evaluated twice.  this is a dynamic problem
;;; which cannot be resolved at compile time, and so we shall
;;; ignore it for now.

;;; we also reset the metap flag on all nodes which have a
;;; substitution at or below them, so that the meta-evaluator will
;;; re-penetrate to substitution points, which may admit further
;;; optimizations.


(define effs-intersect
  (lambda (a b)
    (cond ((eq a 'any) b)
	  ((eq b 'any) a)
	  ((eq a 'none) a)
	  ((eq b 'none) b)
	  (t (intersect a b)))))

(define effectless
  (lambda (x) (or (null x) (eq x 'none))))

(define effectless-except-cons
  (lambda (x) (or (effectless x) (equal x '(cons)))))

;;- If some other node NODE1 with effects/affected sets (EFFS, AFFD) comes before
;;- NODE in execution, return true iff it's provably safe to reorder the two nodes
;;- so NODE1 comes after NODE -- i.e., the two store transforms commute.

(define passable
  (lambda (node effs affd)
    (block (if (empty (node.effs node))
	       (error '"pass 1 analysis missing - passable"
		      node
		      'fail-act))
	   ;;- Three hazards to check for -- in order,
	   ;;- write after read, read after write, and write after write.
	   (and (effectless (effs-intersect effs (node.affd node)))
		(effectless (effs-intersect affd (node.effs node)))
		(effectless-except-cons (effs-intersect effs (node.effs node)))))))

(set' *subst-count* 0)			;count of substitutions
(set' *lambda-body-subst* t)		;switch to control substitution in lambda bodies
(set' *lambda-body-subst-try-count* 0)	;count thereof - tries
(set' *lambda-body-subst-success-count* 0) ;count thereof - successes


;;* Sample code for bug complaint below:
;;* (define blah ((lambda (arg) (labels ((foo (lambda () arg))) foo))
;;*               (set' global 42)))

(define meta-substitute
  (lambda (arg var bod)
    (let ((effs (node.effs arg))
	  (affd (node.affd arg)))
      (if (empty effs)
	  (error '"pass 1 analysis screwed up - meta-substitute" arg 'fail-act))
      (labels
       ((substitute
	 (lambda (node)
	   (if (or (empty (node.refs node))
		   (not (memq var (node.refs node)))) ;efficiency hack
	       node
	       (let ((fm (node.form node)))
		 (eqcase (type fm)
		   (constant node)
		   (variable
		    (if (eq (variable.var fm) var)
			(block (erase-all-nodes node)
			       (increment *subst-count*)
			       (alter-node arg (substp := t))
			       (copy-code arg))
			node))
		   (lambda
		    (if (and (effectless-except-cons effs) (effectless affd))
			(alter-lambda fm (body := (substitute (lambda.body fm)))))
		    (if (node.metap node)
			(alter-node node (metap := (node.metap (lambda.body fm)))))
		    node)
		   (if
		    (alter-if fm (pred := (substitute (if.pred fm))))
		    (if (passable (if.pred fm) effs affd)
			(alter-if fm
				  (con := (substitute (if.con fm)))
				  (alt := (substitute (if.alt fm)))))
		    (if (node.metap node)
			(alter-node node
				    (metap := (and (node.metap (if.pred fm))
						   (node.metap (if.con fm))
						   (node.metap (if.alt fm))))))
		    node)
		   (aset
		    (alter-aset fm (body := (substitute (aset.body fm))))
		    (if (node.metap node)
			(alter-node node (metap := (node.metap (aset.body fm)))))
		    node)
		   (catch
		    (alter-catch fm (body := (substitute (catch.body fm))))
		    (if (node.metap node)
			(alter-node node (metap := (node.metap (catch.body fm)))))
		    node)
		   (labels
		    (alter-labels fm (body := (substitute (labels.body fm))))
		    (do ((d (labels.fndefs fm) (cdr d))
			 (mp (node.metap (labels.body fm))
			     (and mp (node.metap (car d)))))
			((null d)
			 (if (node.metap node)
			     (alter-node node (metap := mp))))
;;* The following line is inconsistent with the lambda case above, where the
;;* substitution gets done only if ARG is both side-effect free and immune
;;* to side effects.  Since LAMBDA is a special case of LABELS, this can't 
;;* be right, can it?  See sample code above.
;;* (Much later: I was able to actually run this code; it's right and I'm
;;* wrong, though I don't know why.)
		      (rplaca d (substitute (car d))))
		    node)
		   (combination
		    (let ((args (combination.args fm)))
		      (do ((a args (cdr a))
			   (x t (and x (passable (car a) effs affd))))
			  ((null a)
;;* Here we only substitute in any arg of the combination if *all* args are
;;* passable -- why?  Possible rearrangement of argument order later?
			   (if x (do ((a (cdr args) (cdr a)))
				     ((null a))
				   (rplaca a (substitute (car a)))))
			   (if (and *lambda-body-subst*
				    (eq (type (node.form (car args))) 'lambda))
			       (let ((fn (node.form (car args))))
				 (increment *lambda-body-subst-try-count*)
				 (cond (x
					(increment
					 *lambda-body-subst-success-count*)
					(alter-lambda
					 fn
					 (body := (substitute
						   (lambda.body fn))))))
				 (if (node.metap (car args))
				     (alter-node
				      (car args)
				      (metap := (node.metap
						 (lambda.body fn))))))
			       (if x (rplaca args (substitute (car args)))))))
		      (do ((a args (cdr a))
			   (mp t (and mp (node.metap (car a)))))
			  ((null a)
			   (if (node.metap node)
			       (alter-node node (metap := mp))))))
		    node)))))))
       (substitute bod)))))

;;- In a substitution, we need to make a complete copy of the substituted code,
;;- both to rename bound variables and to have a separate tree to optimize.

;;* Why only reanalyze1 here?  It works out as a full analysis because all the
;;* new nodes have empty attribute slots, but why not say what you mean and
;;* call pass1-analyze?

(define copy-code
  (lambda (node)
    (reanalyze1 (copy-nodes node (node.env node) nil))))

(define copy-nodes
  (lambda (node env rnl)
    (nodify
     (let ((fm (node.form node)))
       (eqcase (type fm)
	 (constant
	  (cons-constant (value = (constant.value fm))))
	 (variable
	  (cons-variable (var = (let ((slot (assq (variable.var fm) rnl)))
				  (if slot (cadr slot) (variable.var fm))))
			 (globalp = (variable.globalp fm))))
	 (lambda
	  (let ((vars (amapcar gentemp (lambda.vars fm))))
	    (cons-lambda (uvars = (append (lambda.uvars fm) nil))
			 (vars = vars)
			 (body = (copy-nodes
				  (lambda.body fm)
				  (pairlis (lambda.uvars fm) vars env)
				  (pairlis (lambda.vars fm) vars rnl))))))
	 (if (cons-if (pred = (copy-nodes (if.pred fm) env rnl))
		      (con = (copy-nodes (if.con fm) env rnl))
		      (alt = (copy-nodes (if.alt fm) env rnl))))
	 (aset
	  (cons-aset (var = (let ((slot (assq (aset.var fm) rnl)))
			      (if slot (cadr slot) (aset.var fm))))
		     (globalp = (aset.globalp fm))
		     (body = (copy-nodes (aset.body fm) env rnl))))
	 (catch
	  (let ((var (gentemp (catch.var fm)))
		(uvar (catch.uvar fm)))
	    (cons-catch (uvar = (catch.uvar fm))
			(var = var)
			(body = (copy-nodes
				 (catch.body fm)
				 (cons (list uvar var) env)
				 (cons (list (catch.var fm) var) rnl))))))
	 (labels
	  (let ((fnvars (amapcar gentemp (labels.fnvars fm))))
	    (let ((lenv (pairlis (labels.ufnvars fm) fnvars env))
		  (lrnl (pairlis (labels.fnvars fm) fnvars rnl)))
	      (cons-labels (ufnvars = (labels.ufnvars fm))
			   (fnvars = fnvars)
			   (fndefs = (amapcar
				      (lambda (n) (copy-nodes n lenv lrnl))
				      (labels.fndefs fm)))
			   (body = (copy-nodes (labels.body fm)
					       lenv
					       lrnl))))))
	 (combination
	  (cons-combination (args = (amapcar (lambda (n) (copy-nodes n env rnl))
					     (combination.args fm)))
			    (warnp = (combination.warnp fm))))))
     (node.sexpr node)
     env)))

;;; conversion to continuation-passing style

;;; this involves making a complete copy of the program in terms
;;; of the following new data structures:

;;- The first argument to cps procedures is the continuation.
;;- Also note that these deftypes have no slots for side-effect info -- and none
;;- of the following code uses those slots in the `trivial' nodes.  Oops, other
;;- than ASETVARS for CLAMBDA.  A new assignment analysis isn't needed because
;;- the new variables introduced are all continuations; they never get assigned to.

(deftype cnode (env refs clovars cform))
 ;env		environment (a list of variables, not a mapping; debugging only)
 ;refs		variables bound above and referenced below this cnode
 ;clovars  	variables referred to at or below this cnode by closures
 ;		(should be a subset of refs)
 ;cform		one of the below types

(deftype trivial (node))
 ;node		a pass-1 node tree

(deftype cvariable (var))
 ;var		generated variable name

;;- A cvariable always denotes a continuation.
;;- A user variable becomes a trivial node.

(deftype clambda (vars body fnp tvars name dep maxdep consenv closerefs asetvars))
 ;fnp		non-nil => needn't make a full closure of this
 ;		clambda.  may be 'noclose or 'ezclose (the former
 ;		meaning no closure is necessary at all, the latter
 ;		that the closure is merely the environment).
 ;tvars		the variables which are passed through temp locations
 ;		on entry.  non-nil only if fnp='noclose; then is
 ;		normally the lambda vars, but may be decreased
 ;		to account for args which are themselves known noclose's,
 ;		or whose corresponding parameters are never referenced.
 ;		the temp vars involved start in number at dep.
 ;name		the prog tag used to label the final output code for the clambda
 ;dep		depth of temporary register usage when the clambda is invoked
 ;maxdep	maximum depth of register usage within clambda body
 ;consenv  	the `consed environment` when the clambda is evaluated
 ;closerefs  	variables referenced by the clambda which are not in
 ;		the consed environment at evaluation time, and so must be
 ;		added to consenv at that point to make the closure
 ;asetvars  	the elements of vars which are ever seen in a caset

;;- It looks like function calls (including calls to continuations)
;;- always pass values in a consecutive set of registers starting at 0.
;;- I think if there are more than **NUMBER-OF-ARG-REGS** args, the
;;- excess ones get heapified.  Or something.  (However, there's no
;;- such check for continuations since they always have just one
;;- argument.)

;;- Presumably there's a convention for which registers are cont and closure args
;;- -- though there doesn't seem to be provision for a closure arg to normal
;;- functions...

;;- Rabbit doesn't have to spill otherwise, since Maclisp can use an unlimited
;;- number of temporary variables.  

;;- These temporaries get allocated in stack order as you traverse the cnodes
;;- top down.  DEP is the `stack pointer' field.  Note these are the same 
;;- registers used to pass arguments.

(deftype continuation (var body fnp tvars name dep maxdep consenv closerefs))
 ;components are as for clambda

(deftype cif (pred con alt))

(deftype caset (cont var body))

(deftype clabels (fnvars fndefs fnenv easy consenv body))
 ;fnenv		a list of variables to cons onto the environment before
 ;		creating the closures and executing the body
 ;easy		non-nil iff no labeled function is referred to
 ;		as a variable.  can be 'noclose or 'ezclose
 ;		(reflecting the status of all the labelled functions)
 ;consenv  	as for clambda

(deftype ccombination (args))
 ;args		list of cnodes representing arguments

(deftype return (cont val))
 ;cont		cnode for continuation
 ;val		cnode for value

;;- RETURN is like CCOMBINATION, only CONT is required to be a continuation
;;- at runtime.

(define cnodify
  (lambda (cform)
    (cons-cnode (cform = cform))))

;;- Return a cnode representing the evaluation of NODE with continuation
;;- CONT (a cnode or nil).  Nil signifies the top-level continuation, 
;;- apparently -- if so, why is it an error to supply it to anything but
;;- a basic value?
;;- MP = true iff node has been meta-evaluated.

(define convert
  (lambda (node cont mp)
    (let ((fm (node.form node)))
      (if (empty (node.trivp node))
	  (error '"pass 1 analysis missing" node 'fail-act))
      (or (eq (node.metap node) mp)
	  (error '"meta-evaluation screwed up metap" node 'fail-act))
      (eqcase (type fm)
	(constant
	 (or (node.trivp node)
	     (error '"non-trivial constant" node 'fail-act))
	 (make-return (cons-trivial (node = node)) cont))
	(variable
	 (or (node.trivp node)
	     (error '"non-trivial variable" 'fail-act))
	 (make-return (cons-trivial (node = node)) cont))
	(lambda (make-return (convert-lambda-fm node nil mp) cont))
	(if (or cont (error '"null continuation to if" node 'fail-act))
	    (convert-if node fm cont mp))
	(aset (or cont (error '"null continuation to aset" node 'fail-act))
	      (convert-aset node fm cont mp))
	(catch (or cont (error '"null continuation to catch" node 'fail-act))
	       (convert-catch node fm cont mp))
	(labels (or cont (error '"null continuation to labels" node 'fail-act))
		(convert-labels node fm cont mp))
	(combination (or cont (error '"null continuation to combination"
				     node
				     'fail-act))
		     (convert-combination node fm cont mp))))))

(define make-return
  (lambda (cform cont)
    (let ((cn (cnodify cform)))
      (if cont
	  (cnodify (cons-return (cont = cont) (val = cn)))
	  cn))))

;;- (lambda (x ...) body) => (lambda (k x ...) body-cps)
;;* Except I don't get the (or cname cv) bit -- the K is the generated CV,
;;* but the cont in body-cps is CNAME if that's non-nil.

(define convert-lambda-fm
  (lambda (node cname mp)
    (let ((cv (gentemp 'cont))
	  (fm (node.form node)))
      (cons-clambda (vars = (cons cv (lambda.vars fm)))
		    (body = (convert (lambda.body fm)
				     (cnodify
				      (cons-cvariable (var = (or cname cv))))
				     mp))))))

;;; issues for converting if:
;;; (1) if whole if is trivial, may just create a ctrivial.
;;; (2) if continuation is non-cvariable, must bind a variable to it.
;;; (3) if predicate is trivial, may just stick it in simple cif.

(define convert-if
  (lambda (node fm cont mp)
    (if (node.trivp node)
	(make-return (cons-trivial (node = node)) cont)
	(let ((cvar (if (eq (type (cnode.cform cont)) 'cvariable)
			nil
			(gentemp 'cont)))
	      (pvar (if (node.trivp (if.pred fm))
			nil
			(node.name (if.pred fm)))))
	  (let ((icont (if cvar
			   (cnodify (cons-cvariable (var = cvar)))
			   cont))
		(ipred (if pvar
			   (cnodify (cons-cvariable (var = pvar)))
			   (cnodify (cons-trivial (node = (if.pred fm)))))))
	    (let ((cif (cnodify
			(cons-cif
			 (pred = ipred)
			 (con = (convert (if.con fm) icont mp))
			 (alt = (convert (if.alt fm)
					 (cnodify
					  (cons-cvariable
					   (var = (cvariable.var
						   (cnode.cform icont)))))
					 mp))))))
	      (let ((foo (if pvar
			     (convert (if.pred fm)
				      (cnodify (cons-continuation (var = pvar)
								  (body = cif)))
				      mp)
			     cif)))
		(if cvar
		    (cnodify
		     (cons-ccombination
		      (args = (list (cnodify
				     (cons-clambda
				      (vars = (list cvar))
				      (body = foo)))
				    cont))))
		    foo))))))))

(define convert-aset
  (lambda (node fm cont mp)
    (if (node.trivp node)
	(make-return (cons-trivial (node = node)) cont)
	(convert (aset.body fm)
		 (let ((nm (node.name (aset.body fm))))
		   (cnodify
		    (cons-continuation
		     (var = nm)
		     (body = (cnodify
			      (cons-caset
			       (cont = cont)
			       (var = (aset.var fm))
			       (body = (cnodify (cons-cvariable
						 (var = nm))))))))))
		 mp))))

;;; issues for converting catch:
;;; (1) must bind the catch variable to a funny function which ignores its continuation:
;;; (2) if continuation is non-cvariable, must bind a variable to it.

(define convert-catch
  (lambda (node fm cont mp)
    (let ((cvar (if (eq (type (cnode.cform cont)) 'cvariable)
		    nil
		    (gentemp 'cont))))
      (let ((icont (if cvar
		       (cnodify (cons-cvariable (var = cvar)))
		       cont)))
	(let ((cp (cnodify
		   (cons-ccombination
		    (args = (list (cnodify
				   (cons-clambda
				    (vars = (list (catch.var fm)))
				    (body = (convert (catch.body fm) icont mp))))
				  (cnodify
				   (cons-clambda
				    (vars = '(*ignore* v))
				    (body = (make-return
					     (cons-cvariable (var = 'v))
					     (cnodify
					      (cons-cvariable
					       (var = (cvariable.var
						       (cnode.cform icont)))))))))))))))
	  (if cvar (cnodify
		    (cons-ccombination
		     (args = (list (cnodify
				    (cons-clambda (vars = (list cvar))
						  (body = cp)))
				   cont))))
	      cp))))))

;;; issues for converting labels:
;;; (1) must convert all the named lambda-expressions, using a null continuation.
;;; (2) to make things easier later, we forbid aset on a labels variable.

(define convert-labels
  (lambda (node fm cont mp)
    (do ((f (labels.fndefs fm) (cdr f))
	 (v (labels.fnvars fm) (cdr v))
	 (cf nil (cons (convert (car f) nil mp) cf)))
	((null f)
	 (cnodify (cons-clabels (fnvars = (labels.fnvars fm))
				(fndefs = (nreverse cf))
				(body = (convert (labels.body fm) cont mp)))))
      (and (get (car v) 'write-refs)
	   (error '"are you crazy, using aset on a labels variable?"
		  (car v)
		  'fail-act)))))

;;; issues for converting combinations:
;;; (1) trivial argument evaluations are delayed and are not bound to the variable of
;;;	a continuation.  we assume thereby that the compiler is permitted to evaluate
;;;	operands in any order.
;;** This seems to contradict the way side-effect sets are computed...
;;; (2) all non-delayable computations are assigned names and strung out with continuations.
;;; (3) if cont is a cvariable and the combination is ((lambda ...) ...) then when converting
;;;	the lambda-expression we arrange for its body to refer to the cvariable cont rather
;;;	than to its own continuation.  this crock effectively performs the optimization of
;;;     substituting one variable for another, only on continuation variables (which couldn't
;;;	be caught by meta-evaluate).

(define convert-combination
  (lambda (node fm cont mp)
    (if (node.trivp node)
	(make-return (cons-trivial (node = node)) cont)
	(do ((a (combination.args fm) (cdr a))
	     (delay-flags nil
			  (cons (or (node.trivp (car a))
				    (eq (type (node.form (car a))) 'lambda))
				delay-flags)))
	    ((null a)
	     (do ((a (reverse (combination.args fm)) (cdr a))
		  (d delay-flags (cdr d))
		  (f (cnodify
		      (cons-ccombination
		       (args = (do ((a (reverse (combination.args fm)) (cdr a))
				    (d delay-flags (cdr d))
				    (z nil (cons (if (car d)
						     (if (eq (type (node.form (car a)))
							     'lambda)
							 (cnodify
							  (convert-lambda-fm
							   (car a)
							   (and (null (cdr a))
								(eq (type
								     (cnode.cform cont))
								    'cvariable)
								(cvariable.var
								 (cnode.cform cont)))
							   mp))
							 (cnodify
							  (cons-trivial
							   (node = (car a)))))
						     (cnodify
						      (cons-cvariable
						       (var = (node.name (car a))))))
						 z)))
				   ((null a) (cons (car z) (cons cont (cdr z))))))))
		     (if (car d) f
			 (convert (car a)
				  (cnodify (cons-continuation
					    (var = (node.name (car a)))
					    (body = f)))
				  mp))))
		 ((null a) f)))))))

;;; environment analysis for cps version

;;; we wish to determine the environment at each cnode,
;;; and determine what variables are bound above and
;;; referred to below each cnode.

;;; for each cnode we fill in these slots:
;;;	env	the environment seen at that cnode (a list of vars)
;;;	refs	variables bound above and referred to below that cnode
;;; for each variable referred to in non-function position
;;; by a cvariable or ctrivial cnode we give a non-nil value to the property:
;;;	variable-refp

;;; fnp is non-nil iff cnode occurs in functional position

(define cenv-analyze
  (lambda (cnode env fnp)
    (let ((cfm (cnode.cform cnode)))
      (alter-cnode cnode (env := env))
      (eqcase (type cfm)
	(trivial
	 (cenv-triv-analyze (trivial.node cfm) fnp)
	 (alter-cnode cnode
		      (refs := (node.refs (trivial.node cfm)))))
	(cvariable
	 (let ((v (cvariable.var cfm)))
	   (addprop v cnode 'read-refs)
	   (or fnp (putprop v t 'variable-refp))
	   (alter-cnode cnode
			(refs := (and (memq v env)
				      (list (cvariable.var cfm)))))))
	(clambda
	 (let ((b (clambda.body cfm)))
	   (cenv-analyze b (append (clambda.vars cfm) env) nil)
	   (let ((refs (setdiff (cnode.refs b) (clambda.vars cfm))))
	     (alter-cnode cnode (refs := refs)))))
	(continuation
	 (let ((b (continuation.body cfm)))
	   (cenv-analyze b (cons (continuation.var cfm) env) nil)
	   (let ((refs (remove (continuation.var cfm) (cnode.refs b))))
	     (alter-cnode cnode (refs := refs)))))
	(cif
	 (let ((pred (cif.pred cfm))
	       (con (cif.con cfm))
	       (alt (cif.alt cfm)))
	   (cenv-analyze pred env nil)
	   (cenv-analyze con env nil)
	   (cenv-analyze alt env nil)
	   (alter-cnode cnode
			(refs := (union (cnode.refs pred)
					(union (cnode.refs con)
					       (cnode.refs alt)))))))
	(caset
	 (let ((v (caset.var cfm))
	       (cn (caset.cont cfm))
	       (b (caset.body cfm)))
	   (putprop (caset.var cfm) t 'variable-refp)
	   (cenv-analyze cn env t)
	   (cenv-analyze b env nil)
	   (alter-cnode cnode
			(refs := (let ((r (union (cnode.refs cn)
						 (cnode.refs b))))
				   (if (memq v env) (adjoin v r) r))))))
	(clabels
	 (let ((lenv (append (clabels.fnvars cfm) env)))
	   (do ((f (clabels.fndefs cfm) (cdr f))
		(r nil (union r (cnode.refs (car f)))))
	       ((null f)
		(let ((b (clabels.body cfm)))
		  (cenv-analyze b lenv nil)
		  (alter-cnode cnode
			       (refs := (setdiff (union r (cnode.refs b))
						 (clabels.fnvars cfm))))))
	     (cenv-analyze (car f) lenv nil))))
	(ccombination
	 (let ((args (ccombination.args cfm)))
	   (cenv-analyze (car args) env t)
	   (cond ((and (eq (type (cnode.cform (car args))) 'trivial)
		       (eq (type (node.form (trivial.node
					     (cnode.cform (car args)))))
			   'variable)
		       (trivfn (variable.var
				(node.form
				 (trivial.node
				  (cnode.cform
				   (car args)))))))
		  (cenv-analyze (cadr args) env t)    	  ;* Why is FNP T here?
		  (cenv-ccombination-analyze cnode
					     env  
					     (cddr args)
					     (union (cnode.refs (car args))
						    (cnode.refs (cadr args)))))
		 (t (cenv-ccombination-analyze cnode
					       env
					       (cdr args)
					       (cnode.refs (car args)))))))
	(return
	 (let ((c (return.cont cfm))
	       (v (return.val cfm)))
	   (cenv-analyze c env t)
	   (cenv-analyze v env nil)
	   (alter-cnode cnode
			(refs := (union (cnode.refs c) (cnode.refs v))))))))))

;;; this function must go through and locate variables appearing in non-function position.

(define cenv-triv-analyze
  (lambda (node fnp)
    (let ((fm (node.form node)))
      (eqcase (type fm)
	(constant nil)
	(variable
	 (or fnp (putprop (variable.var fm) t 'variable-refp)))
	(lambda
	    (or fnp
		(error '"trivial closure - cenv-triv-analyze" node 'fail-act))
	  (cenv-triv-analyze (lambda.body fm) nil))
	(if
	 (cenv-triv-analyze (if.pred fm) nil)
	 (cenv-triv-analyze (if.con fm) nil)
	 (cenv-triv-analyze (if.alt fm) nil))			      
	(aset
	 (putprop (aset.var fm) t 'variable-refp)
	 (cenv-triv-analyze (aset.body fm) nil))
	(combination
	 (do ((a (combination.args fm) (cdr a))
	      (f t nil))
	     ((null a))
	   (cenv-triv-analyze (car a) f)))))))

(define cenv-ccombination-analyze
  (lambda (cnode env args frefs)
    (do ((a args (cdr a))
	 (r frefs (union r (cnode.refs (car a)))))
	((null a)
	 (alter-cnode cnode (refs := r)))
      (cenv-analyze (car a) env nil))))

;;; binding analysis.

;;; for each cnode we fill in:
;;;	clovars		the set of variables referred to by closures
;;;			at or below this node (should always be a
;;;			subset of refs)
;;; for each clambda and continuation we fill in:
;;;	fnp	non-nil iff referenced only as a function.
;;;		will be 'ezclose if referred to by a closure,
;;;		and otherwise 'noclose.
;;;	tvars	variables passed through temp locations when calling
;;;		this function
;;;	name	the name of the function (used for the prog tag)
;;; for each clabels we fill in:
;;;	easy	reflects fnp status of all the labelled functions
;;; for each variable which always denotes a certain function we
;;; put the properties:
;;;	known-function		iff the variable is never aset
;;; the value of the known-function property is the cnode for
;;; the function definition.
;;; for each labels variable in a labels of the 'ezclose variety
;;; we put the property:
;;;	labels-function
;;; to indicate that its `easy` closure must be cdr'd to get the
;;; correct environment (see produce-labels).

;;; name, if non-nil, is a suggested name for the function

(define bind-analyze
  (lambda (cnode fnp name)
    (let ((cfm (cnode.cform cnode)))
      (eqcase (type cfm)
	(trivial
	 (alter-cnode cnode (clovars := nil)))
	(cvariable
	 (alter-cnode cnode (clovars := nil)))
	(clambda
	 (bind-analyze-clambda cnode fnp name cfm))
	(continuation
	 (bind-analyze-continuation cnode fnp name cfm))
	(cif
	 (bind-analyze-cif cnode cfm))
	(caset
	 (bind-analyze-caset cnode cfm))
	(clabels
	 (bind-analyze-clabels cnode cfm))
	(ccombination
	 (bind-analyze-ccombination cnode cfm))
	(return
	 (bind-analyze-return cnode cfm))))))

(define refd-vars
  (lambda (vars)
    (do ((v vars (cdr v))
	 (w nil (if (or (get (car v) 'read-refs)
			(get (car v) 'write-refs))
		    (cons (car v) w)
		    w)))
	((null v) (nreverse w)))))

(define bind-analyze-clambda
  (lambda (cnode fnp name cfm)
    (block (bind-analyze (clambda.body cfm) nil nil)
	   (alter-cnode cnode
			(clovars := (if (eq fnp 'noclose)
					(cnode.clovars (clambda.body cfm))
					(cnode.refs cnode))))
	   (alter-clambda cfm
			  (fnp := fnp)
			  (tvars := (if (eq fnp 'noclose)
					(refd-vars (clambda.vars cfm))
					nil))
			  (name := (or name (gentemp 'f)))))))

(define bind-analyze-continuation
  (lambda (cnode fnp name cfm)
    (block (bind-analyze (continuation.body cfm) nil nil)
	   (alter-cnode cnode
			(clovars := (if (eq fnp 'noclose)
					(cnode.clovars (continuation.body cfm))
					(cnode.refs cnode))))
	   (alter-continuation cfm
			       (fnp := fnp)
			       (tvars := (if (eq fnp 'noclose)
					     (refd-vars (list (continuation.var cfm)))
					     nil))
			       (name := (or name (gentemp 'c)))))))

(define bind-analyze-cif
  (lambda (cnode cfm)
    (block (bind-analyze (cif.pred cfm) nil nil)
	   (bind-analyze (cif.con cfm) nil nil)
	   (bind-analyze (cif.alt cfm) nil nil)
	   (alter-cnode cnode
			(clovars := (union (cnode.clovars (cif.pred cfm))
					   (union (cnode.clovars (cif.con cfm))
						  (cnode.clovars (cif.alt cfm)))))))))

(define bind-analyze-caset
  (lambda (cnode cfm)
    (let ((cn (caset.cont cfm))
	  (val (caset.body cfm)))
      (bind-analyze cn 'noclose nil)
      (cond ((and (eq (type (cnode.cform cn)) 'continuation)
		  (eq (type (cnode.cform val)) 'clambda))
	     (let ((var (continuation.var (cnode.cform cn))))
	       (putprop var val 'known-function)
	       (bind-analyze val
			     (and (not (get var 'variable-refp))
				  (if (memq var
					    (cnode.clovars
					     (continuation.body
					      (cnode.cform cn))))
				      'ezclose
				      (block (alter-continuation (cnode.cform cn)
								 (tvars := nil))
					     'noclose)))
			     nil)))
	    (t (bind-analyze val nil nil)))
      (alter-cnode cnode
		   (clovars := (union (cnode.clovars cn)
				      (cnode.clovars val)))))))

(define bind-analyze-clabels
  (lambda (cnode cfm)
    (block (bind-analyze (clabels.body cfm) nil nil)
	   (do ((v (clabels.fnvars cfm) (cdr v))
		(d (clabels.fndefs cfm) (cdr d))
		(ez 'noclose (and (null (get (car v) 'variable-refp)) ez)))
	       ((null v)
		(alter-clabels cfm (easy := ez))
		(do ((v (clabels.fnvars cfm) (cdr v))
		     (d (clabels.fndefs cfm) (cdr d))
		     (cv (cnode.clovars (clabels.body cfm))
			 (union cv (cnode.clovars (car d)))))
		    ((null d)
		     (alter-cnode cnode (clovars := cv))
		     (cond ((and ez (intersect cv (labels.fnvars cfm)))
			    (do ((d (clabels.fndefs cfm) (cdr d))
				 (cv (cnode.clovars (clabels.body cfm))
				     (union cv (cnode.clovars (car d)))))
				((null d)
				 (alter-cnode cnode (clovars := cv)))
			      (alter-clambda (cnode.cform (car d))
					     (fnp := 'ezclose)
					     (tvars := nil))
			      (alter-cnode (car d)
					   (clovars := (cnode.refs (car d)))))
			    (amapc (lambda (v) (putprop v t 'labels-function))
				   (clabels.fnvars cfm))
			    (alter-clabels cfm (easy := 'ezclose)))))
		  (bind-analyze (car d) ez (car v))))
	     (putprop (car v) (car d) 'known-function)))))

(define bind-analyze-return
  (lambda (cnode cfm)
    (let ((cn (return.cont cfm))
	  (val (return.val cfm)))
      (bind-analyze cn 'noclose nil)
      (cond ((and (eq (type (cnode.cform cn)) 'continuation)
		  (eq (type (cnode.cform val)) 'clambda))
	     (let ((var (continuation.var (cnode.cform cn))))
	       (putprop var val 'known-function)
	       (bind-analyze val
			     (and (not (get var 'variable-refp))
				  (if (memq var
					    (cnode.clovars
					     (continuation.body
					      (cnode.cform cn))))
				      'ezclose
				      (block (alter-continuation (cnode.cform cn)
								 (tvars := nil))
					     'noclose)))
			     nil)))
	    (t (bind-analyze val nil nil)))
      (alter-cnode cnode
		   (clovars := (union (cnode.clovars cn)
				      (cnode.clovars val)))))))

(define bind-analyze-ccombination
  (lambda (cnode cfm)
    (let ((args (ccombination.args cfm)))
      (bind-analyze (car args) 'noclose nil)
      (let ((fn (cnode.cform (car args))))
	(cond ((and (eq (type fn) 'trivial)
		    (eq (type (node.form (trivial.node fn)))
			'variable)
		    (trivfn (variable.var (node.form (trivial.node fn)))))
	       (bind-analyze (cadr args) 'noclose nil)
	       (bind-ccombination-analyze cnode
					  (cddr args)
					  nil
					  (cnode.clovars (cadr args))))
	      ((eq (type fn) 'clambda)
	       (bind-ccombination-analyze cnode
					  (cdr args)
					  (clambda.vars fn)
					  (cnode.clovars (car args)))
	       (amapc (lambda (v)
			(if (let ((kfn (get v 'known-function)))
			      (and kfn
				   (eq (eqcase (type (cnode.cform kfn))
					 (clambda
					  (clambda.fnp
					   (cnode.cform kfn)))
					 (continuation
					  (continuation.fnp
					   (cnode.cform kfn))))
				       'noclose)))
			    (alter-clambda
			     fn
			     (tvars := (delq v (clambda.tvars fn))))))
		      (clambda.tvars fn)))
	      (t (bind-ccombination-analyze cnode
					    (cdr args)
					    nil
					    (cnode.clovars (car args)))))))))

;;; vars may be nil - we depend on (cdr nil)=nil.

(define bind-ccombination-analyze
  (lambda (cnode args vars fcv)
    (do ((a args (cdr a))
	 (v vars (cdr v))
	 (cv fcv (union cv (cnode.clovars (car a)))))
	((null a)
	 (alter-cnode cnode (clovars := cv)))
      (cond ((and vars
		  (memq (type (cnode.cform (car a))) '(clambda continuation))
		  (not (get (car v) 'write-refs)))
	     (putprop (car v) (car a) 'known-function)
	     (bind-analyze (car a)
			   (and (not (get (car v) 'variable-refp))
				(if (memq (car v) fcv)
				    'ezclose
				    'noclose))
			   nil))
	    (t (bind-analyze (car a) nil nil))))))

;;; depth analysis for cps version.

;;; for each clambda and continuation we fill in:
;;;	dep		depth of temp var usage at this point
;;;	maxdep		max depth below this point

;;; value of depth-analyze is the max depth

(define depth-analyze
  (lambda (cnode dep)
    (let ((cfm (cnode.cform cnode)))
      (eqcase (type cfm)
	(trivial dep)
	(cvariable dep)
	(clambda
	 (let ((md (depth-analyze (clambda.body cfm)
				  (if (eq (clambda.fnp cfm) 'noclose)
				      (+ dep (length (clambda.tvars cfm)))
				      (min (length (clambda.vars cfm))
					   (+ 1 **number-of-arg-regs**))))))
	   (alter-clambda
	    cfm
	    (dep := (if (eq (clambda.fnp cfm) 'noclose) dep 0))
	    (maxdep := md))
	   md))
	(continuation
	 (let ((md (depth-analyze
		    (continuation.body cfm)
		    (if (eq (continuation.fnp cfm) 'noclose)
			(+ dep (length (continuation.tvars cfm)))
			2))))                                      ;;* 2 = arg + closure?
	   (alter-continuation
	    cfm
	    (dep := (if (eq (continuation.fnp cfm) 'noclose) dep 0))
	    (maxdep := md))
	   md))
	(cif
	 (max (depth-analyze (cif.pred cfm) dep)
	      (depth-analyze (cif.con cfm) dep)
	      (depth-analyze (cif.alt cfm) dep)))
	(caset
	 (max (depth-analyze (caset.cont cfm) dep)
	      (depth-analyze (caset.body cfm) dep)))
	(clabels
	 (let ((dp (if (eq (clabels.easy cfm) 'noclose)
		       dep
		       (+ dep (length (clabels.fnvars cfm))))))
	   (do ((d (clabels.fndefs cfm) (cdr d))
		(md (depth-analyze (clabels.body cfm) dp)
		    (max md (depth-analyze (car d) dp))))
	       ((null d) md))))
	(ccombination
	 (do ((a (ccombination.args cfm) (cdr a))
	      (md 0 (max md (depth-analyze (car a) dep))))
	     ((null a) md)))
	(return
	 (max (depth-analyze (return.cont cfm) dep)
	      (depth-analyze (return.val cfm) dep)))))))

;;; closure analysis for cps version

;;; for each clambda, continuation, and clabels we fill in:
;;;	consenv		the consed environment of the clambda,
;;;			continuation, or clabels (before any
;;;			closerefs have been consed on)
;;; for each clambda and continuation we fill in:
;;;	closerefs	a list of variables referenced by the clambda
;;;			or continuation which are not in the consed
;;;			environment at the point of the clambda or
;;;			continuation and so must be consed onto the
;;;			environment at closure time; however, these
;;;			need not be consed on if the clambda or
;;;			continuation is in function position of
;;;			a father which is a ccombination or return
;;; for the clambda's in the fndefs of a clabels, these may be
;;; slightly artificial for the sake of optimization (see below).
;;; for each clambda we fill in:
;;;	asetvars	a list of the variables bound in the clambda
;;;			which are ever aset and so must be consed
;;;			onto the environment immediately if any
;;;			closures occur in the body
;;; for each clabels we fill in:
;;;	fnenv		variables to be consed onto the current consenv
;;;			before closing the labels functions

;;; cenv is the consed environment (a list of variables)

;;- Return REFS minus those elements that are in CENV or that are known NOCLOSE
;;- functions.  (Preserves the order of REFS.)

(define filter-closerefs
  (lambda (refs cenv)
    (do ((x refs (cdr x))
	 (y nil
	    (if (or (memq (car x) cenv)
		    (let ((kfn (get (car x) 'known-function)))
		      (and kfn
			   (eq (eqcase (type (cnode.cform kfn))
				 (clambda
				  (clambda.fnp (cnode.cform kfn)))
				 (continuation
				  (continuation.fnp (cnode.cform kfn))))
			       'noclose))))
		y
		(cons (car x) y))))
	((null x) (nreverse y)))))

;;- Performed for effect.

(define close-analyze
  (lambda (cnode cenv)
    (let ((cfm (cnode.cform cnode)))
      (eqcase (type cfm)
	(trivial nil)
	(cvariable nil)
	(clambda
	 (let ((cr (and (not (eq (clambda.fnp cfm) 'noclose))
			(filter-closerefs (cnode.refs cnode) cenv)))
	       (av (do ((v (clambda.vars (cnode.cform cnode)) (cdr v))
			(a nil (if (and (get (car v) 'write-refs)
					(memq (car v)
					      (cnode.clovars
					       (clambda.body cfm))))
				   (cons (car v) a)
				   a)))
		       ((null v) a))))
	   (alter-clambda cfm
			  (consenv := cenv)
			  (closerefs := cr)
			  (asetvars := av))
	   (close-analyze (clambda.body cfm)
			  (append av cr cenv))))
	(continuation
	 (and (get (continuation.var cfm) 'write-refs)
	      (error '"how could an aset refer to a continuation variable?"
		     cnode
		     'fail-act))
	 (let ((cr (and (not (eq (continuation.fnp cfm) 'noclose))
			(filter-closerefs (cnode.refs cnode) cenv))))
	   (alter-continuation cfm
			       (consenv := cenv)
			       (closerefs := cr))
	   (close-analyze (continuation.body cfm)
			  (append cr cenv))))
	(cif
	 (close-analyze (cif.pred cfm) cenv)
	 (close-analyze (cif.con cfm) cenv)
	 (close-analyze (cif.alt cfm) cenv))
	(caset
	 (close-analyze (caset.cont cfm) cenv)
	 (close-analyze (caset.body cfm) cenv))
	(clabels
	 ((lambda (cenv)
	    (block (amapc (lambda (d) (close-analyze d cenv))
			  (clabels.fndefs cfm))
		   (close-analyze (clabels.body cfm) cenv)))
	  (cond ((clabels.easy cfm)
		 (do ((d (clabels.fndefs cfm) (cdr d))
		      (r nil (union r (cnode.refs (car d)))))
		     ((null d)
		      (let ((e (filter-closerefs r cenv)))
			(alter-clabels cfm
				       (fnenv := e)
				       (consenv := cenv))
			(append e cenv)))))
		(t (alter-clabels cfm
				  (fnenv := nil)
				  (consenv := cenv))
		   cenv))))
	(ccombination
	 (amapc (lambda (a) (close-analyze a cenv))
		(ccombination.args cfm)))
	(return
	 (close-analyze (return.cont cfm) cenv)
	 (close-analyze (return.val cfm) cenv))))))

;;; code generation routines

;;- Here's the runtime organization:

;;- A closure is represented by a list of the form (CBETA <progname> <label> . <env>).
;;- (I'm not sure yet if continuations have the exact same representation.)

;;- A top-level function gets compiled to a Maclisp function with no arguments and a
;;- generated name <progname>.  Its body is a PROG with a label for each cps function
;;- generated from the source code.  To invoke a closure, extract <progname> from it,
;;- set the global variable **ENV** to the closure's cddr (i.e., (<label> . <env>)),
;;- and call (<progname>).  <progname>'s code starts with a stub that extracts <label>,
;;- sets **ENV** to its cdr (i.e., just <env>), and jumps to the label.

;;- The user's name for the function is globally bound to a closure entering <progname>.
;;- The <progname> itself has its value binding set equal to its function binding, and
;;- its USER-FUNCTION property to the user's function name.

;;* Need to fill in details about function calling.  General idea is there's a driver
;;* loop that keeps calling the value of **FUN** -- which may (should?) be a closure,
;;* with arguments stored <mumble> and **NARGS** telling how many.

;;* The current continuation is in **CONT**.


;;- Return Maclisp code for a top-level function named USERNAME with 
;;- definition CNODE (which should be a CLAMBDA).

;;- The code does a DEFUN of the zero-arg function described above, and sets the
;;- properties of USERNAME and the generated progname appropriately.

(define compilate-one-function		;complicate-one-function?
  (lambda (cnode username)
    (let ((progname (gen-global-name)))
      (compilate-loop username
		      progname
		      (list (list username cnode))
		      (list (list progname cnode nil))
		      nil
		      0
		      (list `(setq ,username
				   (list 'cbeta
					 ,progname
					 ',(clambda.name (cnode.cform cnode))))
			    `(defprop ,progname ,username user-function))))))

;;- Produce a Maclisp code block for all FNS.
;;- USERNAME:	see above
;;- PROGNAME, BLOCKFNS, FNS:	see COMPILATE comments
;;- PROGBODY:	accumulator for procedure body
;;- TMAX:	the max number of temporary regs live at any point
;;- STUFF:	stuff at the end of the returned block

(define compilate-loop
  (lambda (username progname blockfns fns progbody tmax stuff)
    (if (null fns)
	`(progn 'compile
		(comment module for function ,username)
		(defun ,progname ()
		  (prog ()
			(declare (special ,progname ,@(used-templocs tmax)))
			(go (prog2 nil
				   (car **env**)
				   (setq **env** (cdr **env**))))
			,@(nreverse progbody)))
		(setq ,progname (get ',progname 'subr))
		,@stuff)
	(compilate (car (car fns))
		   (cadr (car fns))
		   (caddr (car fns))
		   blockfns
		   (cdr fns)
		   (lambda (code newfns)
		     (let ((cfm (cnode.cform (cadr (car fns)))))
		       (compilate-loop
			username
			progname
			blockfns
			newfns
			(nconc (reverse (deprognify1 code t))
			       (cons (remark-on (cadr (car fns)))
				     (cons (eqcase (type cfm)
					     (clambda
					      (clambda.name cfm))
					     (continuation
					      (continuation.name cfm)))
					   progbody)))
			(max tmax
			     (eqcase (type cfm)
			       (clambda
				(clambda.maxdep cfm))
			       (continuation
				(continuation.maxdep cfm))))
			stuff)))))))

;;; progname:	name of a variable which at run time will have
;;;		as value the subr pointer for the prog
;;; fn:		the function to compile (a clambda or continuation cnode)
;;; externalp:	non-nil if the function is external
;;**            (No such parameter any more.)
;;; rnl:	initial rename list (non-nil only for noclose fns).
;;;		entries are: (var . code)
;;; blockfns:	an alist of functions in this block.
;;;		entries are: (username cnode)
;;; fns:	a list of tuples for functions yet to be compiled;
;;;		each tuple is (progname fn rnl)
;;; c:		a continuation, taking:
;;;		code:	the piece of maclisp code for the function
;;;		fns:	an augmented fns list

(define compilate
  (lambda (progname fn rnl blockfns fns c)
    (let ((cfm (cnode.cform fn)))
      (eqcase (type cfm)
	(clambda
	 (let ((cenv (append (clambda.asetvars cfm)
			     (clambda.closerefs cfm)
			     (clambda.consenv cfm))))
	   (comp-body (clambda.body cfm)
		      (regslist cfm t (envcarcdr cenv rnl))
		      progname
		      blockfns
		      cenv
		      fns
		      (lambda (code fns)
			(c (set-up-asetvars code
					    (clambda.asetvars cfm)
					    (regslist cfm nil nil))
			   fns)))))
	(continuation
	 (let ((cenv (append (continuation.closerefs cfm)
			     (continuation.consenv cfm))))
	   (comp-body (continuation.body cfm)
		      (if (eq (continuation.fnp cfm) 'noclose)
			  (if (null (continuation.tvars cfm))
			      (envcarcdr cenv rnl)
			      (cons (cons (continuation.var cfm)
					  (temploc (continuation.dep cfm)))
				    (envcarcdr cenv rnl)))
			  (cons (cons (continuation.var cfm)
				      (car **argument-registers**))
				(envcarcdr cenv rnl)))
		      progname
		      blockfns
		      cenv
		      fns
		      c)))))))

;;; deprognify is used only to make the output pretty by eliminating
;;; unnecessary occurrences of `progn`.

(defmac deprognify (form) `(deprognify1 ,form nil))

(set' *deprognify-count* 0)

(define deprognify1
  (lambda (form atomflushp)
    (if (or (atom form) (not (eq (car form) 'progn)))
	(list form)
	(do ((x (cdr form) (cdr x))
	     (z nil (cond ((null (cdr x)) (cons (car x) z))
			  ((null (car x))
			   (increment *deprognify-count*)
			   z)
			  ((atom (car x))
			   (cond (atomflushp
				  (increment *deprognify-count*)
				  z)
				 (t (cons (car x) z))))
			  ((eq (caar x) 'quote)
			   (increment *deprognify-count*)
			   z)
			  (t (cons (car x) z)))))
	    ((null x) (nreverse z))))))

;;- Return the Nth element of **cont+arg-regs**, if it exists; 
;;- otherwise a symbol of the form -N-.

(define temploc
  (lambda (n)
    (labels ((loop
	      (lambda (regs j)
		(if (null regs)
		    (implode (append '(-) (exploden n) '(-)))
		    (if (= j 0)
			(car regs)
			(loop (cdr regs) (- j 1)))))))
      (loop **cont+arg-regs** n))))

;;- Return RNL extended with each of VARS mapped to successive environment entries.
;;- [(car **env**), (cadr **env**), and so on]

(define envcarcdr
  (lambda (vars rnl)
    (do ((x '**env** `(cdr ,x))
	 (v vars (cdr v))
	 (r rnl (cons (cons (car v) (decarcdrate `(car ,x))) r)))
	((null v) r))))

;;- Allocate registers for the clambda CLAM's arguments.
;;- Returns RNL extended with the new allocations.

;;- For NOCLOSEs: the regs start at reg# (CLAMBDA.DEP CLAM).

;;- With non-NOCLOSEs:
;;- The continuation is always in register '**CONT**.
;;- If there are more than **NUMBER-OF-ARG-REGS** args, they're all passed
;;- in a list in the reg denoted by (CAR **ARGUMENT-REGISTERS**), and the
;;- `register' allocated for an arg is a car-cdr expression accessing that
;;- list.
;;- If there aren't too many args, they're in the regs of **CONT+ARGS-REGS**.
;;- (Presumably the first of those is '**CONT**.)  (These are the same as the
;;- first regs in TEMPLOC's sequence.)

;;; avp non-nil means that asetvars are to be excluded from the consed list.

(define regslist
  (lambda (clam avp rnl)
    (let ((av (and avp (clambda.asetvars clam))))
      (if (eq (clambda.fnp clam) 'noclose)
	  (do ((j (clambda.dep clam) (+ j 1))
	       (tv (clambda.tvars clam) (cdr tv))
	       (r rnl
		  (if (memq (car tv) av)
		      r
		      (cons (cons (car tv) (temploc j)) r))))
	      ((null tv) r))
	  (let ((vars (clambda.vars clam)))
	    (if (> (length (cdr vars)) **number-of-arg-regs**)
		(do ((x (car **argument-registers**) `(cdr ,x))
		     (v (cdr vars) (cdr v))
		     (r (cons (cons (car vars) '**cont**) rnl)
			(if (memq (car v) av)
			    r
			    (cons (cons (car v) (decarcdrate `(car ,x))) r))))
		    ((null v) r))
		(do ((v vars (cdr v))
		     (x **cont+arg-regs** (cdr x))
		     (r rnl
			(if (memq (car v) av)
			    r
			    (cons (cons (car v) (car x)) r))))
		    ((null v) r))))))))

;;- Return CODE prefaced with an extension of the **ENV** reg for the variables
;;- in AV.

(define set-up-asetvars
  (lambda (code av rnl)
    (if (null av)
	code
	`(progn (setq **env**
		      ,(do ((a (reverse av) (cdr a))
			    (e '**env** `(cons ,(lookupicate (car a) rnl) ,e)))
			   ((null a) e)))
		,@(deprognify code)))))

;;; rnl is the `rename list`: an alist describing how to refer to the variables in the
;;; environment.  cenv is the consed environment seen by the body.

;;* Interesting that there's no CLAMBDA or CONTINUATION case.

(define comp-body
  (lambda (body rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform body)))
      (eqcase (type cfm)
	(cif
	 (produce-if body rnl progname blockfns cenv fns c))
	(caset
	 (produce-aset body rnl progname blockfns cenv fns c))
	(clabels
	 (or (equal cenv (clabels.consenv cfm))
	     (error '"environment disagreement" body 'fail-act))
	 (let ((lcenv (append (clabels.fnenv cfm) cenv)))
	   (comp-body
	    (clabels.body cfm)
	    (envcarcdr lcenv rnl)
	    progname
	    blockfns
	    lcenv
	    fns
	    (lambda (lbod fns)
	      (produce-labels body lbod rnl progname blockfns fns c)))))
	(ccombination
	 (let ((fn (cnode.cform (car (ccombination.args cfm)))))
	   (cond ((eq (type fn) 'clambda)
		  (produce-lambda-combination body rnl progname blockfns cenv fns c))
		 ((and (eq (type fn) 'trivial)
		       (eq (type (node.form (trivial.node fn))) 'variable)
		       (trivfn (variable.var (node.form (trivial.node fn)))))
		  (produce-trivfn-combination body rnl progname blockfns cenv fns c))
		 (t (produce-combination body rnl progname blockfns cenv fns c)))))
	(return
	 (let ((fn (cnode.cform (return.cont cfm))))
	   (if (eq (type fn) 'continuation)
	       (produce-continuation-return body rnl progname blockfns cenv fns c)
	       (produce-return body rnl progname blockfns cenv fns c))))))))

(define produce-if
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (analyze (cif.pred cfm)
	       rnl
	       progname
	       blockfns
	       fns
	       (lambda (pred fns)
		 (comp-body (cif.con cfm)
			    rnl
			    progname
			    blockfns
			    cenv
			    fns
			    (lambda (con fns)
			      (comp-body (cif.alt cfm)
					 rnl
					 progname
					 blockfns
					 cenv
					 fns
					 (lambda (alt fns)
					   (c (condicate pred
							 con
							 alt)
					      fns))))))))))

(define produce-aset
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (analyze (caset.body cfm)
	       rnl
	       progname
	       blockfns
	       fns
	       (lambda (body fns)
		 (let ((contcfm (cnode.cform (caset.cont cfm))))
		   (if (eq (type contcfm) 'continuation)
		       (comp-body (continuation.body contcfm)
				  (if (continuation.tvars contcfm)
				      (cons (cons (car (continuation.tvars contcfm))
						  (temploc (continuation.dep
							    contcfm)))
					    (envcarcdr cenv rnl))
				      (envcarcdr cenv rnl))
				  progname
				  blockfns
				  cenv
				  fns
				  (lambda (code fns)
				    (c (lambdacate
					(list (continuation.var contcfm))
					(continuation.tvars contcfm)
					(continuation.dep contcfm)
					(list (output-aset
					       (lookupicate (caset.var cfm)
							    rnl)
					       body))
					(remark-on (caset.cont cfm))
					'**env**
					code)
				       fns)))
		       (analyze
			(caset.cont cfm)
			rnl
			progname
			blockfns
			fns
			(lambda (cont fns)
			  (c `(progn (setq **fun** ,cont)
				     (setq ,(car **argument-registers**)
					   ,(output-aset
					     (lookupicate (caset.var cfm)
							  rnl)
					     body))
				     (return nil))
			     fns))))))))))

(define produce-labels
  (lambda (cnode lbod rnl progname blockfns fns c)
    (let ((cfm (cnode.cform cnode)))
      (let ((vars (clabels.fnvars cfm))
	    (defs (clabels.fndefs cfm))
	    (fnenv (clabels.fnenv cfm)))
	(let ((fnenv-fix (if fnenv `((setq **env** ,(cons-closerefs fnenv rnl))))))
	  (eqcase (clabels.easy cfm)
	    (nil
	     (do ((v vars (cdr v))
		  (d defs (cdr d))
		  (fns fns (cons (list progname (car d) nil) fns))
		  (rp nil (cons `(rplacd (cddr ,(car v))
					 ,(cons-closerefs
					   (clambda.closerefs
					    (cnode.cform (car d)))
					   rnl))
				rp))
		  (cb nil (cons `(list 'cbeta ,progname ',(car v)) cb)))
		 ((null v)
		  (c `((lambda ,vars
			 ,@fnenv-fix
			 ,@rp
			 ,@(deprognify lbod))
		       ,@(nreverse cb))
		     fns))))
	    (ezclose
	     (do ((v vars (cdr v))
		  (d defs (cdr d))
		  (fns fns (cons (list progname (car d) nil) fns))
		  (rp nil (cons `(rplacd ,(car v)
					 ,(cons-closerefs
					   (clambda.closerefs
					    (cnode.cform (car d)))
					   rnl))
				rp))
		  (cb nil (cons `(list ',(car v)) cb)))
		 ((null v)
		  (c `((lambda ,vars
			 ,@fnenv-fix
			 ,@rp
			 ,@(deprognify lbod))
		       ,@(nreverse cb))
		     fns))))
	    (noclose
	     (c `(progn ,@fnenv-fix ,@(deprognify lbod))
		(do ((v vars (cdr v))
		     (d defs (cdr d))
		     (fns fns (cons (list progname (car d) rnl) fns)))
		    ((null v) fns))))))))))

(define produce-lambda-combination
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (let ((fn (cnode.cform (car (ccombination.args cfm)))))
	(and (clambda.closerefs fn)
	     (error '"functional lambda has closerefs" cnode 'fail-act))
	(or (equal cenv (clambda.consenv fn))
	    (error '"environment disagreement" cnode 'fail-act))
	(or (eq (clambda.fnp fn) 'noclose)
	    (error '"non-noclose lambda in function position" cnode 'fail-act))
	(comp-body
	 (clambda.body fn)
	 (envcarcdr (clambda.asetvars fn)
		    (regslist fn t (envcarcdr cenv rnl)))
	 progname
	 blockfns
	 (append (clambda.asetvars fn) cenv)
	 fns
	 (lambda (body fns)
	   (mapanalyze (cdr (ccombination.args cfm))
		       rnl
		       progname
		       blockfns
		       fns
		       (lambda (args fns)
			 (c (lambdacate (clambda.vars fn)
					(clambda.tvars fn)
					(clambda.dep fn)
					args
					(remark-on
					 (car (ccombination.args cfm)))
					'**env**
					(set-up-asetvars
					 body
					 (clambda.asetvars fn)
					 (regslist fn nil nil)))
			    fns)))))))))

(define produce-trivfn-combination
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (let ((fn (cnode.cform (car (ccombination.args cfm))))
	    (cont (cnode.cform (cadr (ccombination.args cfm)))))
	(mapanalyze (cddr (ccombination.args cfm))
		    rnl
		    progname
		    blockfns
		    fns
		    (lambda (args fns)
		      (eqcase (type cont)
			(continuation
			 (produce-trivfn-combination-continuation
			  cnode rnl progname blockfns cenv
			  fns c cfm fn cont args))
			(cvariable
			 (produce-trivfn-combination-cvariable
			  cnode rnl progname blockfns cenv
			  fns c cfm fn cont args)))))))))

(define produce-trivfn-combination-continuation
  (lambda (cnode rnl progname blockfns cenv fns c cfm fn cont args)
    (block (and (continuation.closerefs cont)
		(error '"continuation for trivfn has closerefs" cnode 'fail-act))
	   (or (eq (continuation.fnp cont) 'noclose)
	       (error '"non-noclose continuation for trivfn" cnode 'fail-act))
	   (comp-body (continuation.body cont)
		      (if (continuation.tvars cont)
			  (cons (cons (car (continuation.tvars cont))
				      (temploc (continuation.dep cont)))
				(envcarcdr cenv rnl))
			  (envcarcdr cenv rnl))
		      progname
		      blockfns
		      cenv
		      fns
		      (lambda (body fns)
			(c (lambdacate
			    (list (continuation.var cont))
			    (continuation.tvars cont)
			    (continuation.dep cont)
			    (list `(,(variable.var (node.form (trivial.node fn)))
				    ,@args))
			    (remark-on (cadr (ccombination.args cfm)))
			    '**env**
			    body)
			   fns))))))

(define produce-trivfn-combination-cvariable
  (lambda (cnode rnl progname blockfns cenv fns c cfm fn cont args)
    (analyze
     (cadr (ccombination.args cfm))
     rnl
     progname
     blockfns
     fns
     (lambda (contf fns)
       (let ((kf (get (cvariable.var cont) 'known-function))
	     (val `(,(variable.var (node.form (trivial.node fn))) ,@args)))
	 (if kf
	     (let ((kcfm (cnode.cform kf)))
	       (let ((envadj
		      (adjust-knownfn-cenv cenv
					   (cvariable.var cont)
					   contf
					   (continuation.fnp kcfm)
					   (append
					    (continuation.closerefs kcfm)
					    (continuation.consenv kcfm)))))
		 (c `(progn
		      ,@(if (eq (continuation.fnp kcfm)
				'noclose)
			    (deprognify
			     (lambdacate (list (continuation.var kcfm))
					 (continuation.tvars kcfm)
					 (continuation.dep kcfm)
					 (list val)
					 (remark-on kf)
					 envadj
					 nil))
			    (psetqify (list envadj val)
				      (list '**env**
					    (car **argument-registers**))))
		      (go ,(continuation.name kcfm)))
		    fns)))
	     (c `(progn (setq **fun** ,contf)
			(setq ,(car **argument-registers**) ,val)
			(return nil))
		fns)))))))

(define produce-combination
  (lambda (cnode rnl progname blockfns cenv fns c)
    (mapanalyze (ccombination.args (cnode.cform cnode))
		rnl
		progname
		blockfns
		fns
		(lambda (form fns)
		  (c (let ((f (cnode.cform (car (ccombination.args
						 (cnode.cform cnode))))))
		       (if (and (eq (type f) 'trivial)
				(eq (type (node.form (trivial.node f)))
				    'variable))
			   (let ((v (variable.var
				     (node.form (trivial.node f)))))
			     (produce-combination-variable
			      cnode rnl progname blockfns cenv
			      fns c form v (get v 'known-function)))
			   `(progn (setq **fun** ,(car form))
				   ,@(psetq-args (cdr form))
				   (setq **nargs** ',(length (cddr form)))
				   (return nil))))
		     fns)))))

(define produce-combination-variable
  (lambda (cnode rnl progname blockfns cenv fns c form v kfn)
    (if kfn
	(let ((envadj
	       (adjust-knownfn-cenv cenv
				    v
				    (car form)
				    (clambda.fnp (cnode.cform kfn))
				    (append (clambda.closerefs (cnode.cform kfn))
					    (clambda.consenv (cnode.cform kfn))))))
	  (or (eq (type (cnode.cform kfn)) 'clambda)
	      (error '"known function not clambda" cnode 'fail-act))
	  `(progn ,@(if (eq (clambda.fnp (cnode.cform kfn)) 'noclose)
			(deprognify
			 (lambdacate (clambda.vars (cnode.cform kfn))
				     (clambda.tvars (cnode.cform kfn))
				     (clambda.dep (cnode.cform kfn))
				     (cdr form)
				     (remark-on kfn)
				     envadj
				     nil))
			(psetq-args-env (cdr form) envadj))
		  (go ,(clambda.name (cnode.cform kfn)))))
	(if (assq v blockfns)
	    `(progn ,@(psetq-args (cdr form))
		    ,@(if (not (equal (clambda.consenv
				       (cnode.cform
					(cadr (assq v blockfns))))
				      cenv))
			  `((setq **env** (cdddr ,(car form)))))
		    (go ,(clambda.name (cnode.cform (cadr (assq v blockfns))))))
	    `(progn (setq **fun** ,(car form))
		    ,@(psetq-args (cdr form))
		    (setq **nargs** ',(length (cddr form)))
		    (return nil))))))

(define adjust-knownfn-cenv
  (lambda (cenv var varref fnp lcenv)
    (cond ((equal lcenv cenv) '**env**)
	  ((null lcenv) 'nil)
	  (t (eqcase fnp
	       (noclose
		(do ((x cenv (cdr x))
		     (y '**env** `(cdr ,y))
		     (i (- (length cenv) (length lcenv)) (- i 1)))
		    ((< i 1)
		     (if (equal x lcenv)
			 (decarcdrate y)
			 (error '"cannot recover environment for known function"
				var
				'fail-act)))))
	       (ezclose
		(if (get var 'labels-function)
		    `(cdr ,varref)
		    varref))
	       (nil `(cdddr ,varref)))))))

(define produce-continuation-return
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (let ((fn (cnode.cform (return.cont cfm))))
	(and (continuation.closerefs fn)
	     (error '"functional continuation has closerefs" cnode 'fail-act))
	(or (equal cenv (continuation.consenv fn))
	    (error '"environment disagreement" cnode 'fail-act))
	(or (eq (continuation.fnp fn) 'noclose)
	    (error '"non-noclose continuation in function position"
		   cnode
		   'fail-act))
	(comp-body (continuation.body fn)
		   (if (continuation.tvars fn)
		       (cons (cons (car (continuation.tvars fn))
				   (temploc (continuation.dep fn)))
			     (envcarcdr cenv rnl))
		       (envcarcdr cenv rnl))
		   progname
		   blockfns
		   cenv
		   fns
		   (lambda (body fns)
		     (analyze (return.val cfm)
			      rnl
			      progname
			      blockfns
			      fns
			      (lambda (val fns)
				(c (lambdacate
				    (list (continuation.var fn))
				    (continuation.tvars fn)
				    (continuation.dep fn)
				    (list val)
				    (remark-on (return.cont cfm))
				    '**env**
				    body)
				   fns)))))))))

(define produce-return
  (lambda (cnode rnl progname blockfns cenv fns c)
    (let ((cfm (cnode.cform cnode)))
      (analyze (return.val cfm)
	       rnl
	       progname
	       blockfns
	       fns
	       (lambda (val fns)
		 (analyze (return.cont cfm)
			  rnl
			  progname
			  blockfns
			  fns
			  (lambda (cont fns)
			    (produce-return-1
			     cnode rnl progname blockfns
			     cenv fns c cfm val cont))))))))

(define produce-return-1
  (lambda (cnode rnl progname blockfns cenv fns c cfm val cont)
    (if (and (eq (type (cnode.cform (return.cont cfm))) 'cvariable)
	     (get (cvariable.var (cnode.cform (return.cont cfm)))
		  'known-function))
	(let ((kcfm (cnode.cform
		     (get (cvariable.var
			   (cnode.cform (return.cont cfm)))
			  'known-function))))
	  (or (eq (type kcfm) 'continuation)
	      (error '"known function not continuation" cnode 'fail-act))
	  (let ((envadj
		 (adjust-knownfn-cenv cenv
				      (cvariable.var (cnode.cform (return.cont cfm)))
				      cont
				      (continuation.fnp kcfm)
				      (append
				       (continuation.closerefs kcfm)
				       (continuation.consenv kcfm)))))
	    (c `(progn ,@(if (eq (continuation.fnp kcfm) 'noclose)
			     (deprognify
			      (lambdacate (list (continuation.var kcfm))
					  (continuation.tvars kcfm)
					  (continuation.dep kcfm)
					  (list val)
					  (remark-on
					   (get (cvariable.var
						 (cnode.cform (return.cont cfm)))
						'known-function))
					  envadj
					  nil))
			     (psetqify (list envadj val)
				       (list '**env**
					     (car **argument-registers**))))
		       (go ,(continuation.name kcfm)))
	       fns)))
	(c `(progn (setq **fun** ,cont)
		   ,@(if (not (eq val (car **argument-registers**)))
			 `((setq ,(car **argument-registers**) ,val)))
		   (return nil))
	   fns))))

;;; handle case of invoking a known noclose function or continuation.
;;; for an explicit ((lambda ... body) ...), body is the body.
;;; otherwise, it is nil, and someone will do an appropriate go later.

;;* Huh?

(define lambdacate
  (lambda (vars tvars dep args rem envadj body)
    (labels ((loop
	      (lambda (v a realvars realargs effargs)
		;;realvars is computed purely for error-checking
		(if (null a)
		    (let ((b `(progn ,@(psetq-temps (nreverse realargs) dep envadj)
				     ,rem
				     ,@(deprognify body)))
			  (rv (nreverse realvars)))
		      (if (not (equal rv tvars))
			  (error '"tvars screwup in lambdacate"
				 `((vars = ,vars)
				   (tvars = ,tvars)
				   (realvars = ,rv))
				 'fail-act))
		      (if effargs
			  `(progn ,@effargs ,@(deprognify b))
			  b))
		    (cond ((let ((kfn (get (car v) 'known-function)))
			     (and kfn
				  (eq (eqcase (type (cnode.cform kfn))
					(clambda
					 (clambda.fnp
					  (cnode.cform kfn)))
					(continuation
					 (continuation.fnp
					  (cnode.cform kfn))))
				      'noclose)))
			   (loop (cdr v) (cdr a) realvars realargs effargs))
			  ((or (get (car v) 'read-refs)
			       (get (car v) 'write-refs))
			   (loop (cdr v)
				 (cdr a)
				 (cons (car v) realvars)
				 (cons (car a) realargs)
				 effargs))
			  (t (loop (cdr v)
				   (cdr a)
				   realvars
				   realargs
				   (cons (car a) effargs))))))))
      (loop vars args nil nil nil))))

;;; generate parallel setq'ing of registers to args.
;;; returns a list of things; one writes ,@(psetqify ...) within `.

(define psetqify
  (lambda (args registers)
    (if (< (length args) 5)
	(psetqify-method-2 args registers)
	(psetqify-method-3 args registers))))


;;- Throw out those arg/reg pairs that have no effect, then generate either
;;- special code for the 0 or 1 arg case, or code of the form
;;- ((lambda (temp1 temp2) (setq reg1 temp1) (set1 reg2 temp2)) arg1 arg2).

(define psetqify-method-2
  (lambda (args registers)
    (labels ((psetq1
	      (lambda (a regs qvars setqs used)
		(if (null a)
		    (if (null setqs)
			nil
			(if (null (cdr setqs))
			    `((setq ,(cadar setqs) ,(car used)))
			    ;;important: do not nreverse the setqs!
			    ;;makes maclisp compiler win better.
			    `(((lambda ,(nreverse qvars) ,@setqs)
			       ,@(nreverse used)))))
		    (if (eq (car a) (car regs)) ;avoid useless setq's
			(psetq1 (cdr a)
				(cdr regs)
				qvars
				setqs
				used)
			((lambda (qv)
			   (psetq1 (cdr a)
				   (cdr regs)
				   (cons qv qvars)
				   (cons `(setq ,(car regs) ,qv) setqs)
				   (cons (car a) used)))
			 (gentemp 'q)))))))
      (psetq1 args registers nil nil nil))))

;;- Again, throw out useless setq's and treat the 0 and 1 cases specially, otherwise:
;;- (prog () (declare (special reg1-temp reg2-temp))
;;-          (setq reg2-temp arg2) (setq reg1-temp arg1)
;;-          (setq reg2 reg2-temp) (setq reg1 reg1-temp))

(define psetqify-method-3
  (lambda (args registers)
    (labels ((psetq1
	      (lambda (a regs qvars setqs used)
		(if (null a)
		    (if (null setqs)
			nil
			(if (null (cdr setqs))
			    `((setq ,(cadar setqs) ,(caddr (car used))))
			    `((prog () (declare (special ,@qvars)) ,@used ,@setqs) )))
		    (if (eq (car a) (car regs)) ;avoid useless setq's
			(psetq1 (cdr a)
				(cdr regs)
				qvars
				setqs
				used)
			((lambda (qv)
			   (psetq1 (cdr a)
				   (cdr regs)
				   (cons qv qvars)
				   (cons `(setq ,(car regs) ,qv) setqs)
				   (cons `(setq ,qv ,(car a)) used)))
			 (catenate (car regs) '"-temp")))))))
      (psetq1 args registers nil nil nil))))

;;- Generate assignments for a function call with arguments ARGS.

(define psetq-args
  (lambda (args)
    (psetq-args-env args '**env**)))

;;* mumble

(define psetq-args-env
  (lambda (args envadj)
    (if (> (length args) (+ **number-of-arg-regs** 1))
	(psetqify (list envadj (car args) (cons 'list (cdr args)))
		  **env+cont+arg-regs**)
	(psetqify (cons envadj args) **env+cont+arg-regs**))))

;;- Generate assignments of ENVADJ to '**ENV**, and ARGS to the temp registers 
;;- starting at # DEP.

(define psetq-temps
  (lambda (args dep envadj)
    (do ((a args (cdr a))
	 (j dep (+ j 1))
	 (r nil (cons (temploc j) r)))
	((null a)
	 (psetqify (cons envadj args)
		   (cons '**env** (nreverse r)))))))


;;- Like ANALYZE, only maps over a list of cnodes, producing a list of Maclisp expressions.

(define mapanalyze
  (lambda (flist rnl progname blockfns fns c)
    (labels ((loop
	      (lambda (f z fns)
		(if (null f)
		    (c (nreverse z) fns)
		    (analyze (car f)
			     rnl
			     progname
			     blockfns
			     fns
			     (lambda (stuff fns)
			       (loop (cdr f)
				     (cons stuff z)
				     fns)))))))
      (loop flist nil fns))))

;;- Call C with two args: Maclisp code to execute CNODE, and FNS extended with
;;- any new functions it uses.

(define analyze
  (lambda (cnode rnl progname blockfns fns c)
    (let ((cfm (cnode.cform cnode)))
      (eqcase (type cfm)
	(trivial
	 (c (trivialize (trivial.node cfm) rnl) fns))
	(cvariable
	 (c (lookupicate (cvariable.var cfm) rnl) fns))
	(clambda
	 (analyze-clambda cnode rnl progname blockfns fns c cfm))
	(continuation
	 (analyze-continuation cnode rnl progname blockfns fns c cfm))
	(cif
	 (analyze-cif cnode rnl progname blockfns fns c cfm))
	(clabels
	 (analyze-clabels cnode rnl progname blockfns fns c cfm))
	(ccombination
	 (analyze-ccombination cnode rnl progname blockfns fns c cfm))
	(return
	 (analyze-return cnode rnl progname blockfns fns c cfm))))))

(define analyze-clambda
  (lambda (cnode rnl progname blockfns fns c cfm)
    (eqcase (clambda.fnp cfm)
      (nil
       (c `(cons 'cbeta
		 (cons ,progname
		       (cons ',(clambda.name cfm)
			     ,(cons-closerefs (clambda.closerefs cfm)
					      rnl))))
	  (cons (list progname cnode nil) fns)))
      (ezclose
       (c (cons-closerefs (clambda.closerefs cfm) rnl)
	  (cons (list progname cnode nil) fns)))
      (noclose
       (c '"shouldn't ever be seen - noclose clambda"
	  (cons (list progname cnode rnl) fns))))))

(define analyze-continuation
  (lambda (cnode rnl progname blockfns fns c cfm)
    (eqcase (continuation.fnp cfm)
      (nil
       (c `(cons 'cbeta
		 (cons ,progname
		       (cons ',(continuation.name cfm)
			     ,(cons-closerefs (continuation.closerefs cfm)
					      rnl))))
	  (cons (list progname cnode nil) fns)))
      (ezclose
       (c (cons-closerefs (continuation.closerefs cfm) rnl)
	  (cons (list progname cnode nil) fns)))
      (noclose
       (c '"shouldn't ever be seen - noclose continuation"
	  (cons (list progname cnode rnl) fns))))))

(define analyze-cif
  (lambda (cnode rnl progname blockfns fns c cfm)
    (analyze (cif.pred cfm)
	     rnl
	     progname
	     blockfns
	     fns
	     (lambda (pred fns)
	       (analyze (cif.con cfm)
			rnl
			progname
			blockfns
			fns
			(lambda (con fns)
			  (analyze (cif.alt cfm)
				   rnl
				   progname
				   blockfns
				   fns
				   (lambda (alt fns)
				     (c (condicate pred con alt)
					fns)))))))))

(define analyze-clabels
  (lambda (cnode rnl progname blockfns fns c cfm)
    (analyze (clabels.body cfm)
	     (envcarcdr (append (clabels.fnenv cfm)
				(clabels.consenv cfm))
			rnl)
	     progname
	     blockfns
	     fns
	     (lambda (lbod fns)
	       (produce-labels cnode lbod rnl progname blockfns fns c)))))

(define analyze-ccombination
  (lambda (cnode rnl progname blockfns fns c cfm)
    (let ((fn (cnode.cform (car (ccombination.args cfm)))))
      (if (eq (type fn) 'clambda)
	  (analyze (clambda.body fn)
		   (envcarcdr (clambda.asetvars fn)
			      (regslist fn t (envcarcdr (clambda.consenv fn) rnl)))
		   progname
		   blockfns
		   fns
		   (lambda (body fns)
		     (mapanalyze
		      (cdr (ccombination.args cfm))
		      rnl
		      progname
		      blockfns
		      fns
		      (lambda (args fns)
			(c (lambdacate (clambda.vars fn)
				       (clambda.tvars fn)
				       (clambda.dep fn)
				       args
				       (remark-on (car (ccombination.args cfm)))
				       '**env**
				       (set-up-asetvars body
							(clambda.asetvars fn)
							(regslist fn nil nil)))
			   fns)))))
	  (error '"non-trivial function in analyze-ccombination" cnode 'fail-act)))))

(define analyze-return
  (lambda (cnode rnl progname blockfns fns c cfm)
    (let ((fn (cnode.cform (return.cont cfm))))
      (if (eq (type fn) 'continuation)
	  (analyze (continuation.body fn)
		   (if (continuation.tvars fn)
		       (cons (cons (car (continuation.tvars fn))
				   (temploc (continuation.dep fn)))
			     (envcarcdr (continuation.consenv fn) rnl))
		       (envcarcdr (continuation.consenv fn) rnl))
		   progname
		   blockfns
		   fns
		   (lambda (body fns)
		     (analyze (return.val cfm)
			      rnl
			      progname
			      blockfns
			      fns
			      (lambda (arg fns)
				(c (lambdacate
				    (list (continuation.var fn))
				    (continuation.tvars fn)
				    (continuation.dep fn)
				    (list arg)
				    (remark-on (return.cont cfm))
				    '**env**
				    body)
				   fns)))))
	  (error '"non-trivial function in analyze-return" cnode 'fail-act)))))

;;- The following functions generate Maclisp code for basic actions.
;;- `Code' arguments to them are themselves Maclisp code, and not, say, cnodes.

;;- A variable reference.
;;- (The result may be used as OUTPUT-ASET's VARREF, as well.)

(define lookupicate
  (lambda (var rnl)
    ((lambda (slot)
       (if slot (cdr slot)
	   (if (trivfn var)
	       `(getl ',var '(expr subr lsubr))
	       var)))
     (assq var rnl))))

;;- Cons up an environment (for a closure?).

(define cons-closerefs
  (lambda (closerefs rnl)
    (do ((cr (reverse closerefs) (cdr cr))
	 (x '**env** `(cons ,(lookupicate (car cr) rnl) ,x)))
	((null cr) x))))

;;- An assignment.  
;;- VARREF is a symbol or the car of a cdr chain ending with a symbol.

(define output-aset
  (lambda (varref body)
    (cond ((atom varref)
	   `(setq ,varref ,body))
	  ((eq (car varref) 'car)
	   `(car (rplaca ,(cadr varref) ,body)))
	  ((eq (car varref) 'cadr)
	   `(car (rplaca (cdr ,(cadr varref)) ,body)))
	  ((eq (car varref) 'caddr)
	   `(car (rplaca (cddr ,(cadr varref)) ,body)))
	  ((eq (car varref) 'cadddr)
	   `(car (rplaca (cdddr ,(cadr varref)) ,body)))
	  (t (error '"unknown aset discipline - output-aset" varref 'fail-act)))))

;;- An if/then/else.

;;; condicate turns an if into a cond; in so doing it tries to make the result pretty.

(define condicate
  (lambda (pred con alt)
    (if (or (atom alt) (not (eq (car alt) 'cond)))
	`(cond (,pred ,@(deprognify con))
	       (t ,@(deprognify alt)))
	`(cond (,pred ,@(deprognify con))
	       ,@(cdr alt)))))


;;; decarcdrate makes car-cdr chains prettier.

;;- Input and output are equivalent car/cdr chains ending in an atom.

(define decarcdrate
  (lambda (x)
    (cond ((atom x) x)
	  ((eq (car x) 'car)
	   (if (atom (cadr x))
	       x
	       (let ((y (decarcdrate (cadr x))))
		 (cond ((eq (car y) 'car) `(caar ,(cadr y)))
		       ((eq (car y) 'cdr) `(cadr ,(cadr y)))
		       ((eq (car y) 'cddr) `(caddr ,(cadr y)))
		       ((eq (car y) 'cdddr) `(cadddr ,(cadr y)))
		       (t `(car ,y))))))
	  ((eq (car x) 'cdr)
	   (if (atom (cadr x))
	       x
	       (let ((y (decarcdrate (cadr x))))
		 (cond ((eq (car y) 'cdr) `(cddr ,(cadr y)))
		       ((eq (car y) 'cddr) `(cdddr ,(cadr y)))
		       ((eq (car y) 'cdddr) `(cddddr ,(cadr y)))
		       (t `(cdr ,y))))))
	  (t x))))

;;- Maclisp code for a trivial node.

(define trivialize
  (lambda (node rnl)
    (let ((fm (node.form node)))
      (eqcase (type fm)
	(constant `',(constant.value fm))
	(variable (lookupicate (variable.var fm) rnl))
	(if (condicate (trivialize (if.pred fm) rnl)
		       (trivialize (if.con fm) rnl)
		       (trivialize (if.alt fm) rnl)))
	(aset
	 (output-aset (lookupicate (aset.var fm) rnl)
		      (trivialize (aset.body fm) rnl)))
	(combination
	 (let ((args (combination.args fm)))
	   (let ((fn (node.form (car args))))
	     (if (and (eq (type fn) 'variable)
		      (variable.globalp fn)
		      (trivfn (variable.var fn)))
		 (cons (variable.var fn)
		       (amapcar (lambda (a) (trivialize a rnl))
				(cdr args)))
		 (if (eq (type fn) 'lambda)
		     (triv-lambdacate
		      (lambda.vars fn)
		      (amapcar (lambda (a) (trivialize a rnl))
			       (cdr args))
		      (trivialize (lambda.body fn) rnl))
		     (error '"strange trivial function - trivialize"
			    node
			    'fail-act))))))))))

;;- Maclisp code for a combination with a lambda in function position.
;;- `Real' vars and args go into an equivalent Maclisp ((lambda ,vars ,body) ,@args),
;;- while arguments evaluated only for effect go into a progn before that 
;;- (and the corresponding vars get left out of the lambda).

(define triv-lambdacate
  (lambda (vars args body)
    (labels ((loop
	      (lambda (v a realvars realargs effargs)
		(if (null a)
		    (let ((rv (nreverse realvars)))
		      (or (null v)
			  (error '"we blew it in triv-lambdacate" v 'fail-act))
		      (let ((b (if rv
				   `((lambda ,rv
				       (comment
					(vars = ,(map-user-names rv)))
				       ,@(deprognify body))
				     ,@(nreverse realargs))
				   body)))
			(if effargs
			    `(progn ,@effargs ,@(deprognify b))
			    b)))
		    (if (or (get (car v) 'read-refs)
			    (get (car v) 'write-refs))
			(loop (cdr v)
			      (cdr a)
			      (cons (car v) realvars)
			      (cons (car a) realargs)
			      effargs)
			(loop (cdr v)
			      (cdr a)
			      realvars
			      realargs
			      (cons (car a) effargs)))))))
      (loop vars args nil nil nil))))

;;- Return a list of the first N registers.

(define used-templocs
  (lambda (n)
    (do ((j (+ **number-of-arg-regs** 1) (+ j 1))
	 (x nil (cons (temploc j) x)))
	((> j n) (nreverse x)))))

(define remark-on
  (lambda (cnode)
    (let ((cfm (cnode.cform cnode)))
      (labels ((remark1 
		(lambda (dep fnp vars env)
		  `(comment (depth = ,dep)
			    (fnp = ,fnp)
			    ,@(if vars `((vars = ,(map-user-names vars))))
			    ,@(if env `((env = ,(map-user-names env))))))))
	(eqcase (type cfm)
	  (clambda
	   (remark1 (clambda.dep cfm)
		    (clambda.fnp cfm)
		    (if (eq (clambda.fnp cfm) 'noclose)
			(clambda.tvars cfm)
			(clambda.vars cfm))
		    (append (clambda.closerefs cfm)
			    (clambda.consenv cfm))))
	  (continuation
	   (remark1 (continuation.dep cfm)
		    (continuation.fnp cfm)
		    nil	;never interesting anyway
		    (append (continuation.closerefs cfm)
			    (continuation.consenv cfm)))))))))


;;- Return the user names corresponding to internal names VARS.

(define map-user-names
  (lambda (vars)
    (amapcar (lambda (x) (or (get x 'user-name) x)) vars)))

;;- Compile a Scheme file FNAME to an appropriately-named Lisp output file.

(define comfile
  (lambda (fname)
    (let ((fn (defaultf (mergef fname '(* >))))
	  (rt (runtime))
	  (gct (status gctime)))
      (let ((ifile (open fn 'in))
	    (ofile (open (mergef '(_rabb_ output) fn) 'out)))
	(set' *global-gen-prefix*
	      (catenate (cadar (symeval 'defaultf))
			'{=}
			(cadr (symeval 'defaultf))))
	(let ((tn (namestring (truename ifile))))
	  (print `(comment this is the rabbit lisp code for ,tn) ofile)
	  (timestamp ofile)
	  (terpri ofile)
	  (terpri (symeval 'tyo))
	  (princ '";beginning rabbit compilation on " (symeval 'tyo))
	  (princ tn (symeval 'tyo)))
	(print `(declare (special ,@**cont+arg-regs** **env** **fun** **nargs**))
	       ofile)
	(print '(declare (defun displace (x y) y)) ofile)
	(aset' *testing* nil)
	(aset' *error-count* 0)
	(aset' *error-list* nil)
	(transduce ifile
		   ofile
		   (list nil)
		   (catenate '"init-" (cadr (truename ifile))))
	(timestamp ofile)
	(let ((x 0)      ;- (*quo (- (runtime) rt) 1.0e6))
	      (y 0))     ;- (*quo (- (status gctime) gct) 1.0e6)))
	  (let ((msg `(compile time: ,x seconds
			       (gc time ,y seconds)
			       (net ,(-$ x y) seconds)
			       ,@(if (not (zerop *error-count*))
				     `((,*error-count* errors))))))
	    (print `(comment ,msg) ofile)
	    (renamef ofile
		     (mergef (list (cadr fn) 'lisp)
			     fn))
	    (close ofile)
	    msg))))))

;;- Compile each form in IFILE in order, to OFILE.
;;- EOF is the eof-marker to use with the reader.
;;- INITNAME starts the names of procedures generated to execute the
;;- top-level expressions from the source file -- though I don't understand
;;- why you can't just wrap them all in a block.  INITNAME is also the 
;;- full name of the entry-point procedure.

(define transduce
  (lambda (ifile ofile eof initname)
    (labels ((loop
	      (lambda (form random-forms)
		(if (eq form eof)
		    (do ((x (gentemp initname) (gentemp initname))
			 (y nil x)
			 (z random-forms (cdr z)))
			((null z)
			 (if random-forms
			     (print `(,(length random-forms)
				      random forms in file to compile)
				    (symeval 'tyo)))
			 (if y (process-form `(declare (special ,y))
					     ofile
					     t))
			 (process-form `(define ,initname
					  (lambda () ,(if y (list y) nil)))
				       ofile
				       t))
		      (if y (process-form `(declare (special ,y))
					  ofile
					  nil))
		      (process-form `(define ,x
				       (lambda ()
					 (block ,(car z)
						,(if y
						     (list y)
						     nil))))
				    ofile
				    nil))
;		      (process-form
;			`(define ,initname
;			   (lambda () (block ,@random-forms nil nil)))
;			ofile)
		    (let ((x (process-form form ofile t)))
		      (loop (readify ifile eof) (nconc x random-forms)))))))
      (loop (readify ifile eof) nil))))


(define readify				;funny maclisp convention - readify'll do the job!
  (lambda (ifile eof)
    (if (symeval 'read)
	(apply (symeval 'read) ifile eof)
	(read ifile eof))))

(set' *optimize* t)

(set' *buffer-random-forms* t)

;;- Compile one top-level form, writing to OFILE.
;;- If it's a macro definition, evaluate it as well.
;;- Returns a list, in reverse order encountered, of any `random' forms not 
;;- recognized, if *BUFFER-RANDOM-FORMS* is true; otherwise writes 'em out directly.
;;- If NOISYP, report each function successfully compiled.

(define process-form
  (lambda (form ofile noisyp)
    (cond ((atom form)
	   (print form ofile)
	   nil)
	  ((eq (car form) 'define)
	   (process-define-form form ofile noisyp)
	   nil)
	  ((and (memq (car form) '(block progn))
		(equal (cadr form) ''compile))
	   (do ((f (cddr form) (cdr f))
		(z nil (nconc z (process-form (car f) ofile noisyp))))
	       ((null f) z)))
	  ((eq (car form) 'proclaim)
	   (amapc (lambda (x) ((enclose `(lambda (ofile) ,x)) ofile))
		  (cdr form))
	   nil)
	  ((eq (car form) 'declare)
	   (print form ofile)
	   nil)
	  ((eq (car form) 'comment)
	   nil)
	  ((eq (car form) 'defun)
	   (print form ofile)
	   nil)
	  ((and (atom (car form))
		(eq (get (car form) 'aint) 'amacro)
		(not (eq (get (car form) 'amacro) 'afsubr)))
	   (if (memq (car form) '(defmac schmac macro))
	       (eval form))
	   (process-form (macro-expand form) ofile noisyp))
	  (t (cond (*buffer-random-forms* (list form))
		   (t (print form ofile) nil))))))

;;- Allow FORM to be one of
;;- (define name (lambda ...))
;;- (define name params body ...)
;;- (define (name param ...) body ...)

(define process-define-form
  (lambda (form ofile noisyp)
    (cond ((atom (cadr form))
	   (process-definition form
			       ofile
			       noisyp
			       (cadr form)
			       (if (null (cdddr form))
				   (caddr form)
				   `(lambda ,(caddr form)
				      (block . ,(cdddr form))))))
	  (t (process-definition form
				 ofile
				 noisyp
				 (caadr form)
				 `(lambda ,(cdadr form)
				    (block . ,(cddr form))))))))

;;- Compile to OFILE the function with name NAME and definition LAMBDA-EXP.

(define process-definition
  (lambda (form ofile noisyp name lambda-exp)
    (cond ((not (eq (typep name) 'symbol))
	   (warn "function name not symbol" name form))
	  ((or (not (eq (car lambda-exp) 'lambda))
	       (and (atom (cadr lambda-exp))
		    (not (null (cadr lambda-exp)))))
	   (warn "malformed lambda-expression" lambda-exp form))
	  (t (print (compile name
			     lambda-exp
			     nil
			     *optimize*)
		    ofile)
	     (cleanup)
	     (if noisyp
		 (print (list name 'compiled)
			(symeval 'tyo)))))))

(define cleanup
  (lambda ()
    (block (replace)
	   (genflush)
	   (mapatoms '(lambda (x)
			;;- Hm, what about 'number-of-args ?
			(remprop x 'read-refs)
			(remprop x 'write-refs)
			(remprop x 'node)
			(remprop x 'binding)
			(remprop x 'user-name)
			(remprop x 'known-function)
			(remprop x 'easy-labels-function))))))

;;; inverse of alphatize.  used by sx, e.g., for debugging.

;;- Return an sexpr equivalent to NODE.
;;- Translate variable names back to the original only if USERP is true.

(define sexprfy
  (lambda (node userp)
    (let ((fm (node.form node)))
      (eqcase (type fm)
	(constant `(quote ,(constant.value fm)))
	(variable (if (and userp (not (variable.globalp fm)))
		      (get (variable.var fm) 'user-name)
		      (variable.var fm)))
	(lambda `(lambda ,(if userp (lambda.uvars fm) (lambda.vars fm))
		   ,(sexprfy (lambda.body fm) userp)))
	(if `(if ,(sexprfy (if.pred fm) userp)
		 ,(sexprfy (if.con fm) userp)
		 ,(sexprfy (if.alt fm) userp)))
	(aset `(aset' ,(if (and userp (not (aset.globalp fm)))
			   (get (aset.var fm) 'user-name)
			   (aset.var fm))
		      ,(sexprfy (aset.body fm) userp)))
	(catch `(catch ,(if userp
			    (get (catch.var fm) 'user-name)
			    (catch.var fm))
		       ,(sexprfy (catch.body fm) userp)))
	(labels `(labels ,(amapcar (lambda (v d) `(,(if userp
							(get v 'user-name)
							v)
						   ,(sexprfy d userp)))
				   (labels.fnvars fm)
				   (labels.fndefs fm))
			 ,(sexprfy (labels.body fm) userp)))
	(combination
	 (amapcar (lambda (a) (sexprfy a userp))
		  (combination.args fm)))))))

;;- Return a more human-readable look at CNODE.

(define csexprfy
  (lambda (cnode)
    (let ((cfm (cnode.cform cnode)))
      (eqcase (type cfm)
	(trivial `(trivial ,(sexprfy (trivial.node cfm) nil)))
	(cvariable (cvariable.var cfm))
	(clambda `(clambda ,(clambda.vars cfm)
			   ,(csexprfy (clambda.body cfm))))
	(continuation
	 `(continuation (,(continuation.var cfm))
			,(csexprfy (continuation.body cfm))))
	(cif `(cif ,(csexprfy (cif.pred cfm))
		   ,(csexprfy (cif.con cfm))
		   ,(csexprfy (cif.alt cfm))))
	(caset `(caset' ,(csexprfy (caset.cont cfm))
			,(caset.var cfm)
			,(csexprfy (caset.body cfm))))
	(clabels `(clabels ,(amapcar (lambda (v d) `(,v
						     ,(csexprfy d)))
				     (clabels.fnvars cfm)
				     (clabels.fndefs cfm))
			   ,(csexprfy (clabels.body cfm))))
	(ccombination
	 (amapcar csexprfy (ccombination.args cfm)))
	(return
	 `(return ,(csexprfy (return.cont cfm))
		  ,(csexprfy (return.val cfm))))))))

;;- Warn if a call to NAME with NARGS arguments is inconsistent with NAME and NARGS from
;;- any earlier call to check-number-of-args.  DEFP is true for a definition of NAME.

(define check-number-of-args
  (lambda (name nargs defp)
    (or (getl name '(*lexpr lsubr))
	(let ((n (get name 'number-of-args)))
	  (if n
	      (if (not (= n nargs))
		  (if defp
		      (warn "definition disagrees with earlier use on number of args"
			    name
			    nargs
			    n)
		      (if (get name 'defined)
			  (warn "use disagrees with definition on number of args"
				name
				nargs
				n)
			  (warn "two uses disagree before definition on number of args"
				name
				nargs
				n))))
	      (putprop name nargs 'number-of-args))
	  (if defp (putprop name 't 'defined))))))


(defun *expr fexpr (x)
  (mapcar '(lambda (y) (putprop y 't '*expr)) x))

(defprop *expr afsubr amacro) (defprop *expr amacro aint)

(defun *lexpr fexpr (x)
  (mapcar '(lambda (y) (putprop y 't '*lexpr)) x))

(defprop *lexpr afsubr amacro) (defprop *lexpr amacro aint)


(define dumpit
  (lambda ()
    (block (init-rabbit)
	   (suspend '":pdump dsk:scheme;ts rabbit")
	   (terpri)
	   (princ '"file name: ")
	   (comfile (readline))
	   (quit))))

(define stats
  (lambda ()
    (amapc (lambda (var)
	     (block (terpri)
		    (prin1 var)
		    (princ '" = ")
		    (prin1 (symeval var))))
	   *stat-vars*)))

(define reset-stats
  (lambda () (amapc (lambda (var) (set var 0)) *stat-vars*)))

(My comments date back to the 90s, except for one newer comment that I was wrong about a supposed bug.)

This is a close match to the version found on ITS, but some things have been removed.