rabbit.lsp

;;; RABBIT COMPILER   -*-LISP-*-

(DECLARE (FASLOAD (QUUX) SCHMAC))
(DECLARE (MACROS T) (NEWIO T))
(DECLARE (ALLOC '(LIST (300000 450000 .2) FIXNUM 50000 SYMBOL 24000)))
(DECLARE (DEFUN DISPLACE (X Y) Y))
		  
(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))

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

(PROCLAIM (*EXPR PRINT-SHORT)
	  (SET' *BUFFER-RANDOM-FORMS* NIL)
	  (ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000)
		   SYMBOL (14000 24000 NIL) HUNK4 (20000 53000 NIL)
		   HUNK8 (20000 50000 NIL) HUNK16 (20000 60000 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*))

(ALLOC '(LIST (240000 340000 1000) FIXNUM (30000 40000 1000)
	 SYMBOL (14000 24000 NIL) HUNK4 (20000 50000 NIL)
	 HUNK8 (20000 50000 NIL) HUNK16 (20000 70000 NIL)))

(APPLY 'GCTWA '(T))		;GC USELESS ATOMS (CAN'T SAY (EVAL' (GCTWA T)) BECAUSE OF NCOMPLR)
(REPLACE)			;UNDO ANY DISPLACED MACROS
(SET' *DISPLACE-SW* NIL)	;DON'T LET MACROS SELF-DISPLACE
(GRINDEF)			;LOAD THE GRINDER (PRETTY-PRINTER)

(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|))

(COND ((NOT (BOUNDP '*EMPTY*))
       (SET' *EMPTY* (LIST '*EMPTY*))))

(DEFINE EMPTY
	(LAMBDA (X) (EQ X *EMPTY*)))


(DEFINE TRIVFN
	(LAMBDA (SYM)
		(GETL SYM '(EXPR SUBR LSUBR *EXPR *LEXPR))))


(DEFMAC INCREMENT (X) `(ASET' ,X (+ ,X 1)))

(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)))

(DEFINE GENTEMP
	(LAMBDA (X)
		(BLOCK (INCREMENT *GENTEMPNUM*)
		       (LET ((SYM (CATENATE X '|-| *GENTEMPNUM*)))
			    (ASET' *GENTEMPLIST* (CONS SYM *GENTEMPLIST*)) SYM))))

(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))


(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


(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|))

(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)

(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))))


(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))))))))

(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).

(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

(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)
(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

(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

(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
					  (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))))))

(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)))

(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

;;; 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.

(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.

(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.

(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)))))

(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)))))))))

(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)))))

(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)
       (EFFDEF LIST (CONS) NONE)
       (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))
       (EFFDEF TYI ANY (FILE))
       'SIDE-EFFECTS-PROPERTIES)

;;; 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

(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

(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

(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)



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

(DEFINE PASSABLE
	(LAMBDA (NODE EFFS AFFD)
		(BLOCK (IF (EMPTY (NODE\EFFS NODE))
			   (ERROR '|Pass 1 Analysis Missing - PASSABLE|
				  NODE
				  'FAIL-ACT))
		       (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


(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))))
					(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)
					      (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)))))

(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:

(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
(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
(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

(DEFINE CNODIFY
	(LAMBDA (CFORM)
		(CONS-CNODE (CFORM = CFORM))))

(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))))

(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.
;;; (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)
				   (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))))
				   (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)

(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)))))

(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

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

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

(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.

(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.

(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))))


(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))))

(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))))

(DEFINE PSETQ-ARGS
	(LAMBDA (ARGS)
		(PSETQ-ARGS-ENV ARGS '**ENV**)))

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

(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)))))))


(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))))

(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)))))

(DEFINE LOOKUPICATE
	(LAMBDA (VAR RNL)
		((LAMBDA (SLOT)
			 (IF SLOT (CDR SLOT)
			     (IF (TRIVFN VAR)
				 `(GETL ',VAR '(EXPR SUBR LSUBR))
				 VAR)))
		 (ASSQ VAR RNL))))

(DEFINE CONS-CLOSEREFS
	(LAMBDA (CLOSEREFS RNL)
		(DO ((CR (REVERSE CLOSEREFS) (CDR CR))
		     (X '**ENV** `(CONS ,(LOOKUPICATE (CAR CR) RNL) ,X)))
		    ((NULL CR) X))))

(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)))))

;;; 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.

(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))))

(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))))))))))

(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))))

(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))))))

(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)))))))

(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)))))))))


(DEFINE MAP-USER-NAMES
	(LAMBDA (VARS)
		(AMAPCAR (LAMBDA (X) (OR (GET X 'USER-NAME) X)) VARS)))

(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 (*QUO (- (RUNTIME) RT) 1.0E6))
				(Y (*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))))))

(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)

(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))))))

(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))))))))

(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)
					  (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.

(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)))))))

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