Google
 

Trailing-Edge - PDP-10 Archives - -
Click to see without markup as text/plain
There are no other files named in the archive.
00100	(PROG (SEXPR IBASE) 
00200	      (SETQ IBASE (ADD1 7)) 
00300	 LOOP (SETQ SEXPR (ERRSET (READ))) 
00400	      (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN (QUOTE COMPILER-LOADED)))) 
00500	      (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK))) (GO LOOP))) 
00600	      (PRINT (EVAL (CAR SEXPR))) 
00700	      (GO LOOP)) 
00800	 
00900	(BEGINBLOCK COMPILER) 
01000	
01100	(COND ((EQ (CDR	 (GET (QUOTE COMPILING) (QUOTE VALUE))) (QUOTE NOW)) 
01200	       (SPECIAL LASTOUT LOCVARS SPECVARS TAGCNT P1CNT P2CNT) 
01300	       (SPECIAL ALLVARS RENAMELIST INPROG P1SCNT P1SCV FOUNDFREE) 
01400	       (SPECIAL COMPILING CODESIZE CONSTSIZE LISTING INDEV OUTDEV) 
01500	       (SPECIAL ARGACS REGPDL PDLDEPTH MINDEPTH) 
01600	       (SPECIAL LDLST PRGSPFLG PROGVARS SPLDLST CCLST RSL) 
01700	       (SPECIAL CTAG RSL) 
01800	       (SPECIAL PROGSW GOLIST VARLIST) 
01900	       (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR) 
02000	       (SPECIAL FUNNAME FUNTYPE FUNFLAG) 
02100	       (SPECIAL NACS VALUEAC PDLAC ALLACS INUM0 MSGDEV GOTABAC FARGAC ARRAYAC) 
02200	       (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT) 
02300	       (SPECIAL ALLFUNS GENFUNS UNDFUNS STARTTIME) 
02400	       (SPECIAL P1FUN P2FUN BOOLFUN ACTFUN) 
02500	       (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT *LP *RP *SL *AM *AT *RO *COLON) 
02600	       (SPECIAL IBASE BASE *NOPOINT) 
02700	       (SPECIAL TRACELIST DB) 
02800	       (PRINTMSG (QUOTE DECLARATIONS-MADE)))) 
02900	 
     
00100	(BEGINBLOCK MACROS) 
00200	
00300	(DEFPROP DFUNC (LAMBDA (L) (LIST (Q DEFPROP) 
00400					 (CAADR L) 
00500					 (MCONS (Q LAMBDA) (CDADR L) (CDDR L)) 
00600					 (Q EXPR))) 
00700		 MACRO) 
00800	 
00900	(DEFPROP DOCDR 
01000		 (LAMBDA (CALL) (LIST (Q SETQ) (CADR CALL) (LIST (Q CDR) (CADR CALL)))) 
01100		 MACRO) 
01200	 
01300	(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO) 
01400	 
01500	(DEFPROP GENFUNNAME (LAMBDA (L) (Q (MAKESYM FUNNAME (GENSYM)))) MACRO) 
01600	 
01700	(DEFPROP GENTAG (LAMBDA (L) (Q (GENSYM))) MACRO) 
01800	 
01900	(DEFPROP GENVAL (LAMBDA (L) (Q (GENSYM))) MACRO) 
02000	 
02100	(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO) 
02200	 
02300	(DEFPROP IFIF 
02400		 (LAMBDA (L) (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L))))) 
02500		 MACRO) 
02600	 
02700	(DEFPROP INCR 
02800		 (LAMBDA (L) (LIST (QUOTE SETQ) (CADR L) (LIST (QUOTE ADD1) (CADR L)))) 
02900		 MACRO) 
03000	 
03100	(DEFPROP MAPDEF 
03200	 (LAMBDA (L) 
03300	  (LIST (Q MAPCAR) 
03400		(SUBST (CADR L) 
03500		       (Q IND) 
03600		       (Q (FUNCTION 
03700			   (LAMBDA (PAIR)
03800				   (PUTPROP (CAR PAIR) (CADR PAIR) (QUOTE IND)))))) 
03900		(LIST (Q QUOTE) (CADDR L)))) 
04000	 MACRO) 
04100	 
     
00100	(DEFPROP MCONS 
00200		 (LAMBDA (L) 
00300			 (COND ((NULL (CDDR L)) (CADR L)) 
00400			       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L)))))) 
00500		 MACRO) 
00600	 
00700	(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO) 
00800	 
00900	(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO) 
01000	 
01100	(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO) 
01200	 
01300	(DEFPROP PDLINDEX (LAMBDA (L) (Q (MINUS (ADD1 PDLDEPTH)))) MACRO) 
01400	 
01500	(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO) 
01600	 
01700	(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO) 
01800	 
01900	(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO) 
02000	 
02100	(DEFPROP REPLACECAR (LAMBDA (L) (CONS (Q RPLACA) (CDR L))) MACRO) 
02200	 
02300	(DEFPROP REPLACECDR (LAMBDA (L) (CONS (Q RPLACD) (CDR L))) MACRO) 
02400	 
02500	(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO) 
02600	 
02700	(ENDBLOCK MACROS) 
02800	
     
00100	(BEGINBLOCK TOPLEVEL) 
00200	 
00300	(DFUNC (ACTONEXPR XPR) (PROG (ACTION COMPILING) 
00400				     (SETQ COMPILING (QUOTE NOW)) 
00500				     (COND ((ATOM XPR) (GO FLUSH))) 
00600				     (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT))) 
00700				     (SETQ ACTFUN ACTION) 
00800				     (COND (ACTION ((CAR ACTION) XPR) (RETURN NIL))) 
00900				FLUSH(FLUSHEXPR XPR) 
01000				     (RETURN NIL))) 
01100	 
01200	(DFUNC (ACTONMACRO XPR) (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR))) 
01300	 
01400	(DFUNC (CF) (COMPFILE (GETPROP (QUOTE TRY) (Q FILE)))) 
01500	 
01600	(DEFPROP CMP 
01700	 (LAMBDA (L) 
01800	  (PROG2 (PUTPROP (CAAR L) 
01900			  (MCONS (Q LAMBDA) (CDAR L) (CDR  L)) 
02000			  (Q EXPR)) 
02100		 (EVAL (LIST (Q COMPILE) (CAAR L))))) 
02200	 FEXPR) 
02300	 
02400	(DEFPROP COMFILE 
02500		 (LAMBDA (FILE) (PROG (CODESIZE CONSTSIZE) 
02600				      (PUTPROP (Q TRY) FILE (Q FILE)) 
02700				      (SETQ CODESIZE (SETQ CONSTSIZE 0)) 
02800				      (RETURN (COMPFILE FILE)))) 
02900		 FEXPR) 
03000	 
03100	(DFUNC (COMPDEF DEFIN) 
03200	       (PROG (ACTION) 
03300		     (COND ((NOT (EQUAL (LENGTH DEFIN) 4)) (DATAERR ARGNOERR-COMPDEF))) 
03400		     (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION))) 
03500			    ((PROPVAL ACTION) DEFIN) 
03600			    (RETURN NIL))) 
03700		     (FLUSHDEF DEFIN) 
03800		     (RETURN NIL))) 
03900	 
04000	(DFUNC (COMPFILE INFILE OUTFILE) 
04100	       (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE FOUNDFREE STARTTIME)  
04200		     (CARRET) 
04300		     (SETQ STARTTIME (TIME)) 
04400		     (SETQ CODESIZE (SETQ CONSTSIZE 0)) 
04500		     (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE) 
04600		     (TELLTALE (CADR INFILE)) 
04700		     (LINEF)))
04800	 
     
00100	(DFUNC (COMPFUNC FUNNAME FUNEXP FUNFLAG FUNTYPE) 
00200	       (PROG (LOCVARS SPECVARS P1EXP P1CNT P2CNT) 
00300		     (PUTPROP FUNNAME T FUNTYPE) 
00400		     (SETQ P1EXP (PASS1 FUNEXP)) 
00500		     (P1SPY P1EXP) 
00600		     (CARRET) 
00700		     (PASS2 P1EXP) 
00800		     (CARRET) 
00900		     (LINEF) 
01000		     (COND ((NOT (EQUAL P2CNT P1CNT)) (PRINTMSG (LIST P1CNT P2CNT)) 
01100						      (BARF COUNTSDISAGREE-COMPFUNC))) 
01200		     (PRINSTTY FUNNAME) 
01300		     (RETURN FUNNAME))) 
01400	 
01500	(DEFPROP COMPILE 
01600		 (LAMBDA (NAMES) 
01700			 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE DONE PROP NAME FLAG PLIST) 
01800			       (SETQ CODESIZE (SETQ CONSTSIZE 0)) 
01900			  LOOP (COND ((NULL NAMES) (RETURN (REVERSE DONE)))) 
02000			       (SETQ NAME (CAR NAMES)) 
02100			       (SETQ NAMES (CDR NAMES)) 
02200			       (SETQ PLIST (CDR NAME)) 
02300			  ILOOP(COND ((NULL PLIST) (GO LOOP))) 
02400			       (SETQ FLAG (CAR PLIST)) 
02500			       (SETQ PLIST (CDR PLIST)) 
02600			       (SETQ PROP (SEEKPROP FLAG (Q DEFACTION))) 
02700			       (COND ((NULL PROP) (GO ELOOP))) 
02800			       (SETQ DONE (CONS (CONS NAME FLAG) DONE)) 
02900			       (CARRET) 
03000			       ((PROPVAL PROP) (LIST (Q DEFPROP) NAME (CAR PLIST) FLAG)) 
03100			       (LINEF) 
03200			  ELOOP(SETQ PLIST (CDR PLIST)) 
03300			       (GO ILOOP))) 
03400		 FEXPR) 
03500	 
     
00100	(DEFPROP COMPL 
00200	 (LAMBDA (FILES) 
00300	  (PROG NIL 
00400		(SETQ MSGDEV (COND (LISTING (EVAL (CONS (Q OUTPUT) (CONS (Q LST) LISTING)))))) 
00500	   LOOP (COND ((NULL FILES) 
00600		       (OUTC MSGDEV NIL) 
00700		       (SETQ MSGDEV NIL) 
00800		       (OUTC NIL T) 
00900		       (RETURN NIL))) 
01000		(COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON) 
01100			   (AND (NOT (ATOM (CAR FILES))) (NOT (ATOM (CDAR FILES))))) 
01200		       (SETQ INDEV (CAR FILES)) 
01300		       (GO ELOOP))) 
01400		(COMPFILE (LIST INDEV (CAR FILES)) 
01500			  (LIST OUTDEV 
01600				(CONS (COND ((ATOM (CAR FILES)) (CAR FILES)) 
01700					    (T (CAAR FILES))) 
01800				      (Q LAP)))) 
01900	   ELOOP(DOCDR FILES) 
02000		(GO LOOP))) 
02100	 FEXPR) 
02200	 
02300	(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR))) 
02400	
02500	(DFUNC (CT) (COMPILE TRY)) 
02600	(DFUNC (DEFEXPR DEFIN) 
02700	       (PROG (NAME EXP) 
02800		     (SETQ NAME (CADR DEFIN)) 
02900		     (SETQ EXP (CADDR DEFIN)) 
03000		     (COND ((ATOM EXP) (FLUSHDEF DEFIN)) 
03100			   ((NOT (EQ (CAR EXP) (Q LAMBDA))) (DATAERR NONLAMBDA-DEFEXPR)) 
03200			   ((AND (CADR EXP) (ATOM (CADR EXP))) 
03300			    (COMPFUNC NAME EXP (Q LSUBR) (Q *LSUBR))) 
03400			   (T (COMPFUNC NAME EXP (Q SUBR) (Q *SUBR)))))) 
03500	 
03600	(DFUNC (DEFFEXPR DEF) (COMPFUNC (CADR DEF) (CADDR DEF) (Q FSUBR) (Q *FSUBR))) 
03700	 
     
00100	(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR))) 
00200	 
00300	(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR))) 
00400	 
00500	(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR)) 
00600	 
00700	(DFUNC (DODE XPR) (DEFEXPR (LIST (Q DEFPROP) 
00800					 (CADR XPR) 
00900					 (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR))))) 
01000	 
01100	(DFUNC (DODF XPR) (DEFFEXPR (LIST (Q DEFPROP) 
01200					  (CADR XPR) 
01300					  (LIST (Q LAMBDA) (CADDR XPR) (CADDDR XPR))))) 
01400	 
01500	(DFUNC (DOFILE DOREADS INFILE OUTFILE) 
01600	       (PROG (LINCNT)
01700		     (SETQ LINCNT 0) 
01800		     (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE)) 
01900		     (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE)) 
02000		     (INC (QUOTE INCHAN) NIL) 
02100		     (OUTC (QUOTE OUTCHAN) NIL) 
02200		     (DOREADS) 
02300		     (OUTC NIL T) 
02400		     (INC NIL T))) 
02500	 
02600	(DFUNC (FLUSHEXPR EXPR) (PROG NIL (CARRET) (PRINTEXPR EXPR) (CARRET) (LINEF))) 
02700	 
02800	(DFUNC (FLUSHLAP LC) (PRINTLAP (READLAP LC))) 
02900	 
03000	(DFUNC (MSGSINK) MSGDEV) 
03100	 
03200	(DFUNC (PRINSTTY MESSAGE) (PROG (CHAN LINCNT) 
03300				       (SETQ CHAN (OUTC (MSGSINK) NIL)) 
03400				       (SETQ LINCNT 0) 
03500				       (PRINS MESSAGE) 
03600				       (OUTC CHAN NIL)))  
03700	
03800	(DFUNC (PRINTMSG MESSAGE) 
03900	       (PROG (CHAN LINCNT) 
04000		     (SETQ CHAN (OUTC (MSGSINK) NIL)) 
04100		     (SETQ LINCNT 0) 
04200		     (PRINT MESSAGE) 
04300		     (LINEF) 
04400		     (OUTC CHAN NIL))) 
04500	 
     
00100	(DFUNC (READLOOP ACTFUNC) (PROG (EXPR) 
00200				   LOOP	(SETQ EXPR (ERRSET (READ))) 
00300					(COND ((EQ EXPR (Q $EOF$)) (RETURN NIL))) 
00400					(ACTFUNC (CAR EXPR)) 
00500					(GO LOOP))) 
00600	 
00700	(DEFPROP SPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X)) FEXPR) 
00800	 
00900	(DFUNC (TELLTALE FILENAME) 
01000	       (PROG (CHAN) 
01100		     (SETQ CHAN (OUTC (MSGSINK) NIL)) 
01200		     (LINEF) 
01300		     (LINEF) 
01400		     (PRINL (LIST FILENAME (Q COMPILED))) 
01500		     (PRINL (LIST CODESIZE (Q WORDS))) 
01600		     (PRINL (LIST CONSTSIZE (Q CONSTANTS))) 
01700		     (PRINL (LIST (QUOTIENT (DIFFERENCE (TIME) STARTTIME) 1000.) 
01800				  (Q SECONDS))) 
01900		     (LINEF) 
02000		     (LINEF) 
02100		     (PRINL (Q (UNDEFINED FUNCTIONS))) 
02200		     (LINEF) 
02300		     (MAPC (FUNCTION (LAMBDA (X) 
02400		      (COND ((NOT (GETL X  
02500		       (Q (*SUBR *FSUBR *LSUBR EXPR FEXPR SUBR FSUBR LSUBR)))) 
02600		             (PRINS X))))) 
02700				 UNDFUNS) 
02800		     (LINEF) 
02900		     (LINEF) 
03000		     (PRINL (Q (GENERATED FUNCTIONS))) 
03100		     (LINEF) 
03200		     (PRINL GENFUNS) 
03300		     (LINEF) 
03400		     (LINEF) 
03500		     (OUTC CHAN NIL))) 
03600	 
03700	(DEFPROP UNSPECIAL (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X)) FEXPR) 
03800	 
     
00100	(MAPDEF COMPEFFECT 
00200		((COMPACTION DOACT) (MACRO ACTONMACRO))) 
00300	 
00400	(MAPDEF COMPACTION 
00500		((COND EVAL) 
00600				     (DE DODE) 
00700				     (DF DODF) 
00800				     (DM EVAL) 
00900				     (DEFPROP COMPDEF) 
01000				     (LAP FLUSHLAP) 
01100				     (SPECIAL EVAL) 
01200				     (UNSPECIAL EVAL))) 
01300	 
01400	(MAPDEF DEFACTION 
01500		((EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO EVAL) (SPECIAL EVAL) (*EXPR DO*EXPR) (*FEXPR DO*FEXPR))) 
01600	(SETQ LISTING NIL) 
01700	 
01800	(SETQ MSGDEV NIL) 
01900	 
02000	(SETQ OUTDEV (SETQ INDEV (READLIST (APPEND (EXPLODE (QUOTE DSK)) (LIST (ASCII 72)))))) 
02100	 
02200	(ENDBLOCK TOPLEVEL) 
02300	 
     
00100	(BEGINBLOCK PASS1) 
00200	 
00300	(DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR)) 
00400	 
00500	(DFUNC (GENFUN FUNXPR) 
00600	       (PROG (NAME LAMLIS CALL) 
00700		     (COND ((ATOM FUNXPR) (RETURN FUNXPR))) 
00800		     (COND ((NOT (EQ (CAR FUNXPR) (Q LAMBDA))) 
00900			    (DATAERR NOTLAMBDA-GENFUN))) 
01000		     (SETQ LAMLIS (CADR FUNXPR)) 
01100		     (SETQ CALL (CADDR FUNXPR)) 
01200		     (COND ((AND (ATOM (CAR CALL)) (EQUAL LAMLIS (CDR CALL))) 
01300			    (RETURN (CAR CALL)))) 
01400		     (SETQ NAME (GENFUNNAME)) 
01500		     (SETQ GENFUNS (CONS NAME GENFUNS)) 
01600		     (RETURN (COMPFUNC NAME FUNXPR (Q SUBR) (Q *SUBR))))) 
01700	 
01800	(DFUNC (ITERCONS ARGS) 
01900	       (COND ((NULL ARGS) NIL) 
02000		     ((NULL (CDR ARGS)) (CONS (Q NCONS) ARGS)) 
02100		     (T (LIST (Q CONS) (CAR ARGS) (ITERCONS (CDR ARGS)))))) 
02200	 
02300	(DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS)) 
02400	 
02500	(DFUNC (NEWNAME OLD) (PROG (NEW) 
02600				   (SETQ NEW (ASSOC OLD RENAMELIST)) 
02700				   (COND (NEW (RETURN (CDR NEW)))) 
02800				   (RETURN NIL))) 
02900	 
     
00100	(DFUNC (P1 XPR) 
00200	       (PROG (TEMP) 
00300		     (COND ((ATOM XPR) (GO ATOM))) 
00400		     (COND ((ATOM (CAR XPR)) (GO ATOMCAR))) 
00500		     (COND ((EQ (CAAR XPR) (QUOTE LAMBDA)) (RETURN (P1LAM XPR)))) 
00600		     (COND ((EQ (CAAR XPR) (QUOTE LABEL)) (RETURN (P1LABEL XPR)))) 
00700		     (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR)))) 
00800		ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (QUOTE QUOTE) XPR)))) 
00900		     (COND ((SETQ TEMP (NEWNAME XPR)) (RETURN (P1 (CAR TEMP))))) 
01000		     (INCR P1CNT) 
01100		     (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS)) 
01200					   (RETURN XPR))) 
01300		     (COND ((VARB XPR) (RETURN XPR))) 
01400		     (PUTLOC XPR P1CNT) 
01500		     (RETURN XPR) 
01600		ATOMCAR 
01700		     (COND ((CONSTANTP (CAR XPR)) (DATAERR CONSTFUN-P1))) 
01800		     (COND ((SETQ TEMP (NEWNAME (CAR XPR))) 
01900			    (RETURN (P1 (CONS (CAR TEMP) (CDR XPR)))))) 
02000		     (COND ((SETQ TEMP (GETGET (CAR XPR) (Q PASS1))) 
02100			    (SETQ P1FUN TEMP) 
02200			    (RETURN ((CAR TEMP) XPR)))) 
02300		     (COND ((OR (SPECIALP (CAR XPR)) (MEMBER (CAR XPR) ALLVARS)) 
02400			    (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR)))))) 
02500		     (RETURN (P1ELSE XPR)))) 
02600	 
02700	(DFUNC (P1ANDOR XPR) (PROG (TEM CT ARGS) 
02800				   (SETQ TEM LOCVARS) 
02900				   (SETQ CT P1CNT) 
03000				   (SETQ ARGS (MAPP1 (CDR XPR))) 
03100				   (INCR P1CNT) 
03200				   (P1BUG CT P1CNT TEM) 
03300				   (INCR P1CNT) 
03400				   (RETURN (CONS (CAR XPR) ARGS)))) 
03500	 
03600	(DFUNC (P1BIND Z) 
03700	 (PROG (J NEWZ) 
03800	       (COND ((AND Z (ATOM Z)) (DATAERR ATOMICLAMBDALIST-P1BIND))) 
03900	  LOOP (COND ((NULL Z) (RETURN (REVERSE NEWZ)))) 
04000	       (SETQ J (CAR Z)) 
04100	       (COND ((NOT (VARIABLEP J)) (DATAERR NOTVARIABLE-P1BIND))) 
04200	       (COND ((SPECIALP J) (SETQ SPECVARS (ADDTOLIST J SPECVARS)) 
04300				   (GO ELOOP)) 
04400		     ((MEMBER J ALLVARS) (RENAME J (SETQ J (GENSYM))))) 
04500	       (PUTLOC J 0) 
04600	  ELOOP(SETQ ALLVARS (ADDTOLIST J ALLVARS)) 
04700	       (SETQ NEWZ (CONS J NEWZ)) 
04800	       (SETQ Z (CDR Z)) 
04900	       (GO LOOP))) 
05000	 
     
00100	(DFUNC (P1BUG LOW HIGH PTR) 
00200	       (PROG (X) 
00300		LOOP (COND ((NULL PTR) (RETURN NIL))) 
00400		     (SETQ X (CAR PTR)) 
00500		     (COND ((GREATERP (CDR X) LOW) (REPLACECDR X HIGH))) 
00600		     (SETQ PTR (CDR PTR)) 
00700		     (GO LOOP))) 
00800	 
00900	(DFUNC (P1COND XPR) (PROG (TEM CT PAIRS P1SCV) 
01000				  (SETQ TEM LOCVARS) 
01100				  (SETQ CT P1CNT) 
01200				  (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR))) 
01300				  (INCR P1CNT) 
01400				  (P1BUG CT P1CNT TEM) 
01500				  (INCR P1CNT) 
01600				  (RETURN (MCONS (CAR XPR) P1SCV PAIRS)))) 
01700	 
01800	(DFUNC (P1CONS XPR) 
01900	       (PROG NIL 
02000		     (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (BARF ARGNOERR-P1CONS))) 
02100		     (COND ((NULL (CADDR XPR)) 
02200			    (RETURN (LIST (Q NCONS) (P1 (CADR XPR)))))) 
02300		     (RETURN (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR)))))) 
02400	 
     
00100	(DFUNC (P1ELSE XPR) (PROG NIL 
00200				  (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS)) 
00300				  (PUTPROP (CAR XPR) T (QUOTE *UNDEF)) 
00400				  (RETURN (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))))) 
00500	 
00600	(DFUNC (P1ERRSET XPR) 
00700	       (PROG NIL 
00800		     (COND ((ATOM (CADR XPR)) (RETURN XPR))) 
00900		     (RETURN (CONS (CAR XPR) (CONS (LIST (GENFUN (LIST (Q LAMBDA) 
01000								       NIL 
01100								       (CADR XPR)))) 
01200						   (CDDR XPR)))))) 
01300	 
01400	(DFUNC (P1EVAL XPR) 
01500	       (PROG (CDRXPR) 
01600		     (SETQ CDRXPR (P1SUBRARGS (CDR XPR))) 
01700		     (COND ((NOT (NULL (CDR CDRXPR))) (RETURN (CONS (Q EVAL) CDRXPR)))) 
01800		     (RETURN (CONS (Q *EVAL) CDRXPR)))) 
01900	 
02000	(DFUNC (P1FSUBR XPR) XPR) 
02100	 
02200	(DFUNC (P1FUNCTION XPR) 
02300	       (PROG (WHICH) 
02400		     (SETQ WHICH (ASSOC (CAR XPR) 
02500					(Q ((FUNCTION QUOTE) (*FUNCTION *FUNCTION))))) 
02600		     (RETURN (LIST (CADR WHICH) (GENFUN (CADR XPR)))))) 
02700	 
02800	(DFUNC (P1FUNVAR XPR) 
02900	       (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))) 
03000	
     
00100	(DFUNC (P1GO XPR) (PROG NIL 
00200				(COND ((NOT INPROG) (DATAERR GONOTINPROG-P1GO))) 
00300				(COND ((ATOM (CADR XPR)) (RETURN XPR))) 
00400				(RETURN (LIST (CAR XPR) (P1 (CADR XPR)))))) 
00500	 
00600	(DFUNC (P1LABEL XPR) 
00700	       (PROG (FN) 
00800		     (PUTPROP (CADAR XPR) T (Q FUNVAR)) 
00900		     (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR)))) 
01000		     (REMPROP (CADAR XPR) (Q FUNVAR))
01100		     (RETURN (P1 (LIST (Q PROG) 
01200				       (LIST (CADAR XPR)) 
01300				       (LIST (Q SETQ) (CADAR XPR) FN) 
01400				       (LIST (QUOTE RETURN) 
01500					     (CONS (CADAR XPR) (CDR XPR)))))))) 
01600	
01700	(DFUNC (P1LAM XPR) (PROG (ARGS LAML BODY SAVERENAMELIST) 
01800			       (SETQ SAVERENAMELIST RENAMELIST) 
01900			       (SETQ ARGS (P1SUBRARGS (CDR XPR))) 
02000			       (SETQ LAML (P1BIND (CADAR XPR))) 
02100			       (SETQ BODY (P1 (CADDAR XPR))) 
02200			       (SETQ P1CNT (ADD1 P1CNT)) 
02300			       (SETQ RENAMELIST SAVERENAMELIST) 
02400			       (RETURN (CONS (LIST (Q LAMBDA) LAML BODY) ARGS)))) 
02500	 
02600	(DFUNC (P1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR)))) 
02700	 
02800	(DFUNC (P1*MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q *MACRO)) XPR))) 
02900	 
03000	(DFUNC (P1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR))) 
03100	 
     
00100	(DFUNC (P1PROG X) 
00200	       (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG SAVERENAMELIST) 
00300		     (COND ((NULL (CDR X)) (DATAERR PROGTOOSHORT-P1PROG))) 
00400		     (SETQ INPROG T) 
00500		     (SETQ X (CDR X)) 
00600		     (SETQ SAVERENAMELIST RENAMELIST) 
00700		     (SETQ P1LL (P1BIND (CAR X))) 
00800		     (SETQ TEM LOCVARS) 
00900		     (SETQ P1SCNT (INCR P1CNT)) 
01000		LOOP1(SETQ X (CDR X)) 
01100		     (COND ((NULL X) (GO END1))) 
01200		     (INCR P1CNT) 
01300		     (COND ((ATOM (CAR X)) 
01400			    (COND ((ASSOC (CAR X) TAGLIST) (DATAERR MDT-P1PROG))) 
01500			    (SETQ TAGLIST (CONS (CONS (CAR X) (GENTAG)) TAGLIST)) 
01600			    (SETQ PR (CONS (CAR X) PR))) 
01700			   (T (SETQ PR (CONS (P1 (CAR X)) PR)))) 
01800		     (GO LOOP1) 
01900		END1 (INCR P1CNT) 
02000		     (P1BUG P1SCNT P1CNT TEM) 
02100		     (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE))) 
02200		LOOP (COND ((NULL (CDR TEM)) (GO END))) 
02300		     (COND ((NOT (AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))) 
02400			    (GO ELOOP))) 
02500		     (SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS)) 
02600		     (PRINTMSG (LIST (CAADR TEM) (QUOTE UNUSEDPROGVAR))) 
02700		     (MAKESPECIAL (CAADR TEM)) 
02800		     (REPLACECDR TEM (CDDR TEM)) 
02900		     (GO LOOP) 
03000		ELOOP(SETQ TEM (CDR TEM)) 
03100		     (GO LOOP) 
03200		END  (INCR P1CNT) 
03300		     (SETQ RENAMELIST SAVERENAMELIST) 
03400		     (RETURN (MCONS (QUOTE PROG) TAGLIST P1LL (REVERSE PR))))) 
03500	 
03600	(DFUNC (P1RETURN XPR) 
03700	       (PROG NIL 
03800		     (COND ((NOT INPROG) (DATAERR RETURNNOTINPROG-P1RETURN))) 
03900		     (COND ((NULL (CDR XPR)) (DATAERR NOARG-P1RETURN))) 
04000		     (RETURN (LIST (Q RETURN) (P1 (CADR XPR)))))) 
04100	 
     
00100	(DFUNC (P1SETQ XPR) 
00200	       (PROG (VAR TEM VAL) 
00300		     (COND ((NOT (VARIABLEP (CAR XPR))) (DATAERR NONVARIABLE-P1SETQ))) 
00400		     (SETQ VAR (COND ((SETQ TEM (NEWNAME (CADR XPR))) (CAR TEM)) 
00500				     (T (CADR XPR)))) 
00600		     (VARB VAR) 
00700		     (SETQ P1SCV (CONS VAR P1SCV)) 
00800		     (SETQ VAL (P1 (CADDR XPR))) 
00900		     (SETQ P1CNT (PLUS 2 P1CNT)) 
01000		     (RETURN (LIST (Q SETQ) VAR VAL)))) 
01100	 
01200	(DFUNC (P1STORE XPR) 
01300	       (PROG (ARG1 ARG2) 
01400		     (SETQ ARG2 (P1 (CADDR XPR))) 
01500		     (SETQ ARG1 (P1 (CADR XPR))) 
01600		     (RETURN (LIST (CAR XPR) ARG1 ARG2)))) 
01700	 
01800	(DFUNC (P1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))) 
01900	 
02000	(DFUNC (P1SUBRARGS ARGLST) (PROG NIL 
02100					 (COND ((GREATERP (LENGTH ARGLST) NACS) 
02200						(DATAERR TOOMANYARGS-P1SUBRARGS))) 
02300					 (RETURN (MAPP1 ARGLST)))) 
02400	 
     
00100	(DFUNC (PASS1 EXP) 
00200	       (PROG (ALLVARS LL RENAMELIST P1SCNT P1SCV INPROG FOUNDFREE) 
00300		     (SETQ INPROG NIL) 
00400		     (SETQ P1CNT 1) 
00500		     (SETQ LOCVARS (SETQ SPECVARS NIL)) 
00600		     (COND ((EQ FUNTYPE (Q *LSUBR)) 
00700			    (SETQ EXP (CONS (CAR EXP) 
00800					    (CONS (LIST (CADR EXP)) (CDDR EXP)))))) 
00900		     (SETQ LL (P1BIND (CADR EXP))) 
01000		     (COND ((GREATERP (LENGTH LL) NACS) (BARF TOOMANYARGS-PASS1))) 
01100		     (SETQ EXP (LIST (CAR EXP) LL (P1 (CADDR EXP)))) 
01200		     (COND ((NOT (NULL FOUNDFREE)) 
01300			    (PRINTMSG (CONS (Q SPECIAL) (REVERSE FOUNDFREE))))) 
01400		     (RETURN EXP))) 
01500	 
01600	(DFUNC (PUTLOC IVAR NUMBER) 
01700	       (PROG (TEM) 
01800		     (SETQ TEM (ASSOC IVAR LOCVARS)) 
01900		     (COND (TEM (RETURN (REPLACECDR TEM NUMBER)))) 
02000		     (RETURN (SETQ LOCVARS (CONS (CONS IVAR NUMBER) LOCVARS))))) 
02100	 
02200	(DFUNC (RENAME OLD NEW) (SETQ RENAMELIST (CONS (LIST OLD NEW) RENAMELIST))) 
02300	 
02400	(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL))) 
02500	 
02600	(DFUNC (VARB X) 
02700	       (PROG NIL 
02800		     (COND ((MEMBER X ALLVARS) (RETURN NIL)) ((SPECIALP X) (GO SPEC))) 
02900		     (SETQ FOUNDFREE (CONS X FOUNDFREE)) 
03000		     (MAKESPECIAL X) 
03100		SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS)) 
03200		     (SETQ ALLVARS (ADDTOLIST X ALLVARS)) 
03300		     (RETURN T))) 
03400	 
03500	(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX)))) 
03600	 
     
00100	(MAPDEF PASS1 
00200		((EXPR P1SUBR) (SUBR P1SUBR) 
00300			       (*SUBR P1SUBR) 
00400			       (*UNDEF P1SUBR) 
00500			       (LSUBR P1LSUBR) 
00600			       (*LSUBR P1LSUBR) 
00700			       (FEXPR P1FSUBR) 
00800			       (FSUBR P1FSUBR) 
00900			       (*FSUBR P1FSUBR) 
01000			       (FUNVAR P1FUNVAR) 
01100			       (P1 DOP1) 
01200			       (MACRO P1MACRO) 
01300			       (*MACRO P1*MACRO))) 
01400	 
01500	(MAPDEF P1 
01600		((COND P1COND) (GO P1GO) 
01700			       (PROG P1PROG) 
01800			       (EVAL P1EVAL) 
01900			       (ERRSET P1ERRSET) 
02000			       (SETQ P1SETQ) 
02100			       (STORE P1STORE) 
02200			       (AND P1ANDOR) 
02300			       (CONS P1CONS) 
02400			       (OR P1ANDOR) 
02500			       (*FUNCTION P1FUNCTION) 
02600			       (FUNCTION P1FUNCTION) 
02700			       (RETURN P1RETURN))) 
02800	 
02900	(BEGINBLOCK *MACRO) 
03000	 
03100	(DEFPROP APPEND  
03200		 (LAMBDA (L) 
03300			 (COND ((NULL (CDR L)) NIL) 
03400			       ((NULL (CDDR L)) (CADR L)) 
03500			       (T (LIST (QUOTE *APPEND) (CADR L) (CONS (CAR L) (CDDR L)))))) 
03600		 *MACRO) 
03700	 
03800	(DEFPROP LIST (LAMBDA (L) (ITERCONS (CDR L))) *MACRO) 
03900	 
04000	(DEFPROP NOT (LAMBDA (L) (CONS (QUOTE NULL) (CDR L))) *MACRO) 
04100	 
04200	(ENDBLOCK *MACRO)  
04300	 
04400	(ENDBLOCK PASS1) 
04500	 
     
00100	(BEGINBLOCK PASS2) 
00200	
00300	(DFUNC (ACEFFECTS FN) 
00400	       (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) 
00500		     (T ALLACS))) 
00600	 
00700	(DFUNC (ACNUMP X) (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS)))) 
00800	 
00900	(DFUNC (BINDVARS VARS LAMBDAP) 
01000	       (PROG (VAR ACNUM SPFLG1) 
01100		     (SETQ ACNUM 1) 
01200		A    (COND ((NULL VARS) (RETURN SPFLG1))) 
01300		     (SETQ VAR (CAR VARS)) 
01400		     (COND ((SPECVARP VAR) (GO SP1)) 
01500			   ((ASSOC VAR LOCVARS) (GO LV1)) 
01600			   (T (BARF FUNNYVAR-BINDVARS) (GO SP2))) 
01700		LV1  (COND (LAMBDAP (SETSLOT ACNUM (LIST VAR)))) 
01800		SP2  (SETQ ACNUM (ADD1 ACNUM)) 
01900		     (SETQ VARS (CDR VARS)) 
02000		     (GO A) 
02100		SP1  (COND ((NOT PRGSPFLG) (GO B))) 
02200		SP3  (OUTINST (LIST 0 
02300				    (COND (LAMBDAP ACNUM) (T 0)) 
02400				    (LIST (QUOTE SPECIAL) VAR))) 
02500		     (GO LV1) 
02600		B    (SETQ PRGSPFLG (SETQ SPFLG1 T)) 
02700		     (OUTINST (QUOTE (JSP 6 SPECBIND))) 
02800		     (GO SP3))) 
02900	 
     
00100	(DFUNC (BOOLAND EXP VALAC TAG FLAG) (PROG NIL 
00200						  (BOOL2 (CDR EXP) VALAC TAG T FLAG) 
00300						  (SETQ P2CNT (PLUS 2 P2CNT)))) 
00400	 
00500	(DFUNC (BOOLEQ EXP VALAC TAG FLAG) 
00600	       (PROG NIL 
00700		     (BOOLEQ1 (CDR EXP) VALAC TAG FLAG) 
00800		     (OUTJRST TAG) 
00900		     (RSLSET TAG) 
01000		     (RETURN NIL))) 
01100	 
01200	(DFUNC (BOOLEQ1 EXP VALAC TAG F) 
01300	       (PROG (ARG1 ARG2 ARG1LOC ARG2LOC AC MEM) 
01400		     (SETQ ARG1 (COMP (CAR EXP) (FREEAC))) 
01500		     (SETQ ARG2 (COMP (CADR EXP) (FREEAC))) 
01600		     (SETQ ARG2LOC (ILOC1 ARG2 (FREEAC))) 
01700		     (SETQ ARG1LOC (ILOC1 ARG1 (FREEAC))) 
01800		     (COND ((ACNUMP ARG1LOC) (SETQ AC ARG1LOC) 
01900				       (REMOVE ARG1) 
02000				       (COND ((ACNUMP ARG2LOC) (REMOVE ARG2))) 
02100				       (RST TAG) 
02200				       (SETQ MEM (LOC ARG2)) 
02300				       (GO A)) 
02400			   ((ACNUMP ARG2LOC) (REMOVE ARG2) (SETQ AC ARG2LOC) (RST TAG) (SETQ MEM (LOC ARG1)) (GO A))) 
02500		     (LOADARG (SETQ AC (FREEAC)) ARG1) 
02600		     (RST TAG) 
02700		     (SETQ MEM (LOC ARG2)) 
02800		     (GO B) 
02900		A    (REMOVE ARG1) 
03000		B    (REMOVE ARG2) 
03100		     (SAVEACS) 
03200		     (OUT1 (COND (F (QUOTE CAMN)) (T (QUOTE CAME))) AC MEM))) 
03300	 
03400	(DFUNC (BOOLEXPR EXP VALAC TAG FLAG MINDEPTH) 
03500	       (PROG (TEM) 
03600		     (COND ((ATOM EXP) (GO ELSE))) 
03700		     (COND ((SETQ TEM (SEEKPROP (CAR EXP) (Q BOOL))) 
03800			    (SETQ BOOLFUN (PROPVAL TEM)) 
03900			    (RETURN ((PROPVAL TEM) EXP VALAC TAG FLAG)))) 
04000		ELSE (SETQ EXP (PUTINAC (COMP EXP VALAC) (COND (VALAC) ((FREEAC))))) 
04100		     (OUTCJMP FLAG EXP TAG) 
04200		     (COND (FLAG (RSLSET TAG) (SETSLOT EXP (QUOTE (QUOTE NIL)))) 
04300			   (T (SETQ FLAG (SLOTCONT EXP)) 
04400			      (SETSLOT EXP (QUOTE (QUOTE NIL))) 
04500			      (RSLSET TAG) 
04600			      (SETSLOT EXP FLAG))))) 
04700	 
     
00100	(DFUNC (BOOL2 EXP VALAC TAG F1 F2) 
00200	       (PROG (G) 
00300		     (CLEAR1) 
00400		     (PUTPROP (SETQ G (GENTAG)) (TOPCOPY REGPDL) (QUOTE LEVEL)) 
00500		A    (COND ((NULL EXP) (COND (F2 (OUTJRST TAG))) (GO C))) 
00600		     (COND ((AND F2 (NULL (CDR EXP))) (GO B))) 
00700		     (BOOLEXPR (CAR EXP) VALAC (COND (F2 G) (T TAG)) (NOT F1) MINDEPTH) 
00800		     (SETQ EXP (CDR EXP)) 
00900		     (GO A) 
01000		B    (BOOLEXPR (CAR EXP) VALAC TAG F1 MINDEPTH) 
01100		     (OUTENDTAG G) 
01200		C    (CLEAR2BOTH) 
01300		     (CLRARGACS))) 
01400	 
01500	(DFUNC (BOOLNULL EXP VALAC TAG FLAG) 
01600	       (BOOLEXPR (CADR EXP) VALAC TAG (NOT FLAG) MINDEPTH)) 
01700	 
01800	(DFUNC (BOOLOR EXP VALAC TAG FLAG) 
01900	       (PROG NIL 
02000		     (BOOL2 (CDR EXP) VALAC TAG NIL (NOT FLAG)) 
02100		     (SETQ P2CNT (PLUS 2 P2CNT)))) 
02200	 
02300	(DFUNC (BOOLQUOTE EXP VALAC TAG FLAG) 
02400	       (BOOL2 NIL VALAC TAG NIL (IFIF FLAG (CADR EXP)))) 
02500	 
02600	(DFUNC (BOOLVALUE VALAC EFFECTS TAG) 
02700	       (PROG NIL 
02800		     (COND ((NOT EFFECTS) (OUT1 (QUOTE TDZA) VALAC VALAC))) 
02900		     (OUTENDTAG TAG) 
03000		     (COND ((NOT EFFECTS) 
03100			    (OUT1 (QUOTE MOVEI) VALAC (QUOTE (QUOTE T))))) 
03200		     (RETURN (COND (EFFECTS NIL) (T (VALLOC VALAC)))))) 
03300	 
     
00100	(DFUNC (CALLFSUBR XPR VALAC EFFECTS) 
00200	       (PROG (FUN ARGS VAL) 
00300		     (SETQ FUN (CAR XPR)) 
00400		     (SETQ ARGS (CDR XPR)) 
00500		     (CLEAR2BOTH) 
00600		     (LOADARG FARGAC (LIST (Q QUOTE) ARGS)) 
00700		     (PROTECTACS FUN) 
00800		     (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC))))
00900		     (OUTCALL 17 FUN) 
01000		     (RETURN VAL))) 
01100	 
01200	(DFUNC (CALLFUNARGS XPR VALAC EFFECTS) 
01300	       (PROG (FUN ARGS FUNARGS LOCS VAL) 
01400		     (SETQ FUN (CAR XPR)) 
01500		     (SETQ ARGS (CDR XPR)) 
01600		     (SETQ FUNARGS (COMP FUN VALAC)) 
01700		     (SETQ LOCS (COMPARGS ARGS)) 
01800		     (CLRCCLST LOCS) 
01900		     (LOADSUBRARGS LOCS) 
02000		     (CLEAR2BOTH) 
02100		     (CLRARGACS) 
02200		     (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC)))) 
02300		     (OUTCALLF (LENGTH LOCS) (LOC FUNARGS)) 
02400		     (REMOVE FUNARGS) 
02500		     (RETURN VAL))) 
     
00100	(DFUNC (CALLLSUBR XPR VALAC EFFECTS) 
00200	       (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL) 
00300		     (SETQ FUN (CAR XPR)) 
00400		     (SETQ ARGS (CDR XPR)) 
00500		     (CLEAR1) 
00600		     (SETQ NARGS (LENGTH ARGS)) 
00700		     (SLOTPUSH (Q (NIL . TAKEN))) 
00800		     (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (GENTAG)) 0 0)) 
00900		LOOP (COND ((NULL ARGS) (GO CALL))) 
01000		     (SETQ HOME (TOPCOPY REGPDL)) 
01100		     (SETQ INST (COMP (CAR ARGS) VALAC)) 
01200		     (RESTORE HOME) 
01300		     (SETQ TEM (LOC INST)) 
01400		     (SLOTPUSH (Q (NIL . TAKEN))) 
01500		     (OUTPUSH TEM) 
01600		     (REMOVE INST) 
01700		     (SETQ ARGS (CDR ARGS)) 
01800		     (GO LOOP) 
01900		CALL (SETQ TEM PDLDEPTH) 
02000		     (SAVEACS) 
02100		     (COND ((NOT (EQ PDLDEPTH TEM)) (BARF PDLTOOLONG-LSUBRCALL))) 
02200		     (OUTINST (LIST (Q MOVNI) 6 NARGS)) 
02300		LLOOP(SLOTPOP) 
02400		     (COND ((ZEROP NARGS) (GO CALL1))) 
02500		     (SETQ NARGS (SUB1 NARGS)) 
02600		     (GO LLOOP) 
02700		CALL1(CLEAR2BOTH) 
02800		     (CLRARGACS) 
02900		     (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC)))) 
03000		     (OUTJCALL 16 FUN) 
03100		     (OUTTAG RETTAG) 
03200		     (RETURN VAL))) 
03300	 
     
00100	(DFUNC (CALLSUBR XPR VALAC EFFECTS) 
00200	       (PROG (FUN ARGS NARGS LOCS TEMP VAL) 
00300		     (SETQ FUN (CAR XPR)) 
00400		     (SETQ ARGS (CDR XPR)) 
00500		     (SETQ LOCS (COMPARGS ARGS)) 
00600		     (SETQ NARGS (LENGTH LOCS)) 
00700		     (COND ((AND (SETQ TEMP (SEEKPROP FUN (Q COMMU))) 
00800				 (EQ NARGS 2) 
00900				 (EQ (ILOC (CAR LOCS)) VALUEAC)) 
01000			    (SETQ LOCS (REVERSE LOCS)) 
01100			    (SETQ FUN (PROPVAL TEMP)))) 
01200		     (SETQ TEMP (SIDEEFFECTS FUN)) 
01300		     (COND (TEMP (CLRCCLST LOCS))) 
01400		     (LOADSUBRARGS LOCS) 
01500		     (COND (TEMP (CLEAR2BOTH))) 
01600		     (PROTECTACS FUN) 
01700		     (COND ((NOT (NULL VALAC)) (SETQ VAL (VALLOC VALUEAC)))) 
01800		     (OUTCALL NARGS FUN) 
01900		     (RETURN VAL))) 
02000	 
02100	(DFUNC (CLEAR1) 
02200	       (PROG NIL (CLEAR1BOTH) (SAVEACS) (RETURN (CLRPVARS)))) 
02300	 
02400	(DFUNC (CLEAR1BOTH) (PROG NIL (CLRCCLST1 VALUEAC) (CLRSPLD))) 
02500	
02600	(DFUNC (CLEAR2BOTH) (PROG NIL (CLRCCLST2 VALUEAC) (CLRSPLD))) 
02700	
02800	(DFUNC (CLEARAC ACNO) (PROG NIL (CPUSH ACNO) (SETSLOT ACNO NIL))) 
02900	 
03000	(DFUNC (CLEARITALL) (PROG NIL (CLEAR2BOTH) (CLRARGACS))) 
03100	
03200	(DFUNC (CLRARGACS) (PROG (ACNO) 
03300				   (SETQ ACNO NACS) 
03400			      LOOP (COND ((ZEROP ACNO) (RETURN NIL))) 
03500				   (CLEARAC ACNO) 
03600				   (SETQ ACNO (SUB1 ACNO)) 
03700				   (GO LOOP))) 
03800	 
03900	(DFUNC (CLRCCLST DATA) 
04000	       (PROG (CCL) 
04100		     (SETQ CCL CCLST) 
04200		LOOP (COND ((NULL CCL) (RETURN NIL))) 
04300		     (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP))) 
04400		     (CSFUN (CAR CCL) VALUEAC) 
04500		ELOOP(SETQ CCL (CDR CCL)) 
04600		     (GO LOOP))) 
04700	 
     
00100	(DFUNC (CLRCCLST1 AC) 
00200	       (PROG (CCL) 
00300		     (SETQ CCL CCLST) 
00400		LOOP (COND ((NULL CCL) (RETURN NIL))) 
00500		     (CSFUN (CAR CCL) AC) 
00600		     (SETQ CCL (CDR CCL)) 
00700		     (GO LOOP))) 
00800	 
00900	(DFUNC (CLRCCLST2 AC) 
01000	       (PROG NIL 
01100		LOOP (COND ((NULL CCLST) (RETURN NIL))) 
01200		     (CSFUN (CAR CCLST) AC) 
01300		     (SETQ CCLST (CDR CCLST)) 
01400		     (GO LOOP))) 
01500	
01600	(DFUNC (CLRPVARS) 
01700	       (PROG NIL 
01800		     (COND ((NOT PROGSW) (RETURN NIL))) 
01900		     (SETQ PROGSW NIL) 
02000		LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY REGPDL)) 
02100					    (SETQ MINDEPTH PDLDEPTH) 
02200					    (RETURN NIL)) 
02300			   ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT))) 
02400			    (INITZ (CAR PROGVARS)))) 
02500		     (SETQ PROGVARS (CDR PROGVARS)) 
02600		     (GO LOOP))) 
02700	 
02800	(DFUNC (CLRSPLD) 
02900		(PROG NIL 
03000		LOOP (COND ((NULL SPLDLST) (RETURN NIL))) 
03100		     (CLRSPVAR (CAR SPLDLST)) 
03200		     (SETQ SPLDLST (CDR SPLDLST)) 
03300		     (GO LOOP))) 
03400	
03500	(DFUNC (CLRSPVAR L) 
03600	       (PROG (LOC) 
03700		     (SETQ LOC (ILOC (CONS (CAR L) P2CNT))) 
03800		     (COND ((NOT (NUMBERP LOC)) 
03900			    (OUTSPECPUSH (CAR L))) 
04000			   ((ACNUMP LOC) 
04100			    (SLOTPUSH (SLOTCONT LOC)) 
04200			    (OUTPUSH LOC))) 
04300		     (RETURN NIL))) 
04400	 
04500	(DFUNC (COMP XPR VALAC) (COMPEXPR XPR VALAC NIL)) 
04600	 
     
00100	(DFUNC (COMPARGS ARGS) 
00200	       (PROG (ARGNO RESULT) 
00300		     (SETQ ARGNO 0) 
00400		LOOP (COND ((NULL ARGS) (RETURN RESULT))) 
00500		     (INCR ARGNO) 
00600		     (SETQ RESULT (CONS (COMP (CAR ARGS) ARGNO) RESULT)) 
00700		     (SETQ ARGS (CDR ARGS)) 
00800		     (GO LOOP))) 
00900	 
01000	(DFUNC (COMPE XPR VALAC) (REMOVE (COMPEXPR XPR VALAC T))) 
01100	 
01200	(DFUNC (COMPEXPR XPR VALAC EFFECTS) 
01300	       (PROG (TEMP)
01400		     (COND ((ATOM XPR) (GO ATOM))) 
01500		     (COND ((ATOM (CAR XPR)) (GO ATOMCAR))) 
01600		     (COND ((EQ (CAAR XPR) (QUOTE LAMBDA)) 
01700			    (RETURN (P2LAM XPR VALAC EFFECTS)))) 
01800		     (RETURN (CALLFUNARGS XPR VALAC EFFECTS)) 
01900		ATOM (SETQ TEMP (CONS XPR (INCR P2CNT))) 
02000		     (COND ((SPECVARP XPR) (SETQ SPLDLST (CONS TEMP SPLDLST)))) 
02100		     (SETQ LDLST (CONS TEMP LDLST)) 
02200		     (RETURN TEMP) 
02300		ATOMCAR 
02400		     (COND ((SETQ TEMP (GETGET (CAR XPR) (Q PASS2))) 
02500			    (SETQ P2FUN TEMP) 
02600			    (RETURN ((CAR TEMP) XPR VALAC EFFECTS))))   
02700		     (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS)) 
02800			    (RETURN (CALLFUNARGS XPR VALAC EFFECTS)))) 
02900		     (RETURN (P2ELSE XPR VALAC EFFECTS)))) 
03000	 
03100	(DFUNC (COPT X Y) (PROG (CCL TEM YLOC) 
03200				(SETQ YLOC (ILOC Y)) 
03300				(SETQ CCL CCLST) 
03400			   LOOP	(COND ((NULL CCL) (RETURN NIL)) 
03500				      ((AND (EQ X (CADAR CCL)) 
03600					    (EQUAL (ILOC (CDDAR CCL)) YLOC) 
03700					    (ILOC (SETQ TEM (LIST (CAAR CCL))))) 
03800				       (RETURN TEM))) 
03900				(SETQ CCL (CDR CCL)) 
04000				(GO LOOP))) 
     
00100	(DFUNC (CPUSH ACNO) 
00200	       (PROG (TEMPPDL SLOTNO SLOTCON HOLDSLOT) 
00300		     (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO)))) (RETURN NIL))) 
00400		     (COND ((LESSP ACNO 1) (GO MAKESLOT))) 
00500		START(SETQ SLOTNO 0) 
00600		     (SETQ TEMPPDL REGPDL) 
00700		LOOP (COND ((NULL TEMPPDL) (GO NOSLOT))) 
00800		     (COND ((DVP (CAR TEMPPDL)) (GO ELOOP))) 
00900		     (COND ((OR (NOT (NUMBERP (CDAR TEMPPDL))) 
01000				(SPECVARP (CAAR TEMPPDL))) 
01100			    (SETQ HOLDSLOT SLOTNO))) 
01200		     (COND ((EQ (CAR SLOTCON) (CAAR TEMPPDL)) (GO FOUNDSLOT))) 
01300		ELOOP(SETQ TEMPPDL (CDR TEMPPDL)) 
01400		     (SETQ SLOTNO (SUB1 SLOTNO)) 
01500		     (GO LOOP) 
01600		FOUNDSLOT 
01700		     (SETSLOT SLOTNO SLOTCON) 
01800		     (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP))) 
01900		     (OUTMOVEM ACNO SLOTNO) 
02000		     (RETURN NIL) 
02100		NOSLOT 
02200		     (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUNDSLOT))) 
02300		MAKESLOT 
02400		     (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS))) 
02500			    (SETQ TEMPPDL PDLDEPTH) 
02600			    (CLRPVARS) 
02700			    (COND ((LESSP ACNO 1) 
02800				   (SETQ ACNO 
02900					 (PLUS ACNO (DIFFERENCE TEMPPDL PDLDEPTH))))))) 
03000		     (SLOTPUSH SLOTCON) 
03100		     (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP))) 
03200		     (OUTPUSH ACNO) 
03300		     (RETURN NIL))) 
03400	 
03500	(DFUNC (CSFUN L AC) 
03600	       (PROG (Y) (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y))) 
03700				(LOADCARCDR L AC))))) 
03800	 
03900	(DFUNC (CSTEP FUN AC ARGLOC) 
04000	       (PROG (TEM) 
04100		     (COND ((NULL FUN) (RETURN (LIST ARGLOC)))) 
04200		     (COND ((SETQ TEM (COPT FUN ARGLOC)) (RETURN (LIST TEM)))) 
04300		     (RETURN (CONS (CAR (SETQ TEM 
04400					      (GETPROP FUN (Q CARCDRPROP)))) 
04500				   (CSTEP (CDR TEM) AC ARGLOC))))) 
04600	 
     
00100	(DFUNC (DOP2 XPR VALAC EFFECTS) ((GETPROP (CAR XPR) (Q P2)) XPR VALAC EFFECTS)) 
00200	 
00300	(DFUNC (DVP X) 
00400	       (PROG (Y Z) 
00500		     (COND ((NULL X) (RETURN NIL))) 
00600		     (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN NIL))) 
00700		     (COND ((EQ (CDR X) (QUOTE TAKEN)) (RETURN T))) 
00800		     (COND ((EQ (CDR X) (QUOTE DUP)) (RETURN NIL))) 
00900		     (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL))) 
01000		     (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS)) 
01100			    (NULL (CDR X)) 
01200			    (LESSP P2CNT (CDR Y))) 
01300			    (RETURN T))) 
01400		     (SETQ Z LDLST) 
01500		LOOP (COND ((NULL Z) (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST)) 
01600						    (DVP (CONS (CDR Z) (CDR X)))) 
01700						   (T NIL))))) 
01800		     (COND ((AND (EQ (CAAR Z) (CAR X)) 
01900				 (EQUAL (LOC (COND ((NUMBERP (CDR X)) X) 
02000						   (T (CONS (CAR X) P2CNT)))) 
02100					(LOC (CAR Z)))) 
02200			    (RETURN T))) 
02300		     (SETQ Z (CDR Z)) 
02400		     (GO LOOP))) 
02500	 
02600	(DFUNC (EQUIVTAG TG) (PROG (Z) 
02700				   (COND ((SETQ Z (ASSOC TG GOLIST)) (RETURN (CDR Z)))) 
02800				   (PRINTMSG (LIST (QUOTE UNDEFINED) (QUOTE TAG) TG)) 
02900				   (RETURN EXIT))) 
     
00100	(DFUNC (EXITBUM SPECFLAG) 
00200	       (PROG (TEM1 TEM2) 
00300		     (COND ((SETQ TEM1 (ASSOC (CAAR LASTOUT) 
00400					      (Q ((CALL JCALL) (PUSHJ JRST))))) 
00500			    (SETQ TEM2 (CAR LASTOUT)) 
00600			    (SETQ LASTOUT NIL) 
00700			    (KILLPDL) 
00800			    (OUTINST TEM2) 
00900			    (COND ((NOT SPECFLAG) 
01000				   (SETQ TEM2 (CAR LASTOUT)) 
01100				   (SETQ LASTOUT NIL) 
01200				   (OUTINST (MCONS (CADR TEM1) 
01300						   (SUBST 0 PDLAC (CADR TEM2)) 
01400						   (CDDR TEM2))) 
01500				   (RETURN NIL))))) 
01600		     (KILLPDL) 
01700		     (COND (SPECFLAG (OUTINST (QUOTE (JRST 0 SPECSTR)))) 
01800			   (T (OUTINST (QUOTE (POPJ P))))))) 
01900	 
02000	(DFUNC (FREEAC) (FREEAC1 NIL)) 
02100	 
02200	(DFUNC (FREEAC1 BESTAC) (PROG (ACNO ACS IT) 
02300				      (COND ((NULL BESTAC) (SETQ IT NACS)) 
02400					    ((NOT (DVP (SLOTCONT BESTAC))) (RETURN BESTAC)) 
02500					    (T (SETQ IT BESTAC))) 
02600				      (SETQ ACS ARGACS) 
02700				      (SETQ ACNO 0) 
02800				 LOOP (SETQ ACNO (ADD1 ACNO)) 
02900				      (COND ((NULL ACS) (CPUSH IT) (RETURN IT))) 
03000				      (COND ((NULL (CAR ACS)) (RETURN ACNO))) 
03100				      (COND ((NOT (DVP (CAR ACS))) (SETQ IT ACNO))) 
03200				      (SETQ ACS (CDR ACS)) 
03300				      (GO LOOP))) 
03400	 
     
00100	(DFUNC (FREEZE VAR) (PROG NIL (FREEZE1 VAR ARGACS) (FREEZE1 VAR REGPDL))) 
00200	 
00300	(DFUNC (FREEZE1 X Z) 
00400	       (PROG NIL 
00500		LP   (COND ((NULL Z) (RETURN NIL)) 
00600			   ((EQ X (CAAR Z)) 
00700			    (COND ((OR (NULL (CDAR Z)) (EQ (CDAR Z) (Q DUP))) 
00800				   (REPLACECAR Z (CONS X P2CNT)))))) 
00900		     (SETQ Z (CDR Z)) 
01000		     (GO LP))) 
01100	 
01200	(DFUNC (GENCONST OP AC AD IN IB) 
01300	       (PROG (ANS) 
01400		     (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT)))) 
01500		     (SETQ ANS (APPEND ANS (LIST AC AD IN))) 
01600		     (SETQ ANS (CONS OP ANS)) 
01700		     (RETURN (CONS (QUOTE C) ANS)))) 
01800	 
01900	(DFUNC (GETSLOT NO) 
02000	       (COND ((NOT (NUMBERP NO)) (BARF NOTSLOT-GETSLOT)) 
02100		     ((GREATERP NO NACS) (PRINTMSG NO) (BARF NOTAC-GETSLOT)) 
02200		     ((GREATERP NO 0) (NTHCDR (SUB1 NO) ARGACS)) 
02300		     ((GREATERP (ABS NO) PDLDEPTH) (PRINTMSG NO) 
02400						   (BARF NOTONPDL-GETSLOT)) 
02500		     ((NTHCDR (MINUS NO) REGPDL)))) 
02600	 
     
00100	(DFUNC (ILOC X) 
00200	       (PROG (CNTR BEST BESTNO Y SL SLOT) 
00300		     (SETQ SL (SLOTLIST)) 
00400		     (SETQ CNTR 1) 
00500		LOOP (COND ((NULL SL) (GO EXIT))) 
00600		     (SETQ SLOT (CAR SL)) 
00700		     (COND ((AND SLOT (EQ (CAR SLOT) (CAR X))) (GO ISONE))) 
00800		ELOOP(SETQ SL (CDR SL)) 
00900		     (SETQ CNTR (ADD1 CNTR)) 
01000		     (GO LOOP) 
01100		TAKEIFN 
01200		     (COND (BESTNO (GO ELOOP))) 
01300		     (SETQ BESTNO 105105) 
01400		     (GO TAKEL1) 
01500		TAKEL(SETQ BESTNO (CDR SLOT)) 
01600		TAKEL1 
01700		     (SETQ BEST CNTR) 
01800		     (GO ELOOP) 
01900		EXIT (COND (BESTNO (GO RETVAL))) 
02000		     (COND ((SPECVARP (CAR X)) 
02100			    (RETURN (LIST (QUOTE SPECIAL) (CAR X))))) 
02200		     (COND ((EQ (CAR X) (QUOTE QUOTE)) (RETURN (LIST X)))) 
02300		     (COND ((SETQ Y (ASSOCR (CAR X) VARLIST)) 
02400			    (RETURN (ILOC (CONS (CAR Y) (CDR X)))))) 
02500		     (RETURN NIL) 
02600		ISONE(COND ((EQ (CAR X) (QUOTE QUOTE)) (GO QT))) 
02700		     (COND ((NOT (NUMBERP (CDR SLOT))) (GO TAKEIFN))) 
02800		     (COND ((AND (NOT (LESSP (CDR SLOT) (CDR X))) 
02900				 (OR (NULL BESTNO) (GREATERP BESTNO (CDR SLOT)))) 
03000			    (GO TAKEL))) 
03100		     (GO ELOOP) 
03200		QT   (COND ((NOT (EQUAL X SLOT)) (GO ELOOP))) 
03300		TAKE (SETQ BEST CNTR) 
03400		RETVAL 
03500		     (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST) 
03600				   (T (PLUS (MINUS BEST) NACS 1)))))) 
03700	 
03800	(DFUNC (ILOC1 X AC) 
03900	       (PROG (Z) 
04000		     (COND ((SETQ Z (ILOC X)) (RETURN Z))) 
04100		     (COND ((MEMBER (CAR X) PROGVARS) (RETURN (QUOTE ((QUOTE NIL)))))) 
04200		     (COND ((SETQ Z (ASSOCR (CAR X) VARLIST)) 
04300			    (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC)))) 
04400		     (COND ((SETQ Z (ASSOC (CAR X) CCLST)) 
04500			    (RETURN (LOADCARCDR Z 
04600						(COND ((NULL AC) (FREEAC)) (T AC)))))) 
04700		     (PRINTMSG X) 
04800		     (BARF LOSTVAR-ILOC1))) 
04900	 
     
00100	(DFUNC (INITZ X) 
00200	       (PROG NIL (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL)))))) 
00300	 
00400	(DFUNC (KILLPDL) (RESTORE NIL)) 
00500	 
00600	(DFUNC (LAMBDABIND VARS) (BINDVARS VARS T)) 
00700	 
00800	(DFUNC (LISTNILS NUMBER) (PROG (LIST) 
00900				  LOOP (COND ((ZEROP NUMBER) (RETURN LIST))) 
01000				       (SETQ LIST (CONS NIL LIST)) 
01100				       (SETQ NUMBER (SUB1 NUMBER)) 
01200				       (GO LOOP))) 
01300	 
01400	(DFUNC (LOADARG ACNO VAR) 
01500	       (PROG (DATAORG OLDACC DATACONT DAC DOD) 
01600		     (REMOVE VAR) 
01700		     (SETQ DATAORG (ILOC1 VAR ACNO)) 
01800		     (SETQ OLDACC (SLOTCONT ACNO)) 
01900		     (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG)))) 
02000		     (SETQ DAC (DVP OLDACC)) 
02100		     (SETQ DOD (DVP DATACONT)) 
02200		     (COND ((EQ ACNO DATAORG) (COND (DAC (CPUSH ACNO))) (RETURN NIL))) 
02300		     (COND ((AND (EQ DATAORG 0) (NOT DOD) (NOT DAC) (GREATERP PDLDEPTH MINDEPTH)) (GO POP))) 
02400		     (COND ((AND (NOT DOD) OLDACC (NUMBERP DATAORG) (LESSP DATAORG ACNO)) 
02500			    (GO EXCH))) 
02600		     (COND ((NOT DAC) (GO FREE))) 
02700		     (GO PUSH) 
02800		EXCH (SETSLOT DATAORG OLDACC) 
02900		     (SETSLOT ACNO DATACONT) 
03000		     (OUT1 (QUOTE EXCH) ACNO DATAORG) 
03100		     (RETURN NIL) 
03200		PUSH (CPUSH ACNO) 
03300		     (SETQ DATAORG (LOC VAR)) 
03400		FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE))) 
03500		     (SETSLOT ACNO (COND ((NULL (CDR DATACONT)) 
03600					  (CONS (CAR DATACONT) (QUOTE DUP))) 
03700					 (T DATACONT))) 
03800		     (OUTMOVE ACNO DATAORG) 
03900		     (RETURN NIL) 
04000		POP  (SETSLOT ACNO DATACONT) 
04100		     (OUTPOP ACNO) 
04200		     (RETURN NIL) 
04300		MOVE (SETSLOT ACNO (COND ((EQ (CAAR DATAORG) (QUOTE QUOTE)) (CAR DATAORG)) 
04400						 (T (LIST (CAR VAR))))) 
04500		     (OUTMOVE ACNO DATAORG) 
04600		     (RETURN NIL)))) 
04700	 
     
00100	(DFUNC (LOADCARCDR ITEM AC) 
00200	       (PROG (ARG PATH ORIG) 
00300		     (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC) (REMOVE ARG))) 
00400		     (SETQ PATH (CSTEP (CADR ITEM) AC ARG)) 
00500		     (COND ((NULL (CDR PATH)) 
00600			    (SETQ VARLIST 
00700				  (CONS (CONS (CAR (CAR PATH)) (CAR ITEM)) 
00800					VARLIST)) 
00900			    (REMOVE ARG) 
01000			    (RETURN (LOC (CAR PATH))))) 
01100		     (SETQ PATH (REVERSE PATH)) 
01200		     (CPUSH AC) 
01300		     (SETQ ORIG (LOC (CAR PATH))) 
01400		     (SETQ PATH (CDR PATH)) 
01500		     (REMOVE ARG) 
01600		L1   (COND ((NULL PATH) (GO RET))) 
01700		     (COND ((NULL (CDR PATH)) (GO L2)))  
01800		     (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC)) 
01900			    (OUTCALL 1 (READLIST (CONS (QUOTE C) 
02000						       (REVERSE (CONS (Q R) 
02100								      PATH))))) 
02200			    (GO RET))) 
02300		L2   (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@))))) 
02400			   AC 
02500			   ORIG) 
02600		     (SETQ PATH (CDR PATH)) 
02700		     (SETQ ORIG AC) 
02800		     (GO L1) 
02900		RET  (SETSLOT AC (LIST (CAR ITEM))) 
03000		     (RETURN AC))) 
03100	 
03200	(DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMP XPR AC))) 
03300	 
03400	(DFUNC (LOADSUBRARGS ARGS) (PROG (ARGNO) 
03500				 (SETQ ARGNO (LENGTH ARGS)) 
03600			    LOOP (COND ((NULL ARGS) (RETURN NIL))) 
03700				 (LOADARG ARGNO (CAR ARGS)) 
03800				 (SETQ ARGS (CDR ARGS)) 
03900				 (SETQ ARGNO (SUB1 ARGNO)) 
04000				 (GO LOOP))) 
04100	 
04200	(DFUNC (LOC X) (ILOC1 X NIL)) 
04300	 
     
00100	(DFUNC (NONSPECVARS VRS) (PROG (ANS) 
00200				  LOOP (COND ((NULL VRS) (RETURN ANS)) 
00300					     ((SPECVARP (CAR VRS))) 
00400					     (T (SETQ ANS (CONS (CAR VRS) ANS)))) 
00500				       (SETQ VRS (CDR VRS)) 
00600				       (GO LOOP))) 
00700	 
00800	(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD))) 
00900	 
01000	(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN)) 
01100	 
01200	(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD)) 
01300	 
01400	(DFUNC (OUTCJMP FLAG AC ADRESS) 
01500	       (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS)) 
01600	 
01700	(DFUNC (OUTENDTAG X) (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X)))) 
01800	 
01900	(DFUNC (OUTFUNCALL TYPE NUM FUN) 
02000	       (OUTINST (LIST TYPE NUM (LIST (Q E) FUN)))) 
02100	 
02200	(DFUNC (OUTGOTAB X) 
02300	       (PROG (ETAG) 
02400		     (SETQ ETAG (GENTAG)) 
02500		     (PUTPROP ETAG (TOPCOPY REGPDL) (Q LEVEL)) 
02600		     (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) 
02700			    (OUTJRST ETAG))) 
02800		     (OUTTAG (CAR X)) 
02900		LOOP (SETQ X (CDR X)) 
03000		     (COND ((NULL X) 
03100			    (OUTINST (Q (PUSHJ P *UDT))) 
03200			    (OUTTAG ETAG) 
03300			    (RETURN NIL))) 
03400		     (OUTINST (LIST (QUOTE CAIN) GOTABAC (LIST (QUOTE QUOTE) (CAAR X)))) 
03500		     (OUTJRST (CDAR X)) 
03600		     (GO LOOP))) 
03700	 
03800	(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN)) 
     
00100	(DFUNC (OUTJMP OP AC ADR) (PROG NIL 
00200					(SAVEACS) 
00300					(CLEAR1BOTH) 
00400					(RST ADR) 
00500					(PUTPROP ADR T (QUOTE USED)) 
00600					(OUTINST (LIST OP AC ADR))))) 
00700	 
00800	(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR)) 
00900	 
01000	(DFUNC (OUTMOVE AC MEM) 
01100	       (COND ((EQ AC MEM) (BARF MOVEXX-OUTMOVE)) (T (OUT1 (Q MOVE) AC MEM)))) 
01200	 
01300	(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM)) 
01400	 
01500	(DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (QUOTE POP) PDLAC L))) 
01600	 
01700	(DFUNC (OUTPUSH L) (OUT1  (Q PUSH) PDLAC L)) 
01800	 
01900	(DFUNC (OUTPUT1 ST) 
02000	       (PROG (ADD) 
02100		     (COND ((ATOM ST) (GO PRINT))) 
02200		     (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT))) 
02300		     (INCR CODESIZE) 
02400		     (SETQ ADD (CADDR ST)) 
02500		     (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C))) 
02600			    (INCR CONSTSIZE))) 
02700		PRINT(PRINTSTAT ST))) 
02800	 
02900	(DFUNC (OUTSPECPUSH VAR) 
03000	       (PROG NIL (SLOTPUSH (CONS VAR P2CNT)) (OUTPUSH (LIST (QUOTE SPECIAL) VAR)))) 
03100	 
03200	(DFUNC (OUTSTAT ST) 
03300	       (PROG NIL 
03400		     (COND ((NULL LASTOUT) (GO SETIT))) 
03500		     (OUTPUT1 (CAR LASTOUT)) 
03600		     (MAPC (FUNCTION PRINTEXPR) (CDR LASTOUT)) 
03700		SETIT(SETQ LASTOUT (CONS ST (LAPNOTES))) 
03800		     (RETURN NIL))) 
03900	 
     
00100	(DFUNC (P2*EVAL XPR VALAC EFFECTS) 
00200	       (PROG (ARG TEM) 
00300		     (SETQ ARG (CADR XPR)) 
00400		     (COND ((AND (EQ (CAR ARG) (Q CONS)) 
00500				 (EQ (CAADR ARG) (Q QUOTE)) 
00600				 (GETL (SETQ TEM (CADADR ARG)) 
00700				       (Q (FEXPR FSUBR *FSUBR)))) 
00800			    (GO NOCONS))) 
00900		     (RETURN (CALLSUBR XPR VALAC EFFECTS)) 
01000		NOCONS 
01100		     (LOADCOMP (CADDR ARG) VALUEAC) 
01200		     (PROTECTACS TEM) 
01300		     (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM))) 
01400		     (RETURN (VALLOC VALUEAC)))) 
01500	 
01600	(DFUNC (P2ARG XPR VALAC EFFECTS) 
01700	       (PROG (ARG) 
01800		     (COND ((EQ FUNTYPE (Q *LSUBR)) (GO LSUBR))) 
01900		     (RETURN (CALLSUBR XPR VALAC EFFECTS)) 
02000		LSUBR(SETQ ARG (COMP (CADR XPR) VALAC)) 
02100		     (COND ((EQ (CAR ARG) (QUOTE QUOTE)) 
02200			    (CPUSH VALAC) 
02300			    (OUTMOVE VALAC (PDLINDEX)) 
02400			    (REMOVE ARG) 
02500			    (OUTINST (LIST (QUOTE HRRZ) VALAC (CADR ARG) VALAC)) 
02600			    (RETURN (VALLOC VALAC)))) 
02700		     (LOADARG VALAC ARG) 
02800		     (OUT1 (QUOTE ADD) VALAC (PDLINDEX)) 
02900		     (OUTINST (LIST (QUOTE HRRZ) VALAC (MINUS INUM0) VALAC)) 
03000		     (RETURN (VALLOC VALAC)))) 
03100	 
03200	(DFUNC (P2BOOL XPR VALAC EFFECTS) 
03300	       (PROG (CTAG RSL G) 
03400		     (PUTPROP (SETQ G (GENTAG)) T (QUOTE SET)) 
03500		     (BOOLEXPR XPR VALAC G T MINDEPTH) 
03600		OUT  (RETURN (BOOLVALUE VALAC EFFECTS G)))) 
03700	 
     
00100	(DFUNC (P2CARCDR XPR VALAC EFFECTS) 
00200	       (PROG (TEMP) 
00300	 	     (COND ((NOT (EQ (LENGTH (CDR XPR)) 1)) 
00400			    (DATAERR ARGNOERR-P2CARCDR))) 
00500		     (COND (EFFECTS (RETURN (COMPE (CADR XPR) VALAC)))) 
00600		     (SETQ XPR (CONS (SETQ TEMP (GENSYM)) 
00700				     (CONS (CAR XPR) (COMP (CADR XPR) VALAC)))) 
00800		     (SETQ CCLST (CONS XPR CCLST)) 
00900		     (SETQ TEMP (LIST TEMP)) 
01000		     (SETQ LDLST (CONS TEMP LDLST)) 
01100		     (RETURN TEMP))) 
01200	 
01300	(DFUNC (P2COND XPR VALAC EFFECTS) 
01400	       (PROG (CTAG RSL SETQVARS VARLOC) 
01500		     (SETQ SETQVARS (CADR XPR)) 
01600		LOOP (COND ((NULL SETQVARS) (GO CC2))) 
01700		     (COND ((ASSOC (CAR SETQVARS) LDLST) (GO CC3))) 
01800		ELOOP(DOCDR SETQVARS) 
01900		     (GO LOOP) 
02000		CC2  (CLEAR1) 
02100		     (P2COND1 (CDDR XPR) VALAC EFFECTS MINDEPTH) 
02200		     (SETQ P2CNT (PLUS P2CNT 2)) 
02300		     (RETURN (COND (EFFECTS NIL) (T (VALLOC VALAC)))) 
02400		CC3  (SETQ VARLOC (LOC (CONS (CAR SETQVARS) P2CNT))) 
02500		     (COND ((NOT (NUMBERP VARLOC)) (GO CC4))) 
02600		     (COND ((NOT (DVP (SLOTCONT VARLOC))) 
02700			    (SETSLOT VARLOC (CONS (CAR SETQVARS) P2CNT)) 
02800			    (GO LOOP))) 
02900		CC4  (SLOTPUSH (CONS (CAR SETQVARS) P2CNT)) 
03000		     (OUTPUSH VARLOC) 
03100		     (GO ELOOP))) 
03200	 
     
00100	(DFUNC (P2COND1 EXP VALAC EFFECTS MINDEPTH) 
00200	       (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST AC) 
00300		     (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC))) 
00400		     (SETQ CONDEXIT (GENTAG)) 
00500		     (SETQ IRSSL (TOPCOPY REGPDL)) 
00600		     (SETQ MINDEPTH PDLDEPTH) 
00700		     (PUTPROP CONDEXIT IRSSL (QUOTE LEVEL)) 
00800		LOOP (SETQ RSL NIL) 
00900		     (COND ((NULL EXP) (COND (RETNIL (LOADARG AC (Q (QUOTE NIL))))) 
01000				       (OUTENDTAG CONDEXIT) 
01100				       (COND ((USEDTAGP PAIREXIT) (CLEARITALL))) 
01200				       (RESTORE IRSSL) 
01300				       (RETURN NIL))) 
01400		     (SETQ PAIR (CAR EXP)) 
01500		     (COND ((NULL (CDR PAIR)) 
01600			    (LOADCOMP (CAR PAIR) AC) 
01700			    (COND ((NOT (NULL (CDR EXP))) 
01800				   (OUTCJMP T AC CONDEXIT)) 
01900				  (T (RESTORE IRSSL))) 
02000			    (GO NONIL))) 
02100		     (COND ((AND (EQUAL (CDR PAIR) (QUOTE ((QUOTE NIL)))) 
02200				 (EQ (CAAR PAIR) (QUOTE NULL)) 
02300				 (OR (ATOM (CADAR PAIR)) 
02400				     (NOT (HASPROP (CAADAR PAIR) (Q BOOL))))) 
02500			    (LOADCOMP (CADAR PAIR) AC) 
02600			    (OUTCJMP NIL AC CONDEXIT) 
02700			    (SETQ RETNIL T) 
02800			    (GO ELOOP))) 
02900		     (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2))) 
03000		     (COND ((AND (EQ (CAADR PAIR) (QUOTE GO)) 
03100				 (ATOM (SETQ ATAG (CADADR PAIR)))) 
03200			    (BOOLEXPR (CAR PAIR) AC (EQUIVTAG ATAG) T MINDEPTH) 
03300			    (GO NONIL))) 
03400		     (COND ((EQUAL (CADR PAIR) (QUOTE (RETURN (QUOTE NIL)))) 
03500			    (BOOLEXPR (CAR PAIR) AC EXITN T MINDEPTH) 
03600			    (GO NONIL))) 
03700		L2   (SETQ PAIREXIT (SETQ CTAG (GENTAG))) 
03800		     (PUTPROP PAIREXIT IRSSL (QUOTE LEVEL)) 
03900		     (SETQ RSL NIL) 
04000		     (BOOLEXPR (CAR PAIR) AC PAIREXIT NIL MINDEPTH) 
04100		     (SETQ H2 (COND ((NOT (ATOM RSL)) RSL) 
04200				    (T (LIST (TOPCOPY ARGACS) 
04300					     (TOPCOPY REGPDL) 
04400					     PDLDEPTH)))) 
04500		     (SETQ H1 (LIST (TOPCOPY SPLDLST) (TOPCOPY CCLST))) 
04600		     (SETQ REST (CDR PAIR)) 
04700		LP1  (COND ((NULL (CDR REST)) (GO L1))) 
04800		     (COMPE (CAR REST) AC) 
04900		     (SETQ REST (CDR REST)) 
05000		     (GO LP1) 
05100		L1   (COND (EFFECTS (COMPE (CAR REST) AC)) 
05200			   (T (LOADCOMP (CAR REST) AC))) 
05300		     (SAVEACS) 
05400		     (SETQ SPLDLST (CAR H1)) 
05500		     (SETQ CCLST (CADR H1)) 
05600		     (SETQ H1 ARGACS) 
05700		     (SETQ ARGACS (CAR H2)) 
05800		     (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (QUOTE NIL)))) 
05900		     (SETQ ARGACS H1) 
06000		     (SETQ RETNIL NIL) 
06100		     (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN)))) 
06200			    (COND ((OR (NOT (NULL (CDR EXP))) 
06300				       (AND (NOT EFFECTS) 
06400					    (NOT ACNIL) 
06500					    (SETQ RETNIL (USEDTAGP PAIREXIT)))) 
06600				   (OUTJRST CONDEXIT)) 
06700				  (T (RESTORE IRSSL))))) 
06800		     (SETQ ARGACS (CAR H2)) 
06900		     (SETQ REGPDL (CADR H2)) 
07000		     (SETQ PDLDEPTH (CADDR H2)) 
07100		     (OUTTAG PAIREXIT) 
07200		     (GO ELOOP) 
07300		NONIL(SETQ RETNIL NIL) 
07400		ELOOP(SETQ EXP (CDR EXP)) 
07500		     (GO LOOP))) 
07600	 
     
00100	(DFUNC (P2ELSE XPR VALAC EFFECTS) (BARF SOMETHINGELSE-P2ELSE)) 
00200	 
00300	(DFUNC (P2EQ XPR VALAC EFFECTS) 
00400	       (PROG NIL 
00500		     (COND (EFFECTS (COMPE (CADR XPR) VALAC) 
00600				    (COMPE (CADDR XPR) VALAC)
00700				    (RETURN NIL))) 
00800		     (BOOLEQ1 (CDR XPR) VALAC NIL NIL) 
00900		     (RETURN (BOOLVALUE VALAC EFFECTS NIL)))) 
01000	
01100	(DFUNC (P2GO XPR VALAC EFFECTS) 
01200	       (PROG (TAG) 
01300		     (SETQ TAG (CADR XPR)) 
01400		     (SAVEACS) 
01500		     (CLRPVARS) 
01600		     (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG))) 
01700			   (T (LOADARG GOTABAC (COMP TAG VALAC)) (OUTJRST VGO))) 
01800		     (RETURN (VALLOC VALUEAC)))) 
     
00100	(DFUNC (P2LAM XPR VALAC EFFECTS) 
00200	       (PROG (LAMXPR LAMARGS SF LAMVARS TL ACL TEM) 
00300		     (SETQ LAMXPR (CAR XPR)) 
00400		     (SETQ LAMARGS (REVERSE (COMPARGS (CDR XPR)))) 
00500		     (SETQ LAMVARS (CADR LAMXPR)) 
00600		A    (COND ((NULL LAMVARS) (GO B))) 
00700		     (SETQ TL (ILOC1 (CAR LAMARGS) (FREEAC))) 
00800		     (REMOVE (CAR LAMARGS)) 
00900		     (COND ((SPECVARP (CAR LAMVARS)) 
01000			    (SETQ SF T) 
01100			    (COND ((OR (NOT (NUMBERP TL)) (LESSP TL 1)) 
01200				   (LOADARG (SETQ TL (FREEAC)) (CAR LAMARGS))))) 
01300			   ((OR (NOT (NUMBERP TL)) 
01400			    (DVP (SETQ TEM (SLOTCONT TL)))) 
01500			    (SLOTPUSH  TEM) 
01600			    (COND ((NULL (CDR TEM)) 
01700				   (SETSLOT TL (CONS (CAR TEM) (Q DUP))))) 
01800			    (OUTPUSH TL) 
01900			    (SETQ TL 0))) 
02000		     (SETSLOT TL (CONS (CAR LAMVARS) (QUOTE TAKEN))) 
02100		     (SETQ ACL (CONS TL ACL)) 
02200		     (SETQ LAMARGS (CDR LAMARGS)) 
02300		     (SETQ LAMVARS (CDR LAMVARS)) 
02400		     (GO A) 
02500		B    (COND (SF (OUTINST (QUOTE (JSP 6 SPECBIND)))) (T (GO D))) 
02600		     (SETQ LAMVARS (CADR LAMXPR)) 
02700		C    (COND ((NULL LAMVARS) (GO D)) 
02800			   ((SPECVARP (CAR LAMVARS)) 
02900			    (P2LAM1 LAMVARS ARGACS) 
03000			    (P2LAM1 LAMVARS REGPDL) 
03100			    (OUTINST (LIST 0 
03200					   (ILOC (CONS (CAR LAMVARS) P2CNT)) 
03300					   (LIST (QUOTE SPECIAL) (CAR LAMVARS)))))) 
03400		     (SETQ LAMVARS (CDR LAMVARS)) 
03500		     (GO C) 
03600		D    (COND ((NULL ACL) (GO E))) 
03700		     (REPLACECDR (SLOTCONT (CAR ACL)) NIL) 
03800		     (SETQ ACL (CDR ACL)) 
03900		     (GO D) 
04000		E    (SETQ LAMVARS (COMP (CADDR LAMXPR) VALAC)) 
04100		     (COND (SF (OUTINST (QUOTE (PUSHJ P SPECSTR))))) 
04200		     (SETQ P2CNT (ADD1 P2CNT)) 
04300		     (RETURN LAMVARS))) 
04400	 
04500	(DFUNC (P2LAM1 X Y) (PROG NIL	
04600			     A	  (COND ((NULL Y) (RETURN NIL)) 
04700					((NULL (CAR Y))) 
04800					((AND (EQ (CAAR Y) (CAR X)) (NULL (CDAR Y))) 
04900					 (REPLACECAR Y NIL))) 
05000				  (SETQ Y (CDR Y)) 
05100				  (GO A))) 
05200	 
     
00100	(DFUNC (P2PROG XPR VALAC EFFECTS) 
00200	       (PROG (PSFLG) 
00300		     (SETQ PSFLG (PROGBIND (CADDR XPR))) 
00400		     (SETQ PRGSPFLG NIL) 
00500		     (CLEAR1) 
00600		     (P2PROG1 XPR VALAC EFFECTS MINDEPTH) 
00700		     (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR))))) 
00800		     (RETURN (VALLOC VALAC)))) 
00900	 
01000	(DFUNC (P2PROG1 XPR VALAC EFFECTS MINDEPTH) 
01100	       (PROG (GOLIST EXIT EXITN PVR PRSSL PROGSW VGO) 
01200		     (INCR P2CNT) 
01300		     (SETQ PROGSW T) 
01400		     (SETQ PVR VALAC) 
01500		     (SETQ EXIT (GENTAG)) 
01600		     (SETQ EXITN (GENTAG)) 
01700		     (SETQ VGO (GENTAG)) 
01800		     (SETQ GOLIST (CONS (CONS NIL EXIT) 
01900					(CONS (CONS NIL EXITN) 
02000					      (CONS (CONS NIL VGO) (CADR XPR))))) 
02100		     (SETQ PROGVARS (NONSPECVARS (CADDR XPR))) 
02200		     (SETQ XPR (CDDDR XPR)) 
02300		LOOP (COND ((NULL XPR) (GO EXITN))) 
02400		     (INCR P2CNT) 
02500		     (COND ((NOT PROGSW) (RESTORE PRSSL))) 
02600		     (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR))) 
02700			   ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (QUOTE RETURN))) 
02800			    (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL)))) (GO EXITN)) 
02900				  (T (LOADARG PVR (COMP (CADAR XPR) VALAC)) 
03000				     (COND ((USEDTAGP EXITN) (OUTJRST EXIT) 
03100							     (GO EXITN)) 
03200					   (T (GO EXIT)))))) 
03300			   (T (COMPE (CAR XPR) VALAC))) 
03400		     (SETQ XPR (CDR XPR)) 
03500		     (GO LOOP) 
03600		EXITN(OUTENDTAG EXITN) 
03700		     (COND ((NOT (EQ (CAAR LASTOUT) (QUOTE JRST))) 
03800			    (LOADARG PVR (Q (QUOTE NIL))))) 
03900		EXIT (OUTENDTAG EXIT) 
04000		     (SETQ P2CNT (PLUS 2 P2CNT)) 
04100		     (COND ((USEDTAGP VGO) 
04200			    (OUTGOTAB (CONS VGO (CDDDR GOLIST))))) 
04300		     (RETURN NIL))) 
04400	 
     
00100	(DFUNC (P2PROG2 XPR VALAC EFFECTS) 
00200	       (PROG (ARGS ARG2) 
00300		     (SETQ ARGS (CDR XPR)) 
00400		     (COND ((LESSP (LENGTH ARGS) 2) (BARF TOFEWARGS-P2PROG2))) 
00500		     (COMPE (CAR ARGS) VALAC) 
00600		     (SETQ ARG2 (COND ((NOT EFFECTS) (COMP (CADR ARGS) VALAC)) 
00700				      (T (COMPE (CADR ARGS) VALAC)))) 
00800		     (SETQ ARGS (CDDR ARGS)) 
00900		LOOP (COND ((NULL ARGS) (RETURN ARG2))) 
01000		     (COMPE (CAR ARGS) VALAC) 
01100		     (SETQ ARGS (CDR ARGS)) 
01200		     (GO LOOP))) 
01300	 
01400	(DFUNC (P2QUOTE XPR VALAC EFFECTS) XPR) 
01500	 
01600	(DFUNC (P2RETURN XPR VALAC EFFECTS) 
01700	       (PROG (VAL) 
01800		     (SETQ VAL (CADR XPR)) 
01900		     (SAVEACS) 
02000		     (CLRPVARS) 
02100		     (COND ((EQUAL VAL (QUOTE (QUOTE NIL))) (OUTJRST EXITN)) 
02200			   (T (LOADARG PVR (COMP VAL VALAC)) (OUTJRST EXIT))) 
02300		     (RETURN (COND (EFFECTS NIL) ((VALLOC VALAC)))))) 
02400	 
     
00100	(DFUNC (P2RPLAC XPR VALAC EFFECTS) 
00200	       (PROG (ARG1 ARG2) 
00300		     (SETQ ARG1 (COMP (CADR XPR) (FREEAC))) 
00400		     (SETQ ARG2 (COMP (CADDR XPR) (FREEAC))) 
00500		     (ILOC1 ARG1 VALAC) 
00600		     (LOC ARG2) 
00700		     (REMOVS ARG1) 
00800		     (REMOVS ARG2) 
00900		     (CLEAR2BOTH) 
01000		     (COND ((EQUAL ARG2 (QUOTE (QUOTE NIL))) 
01100			    (OUT1 (CADR (ASSOC (CAR XPR) 
01200					       (Q ((RPLACA HRRZS@) (RPLACD HLLZS@))))) 
01300				  0 
01400				  (LOC ARG1))) 
01500			   (T (OUT1 (CADR (ASSOC (CAR XPR) 
01600						 (Q ((RPLACA HRLM@) (RPLACD HRRM@))))) 
01700				    (PUTINAC ARG2 (FREEAC)) 
01800				    (LOC ARG1)))) 
01900		     (REMOVE ARG1) 
02000		     (REMOVE ARG2) 
02100		     (RETURN ARG1))) 
02200	 
02300	(DFUNC (P2SETARG XPR VALAC EFFECTS) 
02400	       (PROG (TEM) 
02500		     (LOC (SETQ TEM (COMP (CADDR XPR)))) 
02600		     (COND ((EQ (CAADR XPR) (Q QUOTE)) 
02700			    (OUT1 (Q MOVE) 2 (PDLINDEX)) 
02800			    (RETURN (OUTINST (LIST (Q HRRM)
02900						   (PUTINAC TEM VALAC)
03000						   (CADADR XPR) 
03100						   2))))) 
03200		     (LOADARG 2 (COMP (CADR XPR))) 
03300		     (CLRARGACS) 
03400		     (OUT1 (Q ADD) 2 (PDLINDEX)) 
03500		     (OUTINST (LIST (Q HRRM) (PUTINAC TEM VALAC) (MINUS INUM0) 2)))) 
03600	 
     
00100	(DFUNC (P2SETQ XPR VALAC EFFECTS) 
00200	       (PROG (VARLOC VALUELOC HOME VAR VAL TEM AC) 
00300		     (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC))) 
00400		     (SETQ VAR (CAR (CDR XPR))) 
00500		     (SETQ VAL (COMP (CADR (CDR XPR)) AC)) 
00600		     (ILOC1 VAL AC) 
00700		     (COND ((ASSOC VAR SPLDLST) (OUTSPECPUSH VAR) (REMSPVAR VAR))) 
00800		     (REMOVE VAL) 
00900		     (FREEZE VAR) 
01000		     (SETQ VALUELOC (LOC VAL)) 
01100		     (SETQ HOME (COND ((SPECVARP VAR) T) 
01200				      ((NOT (ILOC (SETQ VARLOC (CONS VAR P2CNT)))) NIL) 
01300				      (T (NOT (DVP (SLOTCONT (LOC VARLOC))))))) 
01400		     (SETQ P2CNT (ADD1 P2CNT)) 
01500		     (COND ((AND EFFECTS (NOT HOME)) 
01600			    (COND ((AND (NUMBERP VALUELOC) 
01700					(NOT (DVP (SLOTCONT VALUELOC)))) 
01800				   (SETSLOT VALUELOC (LIST VAR)) 
01900				   (GO EXIT)) 
02000				  (T (SLOTPUSH (LIST VAR)) 
02100				     (OUTPUSH VALUELOC) 
02200				     (GO EXIT))))) 
02300		     (COND ((AND HOME (EQUAL VAL (QUOTE (QUOTE NIL)))) 
02400			    (SETQ TEM T) 
02500			    (OUT1 (COND ((OR EFFECTS (DVP (SLOTCONT AC))) 
02600					 (SETQ TEM NIL) 
02700					 (QUOTE CLEARM)) 
02800					(T (QUOTE CLEARB))) 
02900				  AC 
03000				  (SETQ VAL (COND ((SPECVARP VAR) 
03100						   (LIST (QUOTE SPECIAL) VAR)) 
03200						  (T (ILOC (CONS VAR (SUB1 P2CNT))))))) 
03300			    (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR)))) 
03400			    (COND (TEM (SETSLOT AC (CONS VAR 
03500							 (COND ((NUMBERP VAL) (Q DUP)) 
03600							       (T NIL)))))) 
03700			    (GO EXIT))) 
03800		     (COND ((OR (NOT (NUMBERP VALUELOC)) 
03900				(LESSP VALUELOC 0) 
04000				(DVP (SLOTCONT VALUELOC))) 
04100			    (LOADARG AC  VAL) 
04200			    (SETQ VALUELOC AC))) 
04300		     (SETSLOT VALUELOC (LIST VAR)) 
04400		     (COND ((SPECVARP VAR) 
04500			    (COND ((ZEROP VALUELOC) (OUTPOP (LIST (QUOTE SPECIAL) VAR))) 
04600				  (T (OUTMOVEM VALUELOC (LIST (QUOTE SPECIAL) VAR)))))) 
04700		EXIT (RETURN (COMP VAR AC)))) 
04800	 
     
00100	(DFUNC (P2STORE XPR VALAC EFFECTS) 
00200	       (PROG (TEM) 
00300		     (LOC (SETQ TEM (COMP (CADDR XPR) VALAC))) 
00400		     (COMPE (CADR XPR) VALAC) 
00500		     (LOADARG ARRAYAC TEM) 
00600		     (OUTINST (Q (PUSHJ P NSTR))) 
00700		     (RETURN TEM))) 
00800	 
00900	(DFUNC (PASS2 X) 
01000	       (PROG (ARGACS REGPDL 
01100			     PDLDEPTH 
01200			     MINDEPTH 
01300			     LDLST 
01400			     SPECFLAG 
01500			     PRGSPFLG 
01600			     PROGVARS 
01700			     SPLDLST 
01800			     CCLST 
01900			     PROGSW 
02000			     GOLIST 
02100			     LASTOUT 
02200			     VARLIST) 
02300		     (SETQ P2CNT 1) 
02400		     (SETQ ARGACS (LISTNILS NACS)) 
02500		     (SETQ REGPDL NIL) 
02600		     (SETQ PDLDEPTH (LENGTH REGPDL)) 
02700		     (SETQ MINDEPTH PDLDEPTH) 
02800		     (OUTPSOP (LIST (Q LAP) FUNNAME FUNFLAG)) 
02900		     (COND ((EQ FUNTYPE (Q *LSUBR)) (OUTINST (QUOTE (JSP 3 *LCALL)))) 
03000			   ((AND (EQ FUNTYPE (QUOTE *FSUBR)) (CDADR X)) 
03100			    (OUTINST (QUOTE (PUSHJ P *AMAKE))))) 
03200		     (SETQ SPECFLAG (LAMBDABIND (CADR X))) 
03300		     (COND ((NOT (EQ (CAADDR X) (QUOTE PROG))) (SETQ PRGSPFLG NIL))) 
03400		     (LOADCOMP (CADDR X) VALUEAC) 
03500		     (EXITBUM SPECFLAG) 
03600		     (OUTINST (OUTINST NIL)) 
03700		     (COND (LDLST (BARF LDLSTLEFT-PASS2))) 
03800		     (RETURN NIL))) 
03900	 
     
00100	(DFUNC (PROGBIND VARS) (BINDVARS VARS NIL)) 
00200	 
00300	(DFUNC (PROGTAG TAG) (PROG NIL 
00400				   (CLEAR2BOTH) 
00500				   (CLRARGACS) 
00600				   (CLRPVARS) 
00700				   (RESTORE PRSSL) 
00800				   (OUTTAG (EQUIVTAG TAG)))) 
00900	 
01000	(DFUNC (PROTECTACS X) 
01100	       (PROG (WHICHACS ACNO) 
01200		     (SETQ WHICHACS (ACEFFECTS X)) 
01300		     (SETQ ACNO 0) 
01400		LOOP (SETQ ACNO (ADD1 ACNO)) 
01500		     (COND ((ZEROP WHICHACS) (RETURN NIL)) 
01600			   ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO))) 
01700		     (SETQ WHICHACS (LSH WHICHACS -1)) 
01800		     (GO LOOP))) 
01900	 
02000	(DFUNC (PUTINAC X AC) (PROG (Z) 
02100				    (SETQ Z (LOC X)) 
02200				    (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X))) 
02300				    (REMOVE X) 
02400				    (CPUSH Z) 
02500				    (RETURN Z))) 
02600	 
02700	(DFUNC (REMOVE DATA) 
02800	       (PROG NIL (REMLST DATA (Q LDLST)) (REMLST DATA (Q SPLDLST)))) 
02900	 
03000	(DFUNC (REMLST DATA LST) 
03100	       (PROG (TEM) 
03200		     (SETQ TEM (GETPROP LST (Q VALUE))) 
03300		LOOP (COND ((NULL (CDR TEM)) (RETURN NIL))) 
03400		     (COND ((EQUAL (CADR TEM) DATA) (REPLACECDR TEM (CDDR TEM))) 
03500			   (T (SETQ TEM (CDR TEM)))) 
03600		     (GO LOOP))) 
03700	 
03800	(DFUNC (REMOVS DATA) (REMLST DATA (Q SPLDLST))) 
03900	 
04000	(DFUNC (REMSPVAR SPV) 
04100	       (PROG (SPL) 
04200		     (SETQ SPL (GETPROP (Q SPLDLST) (Q VALUE))) 
04300		BACK (COND ((NULL (CDR SPL)) (RETURN NIL))) 
04400		     (COND ((EQ SPV (CAADR SPL)) (REPLACECDR SPL (CDDR SPL))) 
04500			   (T (SETQ SPL (CDR SPL)))) 
04600		     (GO BACK))) 
04700	 
     
00100	(DFUNC (RESTORE OLDPDL) 
00200	       (PROG (C V R TEM OLDDEPTH DEPTHDIF) 
00300		     (SETQ OLDDEPTH (LENGTH OLDPDL)) 
00400		     (COND ((GREATERP OLDDEPTH PDLDEPTH) (PRINTMSG (LIST OLDPDL REGPDL)) 
00500							 (BARF PDLTOOSHORT-RESTORE))) 
00600		A1   (SETQ C 0) 
00700		A    (COND ((EQUAL OLDDEPTH PDLDEPTH) (RETURN (SHRINKPDL C))) 
00800			   ((DVP (SETQ R (CAR REGPDL))) (GO CPP))) 
00900		     (SETQ C (ADD1 C)) 
01000		     (SLOTPOP) 
01100		     (GO A) 
01200		CPP  (SHRINKPDL C) 
01300		CPP1 (SETQ V OLDPDL) 
01400		     (SETQ C 0) 
01500		     (SETQ DEPTHDIF (*DIF PDLDEPTH OLDDEPTH)) 
01600		CPP3 (COND ((NULL V) (SETSLOT (SETQ V (FREEAC)) R) (OUTPOP V) (GO A1)) 
01700			   ((AND (CAR V) 
01800				 (EQ (CAAR V) (CAR R)) 
01900				 (NOT (DVP (SLOTCONT (SETQ TEM 
02000							   (MINUS (PLUS C 
02100									DEPTHDIF))))))) 
02200			    (GO CPP2))) 
02300		     (SETQ C (ADD1 C)) 
02400		     (SETQ V (CDR V)) 
02500		     (GO CPP3) 
02600		CPP2 (SETSLOT TEM R) 
02700		     (OUTPOP TEM) 
02800		     (GO A1))) 
02900	 
03000	(DFUNC (RSLSET X) 
03100	       (COND ((EQ X CTAG) 
03200		      (SETQ RSL (COND ((AND RSL (NOT (AND (EQUAL (CAR RSL) ARGACS) 
03300							  (EQUAL (CADR RSL) REGPDL)))) 
03400				       (QUOTE LOSE)) 
03500				      (T (LIST (TOPCOPY ARGACS) 
03600					       (TOPCOPY REGPDL) 
03700					       PDLDEPTH))))))) 
03800	 
03900	(DFUNC (RST TAG) (COND ((NULL TAG) NIL) 
04000			     ((ASSOCR TAG GOLIST) (RESTORE PRSSL)) 
04100			     ((REMPROP TAG (QUOTE SET)) 
04200			      (SAVEACS) 
04300			      (PUTPROP TAG (TOPCOPY REGPDL) (QUOTE LEVEL)) 
04400			      (SETQ MINDEPTH PDLDEPTH)) 
04500			     ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG))) 
04600			     (T (BARF NIL-RST)))) 
04700	 
     
00100	(DFUNC (SAVEACS) (PROG (K) 
00200			       (SETQ K 0) 
00300			  LOOP (COND ((EQ K NACS) (RETURN NIL))) 
00400			       (CPUSH (SETQ K (ADD1 K))) 
00500			       (GO LOOP))) 
00600	 
00700	(DFUNC (SETSLOT X Y) (REPLACECAR (GETSLOT X) Y)) 
00800	 
00900	(DFUNC (SHRINKPDL C) 
01000	       (COND ((NOT (ZEROP C)) 
01100		      (OUTINST (LIST (QUOTE SUB) PDLAC (GENCONST 0 0 C C 0)))))) 
01200	 
01300	(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (QUOTE ACS)))) 
01400	 
01500	(DFUNC (SLOTCONT X) (CAR (GETSLOT X))) 
01600	 
01700	(DFUNC (SLOTLIST) (APPEND ARGACS REGPDL)) 
01800	 
01900	(DFUNC (SLOTPOP) 
02000	       (PROG NIL (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ REGPDL (CDR REGPDL)))) 
02100	 
02200	(DFUNC (SLOTPUSH SC) (PROG NIL 
02300				(SETQ PDLDEPTH (ADD1 PDLDEPTH)) 
02400				(SETQ REGPDL (CONS SC REGPDL)))) 
02500	 
02600	(DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS)) 
02700	 
     
00100	(DFUNC (TRANSOUT OP AC AD) 
00200	       (PROG (TEM IND) 
00300		     (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE))) 
00400		     (SETQ AD (CAR AD)) 
00500		     (COND ((SETQ TEM (SEEKPROP OP (Q IMMED))) 
00600			    (SETQ OP (PROPVAL TEM)) 
00700			    (GO DONE))) 
00800		     (SETQ AD (GENCONST 0 0 AD 0 0)) 
00900		DONE (SETQ IND 
01000			   (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL) 
01100				 (T (LIST PDLAC)))) 
01200		     (RETURN (MCONS OP AC AD IND)))) 
01300	 
01400	(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED))) 
01500	 
01600	(DFUNC (VALLOC LOCATION) 
01700	       (PROG (VAR GVAL) 
01800	 	     (COND ((NULL LOCATION) (BARF NULLLOC-VALLOC))) 
01900		     (SETQ GVAL (GENVAL)) 
02000		     (SETQ VAR (CAR (SETSLOT LOCATION (LIST GVAL)))) 
02100		     (SETQ LDLST (CONS VAR LDLST)) 
02200		     (RETURN VAR))) 
02300	 
     
00100	(MAPDEF PASS2 
00200		((EXPR CALLSUBR) (SUBR CALLSUBR) 
00300				 (*SUBR CALLSUBR) 
00400				 (*UNDEF CALLSUBR) 
00500				 (LSUBR CALLLSUBR) 
00600				 (*LSUBR CALLLSUBR) 
00700				 (FEXPR CALLFSUBR) 
00800				 (FSUBR CALLFSUBR) 
00900				 (*FSUBR CALLFSUBR) 
01000				 (FUNVAR CALLFUNARGS) 
01100				 (CARCDRPROP P2CARCDR) 
01200				 (P2 DOP2))) 
01300	 
01400	(MAPDEF P2 
01500		((AND P2BOOL) (ARG P2ARG) 
01600			      (*EVAL P2*EVAL) 
01700			      (COND P2COND) 
01800			      (EQ P2EQ) 
01900			      (GO P2GO) 
02000			      (NULL P2BOOL) 
02100			      (OR P2BOOL) 
02200			      (QUOTE P2QUOTE) 
02300			      (PROG P2PROG) 
02400			      (PROG2 P2PROG2) 
02500			      (RETURN P2RETURN) 
02600			      (RPLACA P2RPLAC) 
02700			      (RPLACD P2RPLAC) 
02800			      (SETARG P2SETARG) 
02900			      (SETQ P2SETQ) 
03000			      (STORE P2STORE))) 
03100	 
03200	(MAPDEF BOOL 
03300		((AND BOOLAND) (EQ BOOLEQ) 
03400			       (NULL BOOLNULL) 
03500			       (OR BOOLOR) 
03600			       (QUOTE BOOLQUOTE))) 
03700	 
     
00100	(SETQ CARCDRDEPTH 4) 
00200	
00300	(PROG (BASE COUNT LIMIT MIDDLE NAME) 
00400	      (SETQ BASE 2) 
00500	      (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH)))) 
00600	      (SETQ COUNT (LSH 1 1)) 
00700	 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL))) 
00800	      (SETQ MIDDLE 
00900		    (SUBST (QUOTE A) 0 (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT))))) 
01000	      (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R))))) 
01100	      (PUTPROP NAME 
01200		       (CONS (CAR MIDDLE)  
01300			     (COND ((CDR MIDDLE) 
01400				    (READLIST (APPEND (QUOTE (C)) 
01500						      (CDR MIDDLE) 
01600						      (QUOTE (R))))))) 
01700		       (QUOTE CARCDRPROP)) 
01800	      (SETQ COUNT (ADD1 COUNT)) 
01900	      (GO LOOP)) 
02000	 
02100	(MAPDEF ACS 
02200		((*APPEND 37) 
02300			      (ATOM 1) 
02400			      (CONS 3) 
02500			      (GENSYM 7) 
02600			      (GET 1) 
02700			      (LAST 3) 
02800			      (LENGTH 7) 
02900			      (MEMBER 37) 
03000			      (NCONS 3) 
03100			      (XCONS 3))) 
03200	 
     
00100	(MAPDEF COMMU 
00200		((CONS XCONS) (EQUAL EQUAL) 
00300			      (*GREAT *LESS) 
00400			      (*LESS *GREAT) 
00500			      (*PLUS *PLUS) 
00600			      (*TIMES *TIMES))) 
00700	 
00800	(MAPDEF IMMED 
00900		((CAME CAIE) (CAMN CAIN) 
01000			     (HLLZS@ HLLZS) 
01100			     (HLRZ@ HLRZ) 
01200			     (HRLM@ HRLM) 
01300			     (HRRM@ HRRM) 
01400			     (HRRZ@ HRRZ) 
01500			     (HRRZS@ HRRZS) 
01600			     (MOVE MOVEI))) 
01700	 
01800	(SETQ NACS 5) 
01900	 
02000	(SETQ VALUEAC 1) 
02100	 
02200	(SETQ ALLACS (SUB1 (LSH 1 NACS))) 
02300	 
02400	(SETQ FARGAC 1) 
02500	 
02600	(SETQ GOTABAC 1) 
02700	 
02800	(SETQ ARRAYAC 1) 
02900	
03000	(SETQ PDLAC (QUOTE P)) 
03100	
03200	(SETQ INUM0 577777) 
03300	 
03400	(ENDBLOCK PASS2) 
03500	 
     
00100	(BEGINBLOCK DEBUG) 
00200	 
00300	(DEFPROP BARF (LAMBDA (L) (BREAK (Q (*COMPILER ERROR*)) L)) FEXPR) 
00400	 
00500	(DEFPROP DATAERR (LAMBDA (L) (BREAK (Q (*USER ERROR*)) L)) FEXPR) 
00600	 
00700	(DFUNC (BREAK TYPE MESSAGE) 
00800	       (PROG NIL 
00900		     (INC NIL T) 
01000		     (OUTC NIL T) 
01100		     (CARRET) 
01200		     (LINEF) 
01300		     (PRINL (APPEND TYPE MESSAGE)) 
01400		LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED))) 
01500			    (RETURN (Q DONE)))) 
01600		     (GO LOOP))) 
01700	 
01800	(DFUNC (EVALREAD) (PROG (EX) 
01900				(CARRET) 
02000				(SETQ EX (READ)) 
02100				(PRINC *SP) 
02200				(RETURN (PRINC (EVAL EX))))) 
02300	 
02400	(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST))) 
02500	 
02600	(DFUNC (P1SPY X) NIL) 
02700	 
02800	(SETQ TRACELIST NIL) 
02900	 
03000	 
03100	(ENDBLOCK DEBUG) 
03200	
     
00100	(BEGINBLOCK IO) 
00200	 
00300	(DFUNC (CARRET) (COND ((NOT (EQ (CHRCT) (LINELENGTH NIL))) (LINEF)))) 
00400	 
00500	(DFUNC (FLATP X Y Z) (LESSP (FLATSIZE X) Z)) 
00600	 
00700	(DFUNC (FORMF) 
00800	       (PROG NIL (PRINC *FF) (SETQ LINCNT PAGEHEIGHT))) 
00900	 
01000	(DFUNC (LINEF) (PROG (LINEL) 
01100			     (SETQ LINCNT (SUB1 LINCNT)) 
01200			     (SETQ LINEL (LINELENGTH NIL)) 
01300			     (LINELENGTH 1) 
01400			     (PRINC *SP) 
01500			     (LINELENGTH LINEL) 
01600			     (TERPRI))) 
01700	 
01800	(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L)) 
01900	 
02000	(DFUNC (PRINS X) (PROG2 (PRIN1 X) (PRINC *SP))) 
02100	 
02200	(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP))) 
02300	 
02400	(DFUNC (PRINTLAP CODE) (MAPC (FUNCTION PRINTSTAT) CODE)) 
02500	 
02600	(DFUNC (PRINTSTAT STAT) 
02700	       (PROG NIL 
02800		     (COND ((GREATERP (DIFFERENCE (LINELENGTH NIL) (CHRCT)) 7) (LINEF))) 
02900		     (COND ((NULL STAT) (GO WORD)) 
03000			   ((ATOM STAT) (GO TAG)) 
03100			   ((EQ (CAR STAT) (QUOTE LAP)) (GO TAG))) 
03200		WORD (PRINC *TB) 
03300		     (PRINTEXPR STAT) 
03400		     (RETURN NIL) 
03500		TAG  (CARRET) 
03600		     (PRINTEXPR STAT) 
03700		     (RETURN NIL))) 
03800	 
03900	(DFUNC (READLAP CALL) 
04000	       (PROG (STAT CODE) 
04100		     (SETQ CODE (LIST CALL)) 
04200		READ (SETQ STAT (ERRSET (READ))) 
04300		     (COND ((ATOM STAT) (BARF READERR-READLAP))) 
04400		     (SETQ CODE (CONS (CAR STAT) CODE)) 
04500		     (COND ((NULL (CAR STAT)) (RETURN (REVERSE CODE)))) 
04600		     (GO READ))) 
04700	 
     
00100	(MAPCAR 
00200	 (FUNCTION 
00300	  (LAMBDA (PAIR) (PROG2 (SET (CAR PAIR) (INTERN (ASCII (CADR PAIR)))) 
00400				(CAR PAIR)))) 
00500	 (QUOTE ((*SP 40) (*TB 11) 
00600			  (*CR 15) 
00700			  (*LF 12) 
00800			  (*VT 13) 
00900			  (*FF 14) 
01000			  (*CO 54) 
01100			  (*PT 56) 
01200			  (*LP 50) 
01300			  (*RP 51) 
01400			  (*SL 57) 
01500			  (*AM 33) 
01600			  (*AT 100) 
01700			  (*RO 177) 
01800			  (*COLON  72)))) 
01900	 
02000	(SETQ LINCNT 0) 
02100	 
02200	(SETQ PAGEHEIGHT 74) 
02300	 
02400	(SETQ PAGEWIDTH 120) 
02500	 
02600	(ENDBLOCK IO) 
     
00100	(BEGINBLOCK GENERAL) 
00200	 
00300	(DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y)))) 
00400	 
00500	(DFUNC (ASSOCR X Y) 
00600	       (PROG NIL 
00700		LOOP (COND ((NULL Y) (RETURN NIL)) ((EQ X (CDAR Y)) (RETURN (CAR Y)))) 
00800		     (SETQ Y (CDR Y)) 
00900		     (GO LOOP))) 
01000	 
01100	(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (QUOTE (T NIL))))) 
01200	 
01300	(DFUNC (COPY EX) (SUBST 0 0 EX)) 
01400	 
01500	(DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR)))) 
01600	 
01700	(DFUNC (GETGET ATOM PROP) 
01800	       (PROG (TEM PTAB) 
01900		     (SETQ PTAB (PROPTABLE ATOM)) 
02000		LOOP (COND ((NULL PTAB) (RETURN NIL))) 
02100		     (COND ((SETQ TEM (GETL (CAR PTAB) (LIST PROP))) 
02200			    (RETURN (LIST (CADR TEM))))) 
02300		     (SETQ PTAB (CDDR PTAB)) 
02400		     (GO LOOP))) 
02500	 
02600	(DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR)))) 
02700	 
02800	(DFUNC (MAKESPECIAL VAR) (PUTPROP VAR T (Q SPECIAL))) 
02900	 
03000	(DFUNC (MAKESYM IDENT NUMBER) 
03100	       (PROG (*NOPOINT) 
03200		     (SETQ *NOPOINT T) 
03300		     (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER)))))) 
03400	 
03500	(DFUNC (MAKEUNSPECIAL VAR) (REMPROP VAR (Q SPECIAL))) 
03600	 
03700	(DFUNC (NTHCDR NUM EXP) 
03800	       (PROG NIL 
03900		     (COND ((MINUSP NUM) (BARF NEGNUM-NTHCDR))) 
04000		LOOP (COND ((ZEROP NUM) (RETURN EXP))) 
04100		     (COND ((ATOM EXP) (BARF ATOM-NTHCDR))) 
04200		     (SETQ EXP (CDR EXP)) 
04300		     (SETQ NUM (SUB1 NUM)) 
04400		     (GO LOOP))) 
04500	 
04600	 
04700	(DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF)))) 
04800	 
04900	(DFUNC (TOPCOPY SXP) (APPEND SXP NIL)) 
05000	 
     
00100	(BEGINBLOCK PROPTABLE) 
00200	 
00300	(DFUNC (INITPROP IDENT PROPNAM PROPVAL) 
00400	       (PUTPROP IDENT PROPVAL PROPNAM)) 
00500	 
00600	(DFUNC (SEEKPROP IDENT PROPNAM) 
00700	       (PROG (TEM) 
00800		     (SETQ TEM (GETL IDENT (LIST PROPNAM))) 
00900		     (COND ((NULL TEM) (RETURN NIL))) 
01000		     (RETURN (CDR TEM)))) 
01100	 
01200	(DFUNC (SETPROP IDENT PROPNAM PROPVAL) 
01300	       (PUTPROP IDENT PROPVAL PROPNAM)) 
01400	 
01500	(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP))) 
01600	 
01700	(ENDBLOCK PROPTABLE) 
01800	 
01900	(ENDBLOCK GENERAL) 
02000	
02100	(ENDBLOCK COMPILER) 
02200