.TY COMPLR.

(PROG (SEXPR IBASE)
      (SETQ IBASE (ADD1 7))
 LOOP (SETQ SEXPR (ERRSET (READ)))
      (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
      (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
	     (GO LOOP)))
      (PRINT (EVAL (CAR SEXPR)))
      (GO LOOP))

(BEGINBLOCK COMPILER)

(DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
	 (SPECIAL CURBIND INPROG P1SCNT FOUNDFREE)
	 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
	 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
	 (SPECIAL LDLST PRGSPFLG PROGVARS CCLST RSL CTAG VARLIST)
	 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
	 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
	 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
	 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
	 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
	 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
	 (SPECIAL IBASE BASE *NOPOINT INUM0)
	 (SPECIAL TRACELIST SHOWNAMES))

(DECLARE (DEFPROP CMP T *FSUBR)
	 (DEFPROP COMPERR T *FSUBR)
	 (DEFPROP COMPILE T *FSUBR)
	 (DEFPROP COMPL T *FSUBR)
	 (DEFPROP DECLARE T *FSUBR)
	 (DEFPROP NEXTSYM T *FSUBR)
	 (DEFPROP PROGN T *LSUBR)
	 (DEFPROP SPECIAL T *FSUBR)
	 (DEFPROP STARTSYM T *FSUBR)
	 (DEFPROP STOPSYM T *FSUBR)
	 (DEFPROP UNSPECIAL T *FSUBR)
	 (DEFPROP USERERR T *FSUBR))

(BEGINBLOCK MACROS)

(DEFPROP DFUNC
	 (LAMBDA (L)
		 (LIST (Q DEFPROP)
		       (CAADR L)
		       (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
		       (Q EXPR)))
	 MACRO)

(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)

(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)


(DEFPROP IFIF
 (LAMBDA (L)
	 (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
 MACRO)

(DEFPROP INCR
 (LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
 MACRO)

(DEFPROP MAPDEF
 (LAMBDA (L)
	 (LIST (Q MAPCAR)
	       (SUBST (CADR L)
		      (Q IND)
		      (Q (FUNCTION (LAMBDA (PAIR)
					   (PUTPROP (CAR PAIR)
						    (CADR PAIR)
						    (QUOTE IND))))))
	       (LIST (Q QUOTE) (CDDR L))))
 MACRO)

(DEFPROP MCONS
 (LAMBDA (L)
	 (COND ((NULL (CDDR L)) (CADR L))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 MACRO)

(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)

(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)

(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)

(DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)

(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)

(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)

(DEFPROP USERWARN
	 (LAMBDA (L)
		 (LIST (Q PRINTMSG)
		       (LIST (Q APPEND)
			     (LIST (Q LIST) (CADR L))
			     (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
			     (Q (LIST (CURFUN))))))
	 MACRO)

(BEGINBLOCK PROPTABLE)

(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)


(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)

(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)

(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)

(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)

(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)

(DFUNC (DELETEPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM IDENT)
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
					    (RETURN T)))
	     (SETQ TEM (CDDR TEM))
	     (GO LOOP)))

(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))

(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
       (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))

(DFUNC (SEEKPROP IDENT PROPNAM)
       (PROG (TEM)
	     (SETQ TEM (GETL IDENT (LIST PROPNAM)))
	     (COND ((NULL TEM) (RETURN NIL)))
	     (RETURN TEM)))

(DFUNC (SETPROP IDENT PROPNAM PROPVAL)
       (PUTPROP IDENT PROPVAL PROPNAM))

(ENDBLOCK PROPTABLE)

(ENDBLOCK MACROS)

(BEGINBLOCK TOPLEVEL)

(DFUNC (ACTONEXPR XPR)
       (PROG (ACTION)
	     (COND ((ATOM XPR) (GO FLUSH)))
	     (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
	     (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
	FLUSH(FLUSHEXPR XPR)
	     (RETURN NIL)))

(DFUNC (ACTONMACRO XPR)
       (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))


(DEFPROP CMP
 (LAMBDA (L)
  (COND	((NULL L) NIL)
	((NULL (CDR L)) (COMPILEFUN (CAR L)))
	(T (PUTPROP (CAAR L)
		    (MCONS (Q LAMBDA) (CDAR L) (CDR L))
		    (COND ((NULL (CDDR L)) (Q EXPR)) (T (CADDR L))))
	   (COMPILEFUN (CAAR L)))))
 FEXPR)

(DFUNC (COMPDEF DEFIN)
 (PROG (ACTION)
       (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
	      (USERERR ARGNOERR-COMPDEF)))
       (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
	      ((PROPVAL ACTION) DEFIN)
	      (RETURN NIL)))
       (FLUSHDEF DEFIN)
       (RETURN NIL)))

(DFUNC (COMPFILE INFILE OUTFILE)
       (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
	     (INITPROP (Q CURFILE) (Q NAME) INFILE)
	     (SETQ STARTTIME (TIME))
	     (SETQ CODESIZE (SETQ CONSTSIZE 0))
	     (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
	     (TELLTALE (CADR INFILE) STARTTIME)
	     (DELETEPROP (Q CURFILE) (Q NAME))))

(DFUNC (COMPFUNC NAME EXPR FLAG)
       (PROG (LOCVARS SPECVARS P1CNT P2CNT LASTOUT)
	     (STARTSYM VAL VAR TAG)
	     (INITPROP (Q CURFUN) (Q NAME) NAME)
	     (PASS2 NAME (PASS1 NAME EXPR FLAG) FLAG)
	     (DELETEPROP (Q CURFUN) (Q NAME))
	     (STOPSYM VAL VAR TAG)
	     (COND ((NOT (EQUAL P2CNT P1CNT))
		    (PRINTMSG (LIST P1CNT P2CNT))
		    (COMPERR COUNTSDISAGREE-COMPFUNC)))
	     (RETURN NAME)))

(DEFPROP COMPILE
 (LAMBDA (NAMES)
  (PROG (DONE)
   LOOP	(COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
	(COND ((NOT (ATOM (CAR NAMES)))
	       (OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
	      (T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
	(SETQ NAMES (CDR NAMES))
	(GO LOOP)))
 FEXPR)


(DFUNC (COMPILEFUN NAME)
 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
	DONE PLIST)
       (SETQ CODESIZE (SETQ CONSTSIZE 0))
       (SETQ PLIST (CDR NAME))
  LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
       (SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
       (COND ((NULL PROP) (GO ELOOP)))
       (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
       ((PROPVAL PROP)
	(LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
  ELOOP(SETQ PLIST (CDDR PLIST))
       (GO LOOP)))

(DEFPROP COMPL
 (LAMBDA (FILES)
  (PROG (MSGCHAN)
	(COND ((NOT (NULL LISTING))
	       (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
					  (GENSYM)
					  LISTING)))))
   LOOP	(COND ((NULL FILES) (OUTC MSGCHAN NIL)
			    (OUTC NIL T)
			    (RETURN NIL)))
	(COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
		   (AND	(NOT (ATOM (CAR FILES)))
			(NOT (ATOM (CDAR FILES)))))
	       (SETQ INDEV (CAR FILES))
	       (GO ELOOP)))
	(COMPFILE (LIST INDEV (CAR FILES))
		  (LIST	OUTDEV
			(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
				    (T (CAAR FILES)))
			      OUTEXT)))
   ELOOP(SETQ FILES (CDR FILES))
	(GO LOOP)))
 FEXPR)

(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))

(DFUNC (CURFILE) (GETPROP (Q CURFILE) (Q NAME)))

(DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))

(DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)


(DFUNC (DEFEXPR DEF)
 (PROG (FN EX)
       (SETQ FN (CADR DEF))
       (SETQ EX (CADDR DEF))
       (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
	      (FLUSHDEF DEF))
	     ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
	      (COND ((REMPROP FN (Q *UNDEF))
		     (PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
	      (PUTPROP FN T (Q *LSUBR))
	      (COMPFUNC	FN
			(MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
			(Q LSUBR)))
	     (T	(REMPROP FN (Q *UNDEF))
		(PUTPROP FN T (Q *SUBR))
		(COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))
       (TYPEFN FN)))

(DFUNC (DEFFEXPR DEF)
       (PROG (FN EX)
	     (SETQ FN (CADR DEF))
	     (SETQ EX (CADDR DEF))
	     (COND ((REMPROP FN (Q *UNDEF))
		    (PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
	     (PUTPROP FN T (Q *FSUBR))
	     (COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))
	     (TYPEFN FN)))

(DFUNC (DEFMACRO DEF)
       (PROGN (COND ((REMPROP (CADR DEF) (Q *UNDEF))
		     (PRINTMSG (CONS (CADR DEF)
				     (Q (MACRO USED AS SUBR))))))
	      (PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
	      (TYPEFN (CADR DEF))))

(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))

(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))

(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))

(DFUNC (DODE L)
       (DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q EXPR))))

(DFUNC (DODF L)
       (DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q FEXPR))))

(DFUNC (DODM L)
       (DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q MACRO))))


(DFUNC (DOFILE DOREADS INFILE OUTFILE)
       (PROG (LINCNT)
	     (SETQ LINCNT 0)
	     (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
	     (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
	     (INC (Q INCHAN) NIL)
	     (OUTC (Q OUTCHAN) NIL)
	     (DOREADS)
	     (OUTC NIL T)
	     (INC NIL T)))

(DFUNC (FLUSHEXPR EXPR)
       (PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))

(DFUNC (FLUSHLAP ENTRY)
       (PROG (NAME FLAG TYPE STAT)
	     (SETQ NAME (CADR ENTRY))
	     (SETQ FLAG (CADDR ENTRY))
	     (SETQ TYPE	(ASSOC FLAG
			       (Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
						  (SUBR *SUBR)))))
	     (COND ((NULL TYPE) (GO PRINT)))
	     (SETQ TYPE (CADR TYPE))
	     (COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
			 (GETPROP NAME (Q *UNDEF)))
		    (PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
	     (SETPROP NAME TYPE T)
	     (REMPROP NAME (Q *UNDEF))
	     (TYPEFN NAME)
	PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
	     (OUTPUTSTAT ENTRY)
	LOOP (SETQ STAT (ERRSET (READ)))
	     (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
	     (OUTPUTSTAT (CAR STAT))
	     (COND ((NULL (CAR STAT)) (RETURN NIL)))
	     (GO LOOP)))

(DFUNC (MAKDEF NAME ARGS BODY TYPE)
       (LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))

(DFUNC (MAPPUT EXP)
       (PROG (IND ARGS)
	     (SETQ IND (CAR EXP))
	     (SETQ ARGS (CDR EXP))
	LOOP (COND ((NULL ARGS) (RETURN EXP)))
	     (PUTPROP (CAR ARGS) T IND)
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))


(DFUNC (PRINTMSG MESSAGE)
       (PROG (CHAN LINCNT)
	     (SETQ CHAN (OUTC MSGCHAN NIL))
	     (SETQ LINCNT 0)
	     (COND ((NOT (ATMARGIN)) (LINEF 2)))
	     (PRINL (CONS (Q *) MESSAGE))
	     (LINEF 1)
	     (OUTC CHAN NIL)))

(DFUNC (READLOOP ACTFUN)
       (PROG (EXPR)
	LOOP (SETQ EXPR (ERRSET (READ)))
	     (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
	     (ACTFUN (CAR EXPR))
	     (GO LOOP)))

(DEFPROP SPECIAL
	 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
	 FEXPR)

(DFUNC (TELLTALE FILENAME STARTTIME)
 (PROG (CHAN UNDS)
       (SETQ CHAN (OUTC MSGCHAN NIL))
       (CARRETN)
       (LINEF 1)
       (PRINL (LIST FILENAME (Q COMPILED)))
       (PRINL (LIST CODESIZE (Q WORDS)))
       (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
       (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
				    1750))
		    (Q SECONDS)))
       (LINEF 2)
  UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
       (COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
	      (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
       (SETQ UNDFUNS (CDR UNDFUNS))
       (GO UNDF)
  UNDF1(COND ((NULL UNDS) (GO GENF)))
       (PRINL (Q (UNDEFINED FUNCTIONS)))
       (LINEF 1)
       (PRINL UNDS)
       (LINEF 2)
  GENF (COND ((NULL GENFUNS) (GO END)))
       (PRINL (Q (GENERATED FUNCTIONS)))
       (LINEF 1)
       (PRINL GENFUNS)
       (LINEF 2)
  END  (OUTC CHAN NIL)))


(DFUNC (TYPEFN MESSAGE)
       (PROG (CHAN LINCNT)
	     (COND ((NULL SHOWNAMES) (RETURN NIL)))
	     (SETQ CHAN (OUTC MSGCHAN NIL))
	     (SETQ LINCNT 0)
	     (COND ((ATMARGIN) (LINEF 1)))
	     (PRINS MESSAGE)
	     (OUTC CHAN NIL)))

(DEFPROP UNSPECIAL
	 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
	 FEXPR)

(BEGINBLOCK INITIALIZATION)

(DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (Q CSTART))))

(DFUNC (CSTART)
 (PROGN	(INITFN NIL)
	(COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
	       (SYSIN (COMPLR . INI))))
	(COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
	       (SYSIN DSK: (COMPLR . INI))))
	(LINEF 1)
	(PRINL (Q (LISP COMPILER)))))

(ENDBLOCK INITIALIZATION)

(MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))

(MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
		   (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
		   (UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
		   (*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))

(MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
		  (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
		  (*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
		  (*LSUBR EVAL))

(SETQ LISTING NIL)

(SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))

(SETQ OUTEXT (QUOTE LAP))

(SETQ SHOWNAMES T)

(ENDBLOCK TOPLEVEL)

(BEGINBLOCK PASS1)


(DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))

(DFUNC (GENFUN EXPR)
 (PROG (NAME ARGS CALL)
       (COND ((ATOM EXPR) (RETURN EXPR)))
       (COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
	      (USERERR NOTLAMBDA-GENFUN)))
       (SETQ ARGS (CADR EXPR))
       (SETQ CALL (CADDR EXPR))
       (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
	      (RETURN (CAR CALL))))
       (SETQ NAME (MAKESYM (NEXTSYM SUBFUN) (CURFUN)))
       (SETQ GENFUNS (CONS NAME GENFUNS))
       (RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))

(DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))

(DFUNC (P1 XPR)
 (PROG (TEM)
       (COND ((ATOM XPR) (GO ATOM)))
       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
       (COND ((EQ (CAAR XPR) (Q LAMBDA))
	      (RETURN (P1LAM XPR CURBIND))))
       (COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
       (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
  ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
       (COND ((SETQ TEM (ASSOC XPR CURBIND)) (SETQ XPR (CDR TEM))))
       (INCR P1CNT)
       (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
			     (RETURN XPR)))
       (COND ((VARB XPR) (RETURN XPR)))
       (RPLACD (ASSOC XPR LOCVARS) P1CNT)
       (RETURN XPR)
  ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
       (COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
	      (RETURN ((PROPVAL TEM) XPR))))
       (COND ((SETQ TEM (ASSOC (CAR XPR) CURBIND))
	      (SETQ XPR (CONS (CDR TEM) (CDR XPR)))))
       (COND ((OR (SPECIALP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
	      (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
       (RETURN (P1ELSE XPR))))

(DFUNC (P1ANDOR XPR)
       (PROG (TEM CT ARGS)
	     (SETQ TEM LOCVARS)
	     (SETQ CT P1CNT)
	     (SETQ ARGS (MAPP1 (CDR XPR)))
	     (INCR P1CNT)
	     (P1BUG CT P1CNT TEM)
	     (RETURN (CONS (CAR XPR) ARGS))))


(DFUNC (P1BIND VARS)
 (PROG (VAR NEWVARS)
       (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
  LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
       (SETQ VAR (CAR VARS))
       (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
       (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
       (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
			     (GO ELOOP)))
       (SETQ CURBIND (CONS (CONS VAR
				 (SETQ VAR (COND ((ASSOC VAR LOCVARS)
						  (NEXTSYM VAR))
						 (T VAR))))
			   CURBIND))
       (SETQ LOCVARS (CONS (CONS VAR 0) LOCVARS))
  ELOOP(SETQ NEWVARS (CONS VAR NEWVARS))
       (SETQ VARS (CDR VARS))
       (GO LOOP)))

(DFUNC (P1BUG LOW HIGH PTR)
       (PROG (X)
	LOOP (COND ((NULL PTR) (RETURN NIL)))
	     (SETQ X (CAR PTR))
	     (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
	     (SETQ PTR (CDR PTR))
	     (GO LOOP)))

(DFUNC (P1COND XPR)
       (PROG (TEM CT PAIRS)
	     (SETQ TEM LOCVARS)
	     (SETQ CT P1CNT)
	     (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
	     (INCR P1CNT)
	     (P1BUG CT P1CNT TEM)
	     (INCR P1CNT)
	     (RETURN (CONS (CAR XPR) PAIRS))))

(DFUNC (P1CONS XPR)
       (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
	     ((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
	     (T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))

(DFUNC (P1ELSE XPR)
       (PROGN (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
	      (PUTPROP (CAR XPR) T (Q *UNDEF))
	      (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))))


(DFUNC (P1ERRSET XPR)
 (COND ((ATOM (CADR XPR)) XPR)
       (T (MCONS (CAR XPR)
		 (LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
		 (CDDR XPR)))))

(DFUNC (P1EVAL XPR)
       (PROG (CDRXPR)
	     (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
	     (COND ((NOT (NULL (CDR CDRXPR)))
		    (RETURN (CONS (Q EVAL) CDRXPR))))
	     (RETURN (CONS (Q *EVAL) CDRXPR))))

(DFUNC (P1FUNCTION XPR) (LIST (Q QUOTE) (GENFUN (CADR XPR))))

(DFUNC (P1*FUNCTION XPR) (LIST (Q *FUNCTION) (GENFUN (CADR XPR))))

(DFUNC (P1GO XPR)
       (PROGN (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
	      (COND ((ATOM (CADR XPR)) XPR)
		    (T (LIST (CAR XPR) (P1 (CADR XPR)))))))

(DFUNC (P1LABEL XPR)
 (PROG (FN)
       (INITPROP (CADAR XPR) (Q FUNVAR) T)
       (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
       (DELETEPROP (CADAR XPR) (Q FUNVAR))
       (RETURN (P1 (LIST (Q PROG)
			 (LIST (CADAR XPR))
			 (LIST (Q SETQ) (CADAR XPR) FN)
			 (LIST (Q RETURN)
			       (CONS (CADAR XPR) (CDR XPR))))))))

(DFUNC (P1LAM XPR CURBIND)
       (PROG (ARGS VARS BODY)
	     (SETQ ARGS (P1SUBRARGS (CDR XPR)))
	     (INCR P1CNT)
	     (SETQ VARS (P1BIND (CADAR XPR)))
	     (COND ((NOT (EQUAL (LENGTH ARGS) (LENGTH VARS)))
		    (USERERR ARGNOERR-P1LAM)))
	     (SETQ BODY (P1 (CADDAR XPR)))
	     (INCR P1CNT)
	     (RETURN (CONS (LIST (Q LAMBDA) VARS BODY) ARGS))))


(DFUNC (P1PROG X)
 ((LAMBDA (CURBIND)
   (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
	 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
	 (SETQ INPROG T)
	 (SETQ X (CDR X))
	 (SETQ P1LL (P1BIND (CAR X)))
	 (SETQ TEM LOCVARS)
	 (SETQ P1SCNT (INCR P1CNT))
    LOOP1(SETQ X (CDR X))
	 (COND ((NULL X) (GO END1)))
	 (INCR P1CNT)
	 (COND ((ATOM (CAR X))
		(COND ((ASSOC (CAR X) TAGLIST)
		       (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
		(SETQ TAGLIST (CONS (CONS (CAR X) (NEXTSYM TAG))
				    TAGLIST))
		(SETQ PR (CONS (CAR X) PR)))
	       (T (SETQ PR (CONS (P1 (CAR X)) PR))))
	 (GO LOOP1)
    END1 (INCR P1CNT)
	 (P1BUG P1SCNT P1CNT TEM)
	 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
    LOOP (COND ((NULL (CDR TEM)) (GO END)))
	 (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
		(USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
		(SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
		(MAKESPECIAL (CAADR TEM))))
    ELOOP(SETQ TEM (CDR TEM))
	 (GO LOOP)
    END	 (INCR P1CNT)
	 (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
  CURBIND))

(DFUNC (P1RETURN XPR)
 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
       (T (LIST	(Q RETURN)
		(P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))

(DFUNC (P1SETQ XPR)
       (PROG (VAR TEM VAL)
	     (COND ((NOT (VARIABLEP (CAR XPR)))
		    (USERERR NOTVARIABLE-P1SETQ)))
	     (SETQ VAR (COND ((SETQ TEM (ASSOC (CADR XPR) CURBIND))
			      (CDR TEM))
			     (T (CADR XPR))))
	     (VARB VAR)
	     (SETQ VAL (P1 (CADDR XPR)))
	     (INCR P1CNT)
	     (INCR P1CNT)
	     (RETURN (LIST (Q SETQ) VAR VAL))))


(DFUNC (P1STORE XPR)
       (PROG (ARG1 ARG2)
	     (SETQ ARG2 (P1 (CADDR XPR)))
	     (SETQ ARG1 (P1 (CADR XPR)))
	     (RETURN (LIST (CAR XPR) ARG1 ARG2))))

(DFUNC (P1SUBRARGS ARGS)
 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
       (T (MAPP1 ARGS))))

(DFUNC (PASS1 NAME EXPR FLAG)
 (PROG (LL CURBIND P1SCNT INPROG FOUNDFREE LOCVS)
       (SETQ INPROG NIL)
       (SETQ P1CNT 1)
       (SETQ LOCVARS (SETQ SPECVARS NIL))
       (SETQ LL (P1BIND (CADR EXPR)))
       (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
       (STARTSYM SUBFUN)
       (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
       (STOPSYM SUBFUN)
       (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
					       UNDECLARED
					       FREE
					       VARIABLES)))
       (SETQ LOCVS LOCVARS)
       (SETQ LOCVARS NIL)
  LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
       (COND ((NOT (SPECIALP (CAAR LOCVS)))
	      (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
	      (SETPROP (CAAR LOCVS) (Q LOCAL) T))
	     (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
       (SETQ LOCVS (CDR LOCVS))
       (GO LOOP)))

(DFUNC (PASS1FSUBR XPR) XPR)

(DFUNC (PASS1FUNVAR XPR)
       (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))

(DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))

(DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))

(DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))

(DFUNC (PASS1UNDEF XPR)
       (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
	      (PASS1SUBR XPR)))

(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))


(DFUNC (VARB X)
       (PROG NIL
	     (COND ((ASSOCR X CURBIND) (RETURN NIL))
		   ((SPECIALP X) (GO SPEC)))
	     (SETQ FOUNDFREE (CONS X FOUNDFREE))
	     (MAKESPECIAL X)
	SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
	     (RETURN T)))

(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))

(MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
	      (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
	      (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
	      (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
	      (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
	      (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))

(MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
	   (ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
	   (AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
	   (*FUNCTION P1*FUNCTION) (FUNCTION P1FUNCTION)
	   (RETURN P1RETURN))

(BEGINBLOCK INTERNALMACROS)

(DEFPROP INMACRO PASS1INMACRO PASS1)

(DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))

(DEFPROP INMACRO
 (LAMBDA (DF)
  (COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
 DEFACTION)

(DEFPROP APPEND
 (LAMBDA (L)
  (COND	((NULL (CDR L)) NIL)
	((NULL (CDDR L)) (CADR L))
	(T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)

(DEFPROP LIST
 (LAMBDA (L)
	 (COND ((NULL (CDR L)) NIL)
	       ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
	       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
 INMACRO)

(DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)


(DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)

(ENDBLOCK INTERNALMACROS)

(ENDBLOCK PASS1)

(BEGINBLOCK PASS2)

(DFUNC (ACEFFECTS FN)
 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))

(DFUNC (ACNUMP X)
       (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))

(DFUNC (BINDARGS ARGS)
       (PROG (ACNUM)
	     (SETQ ACNUM 1)
	LOOP (COND ((NULL ARGS) (RETURN NIL)))
	     (SETSLOT ACNUM (LIST (CAR ARGS)))
	     (SETQ ACNUM (ADD1 ACNUM))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (BOOLAND EXP VALAC TEST)
 (PROG2 (BOOLARGS (CDR EXP) (CAR TEST) (CDR TEST) T) (INCR P2CNT)))

(DFUNC (BOOLARGS ARGS FLAG TAG SWITCH)
       (PROG (G)
	     (GUARDLOCS)
	     (CLEAR1)
	     (RST TAG)
	     (PUTPROP (SETQ G (NEXTSYM TAG)) (TOPCOPY PDL) (Q LEVEL))
	A    (COND ((NULL ARGS) (COND (FLAG (OUTJRST TAG))) (GO C)))
	     (COND ((AND FLAG (NULL (CDR ARGS))) (GO B)))
	     (COMPPRED (CAR ARGS)
		       (CONS (NOT SWITCH) (COND (FLAG G) (T TAG))))
	     (SETQ ARGS (CDR ARGS))
	     (GO A)
	B    (COMPPRED (CAR ARGS) (CONS SWITCH TAG))
	     (OUTENDTAG G)
	C    (CLEARBOTH)
	     (CLEARACS)))


(DFUNC (BOOLEQ EXP VALAC TEST)
 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM TAG F)
       (SETQ EXP (CDR EXP))
       (COND ((AND (NULL VALAC) (NULL TEST)) (COMPSTAT (CADR EXP))
					     (COMPSTAT (CADDR EXP))
					     (RETURN NIL)))
       (COND ((OR (NOT (NULL VALAC)) (NULL TEST)) (SETQ F NIL)
						  (SETQ TAG NIL))
	     (T (SETQ F (CAR TEST)) (SETQ TAG (CDR TEST))))
       (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ)))
       (SETQ ARG1 (COMPEXPR (CAR EXP) (FREEAC)))
       (SETQ ARG2 (COMPEXPR (CADR EXP) (FREEAC)))
       (SETQ LOC2 (LOC ARG2))
       (SETQ LOC1 (LOC ARG1))
       (RST TAG)
       (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
	     ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
	     (T	(LOADARG (SETQ AC (FREEAC)) ARG1)
		(SETQ MEM (LOC ARG2))))
       (REMOVE ARG1)
       (REMOVE ARG2)
       (SAVEACS)
       (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)
       (COND ((NOT (NULL VALAC)) (SETQ AC (BOOLVALUE VALAC TAG))))
       (COND ((NOT (NULL TEST)) (OUTJRST (CDR TEST))))
       (RETURN AC)))

(DFUNC (BOOLEXPR XPR VALAC TEST)
       ((GETPROP (CAR XPR) (Q P2BOOL)) XPR VALAC TEST))

(DFUNC (BOOLNULL EXP VALAC TEST)
       (COMPPRED (CADR EXP) (CONS (NOT (CAR TEST)) (CDR TEST))))

(DFUNC (BOOLOR EXP VALAC TEST)
       (PROG2 (BOOLARGS (CDR EXP) (NOT (CAR TEST)) (CDR TEST) NIL)
	      (INCR P2CNT)))

(DFUNC (BOOLVALUE AC TAG)
       (PROGN (OUT1 (Q TDZA) AC AC)
	      (OUTENDTAG TAG)
	      (OUT1 (Q MOVEI) AC (Q (QUOTE T)))
	      (MARKVAL AC AC)))


(DFUNC (CALLFSUBR XPR VALAC TEST)
       (PROG (FUN ARGS VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (CLEARBOTH)
	     (LOADARG FARGAC (CONS ARGS (Q QT)))
	     (PROTECTACS FUN)
	     (SETQ VAL (MARKVAL VALAC VALUEAC))
	     (OUTCALL 17 FUN)
	     (RETURN (TESTJUMP VAL TEST))))

(DFUNC (CALLFUNARGS XPR VALAC TEST)
       (PROG (FUN ARGS FUNARGS LOCS VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (SETQ FUNARGS (COMPEXPR FUN VALUEAC))
	     (SETQ LOCS (COMPARGS ARGS))
	     (CLRCCLST LOCS NIL)
	     (LOADSUBRARGS LOCS)
	     (CLEARBOTH)
	     (CLEARACS)
	     (SETQ VAL (MARKVAL VALAC VALUEAC))
	     (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
	     (REMOVE FUNARGS)
	     (RETURN (TESTJUMP VAL TEST))))


(DFUNC (CALLLSUBR XPR VALAC TEST)
       (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (CLEAR1)
	     (SETQ NARGS (LENGTH ARGS))
	     (SLOTPUSH (Q (NIL . TAKEN)))
	     (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (NEXTSYM TAG)) 0 0))
	LOOP (COND ((NULL ARGS) (GO CALL)))
	     (SETQ HOME (TOPCOPY PDL))
	     (SETQ INST (COMPEXPR (CAR ARGS) VALUEAC))
	     (RESTORE HOME)
	     (SETQ TEM (LOC INST))
	     (SLOTPUSH (Q (NIL . TAKEN)))
	     (OUTPUSH TEM)
	     (REMOVE INST)
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)
	CALL (SETQ TEM (PDLDEPTH))
	     (SAVEACS)
	     (COND ((NOT (EQ (PDLDEPTH) TEM))
		    (COMPERR PDLTOOLONG-LSUBRCALL)))
	     (OUTINST (LIST (Q MOVNI) 6 NARGS))
	LLOOP(SLOTPOP)
	     (COND ((ZEROP NARGS) (GO CALL1)))
	     (SETQ NARGS (SUB1 NARGS))
	     (GO LLOOP)
	CALL1(CLEARBOTH)
	     (CLEARACS)
	     (SETQ VAL (MARKVAL VALAC VALUEAC))
	     (OUTJCALL 16 FUN)
	     (OUTTAG RETTAG)
	     (RETURN (TESTJUMP VAL TEST))))


(DFUNC (CALLSUBR XPR VALAC TEST)
       (PROG (FUN ARGS NARGS LOCS TEM VAL)
	     (SETQ FUN (CAR XPR))
	     (SETQ ARGS (CDR XPR))
	     (SETQ LOCS (COMPARGS ARGS))
	     (SETQ NARGS (LENGTH LOCS))
	     (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
			 (EQ NARGS 2)
			 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
		    (SETQ LOCS (REVERSE LOCS))
		    (SETQ FUN (PROPVAL TEM))))
	     (SETQ TEM (SIDEEFFECTS FUN))
	     (COND (TEM (CLRCCLST LOCS NIL)))
	     (LOADSUBRARGS LOCS)
	     (COND (TEM (CLEARBOTH)))
	     (PROTECTACS FUN)
	     (SETQ VAL (MARKVAL VALAC VALUEAC))
	     (OUTCALL NARGS FUN)
	     (RETURN (TESTJUMP VAL TEST))))

(DFUNC (CLEAR1) (PROGN (CLEARBOTH) (SAVEACS) (CLRPVARS)))

(DFUNC (CLEARBOTH) (PROGN (CLRCCLST NIL T) (CLRSPLD)))

(DFUNC (CLEARAC ACNO) (PROGN (CPUSH ACNO) (SETSLOT ACNO NIL)))

(DFUNC (CLEARITALL) (PROGN (CLEARBOTH) (CLEARACS)))

(DFUNC (CLEARACS)
       (PROG (ACNO)
	     (SETQ ACNO NACS)
	LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
	     (CLEARAC ACNO)
	     (SETQ ACNO (SUB1 ACNO))
	     (GO LOOP)))

(DFUNC (CLRCCLST DATA FL)
 (PROG (CCL)
       (SETQ CCL CCLST)
  LOOP (COND ((NULL CCL) (COND (FL (SETQ CCLST NIL))) (RETURN NIL)))
       (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
       (CSFUN (CAR CCL) VALUEAC)
  ELOOP(SETQ CCL (CDR CCL))
       (GO LOOP)))


(DFUNC (CLRPVARS)
       (PROG NIL
	     (COND ((NOT PROGSW) (RETURN NIL)))
	     (SETQ PROGSW NIL)
	LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
				    (SETQ MINDEPTH (PDLDEPTH))
				    (RETURN NIL))
		   ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
		    (INITZ (CAR PROGVARS))))
	     (SETQ PROGVARS (CDR PROGVARS))
	     (GO LOOP)))

(DFUNC (CLRSPLD)
       (PROG (LDL)
	     (SETQ LDL LDLST)
	LOOP (COND ((NULL LDL) (RETURN NIL)))
	     (COND ((SPECVARP (CAAR LDL)) (CLRSPVAR (CAR LDL))))
	     (SETQ LDL (CDR LDL))
	     (GO LOOP)))

(DFUNC (CLRSPVAR L)
 (PROG (LOC)
       (SETQ LOC (ILOC L VALUEAC))
       (COND ((NOT (NUMBERP LOC))
	      (SLOTPUSH (CONS (CAR L) P2CNT))
	      (OUTPUSH (LIST (Q SPECIAL) (CAR L))))
	     ((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
       (RETURN NIL)))

(DFUNC (COMPARGS ARGS)
       (PROG (ARGNO RESULT)
	     (SETQ ARGNO 0)
	LOOP (COND ((NULL ARGS) (RETURN RESULT)))
	     (SETQ ARGNO (ADD1 ARGNO))
	     (SETQ RESULT (CONS (COMPEXPR (CAR ARGS) ARGNO) RESULT))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (COMPEXPR XPR VALAC) (COMPFORM XPR VALAC NIL))

(DFUNC (COMPPRED XPR TEST) (COMPFORM XPR NIL TEST))


(DFUNC (COMPFORM XPR VALAC TEST)
 (PROG (TEM)
       (COND ((ATOM XPR) (GO ATOM)))
       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
       (COND ((EQ (CAAR XPR) (Q LAMBDA))
	      (RETURN (INTERNALLAMBDA XPR VALAC TEST))))
       (RETURN (CALLFUNARGS XPR VALAC TEST))
  ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
       (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
       (RETURN (TESTJUMP TEM TEST))
  ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
	      (RETURN ((PROPVAL TEM) XPR VALAC TEST))))
       (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
	      (RETURN (CALLFUNARGS XPR VALAC TEST))))
       (COMPERR UNKNOWNFUNCTION-COMPFORM)))

(DFUNC (COMPSTAT XPR) (COMPFORM XPR NIL NIL))

(DFUNC (COPT FUN AC ARGLOC)
       (PROG (CCL TEM YLOC)
	     (SETQ YLOC (ILOC ARGLOC AC))
	     (SETQ CCL CCLST)
	LOOP (COND ((NULL CCL) (RETURN NIL))
		   ((AND (EQ FUN (CADAR CCL))
			 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
			 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
		    (RETURN TEM)))
	     (SETQ CCL (CDR CCL))
	     (GO LOOP)))


(DFUNC (CPUSH ACNO)
 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
       (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
	      (RETURN NIL)))
       (COND ((LESSP ACNO 1) (GO MAKE)))
  START(SETQ SLOTNO 0)
       (SETQ TEMPDL PDL)
  LOOP (COND ((NULL TEMPDL) (GO NONE)))
       (COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
       (COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
		  (SPECVARP (CAAR TEMPDL)))
	      (SETQ HOLDSLOT SLOTNO)))
       (COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
  ELOOP(SETQ TEMPDL (CDR TEMPDL))
       (SETQ SLOTNO (SUB1 SLOTNO))
       (GO LOOP)
  FOUND(SETSLOT SLOTNO SLOTCON)
       (COND ((NULL (CDR SLOTCON))
	      (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
       (OUTMOVEM ACNO SLOTNO)
       (RETURN NIL)
  NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
  MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
	      (SETQ TEMPDL (PDLDEPTH))
	      (CLRPVARS)
	      (COND ((LESSP ACNO 1)
		     (SETQ ACNO	(PLUS ACNO
				      (DIFFERENCE TEMPDL
						  (PDLDEPTH))))))))
       (SLOTPUSH SLOTCON)
       (SETSLOT	ACNO
		(COND ((NULL (CDR SLOTCON))
		       (CONS (CAR SLOTCON) (Q DUP)))
		      (T NIL)))
       (OUTPUSH ACNO)
       (RETURN NIL)))

(DFUNC (CSFUN L AC)
 (PROG (Y)
       (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
	      (LOADCARCDR L AC)))))

(DFUNC (CSTEP FUN AC ARGLOC)
 (PROG (TEM)
       (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
       (COND ((SETQ TEM (COPT FUN AC ARGLOC)) (RETURN (LIST TEM))))
       (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
		     (CSTEP (CDR TEM) AC ARGLOC)))))


(DFUNC (DOP2BOOL XPR VALAC TEST)
 (PROG (TG)
       (CLEARBOTH)
       (PUTPROP (SETQ TG (NEXTSYM TAG)) T (Q SET))
       (COND ((NOT (NULL VALAC))
	      (RETURN (PROG (CTAG RSL)
			    (BOOLEXPR XPR VALAC (CONS T TG))
			    (RETURN (TESTJUMP (BOOLVALUE VALAC TG)
					      TEST))))))
       (BOOLEXPR XPR VALAC (COND ((NULL TEST) (CONS T TG)) (T TEST)))
       (COND ((NULL TEST) (OUTENDTAG TG)))))

(DFUNC (DOP2ELSE XPR VALAC TEST)
       ((GETPROP (CAR XPR) (Q P2ELSE)) XPR VALAC TEST))

(DFUNC (DOP2VAL XPR VALAC TEST)
 (TESTJUMP ((GETPROP (CAR XPR) (Q P2VAL)) XPR VALAC TEST) TEST))

(DFUNC (DVP X)
 (PROG (Y Z)
       (COND ((NULL X) (RETURN NIL)))
       (COND ((EQ (CDR X) (Q QT)) (RETURN NIL)))
       (COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
       (COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
       (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
       (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
		   (NULL (CDR X))
		   (LESSP P2CNT (CDR Y)))
	      (RETURN T)))
       (SETQ Z LDLST)
  LOOP (COND ((NULL Z)
	      (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
			     (DVP (CONS (CDR Z) (CDR X))))
			    (T NIL)))))
       (COND ((AND (EQ (CAAR Z) (CAR X))
		   (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
				     (T (CONS (CAR X) P2CNT))))
			  (LOC (CAR Z))))
	      (RETURN T)))
       (SETQ Z (CDR Z))
       (GO LOOP)))

(DFUNC (EQUIVTAG PTAG)
 (PROG (LTAG)
       (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
       (USERWARN PTAG UNDEFINED TAG)
       (RETURN EXIT)))


(DFUNC (EXITBUM SPECFLAG)
 (PROG (TEM1 TEM2)
       (COND ((SETQ TEM1 (ASSOC	(CAAR LASTOUT)
				(Q ((CALL JCALL) (PUSHJ JRST)))))
	      (SETQ TEM2 (CAR LASTOUT))
	      (SETQ LASTOUT NIL)
	      (KILLPDL)
	      (OUTINST TEM2)
	      (COND ((NOT SPECFLAG)
		     (SETQ TEM2 (CAR LASTOUT))
		     (SETQ LASTOUT NIL)
		     (OUTINST (MCONS (CADR TEM1)
				     (SUBST 0 (Q P) (CADR TEM2))
				     (CDDR TEM2)))
		     (RETURN NIL)))))
       (KILLPDL)
       (COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
	     (T (OUTINST (Q (POPJ P)))))))

(DFUNC (FREEAC) (FREEAC1 VALUEAC))

(DFUNC (FREEAC1 BEST)
 (PROG (ACNO ACCS)
       (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
	      (RETURN BEST)))
       (SETQ ACCS ACS)
       (SETQ ACNO 1)
  LOOP (COND ((NULL ACCS) (COND	((NULL BEST) (RETURN NIL))
				(T (CPUSH BEST) (RETURN BEST)))))
       (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
       (SETQ ACCS (CDR ACCS))
       (SETQ ACNO (ADD1 ACNO))
       (GO LOOP)))

(DFUNC (FINDFREEAC) (FREEAC1 NIL))

(DFUNC (FREEZE VAR) (PROGN (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))

(DFUNC (FREEZE1 X Z)
       (PROG NIL
	LOOP (COND ((NULL Z) (RETURN NIL)))
	     (COND ((EQ X (CAAR Z))
		    (COND ((NULL (CDAR Z)) (RPLACA Z (CONS X P2CNT)))
			  ((EQ (CDAR Z) (Q DUP)) (RPLACA Z NIL)))))
	     (SETQ Z (CDR Z))
	     (GO LOOP)))


(DFUNC (GENCONST OP AC AD IN IB)
       (PROG (ANS)
	     (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
	     (SETQ ANS (APPEND ANS (LIST AC AD IN)))
	     (SETQ ANS (CONS OP ANS))
	     (RETURN (CONS (Q C) ANS))))

(DFUNC (GETSLOT NO)
 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
       ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
       ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
       ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
				       (COMPERR NOTONPDL-GETSLOT))
       ((NTHCDR (MINUS NO) PDL))))

(DFUNC (GUARDLOCS)
       (PROG (LDL VARLOC LOCCONT)
	     (SETQ LDL LDLST)
	LOOP (COND ((NULL LDL) (RETURN NIL)))
	     (COND ((ASSOC (CAAR LDL) LOCVARS) (GO ISVAR)))
	ELOOP(SETQ LDL (CDR LDL))
	     (GO LOOP)
	ISVAR(SETQ VARLOC (LOC (CAR LDL)))
	     (COND ((NOT (NUMBERP VARLOC)) (GO PUSH)))
	     (SETQ LOCCONT (SLOTCONT VARLOC))
	     (COND ((NOT (DVP LOCCONT))
		    (SETSLOT VARLOC (CONS (CAAR LDL) P2CNT))
		    (GO ELOOP))
		   ((NUMBERP (CDR LOCCONT)) (GO ELOOP)))
	PUSH (SLOTPUSH (CONS (CAAR LDL) P2CNT))
	     (OUTPUSH VARLOC)
	     (GO ELOOP)))


(DFUNC (ILOC X AC)
 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
       (COND ((NULL AC) (GO LOOK)))
       (COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
  LOOK (COND ((EQ (CDR X) (Q QT))
	      (RETURN (LIST (LIST (Q QUOTE) (CAR X))))))
       (SETQ SL (APPEND ACS PDL))
       (SETQ CNTR 1)
       (SETQ BESTNO (ADD1 P2CNT))
       (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
  LOOP (COND ((NULL SL) (GO EXIT)))
       (SETQ SLOT (CAR SL))
       (COND ((AND SLOT (EQ (CAR X) (CAR SLOT))) (GO ISONE)))
  ELOOP(SETQ SL (CDR SL))
       (SETQ CNTR (ADD1 CNTR))
       (GO LOOP)
  EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
       (COND ((SPECVARP (CAR X))
	      (RETURN (LIST (Q SPECIAL) (CAR X)))))
       (RETURN NIL)
  ISONE(COND ((OR (EQUAL X SLOT)
		  (NOT (MEMQ (CDR SLOT) (Q (QT TAKEN)))))
	      (SETQ CNT	(COND ((NUMBERP (CDR SLOT)) (CDR SLOT))
			      (T P2CNT)))
	      (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
		     (SETQ BESTNO CNT)
		     (SETQ BEST CNTR)))))
       (GO ELOOP)
  RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
		     (T (PLUS (MINUS BEST) NACS 1))))))

(DFUNC (ILOC1 X AC)
 (PROG (Z)
       (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
       (COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
       (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
	      (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
       (COND ((SETQ Z (ASSOC (CAR X) CCLST))
	      (RETURN (LOADCARCDR Z
				  (COND	((NULL AC) (FREEAC))
					(T AC))))))
       (PRINTMSG (LIST X))
       (COMPERR LOSTVAR-ILOC1)))

(DFUNC (INITZ X)
       (PROGN (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))


(DFUNC (INTERNALLAMBDA XPR VALAC TEST)
 (PROG (BODY ARGS SF VARS VAL LOC SAVCNT TEM)
       (SETQ BODY (CADDAR XPR))
       (SETQ VARS (CADAR XPR))
       (SETQ ARGS (REVERSE (COMPARGS (CDR XPR))))
       (SETQ SAVCNT P2CNT)
       (INCR P2CNT)
  A    (COND ((NULL VARS) (GO B)))
       (SETQ LOC (LOC (CAR ARGS)))
       (REMOVE (CAR ARGS))
       (COND ((SPECVARP (CAR VARS))
	      (SETQ SF T)
	      (FREEZE (CAR VARS))
	      (SETQ LOC (PUTINAC (CAR ARGS) (FREEAC))))
	     ((OR (NOT (NUMBERP LOC)) (DVP (SETQ TEM (SLOTCONT LOC))))
	      (SLOTPUSH TEM)
	      (COND ((NULL (CDR TEM))
		     (SETSLOT LOC (CONS (CAR TEM) (Q DUP)))))
	      (OUTPUSH LOC)
	      (SETQ LOC 0)))
       (SETSLOT LOC (CONS (CAR VARS) (Q TAKEN)))
       (SETQ ARGS (CDR ARGS))
       (SETQ VARS (CDR VARS))
       (GO A)
  B    (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
       (SETQ VARS (CADAR XPR))
  C    (COND ((NULL VARS) (GO D)))
       (SETQ LOC (ILOC (CONS (CAR VARS) (Q TAKEN)) NIL))
       (COND ((SPECVARP (CAR VARS))
	      (OUTINST (LIST 0 LOC (LIST (Q SPECIAL) (CAR VARS))))))
       (RPLACD (SLOTCONT LOC) NIL)
       (SETQ VARS (CDR VARS))
       (GO C)
  D    (SETQ TEM (COMPEXPR BODY VALAC))
       (SETQ LOC (LOC TEM))
       (SETQ VAL (MARKVAL VALAC
			 (COND ((NUMBERP LOC) LOC)
			       (T (PUTINAC TEM (FREEAC))))))
       (REMOVE TEM)
       (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
       (INCR P2CNT)
       (SETQ VARS (CADAR XPR))
       (INTLAM1 ACS VARS SAVCNT)
       (INTLAM1 PDL VARS SAVCNT)
       (RETURN (TESTJUMP VAL TEST))))


(DFUNC (INTLAM1 LST VARS CNT)
       (PROG NIL
	LOOP (COND ((NULL LST) (RETURN NIL)))
	     (COND ((AND (NOT (NULL (CAR LST)))
			 (SPECVARP (CAAR LST))
			 (MEMQ (CAAR LST) VARS)
			 (OR (NULL (CDAR LST))
			     (GREATERP (CDAR LST) CNT)))
		    (RPLACA LST NIL)))
	     (SETQ LST (CDR LST))
	     (GO LOOP)))

(DFUNC (KILLPDL) (RESTORE NIL))

(DFUNC (LISTNILS NUMBER)
       (PROG (LIST)
	LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
	     (SETQ LIST (CONS NIL LIST))
	     (SETQ NUMBER (SUB1 NUMBER))
	     (GO LOOP)))


(DFUNC (LOADARG ACNO VAR)
 (PROG (DATAORG OLDACC DATACONT DAC DOD)
       (REMOVE VAR)
       (COND ((NULL ACNO) (RETURN NIL)))
       (SETQ DATAORG (ILOC1 VAR ACNO))
       (SETQ OLDACC (SLOTCONT ACNO))
       (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
       (SETQ DAC (DVP OLDACC))
       (SETQ DOD (DVP DATACONT))
       (COND ((EQ ACNO DATAORG)	(COND (DAC (CPUSH ACNO)))
				(RETURN NIL)))
       (COND ((AND (EQ DATAORG 0)
		   (NOT DOD)
		   (NOT DAC)
		   (GREATERP (PDLDEPTH) MINDEPTH))
	      (GO POP)))
       (COND ((AND (NOT DOD)
		   (NOT (NULL OLDACC))
		   (NUMBERP DATAORG)
		   (LESSP DATAORG ACNO))
	      (GO EXCH)))
       (COND ((NOT DAC) (GO FREE)))
       (GO PUSH)
  EXCH (SETSLOT DATAORG OLDACC)
       (SETSLOT ACNO DATACONT)
       (OUT1 (Q EXCH) ACNO DATAORG)
       (RETURN NIL)
  PUSH (CPUSH ACNO)
       (SETQ DATAORG (LOC VAR))
  FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
       (SETSLOT	ACNO
		(COND ((NULL (CDR DATACONT))
		       (CONS (CAR DATACONT) (Q DUP)))
		      (T DATACONT)))
       (OUTMOVE ACNO DATAORG)
       (RETURN NIL)
  POP  (SETSLOT ACNO DATACONT)
       (OUTPOP ACNO)
       (RETURN NIL)
  MOVE (SETSLOT	ACNO
		(COND ((EQ (CAAR DATAORG) (Q QUOTE))
		       (CONS (CADAR DATAORG) (Q QT)))
		      (T (LIST (CAR VAR)))))
       (OUTMOVE ACNO DATAORG)
       (RETURN NIL)))


(DFUNC (LOADCARCDR ITEM AC)
 (PROG (ARG PATH ORIG)
       (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
	      (REMOVE ARG)))
       (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
       (COND ((NULL (CDR PATH))
	      (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
				  VARLIST))
	      (REMOVE ARG)
	      (RETURN (LOC (CAR PATH)))))
       (SETQ PATH (REVERSE PATH))
       (CPUSH AC)
       (SETQ ORIG (LOC (CAR PATH)))
       (SETQ PATH (CDR PATH))
       (REMOVE ARG)
  L1   (COND ((NULL PATH) (GO RET)))
       (COND ((NULL (CDR PATH)) (GO L2)))
       (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
	      (OUTCALL 1
		       (READLIST (CONS (Q C)
				       (REVERSE (CONS (Q R) PATH)))))
	      (GO RET)))
  L2   (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
	     AC
	     ORIG)
       (SETQ PATH (CDR PATH))
       (SETQ ORIG AC)
       (GO L1)
  RET  (SETSLOT AC (LIST (CAR ITEM)))
       (RETURN AC)))

(DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMPEXPR XPR AC)))

(DFUNC (LOADSUBRARGS ARGS)
       (PROG (ARGNO)
	     (SETQ ARGNO (LENGTH ARGS))
	LOOP (COND ((NULL ARGS) (RETURN NIL)))
	     (LOADARG ARGNO (CAR ARGS))
	     (SETQ ARGS (CDR ARGS))
	     (SETQ ARGNO (SUB1 ARGNO))
	     (GO LOOP)))

(DFUNC (LOC X) (ILOC1 X NIL))

(DFUNC (MARKVAL FLAG LOC)
       (PROG (VAR GVAL)
	     (COND ((NULL LOC) (RETURN NIL)))
	     (SETQ GVAL (NEXTSYM VAL))
	     (SETQ VAR (CAR (SETSLOT LOC (LIST GVAL))))
	     (COND ((NOT (NULL FLAG)) (SETQ LDLST (CONS VAR LDLST))))
	     (RETURN VAR)))


(DFUNC (NONSPECVARS VRS)
       (PROG (ANS)
	LOOP (COND ((NULL VRS) (RETURN ANS))
		   ((SPECVARP (CAR VRS)))
		   (T (SETQ ANS (CONS (CAR VRS) ANS))))
	     (SETQ VRS (CDR VRS))
	     (GO LOOP)))

(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))

(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))

(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))

(DFUNC (OUTCJMP FLAG AC ADRESS)
       (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))

(DFUNC (OUTENDTAG X)
       (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))

(DFUNC (OUTFUNCALL TYPE NUM FUN)
       (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))

(DFUNC (OUTGOTAB X)
 (PROG (ETAG)
       (SETQ ETAG (NEXTSYM TAG))
       (PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
       (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
       (OUTTAG (CAR X))
  LOOP (SETQ X (CDR X))
       (COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
		       (OUTTAG ETAG)
		       (RETURN NIL)))
       (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
       (OUTJRST (CDAR X))
       (GO LOOP)))

(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))

(DFUNC (OUTJMP OP AC ADR)
       (PROGN (SAVEACS)
	      (CLEARBOTH)
	      (RST ADR)
	      (PUTPROP ADR T (Q USED))
	      (OUTINST (LIST OP AC ADR))))

(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))

(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))

(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))


(DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (Q POP) (Q P) L)))

(DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))

(DFUNC (OUTPUTSTAT ST)
       (PROG (ADD)
	     (COND ((ATOM ST) (GO PRINT)))
	     (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
	     (SETQ CODESIZE (ADD1 CODESIZE))
	     (SETQ ADD (CADDR ST))
	     (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
		    (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
	PRINT(PRINTSTAT ST)))

(DFUNC (OUTSTAT ST)
       (PROG (COL EXPRS)
	     (COND ((NULL LASTOUT) (GO SETIT)))
	     (OUTPUTSTAT (CAR LASTOUT))
	     (SETQ COL (CURCOL))
	     (SETQ EXPRS (CDR LASTOUT))
	TRACE(COND ((NULL EXPRS) (GO SETIT)))
	     (TABTO COL)
	     (PRINTEXPR (CAR EXPRS))
	     (SETQ EXPRS (CDR EXPRS))
	     (GO TRACE)
	SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
	     (RETURN NIL)))

(DFUNC (P2*EVAL XPR VALAC TEST)
       (PROG (ARG TEM VAL)
	     (SETQ ARG (CADR XPR))
	     (COND ((AND (EQ (CAR ARG) (Q CONS))
			 (EQ (CAADR ARG) (Q QUOTE))
			 (GETL (SETQ TEM (CADADR ARG))
			       (Q (FEXPR FSUBR *FSUBR))))
		    (GO NOCONS)))
	     (RETURN (CALLSUBR XPR VALAC TEST))
	NOCONS
	     (LOADCOMP (CADDR ARG) VALUEAC)
	     (PROTECTACS TEM)
	     (SETQ VAL (MARKVAL (NOT (NULL VALAC)) VALUEAC))
	     (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
	     (RETURN VAL)))


(DFUNC (P2ARG XPR VALAC TEST)
       (PROG (ARG)
	     (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
	     (COND ((EQ (CDR ARG) (Q QT))
		    (CPUSH VALAC)
		    (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
		    (REMOVE ARG)
		    (OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
		    (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
	     (LOADARG VALAC ARG)
	     (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
	     (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))

(DFUNC (P2CARCDR XPR VALAC TEST)
 (PROG (TEM AC)
       (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
	      (USERERR ARGNOERR-P2CARCDR)))
       (COND ((AND (NULL VALAC) (NULL TEST))
	      (RETURN (COMPSTAT (CADR XPR)))))
       (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
       (SETQ XPR (CONS (SETQ TEM (GENSYM))
		       (CONS (CAR XPR) (COMPEXPR (CADR XPR) AC))))
       (SETQ CCLST (CONS XPR CCLST))
       (SETQ TEM (LIST TEM))
       (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
       (RETURN (TESTJUMP TEM TEST))))

(DFUNC (P2COND XPR VALAC TEST)
       (PROG (AC CTAG RSL VALF)
	     (GUARDLOCS)
	     (CLEAR1)
	     (SETQ VALF (OR (NOT (NULL VALAC)) (NOT (NULL TEST))))
	     (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
	     (P2COND1 (CDR XPR) VALF AC MINDEPTH)
	     (INCR P2CNT)
	     (INCR P2CNT)
	     (RETURN (MARKVAL VALF AC))))


(DFUNC (P2COND1 ARGS VALF AC MINDEPTH)
 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST)
       (SETQ CONDEXIT (NEXTSYM TAG))
       (SETQ IRSSL (TOPCOPY PDL))
       (SETQ MINDEPTH (PDLDEPTH))
       (PUTPROP CONDEXIT IRSSL (Q LEVEL))
  LOOP (SETQ RSL NIL)
       (COND ((NULL ARGS) (COND (RETNIL (LOADARG AC (Q (NIL . QT)))))
			  (OUTENDTAG CONDEXIT)
			  (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
			  (RESTORE IRSSL)
			  (RETURN NIL)))
       (SETQ PAIR (CAR ARGS))
       (COND ((NULL (CDR PAIR))
	      (LOADCOMP (CAR PAIR) AC)
	      (COND ((NOT (NULL (CDR ARGS))) (OUTCJMP T AC CONDEXIT))
		    (T (RESTORE IRSSL)))
	      (GO NONIL)))
       (COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
		   (EQ (CAAR PAIR) (Q NULL))
		   (OR (ATOM (CADAR PAIR))
		       (NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
	      (LOADCOMP (CADAR PAIR) AC)
	      (OUTCJMP NIL AC CONDEXIT)
	      (SETQ RETNIL T)
	      (GO ELOOP)))
       (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
       (COND ((AND (EQ (CAADR PAIR) (Q GO))
		   (ATOM (SETQ ATAG (CADADR PAIR))))
	      (COMPPRED (CAR PAIR) (CONS T (EQUIVTAG ATAG)))
	      (GO NONIL)))
       (COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
	      (COMPPRED (CAR PAIR) (CONS T EXITN))
	      (GO NONIL)))
  L2   (SETQ PAIREXIT (SETQ CTAG (NEXTSYM TAG)))
       (PUTPROP PAIREXIT IRSSL (Q LEVEL))
       (SETQ RSL NIL)
       (COMPPRED (CAR PAIR) (CONS NIL PAIREXIT))
       (SETQ H2	(COND ((NOT (ATOM RSL)) RSL)
		      (T (LIST (TOPCOPY ACS) (TOPCOPY PDL)))))
       (SETQ H1 (TOPCOPY CCLST))
       (SETQ REST (CDR PAIR))
  LP1  (COND ((NULL (CDR REST)) (GO L1)))
       (COMPSTAT (CAR REST))
       (SETQ REST (CDR REST))
       (GO LP1)
  L1   (COND ((NULL VALF) (COMPSTAT (CAR REST)))
	     (T (LOADCOMP (CAR REST) AC)))
       (SAVEACS)
       (SETQ CCLST H1)
       (SETQ H1 ACS)
       (SETQ ACS (CAR H2))
       (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (NIL . QT))))
       (SETQ ACS H1)
       (SETQ RETNIL NIL)
       (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
	      (COND ((OR (NOT (NULL (CDR ARGS)))
			 (AND VALF
			      (NOT ACNIL)
			      (SETQ RETNIL (USEDTAGP PAIREXIT))))
		     (OUTJRST CONDEXIT))
		    (T (RESTORE IRSSL)))))
       (SETQ ACS (CAR H2))
       (SETQ PDL (CADR H2))
       (SETQ PDLDEPTH (LENGTH PDL))
       (COND ((USEDTAGP PAIREXIT) (OUTTAG PAIREXIT)))
       (GO ELOOP)
  NONIL(SETQ RETNIL NIL)
  ELOOP(SETQ ARGS (CDR ARGS))
       (GO LOOP)))


(DFUNC (P2GO XPR VALAC TEST)
       (PROG (TAG)
	     (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
		    (USERERR GO FOR VALUE OR TEST P2GO)))
	     (SETQ TAG (CADR XPR))
	     (SAVEACS)
	     (CLRPVARS)
	     (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
		   (T (LOADCOMP TAG GOTABAC) (OUTJRST VGO)))
	     (RETURN (MARKVAL (NOT (NULL VALAC)) VALUEAC))))


(DFUNC (P2PROG XPR VALAC TEST)
 (PROG (PSFLG PVR)
       (SETQ PVR (COND ((NOT (NULL VALAC)) VALAC)
		       ((NOT (NULL TEST)) (FREEAC))
		       (T NIL)))
       (SETQ PSFLG (SPECBIND (CADDR XPR) NIL))
       (SETQ PRGSPFLG NIL)
       (CLEAR1)
       (PROG (GOLIST EXIT EXITN PRSSL PROGSW VGO)
	     (GUARDLOCS)
	     (INCR P2CNT)
	     (SETQ PROGSW T)
	     (SETQ EXIT (NEXTSYM TAG))
	     (SETQ EXITN (NEXTSYM TAG))
	     (SETQ VGO (NEXTSYM TAG))
	     (SETQ GOLIST (CONS	(CONS NIL EXIT)
				(CONS (CONS NIL EXITN)
				      (CONS (CONS NIL VGO)
					    (CADR XPR)))))
	     (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
	     (SETQ XPR (CDDDR XPR))
	LOOP (COND ((NULL XPR) (GO EXITN)))
	     (INCR P2CNT)
	     (COND ((NOT PROGSW) (RESTORE PRSSL)))
	     (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
		   ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
		    (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL))))
			   (GO EXITN))
			  (T (LOADCOMP (CADAR XPR) PVR)
			     (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
						     (GO EXITN))
				   (T (GO EXIT))))))
		   (T (COMPSTAT (CAR XPR))))
	     (SETQ XPR (CDR XPR))
	     (GO LOOP)
	EXITN(OUTENDTAG EXITN)
	     (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
		    (LOADARG PVR (Q (NIL . QT)))))
	EXIT (OUTENDTAG EXIT)
	     (INCR P2CNT)
	     (INCR P2CNT)
	     (COND ((USEDTAGP VGO)
		    (OUTGOTAB (CONS VGO (CDDDR GOLIST))))))
       (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
       (RETURN (MARKVAL (NOT (NULL PVR)) PVR))))


(DFUNC (P2PROG2 XPR VALAC TEST)
 (PROG (ARGS ARG2)
       (SETQ ARGS (CDR XPR))
       (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
       (COMPSTAT (CAR ARGS))
       (COND ((NULL (CDDR ARGS))
	      (RETURN (COMPFORM (CADR ARGS) VALAC TEST))))
       (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
	      (SETQ ARG2 (COMPEXPR (CADR ARGS) VALAC)))
	     (T (COMPSTAT (CADR ARGS))))
       (SETQ ARGS (CDDR ARGS))
  LOOP (COND ((NULL ARGS) (RETURN (TESTJUMP ARG2 TEST))))
       (COMPSTAT (CAR ARGS))
       (SETQ ARGS (CDR ARGS))
       (GO LOOP)))

(DFUNC (P2PROGN XPR VALAC TEST)
       (PROG (ARGS)
	     (COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
	LOOP (COND ((NULL (CDR ARGS))
		    (RETURN (COMPFORM (CAR ARGS) VALAC TEST))))
	     (COMPSTAT (CAR ARGS))
	     (SETQ ARGS (CDR ARGS))
	     (GO LOOP)))

(DFUNC (P2QUOTE XPR VALAC TEST)
       (PROG2 (COND ((NOT (NULL TEST))
		     (BOOLARGS NIL
			       (IFIF (CAR TEST) (CADR XPR))
			       (CDR TEST)
			       NIL)))
	      (CONS (CADR XPR) (Q QT))))

(DFUNC (P2RETURN XPR VALAC TEST)
       (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
	      (USERERR RETURN FOR VALUE OR TEST P2RETURN))
	     (T	(SAVEACS)
		(CLRPVARS)
		(COND ((EQUAL (CADR XPR) (Q (QUOTE NIL))) (OUTJRST EXITN))
		      (T (LOADCOMP (CADR XPR) PVR) (OUTJRST EXIT))))))


(DFUNC (P2RPLAC XPR VALAC TEST)
       (PROG (ARG1 ARG2)
	     (SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
	     (SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
	     (ILOC1 ARG1 VALAC)
	     (LOC ARG2)
	     (CLEARBOTH)
	     (COND ((EQUAL ARG2 (Q (NIL . QT)))
		    (OUT1 (CADR	(ASSOC (CAR XPR)
				       (Q ((RPLACA HRRZS@)
					   (RPLACD HLLZS@)))))
			  0
			  (LOC ARG1)))
		   (T (OUT1 (CADR (ASSOC (CAR XPR)
					 (Q ((RPLACA HRLM@)
					     (RPLACD HRRM@)))))
			    (PUTINAC ARG2 (FREEAC))
			    (LOC ARG1))))
	     (REMOVE ARG2)
	     (COND ((NULL VALAC) (REMOVE ARG1)))
	     (RETURN ARG1)))

(DFUNC (P2SETARG XPR VALAC TEST)
       (PROG (TEM)
	     (LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
	     (COND ((EQ (CAADR XPR) (Q QUOTE))
		    (OUT1 (Q MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
		    (RETURN (OUTINST (LIST (Q HRRM)
					   (PUTINAC TEM VALAC)
					   (CADADR XPR)
					   2)))))
	     (LOADCOMP (COMPEXPR (CADR XPR)) 2)
	     (CLEARACS)
	     (OUT1 (Q ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
	     (OUTINST (LIST (Q HRRM)
			    (PUTINAC TEM VALAC)
			    (MINUS INUM0)
			    2))))


(DFUNC (P2SETQ XPR VALAC TEST)
 (PROG (NVAR VALLOC HOME VAR VAL TEM AC)
       (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
       (SETQ VAR (CADR XPR))
       (SETQ VAL (COMPEXPR (CADDR XPR) AC))
       (ILOC1 VAL AC)
       (COND ((AND (SPECVARP VAR) (SETQ TEM (ASSOC VAR LDLST)))
	      (CLRSPVAR TEM)))
       (REMOVE VAL)
       (FREEZE VAR)
       (SETQ VALLOC (LOC VAL))
       (SETQ HOME (COND	((SPECVARP VAR) T)
			((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
			 NIL)
			(T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
       (INCR P2CNT)
       (COND ((AND (NULL VALAC) (NOT HOME))
	      (COND ((AND (NUMBERP VALLOC)
			  (NOT (DVP (SLOTCONT VALLOC))))
		     (SETSLOT VALLOC (LIST VAR))
		     (GO EXIT))
		    (T (SLOTPUSH (LIST VAR))
		       (OUTPUSH VALLOC)
		       (GO EXIT)))))
       (COND ((AND HOME (EQUAL VAL (Q (NIL . QT))))
	      (SETQ VAL	(COND ((SPECVARP VAR) (LIST (Q SPECIAL) VAR))
			      (T (ILOC (CONS VAR (SUB1 P2CNT)) AC))))
	      (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
	      (COND ((OR (NULL VALAC) (DVP (SLOTCONT AC)))
		     (OUT1 (Q CLEARM) 0 VAL))
		    (T (SETSLOT AC (CONS VAR (Q DUP)))
		       (OUT1 (Q CLEARB) AC VAL)))
	      (GO EXIT)))
       (COND ((OR (NOT (NUMBERP VALLOC))
		  (LESSP VALLOC 0)
		  (DVP (SLOTCONT VALLOC)))
	      (LOADARG AC VAL)
	      (SETQ VALLOC AC)))
       (SETSLOT VALLOC (LIST VAR))
       (COND ((SPECVARP VAR)
	      (COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
		    (T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
  EXIT (RETURN (COMPFORM VAR VALAC TEST))))


(DFUNC (P2STORE XPR VALAC TEST)
       (PROG (TEM)
	     (LOC (SETQ TEM (COMPEXPR (CADDR XPR)
				      (COND ((NULL VALAC) (FREEAC))
					    (T VALAC)))))
	     (COMPSTAT (CADR XPR))
	     (LOADARG ARRAYAC TEM)
	     (OUTINST (Q (PUSHJ P NSTR)))
	     (RETURN TEM)))

(DFUNC (PASS2 NAME EXPR FLAG)
 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPECFLAG PRGSPFLG CCLST
	VARLIST PROGVARS PROGSW GOLIST CTAG RSL)
       (SETQ P2CNT 1)
       (SETQ ACS (LISTNILS NACS))
       (SETQ ALLACS (SUB1 (LSH 1 NACS)))
       (SETQ PDL NIL)
       (SETQ PDLDEPTH (LENGTH PDL))
       (SETQ MINDEPTH (PDLDEPTH))
       (BINDARGS (CADR EXPR))
       (COND ((NOT (ATMARGIN)) (LINEF 2)))
       (OUTPSOP (LIST (Q LAP) NAME FLAG))
       (COND ((EQ (CAR EXPR) (Q FSUBR))
	      (COND ((NOT (NULL (CDADR EXPR)))
		     (OUTINST (Q (PUSHJ P *AMAKE))))))
	     ((EQ (CAR EXPR) (Q LSUBR))
	      (OUTINST (Q (JSP 3 *LCALL)))
	      (INITPROP (Q ARG) (Q P2) (Q P2ARG))))
       (SETQ SPECFLAG (SPECBIND (CADR EXPR) T))
       (COND ((NOT (EQ (CAADDR EXPR) (Q PROG))) (SETQ PRGSPFLG NIL)))
       (LOADCOMP (CADDR EXPR) VALUEAC)
       (EXITBUM SPECFLAG)
       (OUTINST (OUTINST NIL))
       (COND ((EQ (CAR EXPR) (Q LSUBR)) (DELETEPROP (Q ARG) (Q P2))))
       (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
       (RETURN NIL)))

(DFUNC (PROGTAG TAG)
       (PROGN (CLEARBOTH)
	      (CLEARACS)
	      (CLRPVARS)
	      (RESTORE PRSSL)
	      (OUTTAG (EQUIVTAG TAG))))


(DFUNC (PROTECTACS X)
 (PROG (WHICHACS ACNO)
       (SETQ WHICHACS (ACEFFECTS X))
       (SETQ ACNO 0)
  LOOP (SETQ ACNO (ADD1 ACNO))
       (COND ((ZEROP WHICHACS) (RETURN NIL))
	     ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
       (SETQ WHICHACS (LSH WHICHACS -1))
       (GO LOOP)))

(DFUNC (PUTINAC X AC)
       (PROG (Z)
	     (SETQ Z (LOC X))
	     (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
	     (REMOVE X)
	     (CPUSH Z)
	     (RETURN Z)))

(DFUNC (REMOVE DATA)
       (PROG (TEM)
	     (SETQ TEM (GETPROP (Q LDLST) (Q VALUE)))
	LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
	     (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
		   (T (SETQ TEM (CDR TEM))))
	     (GO LOOP)))


(DFUNC (RESTORE OLDPDL)
 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
       (SETQ OLDDEPTH (LENGTH OLDPDL))
       (COND ((GREATERP OLDDEPTH (PDLDEPTH))
	      (PRINTMSG (LIST OLDPDL PDL))
	      (COMPERR PDLSHORT-RESTORE)))
  A1   (SETQ C 0)
  A    (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
	     ((DVP (SETQ R (CAR PDL))) (GO CPP)))
       (SETQ C (ADD1 C))
       (SLOTPOP)
       (GO A)
  CPP  (SHRINKPDL C)
  CPP1 (SETQ V OLDPDL)
       (SETQ C 0)
       (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
  CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
		       (COND ((NULL V) (COMPERR NOAC-RESTORE)))
		       (SETSLOT V R)
		       (OUTPOP V)
		       (GO A1))
	     ((AND (CAR V)
		   (EQ (CAAR V) (CAR R))
		   (NOT	(DVP (SLOTCONT (SETQ TEM
					(MINUS (PLUS C
						     DEPTHDIF)))))))
	      (GO CPP2)))
       (SETQ C (ADD1 C))
       (SETQ V (CDR V))
       (GO CPP3)
  CPP2 (SETSLOT TEM R)
       (OUTPOP TEM)
       (GO A1)))

(DFUNC (RSLSET X)
 (COND ((EQ X CTAG)
	(SETQ RSL (COND	((AND RSL
			      (NOT (AND	(EQUAL (CAR RSL) ACS)
					(EQUAL (CADR RSL) PDL))))
			 (Q LOSE))
			(T (LIST (TOPCOPY ACS) (TOPCOPY PDL))))))))

(DFUNC (RST TAG)
 (COND ((NULL TAG) NIL)
       ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
       ((REMPROP TAG (Q SET)) (SAVEACS)
			      (PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
			      (SETQ MINDEPTH (PDLDEPTH)))
       ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
       (T (COMPERR NIL-RST))))


(DFUNC (SAVEACS)
       (PROG (K)
	     (SETQ K 0)
	LOOP (COND ((EQ K NACS) (RETURN NIL)))
	     (CPUSH (SETQ K (ADD1 K)))
	     (GO LOOP)))

(DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))

(DFUNC (SHRINKPDL C)
       (COND ((NOT (ZEROP C))
	      (OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))

(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))

(DFUNC (SLOTCONT X) (CAR (GETSLOT X)))

(DFUNC (SLOTPOP)
       (PROGN (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))

(DFUNC (SLOTPUSH SC)
 (PROGN (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))

(DFUNC (SPECBIND VARS LAMBDAP)
       (PROG (ACNUM SPFLG)
	     (SETQ ACNUM 1)
	LOOP (COND ((NULL VARS) (RETURN SPFLG)))
	     (COND ((NOT (SPECVARP (CAR VARS))) (GO ELOOP)))
	     (COND ((NOT PRGSPFLG) (SETQ PRGSPFLG (SETQ SPFLG T))
				   (OUTINST (Q (JSP 6 SPECBIND)))))
	     (OUTINST (LIST 0
			    (COND (LAMBDAP ACNUM) (T 0))
			    (LIST (Q SPECIAL) (CAR VARS))))
	ELOOP(SETQ ACNUM (ADD1 ACNUM))
	     (SETQ VARS (CDR VARS))
	     (GO LOOP)))

(DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))


(DFUNC (TESTJUMP ITEM TEST)
       (PROG (AC FLAG TAG)
	     (COND ((NULL TEST) (RETURN ITEM)))
	     (SETQ FLAG (CAR TEST))
	     (SETQ TAG (CDR TEST))
	     (SETQ AC (PUTINAC ITEM (FREEAC)))
	     (OUTCJMP FLAG AC TAG)
	     (COND (FLAG (RSLSET TAG) (SETSLOT AC (Q (NIL . QT))))
		   (T (SETQ FLAG (SLOTCONT AC))
		      (SETSLOT AC (Q (NIL . QT)))
		      (RSLSET TAG)
		      (SETSLOT AC FLAG)))
	     (RETURN ITEM)))

(DFUNC (TRANSOUT OP AC AD)
 (PROG (TEM IND)
       (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
       (SETQ AD (CAR AD))
       (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
	      (SETQ OP (PROPVAL TEM))
	      (GO DONE)))
       (SETQ AD (GENCONST 0 0 AD 0 0))
  DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
		       (T (LIST (Q P)))))
       (RETURN (MCONS OP AC AD IND))))

(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))

(MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
	      (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
	      (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
	      (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR)
	      (P2BOOL DOP2BOOL) (P2ELSE DOP2ELSE) (P2VAL DOP2VAL))

(MAPDEF P2BOOL (AND BOOLAND) (NULL BOOLNULL) (OR BOOLOR))

(MAPDEF P2ELSE (EQ BOOLEQ) (GO P2GO) (QUOTE P2QUOTE) (PROG2 P2PROG2)
	       (RETURN P2RETURN) (SETQ P2SETQ))

(MAPDEF P2VAL (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND) (PROG P2PROG)
	      (PROGN P2PROGN) (RETURN P2RETURN) (RPLACA P2RPLAC)
	      (RPLACD P2RPLAC) (SETARG P2SETARG) (STORE P2STORE))

(SETQ CARCDRDEPTH 4)


(PROG (BASE COUNT LIMIT MIDDLE NAME)
      (SETQ BASE 2)
      (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
      (SETQ COUNT (LSH 1 1))
 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
      (SETQ MIDDLE (SUBST (QUOTE A)
			  0
			  (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
      (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
      (PUTPROP NAME
	       (CONS (CAR MIDDLE)
		     (COND ((CDR MIDDLE)
			    (READLIST (APPEND (QUOTE (C))
					      (CDR MIDDLE)
					      (QUOTE (R)))))))
	       (QUOTE CARCDR))
      (SETQ COUNT (ADD1 COUNT))
      (GO LOOP))

(MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
	    (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))

(MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
	      (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))

(MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
	      (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
	      (MOVE MOVEI))

(SETQ NACS 5)

(SETQ VALUEAC 1)

(SETQ FARGAC 1)

(SETQ GOTABAC 1)

(SETQ ARRAYAC 1)

(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))

(ENDBLOCK PASS2)

(BEGINBLOCK DEBUG)


(DFUNC (CMPBREAK TYPE MESSAGE)
       (PROG NIL
	     (INC NIL T)
	     (OUTC NIL T)
	     (COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
	     (PRINL (APPEND TYPE MESSAGE))
	     (LINEF 1)
	LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
		    (RETURN (Q DONE))))
	     (GO LOOP)))

(DEFPROP COMPERR
	 (LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
	 FEXPR)

(DFUNC (EVALREAD)
       (PROG (EX)
	     (LINEF 1)
	     (SETQ EX (READ))
	     (PRINC *SP)
	     (RETURN (PRINC (EVAL EX)))))

(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))

(DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)

(SETQ TRACELIST NIL)

(ENDBLOCK DEBUG)

(BEGINBLOCK IO)

(DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))

(DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))

(DFUNC (CURCOL) (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))

(DFUNC (FORMF) (PROGN (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))

(DFUNC (LINEF N)
       (PROG NIL
	LOOP (COND ((ZEROP N) (RETURN NIL)))
	     (TERPRI)
	     (SETQ N (SUB1 N))
	     (GO LOOP)))

(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))


(DFUNC (PRINS FN)
 (PROG2	(COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
	(PRINTEXPR FN)))

(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))

(DFUNC (PRINTN CHAR NUM)
       (PROG (NO)
	     (SETQ NO 1)
	LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
	     (PRINC CHAR)
	     (SETQ NO (ADD1 NO))
	     (GO LOOP)))

(DFUNC (PRINTSTAT STAT)
 (PROG2 (COND ((NULL STAT) (CARRETN) (TABTO 10))
	      ((ATOM STAT) (TABTO 2))
	      ((EQ (CAR STAT) (Q LAP)) (TABTO 1))
	      (T (TABTO 10)))
	(PRINTEXPR STAT)))

(DFUNC (TABTO COL)
 (PROGN	(COND ((GREATERP (CURCOL) COL) (LINEF 1)))
	(PRINTN	*TB
		(*DIF (LSH (SUB1 COL) -3) (LSH (SUB1 (CURCOL)) -3)))
	(PRINTN *SP (*DIF COL (CURCOL)))))


(MAPCAR	(FUNCTION (LAMBDA (PAIR)
			  (PROG2 (SET (CAR PAIR)
				      (INTERN (ASCII (CADR PAIR))))
				 (CAR PAIR))))
	(QUOTE ((*SP 40) (*TB 11)
			 (*CR 15)
			 (*LF 12)
			 (*VT 13)
			 (*FF 14)
			 (*CO 54)
			 (*PT 56)
			 (*LP 50)
			 (*RP 51)
			 (*SL 57)
			 (*AM 33)
			 (*AT 100)
			 (*RO 177)
			 (*COLON 72))))

(SETQ LINCNT 0)

(SETQ PAGEHEIGHT 74)

(SETQ PAGEWIDTH 120)

(ENDBLOCK IO)

(BEGINBLOCK GENERAL)

(DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))

(DFUNC (ASSOCR X Y)
       (PROG NIL
	LOOP (COND ((NULL Y) (RETURN NIL))
		   ((EQ X (CDAR Y)) (RETURN (CAR Y))))
	     (SETQ Y (CDR Y))
	     (GO LOOP)))

(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (Q (T NIL)))))

(DFUNC (COPY EX) (SUBST 0 0 EX))

(DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))

(DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))


(DFUNC (GETGET ATOM PROP)
       (PROG (TEM PTAB)
	     (SETQ PTAB (FIRSTPROP ATOM))
	LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
	     (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
		    (RETURN TEM)))
	     (SETQ PTAB (NEXTPROP PTAB))
	     (GO LOOP)))

(DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))

(DFUNC (MAKESPECIAL VAR)
       (PROGN (COND ((HASPROP VAR (Q LOCAL))
		     (PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
	      (SETPROP VAR (Q SPECIAL) T)
	      VAR))

(DFUNC (MAKESYM IDENT NUMBER)
 (PROG (*NOPOINT)
       (SETQ *NOPOINT T)
       (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))

(DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))

(DEFPROP NEXTSYM
	 (LAMBDA (NAME)
		 (PROG (NUM)
		       (SETQ NUM (GETPROP (CAR NAME) (Q SYMNO)))
		       (PUTPROP (CAR NAME) (ADD1 NUM) (Q SYMNO))
		       (RETURN (MAKESYM (CAR NAME) NUM))))
	 FEXPR)

(DFUNC (NTHCDR NUM EXP)
       (PROG NIL
	     (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
	LOOP (COND ((ZEROP NUM) (RETURN EXP)))
	     (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
	     (SETQ EXP (CDR EXP))
	     (SETQ NUM (SUB1 NUM))
	     (GO LOOP)))

(DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)

(DEFPROP STARTSYM
	 (LAMBDA (SYMS)
		 (PROG NIL
		  LOOP (COND ((NULL SYMS) (RETURN NIL)))
		       (INITPROP (CAR SYMS) (Q SYMNO) 1)
		       (SETQ SYMS (CDR SYMS))
		       (GO LOOP)))
	 FEXPR)


(DEFPROP STOPSYM
	 (LAMBDA (SYMS)
		 (PROG NIL
		  LOOP (COND ((NULL SYMS) (RETURN NIL)))
		       (DELETEPROP (CAR SYMS) (Q SYMNO))
		       (SETQ SYMS (CDR SYMS))
		       (GO LOOP)))
	 FEXPR)

(DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))

(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))

(ENDBLOCK GENERAL)

(ENDBLOCK COMPILER)



EXIT
^C
