Google
 

Trailing-Edge - PDP-10 Archives - -
Click to see without markup as text/plain
There are no other files named in the archive.
00010	(PROG (SEXPR IBASE)
00020	      (SETQ IBASE (ADD1 7))
00030	 LOOP (SETQ SEXPR (ERRSET (READ)))
00040	      (COND ((EQ SEXPR (QUOTE $EOF$)) (RETURN NIL)))
00050	      (COND ((MEMQ (CAAR SEXPR) (QUOTE (BEGINBLOCK ENDBLOCK)))
00060		     (GO LOOP)))
00070	      (PRINT (EVAL (CAR SEXPR)))
00080	      (GO LOOP))
00090	
00100	(BEGINBLOCK COMPILER)
00110	
00120	(COND  ((NULL (GETL (QUOTE SPECIAL) (QUOTE (FEXPR FSUBR))))
00130		(DF SPECIAL (L) (MAPCAR (FUNCTION
00140			(LAMBDA (N) (PUTPROP N (QUOTE T) (QUOTE SPECIAL)))
00150			) L))))
00160	
00170	(DECLARE (SPECIAL LASTOUT LOCVARS SPECVARS P1CNT P2CNT FUNNAME)
00180		 (SPECIAL CURBIND INPROG P1SCNT FOUNDFREE)
00190		 (SPECIAL LISTING MSGCHAN INDEV OUTDEV OUTEXT)
00200		 (SPECIAL ACS PDL PDLDEPTH MINDEPTH)
00210		 (SPECIAL LDLST PRGSPFLG PROGVARS CCLST RSL CTAG VARLIST)
00220		 (SPECIAL GOLIST EXIT EXITN PRSSL PROGSW VGO PVR)
00230		 (SPECIAL NACS VALUEAC ALLACS GOTABAC FARGAC ARRAYAC)
00240		 (SPECIAL ALLFUNS GENFUNS UNDFUNS CODESIZE CONSTSIZE)
00250		 (SPECIAL LINCNT PAGEWIDTH PAGEHEIGHT)
00260		 (SPECIAL *SP *TB *CR *LF *VT *FF *CO *PT)
00270		 (SPECIAL *LP *RP *SL *AM *AT *RO *COLON)
00280		 (SPECIAL IBASE BASE *NOPOINT INUM0)
00290		 (SPECIAL TRACELIST SHOWNAMES))
00300	
00310	(DECLARE (DEFPROP CMP T *FSUBR)
00320		 (DEFPROP COMPERR T *FSUBR)
00330		 (DEFPROP COMPILE T *FSUBR)
00340		 (DEFPROP COMPL T *FSUBR)
00350		 (DEFPROP DECLARE T *FSUBR)
00360		 (DEFPROP NEXTSYM T *FSUBR)
00370		 (DEFPROP PROGN T *LSUBR)
00380		 (DEFPROP SPECIAL T *FSUBR)
00390		 (DEFPROP STARTSYM T *FSUBR)
00400		 (DEFPROP STOPSYM T *FSUBR)
00410		 (DEFPROP UNSPECIAL T *FSUBR)
00420		 (DEFPROP USERERR T *FSUBR))
00430	
00440	
00450	(BEGINBLOCK MACROS)
00460	
00470	(DEFPROP DFUNC
00480		 (LAMBDA (L)
00490			 (LIST (Q DEFPROP)
00500			       (CAADR L)
00510			       (MCONS (Q LAMBDA) (CDADR L) (CDDR L))
00520			       (Q EXPR)))
00530		 MACRO)
00540	
00550	(DEFPROP FLUSHDEF (LAMBDA (L) (CONS (Q FLUSHEXPR) (CDR L))) MACRO)
00560	
00570	(DEFPROP GETPROP (LAMBDA (L) (CONS (Q GET) (CDR L))) MACRO)
00580	
00590	
00600	(DEFPROP IFIF
00610	 (LAMBDA (L)
00620		 (LIST (Q COND) (CDR L) (LIST T (CONS (Q NOT) (CDDR L)))))
00630	 MACRO)
00640	
00650	(DEFPROP INCR
00660	 (LAMBDA (L) (LIST (Q SETQ) (CADR L) (LIST (Q ADD1) (CADR L))))
00670	 MACRO)
00680	
00690	(DEFPROP MAPDEF
00700	 (LAMBDA (L)
00710		 (LIST (Q MAPCAR)
00720		       (SUBST (CADR L)
00730			      (Q IND)
00740			      (Q (FUNCTION (LAMBDA (PAIR)
00750						   (PUTPROP (CAR PAIR)
00760							    (CADR PAIR)
00770							    (QUOTE IND))))))
00780		       (LIST (Q QUOTE) (CDDR L))))
00790	 MACRO)
00800	
00810	(DEFPROP MCONS
00820	 (LAMBDA (L)
00830		 (COND ((NULL (CDDR L)) (CADR L))
00840		       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
00850	 MACRO)
00860	
00870	(DEFPROP OUTINST (LAMBDA (INST) (CONS (Q OUTSTAT) (CDR INST))) MACRO)
00880	
00890	(DEFPROP OUTPSOP (LAMBDA (PSOP) (CONS (Q OUTSTAT) (CDR PSOP))) MACRO)
00900	
00910	(DEFPROP OUTTAG (LAMBDA (TAG) (CONS (Q OUTSTAT) (CDR TAG))) MACRO)
00920	
00930	(DEFPROP PDLDEPTH (LAMBDA (L) (Q PDLDEPTH)) MACRO)
00940	
00950	(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
00960	
00970	(DEFPROP TAGP (LAMBDA (L) (CONS (Q ATOM) (CDR L))) MACRO)
00980	
00990	(DEFPROP USERWARN
01000		 (LAMBDA (L)
01010			 (LIST (Q PRINTMSG)
01020			       (LIST (Q APPEND)
01030				     (LIST (Q LIST) (CADR L))
01040				     (LIST (Q Q) (APPEND (CDDR L) (Q (IN))))
01050				     (Q (LIST (CURFUN))))))
01060		 MACRO)
01070	
01080	(BEGINBLOCK PROPTABLE)
01090	
01100	(DEFPROP FIRSTPROP (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01110	
01120	
01130	(DEFPROP LASTPROP (LAMBDA (L) (CONS (Q NULL) (CDR L))) MACRO)
01140	
01150	(DEFPROP NEXTPROP (LAMBDA (L) (CONS (Q CDDR) (CDR L))) MACRO)
01160	
01170	(DEFPROP PROPNAM (LAMBDA (L) (CONS (Q CAR) (CDR L))) MACRO)
01180	
01190	(DEFPROP PROPTABLE (LAMBDA (L) (CONS (Q CDR) (CDR L))) MACRO)
01200	
01210	(DEFPROP PROPVAL (LAMBDA (L) (CONS (Q CADR) (CDR L))) MACRO)
01220	
01230	(DFUNC (DELETEPROP IDENT PROPNAM)
01240	       (PROG (TEM)
01250		     (SETQ TEM IDENT)
01260		LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
01270		     (COND ((EQ (CADR TEM) PROPNAM) (RPLACD TEM (CDDDR TEM))
01280						    (RETURN T)))
01290		     (SETQ TEM (CDDR TEM))
01300		     (GO LOOP)))
01310	
01320	(DFUNC (HASPROP IDENT PROP) (GETL IDENT (LIST PROP)))
01330	
01340	(DFUNC (INITPROP IDENT PROPNAM PROPVAL)
01350	       (RPLACD IDENT (MCONS PROPNAM PROPVAL (CDR IDENT))))
01360	
01370	(DFUNC (SEEKPROP IDENT PROPNAM)
01380	       (PROG (TEM)
01390		     (SETQ TEM (GETL IDENT (LIST PROPNAM)))
01400		     (COND ((NULL TEM) (RETURN NIL)))
01410		     (RETURN TEM)))
01420	
01430	(DFUNC (SETPROP IDENT PROPNAM PROPVAL)
01440	       (PUTPROP IDENT PROPVAL PROPNAM))
01450	
01460	(ENDBLOCK PROPTABLE)
01470	
01480	(ENDBLOCK MACROS)
01490	
01500	(BEGINBLOCK TOPLEVEL)
01510	
01520	(DFUNC (ACTONEXPR XPR)
01530	       (PROG (ACTION)
01540		     (COND ((ATOM XPR) (GO FLUSH)))
01550		     (SETQ ACTION (GETGET (CAR XPR) (Q COMPEFFECT)))
01560		     (COND (ACTION ((PROPVAL ACTION) XPR) (RETURN NIL)))
01570		FLUSH(FLUSHEXPR XPR)
01580		     (RETURN NIL)))
01590	
01600	(DFUNC (ACTONMACRO XPR)
01610	       (ACTONEXPR ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
01620	
01630	
01640	(DEFPROP CMP
01650	 (LAMBDA (L)
01660	  (COND	((NULL L) NIL)
01670		((NULL (CDR L)) (COMPILEFUN (CAR L)))
01680		(T (PUTPROP (CAAR L)
01690			    (MCONS (Q LAMBDA) (CDAR L) (CDR L))
01700			    (COND ((NULL (CDDR L)) (Q EXPR)) (T (CADDR L))))
01710		   (COMPILEFUN (CAAR L)))))
01720	 FEXPR)
01730	
01740	(DFUNC (COMPDEF DEFIN)
01750	 (PROG (ACTION)
01760	       (COND ((NOT (EQUAL (LENGTH DEFIN) 4))
01770		      (USERERR ARGNOERR-COMPDEF)))
01780	       (COND ((SETQ ACTION (SEEKPROP (CADDDR DEFIN) (Q DEFACTION)))
01790		      ((PROPVAL ACTION) DEFIN)
01800		      (RETURN NIL)))
01810	       (FLUSHDEF DEFIN)
01820	       (RETURN NIL)))
01830	
01840	(DFUNC (COMPFILE INFILE OUTFILE)
01850	       (PROG (ALLFUNS UNDFUNS GENFUNS CODESIZE CONSTSIZE STARTTIME)
01860		     (INITPROP (Q CURFILE) (Q NAME) INFILE)
01870		     (SETQ STARTTIME (TIME))
01880		     (SETQ CODESIZE (SETQ CONSTSIZE 0))
01890		     (DOFILE (FUNCTION COMPREADS) INFILE OUTFILE)
01900		     (TELLTALE (CADR INFILE) STARTTIME)
01910		     (DELETEPROP (Q CURFILE) (Q NAME))))
01920	
01930	(DFUNC (COMPFUNC NAME EXPR FLAG)
01940	       (PROG (LOCVARS SPECVARS P1CNT P2CNT LASTOUT)
01950		     (STARTSYM VAL VAR TAG)
01960		     (INITPROP (Q CURFUN) (Q NAME) NAME)
01970		     (PASS2 NAME (PASS1 NAME EXPR FLAG) FLAG)
01980		     (DELETEPROP (Q CURFUN) (Q NAME))
01990		     (STOPSYM VAL VAR TAG)
02000		     (COND ((NOT (EQUAL P2CNT P1CNT))
02010			    (PRINTMSG (LIST P1CNT P2CNT))
02020			    (COMPERR COUNTSDISAGREE-COMPFUNC)))
02030		     (RETURN NAME)))
02040	
02050	(DEFPROP COMPILE
02060	 (LAMBDA (NAMES)
02070	  (PROG (DONE)
02080	   LOOP	(COND ((NULL NAMES) (OUTC NIL T) (RETURN DONE)))
02090		(COND ((NOT (ATOM (CAR NAMES)))
02100		       (OUTC (EVAL (CONS (Q OUTPUT) (CAR NAMES))) NIL))
02110		      (T (SETQ DONE (APPEND DONE (COMPILEFUN (CAR NAMES))))))
02120		(SETQ NAMES (CDR NAMES))
02130		(GO LOOP)))
02140	 FEXPR)
02150	
02160	
02170	(DFUNC (COMPILEFUN NAME)
02180	 (PROG (GENFUNS UNDFUNS CODESIZE CONSTSIZE MSGCHAN SHOWNAMES PROP
02190		DONE PLIST)
02200	       (SETQ CODESIZE (SETQ CONSTSIZE 0))
02210	       (SETQ PLIST (CDR NAME))
02220	  LOOP (COND ((NULL PLIST) (RETURN (REVERSE DONE))))
02230	       (SETQ PROP (SEEKPROP (CAR PLIST) (Q DEFACTION)))
02240	       (COND ((NULL PROP) (GO ELOOP)))
02250	       (SETQ DONE (CONS (CONS NAME (CAR PLIST)) DONE))
02260	       ((PROPVAL PROP)
02270		(LIST (Q DEFPROP) NAME (CADR PLIST) (CAR PLIST)))
02280	  ELOOP(SETQ PLIST (CDDR PLIST))
02290	       (GO LOOP)))
02300	
02310	(DEFPROP COMPL
02320	 (LAMBDA (FILES)
02330	  (PROG (MSGCHAN)
02340		(COND ((NOT (NULL LISTING))
02350		       (SETQ MSGCHAN (EVAL (MCONS (Q OUTPUT)
02360						  (GENSYM)
02370						  LISTING)))))
02380	   LOOP	(COND ((NULL FILES) (OUTC MSGCHAN NIL)
02390				    (OUTC NIL T)
02400				    (RETURN NIL)))
02410		(COND ((OR (EQ (CAR (LAST (EXPLODE (CAR FILES)))) *COLON)
02420			   (AND	(NOT (ATOM (CAR FILES)))
02430				(NOT (ATOM (CDAR FILES)))))
02440		       (SETQ INDEV (CAR FILES))
02450		       (GO ELOOP)))
02460		(COMPFILE (LIST INDEV (CAR FILES))
02470			  (LIST	OUTDEV
02480				(CONS (COND ((ATOM (CAR FILES)) (CAR FILES))
02490					    (T (CAAR FILES)))
02500				      OUTEXT)))
02510	   ELOOP(SETQ FILES (CDR FILES))
02520		(GO LOOP)))
02530	 FEXPR)
02540	
02550	(DFUNC (COMPREADS) (READLOOP (FUNCTION ACTONEXPR)))
02560	
02570	(DFUNC (CURFILE) (GETPROP (Q CURFILE) (Q NAME)))
02580	
02590	(DFUNC (CURFUN) (GETPROP (Q CURFUN) (Q NAME)))
02600	
02610	(DEFPROP DECLARE (LAMBDA (L) (MAPC (FUNCTION EVAL) L)) FEXPR)
02620	
02630	
02640	(DFUNC (DEFEXPR DEF)
02650	 (PROG (FN EX)
02660	       (SETQ FN (CADR DEF))
02670	       (SETQ EX (CADDR DEF))
02680	       (COND ((OR (ATOM EX) (NOT (EQ (CAR EX) (Q LAMBDA))))
02690		      (FLUSHDEF DEF))
02700		     ((AND (ATOM (CADR EX)) (NOT (NULL (CADR EX))))
02710		      (COND ((REMPROP FN (Q *UNDEF))
02720			     (PRINTMSG (CONS FN (Q (LSUBR USED AS SUBR))))))
02730		      (PUTPROP FN T (Q *LSUBR))
02740		      (COMPFUNC	FN
02750				(MCONS (Q LSUBR) (LIST (CADR EX)) (CDDR EX))
02760				(Q LSUBR)))
02770		     (T	(REMPROP FN (Q *UNDEF))
02780			(PUTPROP FN T (Q *SUBR))
02790			(COMPFUNC FN (CONS (Q SUBR) (CDR EX)) (Q SUBR))))
02800	       (TYPEFN FN)))
02810	
02820	(DFUNC (DEFFEXPR DEF)
02830	       (PROG (FN EX)
02840		     (SETQ FN (CADR DEF))
02850		     (SETQ EX (CADDR DEF))
02860		     (COND ((REMPROP FN (Q *UNDEF))
02870			    (PRINTMSG (CONS FN (Q (FSUBR USED AS SUBR))))))
02880		     (PUTPROP FN T (Q *FSUBR))
02890		     (COMPFUNC FN (CONS (Q FSUBR) (CDR EX)) (Q FSUBR))
02900		     (TYPEFN FN)))
02910	
02920	(DFUNC (DEFMACRO DEF)
02930	       (PROGN (COND ((REMPROP (CADR DEF) (Q *UNDEF))
02940			     (PRINTMSG (CONS (CADR DEF)
02950					     (Q (MACRO USED AS SUBR))))))
02960		      (PUTPROP (CADR DEF) (CADDR DEF) (Q MACRO))
02970		      (TYPEFN (CADR DEF))))
02980	
02990	(DFUNC (DO*EXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *SUBR)))
03000	
03010	(DFUNC (DO*FEXPR DEF) (PUTPROP (CADR DEF) (CADDR DEF) (Q *FSUBR)))
03020	
03030	(DFUNC (DOACT XPR) ((GETPROP (CAR XPR) (Q COMPACTION)) XPR))
03040	
03050	(DFUNC (DODE L)
03060	       (DEFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q EXPR))))
03070	
03080	(DFUNC (DODF L)
03090	       (DEFFEXPR (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q FEXPR))))
03100	
03110	(DFUNC (DODM L)
03120	       (DEFMACRO (MAKDEF (CADR L) (CADDR L) (CADDDR L) (Q MACRO))))
03130	
03140	
03150	(DFUNC (DOFILE DOREADS INFILE OUTFILE)
03160	       (PROG (LINCNT)
03170		     (SETQ LINCNT 0)
03180		     (EVAL (MCONS (Q INPUT) (Q INCHAN) INFILE))
03190		     (EVAL (MCONS (Q OUTPUT) (Q OUTCHAN) OUTFILE))
03200		     (INC (Q INCHAN) NIL)
03210		     (OUTC (Q OUTCHAN) NIL)
03220		     (DOREADS)
03230		     (OUTC NIL T)
03240		     (INC NIL T)))
03250	
03260	(DFUNC (FLUSHEXPR EXPR)
03270	       (PROG2 (COND ((NOT (ATMARGIN)) (LINEF 2))) (PRINTEXPR EXPR)))
03280	
03290	(DFUNC (FLUSHLAP ENTRY)
03300	       (PROG (NAME FLAG TYPE STAT)
03310		     (SETQ NAME (CADR ENTRY))
03320		     (SETQ FLAG (CADDR ENTRY))
03330		     (SETQ TYPE	(ASSOC FLAG
03340				       (Q ((FSUBR *FSUBR) (LSUBR *LSUBR)
03350							  (SUBR *SUBR)))))
03360		     (COND ((NULL TYPE) (GO PRINT)))
03370		     (SETQ TYPE (CADR TYPE))
03380		     (COND ((AND (MEMQ TYPE (Q (*FSUBR *LSUBR)))
03390				 (GETPROP NAME (Q *UNDEF)))
03400			    (PRINTMSG (MCONS NAME FLAG (Q (USED AS SUBR))))))
03410		     (SETPROP NAME TYPE T)
03420		     (REMPROP NAME (Q *UNDEF))
03430		     (TYPEFN NAME)
03440		PRINT(COND ((NOT (ATMARGIN)) (LINEF 2)))
03450		     (OUTPUTSTAT ENTRY)
03460		LOOP (SETQ STAT (ERRSET (READ)))
03470		     (COND ((ATOM STAT) (USERERR READERR-FLUSHLAP)))
03480		     (OUTPUTSTAT (CAR STAT))
03490		     (COND ((NULL (CAR STAT)) (RETURN NIL)))
03500		     (GO LOOP)))
03510	
03520	(DFUNC (MAKDEF NAME ARGS BODY TYPE)
03530	       (LIST (Q DEFPROP) NAME (LIST (Q LAMBDA) ARGS BODY) TYPE))
03540	
03550	(DFUNC (MAPPUT EXP)
03560	       (PROG (IND ARGS)
03570		     (SETQ IND (CAR EXP))
03580		     (SETQ ARGS (CDR EXP))
03590		LOOP (COND ((NULL ARGS) (RETURN EXP)))
03600		     (PUTPROP (CAR ARGS) T IND)
03610		     (SETQ ARGS (CDR ARGS))
03620		     (GO LOOP)))
03630	
03640	
03650	(DFUNC (PRINTMSG MESSAGE)
03660	       (PROG (CHAN LINCNT)
03670		     (SETQ CHAN (OUTC MSGCHAN NIL))
03680		     (SETQ LINCNT 0)
03690		     (COND ((NOT (ATMARGIN)) (LINEF 2)))
03700		     (PRINL (CONS (Q *) MESSAGE))
03710		     (LINEF 1)
03720		     (OUTC CHAN NIL)))
03730	
03740	(DFUNC (READLOOP ACTFUN)
03750	       (PROG (EXPR)
03760		LOOP (SETQ EXPR (ERRSET (READ)))
03770		     (COND ((EQ EXPR (Q $EOF$)) (RETURN NIL)))
03780		     (ACTFUN (CAR EXPR))
03790		     (GO LOOP)))
03800	
03810	(DEFPROP SPECIAL
03820		 (LAMBDA (X) (MAPCAR (FUNCTION MAKESPECIAL) X))
03830		 FEXPR)
03840	
03850	(DFUNC (TELLTALE FILENAME STARTTIME)
03860	 (PROG (CHAN UNDS)
03870	       (SETQ CHAN (OUTC MSGCHAN NIL))
03880	       (CARRETN)
03890	       (LINEF 1)
03900	       (PRINL (LIST FILENAME (Q COMPILED)))
03910	       (PRINL (LIST CODESIZE (Q WORDS)))
03920	       (PRINL (LIST CONSTSIZE (Q CONSTANTS)))
03930	       (PRINL (LIST (ADD1 (QUOTIENT (DIFFERENCE (TIME) STARTTIME)
03940					    1750))
03950			    (Q SECONDS)))
03960	       (LINEF 2)
03970	  UNDF (COND ((NULL UNDFUNS) (GO UNDF1)))
03980	       (COND ((HASPROP (CAR UNDFUNS) (Q *UNDEF))
03990		      (SETQ UNDS (CONS (CAR UNDFUNS) UNDS))))
04000	       (SETQ UNDFUNS (CDR UNDFUNS))
04010	       (GO UNDF)
04020	  UNDF1(COND ((NULL UNDS) (GO GENF)))
04030	       (PRINL (Q (UNDEFINED FUNCTIONS)))
04040	       (LINEF 1)
04050	       (PRINL UNDS)
04060	       (LINEF 2)
04070	  GENF (COND ((NULL GENFUNS) (GO END)))
04080	       (PRINL (Q (GENERATED FUNCTIONS)))
04090	       (LINEF 1)
04100	       (PRINL GENFUNS)
04110	       (LINEF 2)
04120	  END  (OUTC CHAN NIL)))
04130	
04140	
04150	(DFUNC (TYPEFN MESSAGE)
04160	       (PROG (CHAN LINCNT)
04170		     (COND ((NULL SHOWNAMES) (RETURN NIL)))
04180		     (SETQ CHAN (OUTC MSGCHAN NIL))
04190		     (SETQ LINCNT 0)
04200		     (COND ((ATMARGIN) (LINEF 1)))
04210		     (PRINS MESSAGE)
04220		     (OUTC CHAN NIL)))
04230	
04240	(DEFPROP UNSPECIAL
04250		 (LAMBDA (X) (MAPCAR (FUNCTION MAKEUNSPECIAL) X))
04260		 FEXPR)
04270	
04280	(BEGINBLOCK INITIALIZATION)
04290	
04300	(DFUNC (CINIT) (PROG2 (EXCISE) (INITFN (Q CSTART)) (NOUUO NIL)))
04310	
04320	(DFUNC (CSTART)
04330	 (PROGN	(INITFN NIL)
04340		(COND ((NOT (NULL (ERRSET (INPUT SYS: (COMPLR . INI)) NIL)))
04350		       (SYSIN (COMPLR . INI))))
04360		(COND ((NOT (NULL (ERRSET (INPUT DSK: (COMPLR . INI)) NIL)))
04370		       (SYSIN DSK: (COMPLR . INI))))
04380		(LINEF 1)
04390		(PRINL (Q (LISP COMPILER)))))
04400	
04410	(ENDBLOCK INITIALIZATION)
04420	
04430	(MAPDEF COMPEFFECT (COMPACTION DOACT) (MACRO ACTONMACRO))
04440	
04450	(MAPDEF COMPACTION (DE DODE) (DECLARE EVAL) (DEFPROP COMPDEF)
04460			   (DF DODF) (DM DODM) (LAP FLUSHLAP) (SPECIAL EVAL)
04470			   (UNSPECIAL EVAL) (*SUBR MAPPUT) (*FSUBR MAPPUT)
04480			   (*LSUBR MAPPUT) (*EXPR MAPPUT) (*FEXPR MAPPUT))
04490	
04500	(MAPDEF DEFACTION (EXPR DEFEXPR) (FEXPR DEFFEXPR) (MACRO DEFMACRO)
04510			  (SPECIAL EVAL) (DEFACTION EVAL) (*EXPR DO*EXPR)
04520			  (*FEXPR DO*FEXPR) (*SUBR EVAL) (*FSUBR EVAL)
04530			  (*LSUBR EVAL))
04540	
04550	(SETQ LISTING NIL)
04560	
04570	(SETQ OUTDEV (SETQ INDEV (QUOTE DSK:)))
04580	
04590	(SETQ OUTEXT (QUOTE LAP))
04600	
04610	(SETQ SHOWNAMES T)
04620	
04630	(ENDBLOCK TOPLEVEL)
04640	
04650	(BEGINBLOCK PASS1)
04660	
04670	
04680	(DFUNC (DOP1 XPR) ((GETPROP (CAR XPR) (Q P1)) XPR))
04690	
04700	(DFUNC (GENFUN EXPR)
04710	 (PROG (NAME ARGS CALL)
04720	       (COND ((ATOM EXPR) (RETURN EXPR)))
04730	       (COND ((NOT (EQ (CAR EXPR) (Q LAMBDA)))
04740		      (USERERR NOTLAMBDA-GENFUN)))
04750	       (SETQ ARGS (CADR EXPR))
04760	       (SETQ CALL (CADDR EXPR))
04770	       (COND ((AND (ATOM (CAR CALL)) (EQUAL ARGS (CDR CALL)))
04780		      (RETURN (CAR CALL))))
04790	       (SETQ NAME (MAKESYM (NEXTSYM SUBFUN) (CURFUN)))
04800	       (SETQ GENFUNS (CONS NAME GENFUNS))
04810	       (RETURN (COMPFUNC NAME (LIST (Q SUBR) ARGS CALL) (Q SUBR)))))
04820	
04830	(DFUNC (MAPP1 ARGS) (MAPCAR (FUNCTION P1) ARGS))
04840	
04850	(DFUNC (P1 XPR)
04860	 (PROG (TEM)
04870	       (COND ((ATOM XPR) (GO ATOM)))
04880	       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
04890	       (COND ((EQ (CAAR XPR) (Q LAMBDA))
04900		      (RETURN (P1LAM XPR CURBIND))))
04910	       (COND ((EQ (CAAR XPR) (Q LABEL)) (RETURN (P1LABEL XPR))))
04920	       (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
04930	  ATOM (COND ((CONSTANTP XPR) (RETURN (LIST (Q QUOTE) XPR))))
04940	       (COND ((SETQ TEM (ASSOC XPR CURBIND)) (SETQ XPR (CDR TEM))))
04950	       (INCR P1CNT)
04960	       (COND ((SPECIALP XPR) (SETQ SPECVARS (ADDTOLIST XPR SPECVARS))
04970				     (RETURN XPR)))
04980	       (COND ((VARB XPR) (RETURN XPR)))
04990	       (RPLACD (ASSOC XPR LOCVARS) P1CNT)
05000	       (RETURN XPR)
05010	  ATOMC(COND ((CONSTANTP (CAR XPR)) (USERERR CONSTFUN-P1)))
05020	       (COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS1)))
05030		      (RETURN ((PROPVAL TEM) XPR))))
05040	       (COND ((SETQ TEM (ASSOC (CAR XPR) CURBIND))
05050		      (SETQ XPR (CONS (CDR TEM) (CDR XPR)))))
05060	       (COND ((OR (SPECIALP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
05070		      (RETURN (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))))
05080	       (RETURN (P1ELSE XPR))))
05090	
05100	(DFUNC (P1ANDOR XPR)
05110	       (PROG (TEM CT ARGS)
05120		     (SETQ TEM LOCVARS)
05130		     (SETQ CT P1CNT)
05140		     (SETQ ARGS (MAPP1 (CDR XPR)))
05150		     (INCR P1CNT)
05160		     (P1BUG CT P1CNT TEM)
05170		     (RETURN (CONS (CAR XPR) ARGS))))
05180	
05190	
05200	(DFUNC (P1BIND VARS)
05210	 (PROG (VAR NEWVARS)
05220	       (COND ((AND VARS (ATOM VARS)) (USERERR ATOMICVARLIST-P1BIND)))
05230	  LOOP (COND ((NULL VARS) (RETURN (REVERSE NEWVARS))))
05240	       (SETQ VAR (CAR VARS))
05250	       (COND ((NOT (VARIABLEP VAR)) (USERERR NOTVARIABLE-P1BIND)))
05260	       (COND ((MEMBER VAR NEWVARS) (USERWARN VAR REPEATED VARIABLE)))
05270	       (COND ((SPECIALP VAR) (SETQ SPECVARS (ADDTOLIST VAR SPECVARS))
05280				     (GO ELOOP)))
05290	       (SETQ CURBIND (CONS (CONS VAR
05300					 (SETQ VAR (COND ((ASSOC VAR LOCVARS)
05310							  (NEXTSYM VAR))
05320							 (T VAR))))
05330				   CURBIND))
05340	       (SETQ LOCVARS (CONS (CONS VAR 0) LOCVARS))
05350	  ELOOP(SETQ NEWVARS (CONS VAR NEWVARS))
05360	       (SETQ VARS (CDR VARS))
05370	       (GO LOOP)))
05380	
05390	(DFUNC (P1BUG LOW HIGH PTR)
05400	       (PROG (X)
05410		LOOP (COND ((NULL PTR) (RETURN NIL)))
05420		     (SETQ X (CAR PTR))
05430		     (COND ((GREATERP (CDR X) LOW) (RPLACD X HIGH)))
05440		     (SETQ PTR (CDR PTR))
05450		     (GO LOOP)))
05460	
05470	(DFUNC (P1COND XPR)
05480	       (PROG (TEM CT PAIRS)
05490		     (SETQ TEM LOCVARS)
05500		     (SETQ CT P1CNT)
05510		     (SETQ PAIRS (MAPCAR (FUNCTION MAPP1) (CDR XPR)))
05520		     (INCR P1CNT)
05530		     (P1BUG CT P1CNT TEM)
05540		     (INCR P1CNT)
05550		     (RETURN (CONS (CAR XPR) PAIRS))))
05560	
05570	(DFUNC (P1CONS XPR)
05580	       (COND ((NOT (EQ (LENGTH (CDR XPR)) 2)) (USERERR ARGNO-P1CONS))
05590		     ((NULL (CADDR XPR)) (LIST (Q NCONS) (P1 (CADR XPR))))
05600		     (T (LIST (Q CONS) (P1 (CADR XPR)) (P1 (CADDR XPR))))))
05610	
05620	(DFUNC (P1ELSE XPR)
05630	       (PROGN (SETQ UNDFUNS (CONS (CAR XPR) UNDFUNS))
05640		      (PUTPROP (CAR XPR) T (Q *UNDEF))
05650		      (CONS (CAR XPR) (P1SUBRARGS (CDR XPR)))))
05660	
05670	
05680	(DFUNC (P1ERRSET XPR)
05690	 (COND ((ATOM (CADR XPR)) XPR)
05700	       (T (MCONS (CAR XPR)
05710			 (LIST (GENFUN (LIST (Q LAMBDA) NIL (CADR XPR))))
05720			 (CDDR XPR)))))
05730	
05740	(DFUNC (P1EVAL XPR)
05750	       (PROG (CDRXPR)
05760		     (SETQ CDRXPR (P1SUBRARGS (CDR XPR)))
05770		     (COND ((NOT (NULL (CDR CDRXPR)))
05780			    (RETURN (CONS (Q EVAL) CDRXPR))))
05790		     (RETURN (CONS (Q *EVAL) CDRXPR))))
05800	
05810	(DFUNC (P1FUNCTION XPR) (LIST (Q QUOTE) (GENFUN (CADR XPR))))
05820	
05830	(DFUNC (P1*FUNCTION XPR) (LIST (Q *FUNCTION) (GENFUN (CADR XPR))))
05840	
05850	(DFUNC (P1GO XPR)
05860	       (PROGN (COND ((NOT INPROG) (USERERR NOTINPROG-P1GO)))
05870		      (COND ((ATOM (CADR XPR)) XPR)
05880			    (T (LIST (CAR XPR) (P1 (CADR XPR)))))))
05890	
05900	(DFUNC (P1LABEL XPR)
05910	 (PROG (FN)
05920	       (INITPROP (CADAR XPR) (Q FUNVAR) T)
05930	       (SETQ FN (P1 (LIST (Q FUNCTION) (CADDAR XPR))))
05940	       (DELETEPROP (CADAR XPR) (Q FUNVAR))
05950	       (RETURN (P1 (LIST (Q PROG)
05960				 (LIST (CADAR XPR))
05970				 (LIST (Q SETQ) (CADAR XPR) FN)
05980				 (LIST (Q RETURN)
05990				       (CONS (CADAR XPR) (CDR XPR))))))))
06000	
06010	(DFUNC (P1LAM XPR CURBIND)
06020	       (PROG (ARGS VARS BODY)
06030		     (SETQ ARGS (P1SUBRARGS (CDR XPR)))
06040		     (INCR P1CNT)
06050		     (SETQ VARS (P1BIND (CADAR XPR)))
06060		     (COND ((NOT (EQUAL (LENGTH ARGS) (LENGTH VARS)))
06070			    (USERERR ARGNOERR-P1LAM)))
06080		     (SETQ BODY (P1 (CADDAR XPR)))
06090		     (INCR P1CNT)
06100		     (RETURN (CONS (LIST (Q LAMBDA) VARS BODY) ARGS))))
06110	
06120	
06130	(DFUNC (P1PROG X)
06140	 ((LAMBDA (CURBIND)
06150	   (PROG (TAGLIST P1SCNT PR TEM P1LL INPROG)
06160		 (COND ((NULL (CDR X)) (USERERR PROGTOOSHORT-P1PROG)))
06170		 (SETQ INPROG T)
06180		 (SETQ X (CDR X))
06190		 (SETQ P1LL (P1BIND (CAR X)))
06200		 (SETQ TEM LOCVARS)
06210		 (SETQ P1SCNT (INCR P1CNT))
06220	    LOOP1(SETQ X (CDR X))
06230		 (COND ((NULL X) (GO END1)))
06240		 (INCR P1CNT)
06250		 (COND ((ATOM (CAR X))
06260			(COND ((ASSOC (CAR X) TAGLIST)
06270			       (USERWARN (CAR X) MULTIPLY DEFINED TAG)))
06280			(SETQ TAGLIST (CONS (CONS (CAR X) (NEXTSYM TAG))
06290					    TAGLIST))
06300			(SETQ PR (CONS (CAR X) PR)))
06310		       (T (SETQ PR (CONS (P1 (CAR X)) PR))))
06320		 (GO LOOP1)
06330	    END1 (INCR P1CNT)
06340		 (P1BUG P1SCNT P1CNT TEM)
06350		 (SETQ TEM (GETPROP (Q LOCVARS) (Q VALUE)))
06360	    LOOP (COND ((NULL (CDR TEM)) (GO END)))
06370		 (COND ((AND (MEMBER (CAADR TEM) P1LL) (ZEROP (CDADR TEM)))
06380			(USERWARN (CAADR TEM) UNUSED PROG VARIABLE)
06390			(SETQ SPECVARS (ADDTOLIST (CAADR TEM) SPECVARS))
06400			(MAKESPECIAL (CAADR TEM))))
06410	    ELOOP(SETQ TEM (CDR TEM))
06420		 (GO LOOP)
06430	    END	 (INCR P1CNT)
06440		 (RETURN (MCONS (Q PROG) TAGLIST P1LL (REVERSE PR)))))
06450	  CURBIND))
06460	
06470	(DFUNC (P1RETURN XPR)
06480	 (COND ((NOT INPROG) (USERERR NOTINPROG-P1RETURN))
06490	       (T (LIST	(Q RETURN)
06500			(P1 (COND ((NULL (CDR XPR)) NIL) (T (CADR XPR))))))))
06510	
06520	(DFUNC (P1SETQ XPR)
06530	       (PROG (VAR TEM VAL)
06540		     (COND ((NOT (VARIABLEP (CAR XPR)))
06550			    (USERERR NOTVARIABLE-P1SETQ)))
06560		     (SETQ VAR (COND ((SETQ TEM (ASSOC (CADR XPR) CURBIND))
06570				      (CDR TEM))
06580				     (T (CADR XPR))))
06590		     (VARB VAR)
06600		     (SETQ VAL (P1 (CADDR XPR)))
06610		     (INCR P1CNT)
06620		     (INCR P1CNT)
06630		     (RETURN (LIST (Q SETQ) VAR VAL))))
06640	
06650	
06660	(DFUNC (P1STORE XPR)
06670	       (PROG (ARG1 ARG2)
06680		     (SETQ ARG2 (P1 (CADDR XPR)))
06690		     (SETQ ARG1 (P1 (CADR XPR)))
06700		     (RETURN (LIST (CAR XPR) ARG1 ARG2))))
06710	
06720	(DFUNC (P1SUBRARGS ARGS)
06730	 (COND ((GREATERP (LENGTH ARGS) NACS) (USERERR EXTRAARGS-P1SUBRARGS))
06740	       (T (MAPP1 ARGS))))
06750	
06760	(DFUNC (PASS1 NAME EXPR FLAG)
06770	 (PROG (LL CURBIND P1SCNT INPROG FOUNDFREE LOCVS)
06780	       (SETQ INPROG NIL)
06790	       (SETQ P1CNT 1)
06800	       (SETQ LOCVARS (SETQ SPECVARS NIL))
06810	       (SETQ LL (P1BIND (CADR EXPR)))
06820	       (COND ((GREATERP (LENGTH LL) NACS) (USERERR EXTRAARGS-PASS1)))
06830	       (STARTSYM SUBFUN)
06840	       (SETQ EXPR (LIST (CAR EXPR) LL (P1 (CADDR EXPR))))
06850	       (STOPSYM SUBFUN)
06860	       (COND ((NOT (NULL FOUNDFREE)) (USERWARN (REVERSE FOUNDFREE)
06870						       UNDECLARED
06880						       FREE
06890						       VARIABLES)))
06900	       (SETQ LOCVS LOCVARS)
06910	       (SETQ LOCVARS NIL)
06920	  LOOP (COND ((NULL LOCVS) (RETURN EXPR)))
06930	       (COND ((NOT (SPECIALP (CAAR LOCVS)))
06940		      (SETQ LOCVARS (CONS (CAR LOCVS) LOCVARS))
06950		      (SETPROP (CAAR LOCVS) (Q LOCAL) T))
06960		     (T (SETQ SPECVARS (ADDTOLIST (CAAR LOCVS) SPECVARS))))
06970	       (SETQ LOCVS (CDR LOCVS))
06980	       (GO LOOP)))
06990	
07000	(DFUNC (PASS1FSUBR XPR) XPR)
07010	
07020	(DFUNC (PASS1FUNVAR XPR)
07030	       (CONS (P1 (CAR XPR)) (P1SUBRARGS (CDR XPR))))
07040	
07050	(DFUNC (PASS1LSUBR XPR) (CONS (CAR XPR) (MAPP1 (CDR XPR))))
07060	
07070	(DFUNC (PASS1MACRO XPR) (P1 ((GETPROP (CAR XPR) (Q MACRO)) XPR)))
07080	
07090	(DFUNC (PASS1SUBR XPR) (CONS (CAR XPR) (P1SUBRARGS (CDR XPR))))
07100	
07110	(DFUNC (PASS1UNDEF XPR)
07120	       (PROG2 (SETQ UNDFUNS (ADDTOLIST (CAR XPR) UNDFUNS))
07130		      (PASS1SUBR XPR)))
07140	
07150	(DFUNC (SPECIALP VAR) (HASPROP VAR (Q SPECIAL)))
07160	
07170	
07180	(DFUNC (VARB X)
07190	       (PROG NIL
07200		     (COND ((ASSOCR X CURBIND) (RETURN NIL))
07210			   ((SPECIALP X) (GO SPEC)))
07220		     (SETQ FOUNDFREE (CONS X FOUNDFREE))
07230		     (MAKESPECIAL X)
07240		SPEC (SETQ SPECVARS (ADDTOLIST X SPECVARS))
07250		     (RETURN T)))
07260	
07270	(DFUNC (VARIABLEP EX) (AND (ATOM EX) (NOT (CONSTANTP EX))))
07280	
07290	(MAPDEF PASS1 (EXPR PASS1SUBR) (*EXPR PASS1SUBR) (SUBR PASS1SUBR)
07300		      (*SUBR PASS1SUBR) (*UNDEF PASS1UNDEF)
07310		      (LSUBR PASS1LSUBR) (*LSUBR PASS1LSUBR)
07320		      (FEXPR PASS1FSUBR) (*FEXPR PASS1FSUBR)
07330		      (FSUBR PASS1FSUBR) (*FSUBR PASS1FSUBR) (P1 DOP1)
07340		      (FUNVAR PASS1FUNVAR) (MACRO PASS1MACRO))
07350	
07360	(MAPDEF P1 (COND P1COND) (GO P1GO) (PROG P1PROG) (EVAL P1EVAL)
07370		   (ERRSET P1ERRSET) (SETQ P1SETQ) (STORE P1STORE)
07380		   (AND P1ANDOR) (CONS P1CONS) (OR P1ANDOR)
07390		   (*FUNCTION P1*FUNCTION) (FUNCTION P1FUNCTION)
07400		   (RETURN P1RETURN))
07410	
07420	(BEGINBLOCK INTERNALMACROS)
07430	
07440	(DEFPROP INMACRO PASS1INMACRO PASS1)
07450	
07460	(DFUNC (PASS1INMACRO XPR) (P1 ((GETPROP (CAR XPR) (Q INMACRO)) XPR)))
07470	
07480	(DEFPROP INMACRO
07490	 (LAMBDA (DF)
07500	  (COMPFUNC (CADR DF) (CONS (Q SUBR) (CDADDR DF)) (Q INMACRO)))
07510	 DEFACTION)
07520	
07530	(DEFPROP APPEND
07540	 (LAMBDA (L)
07550	  (COND	((NULL (CDR L)) NIL)
07560		((NULL (CDDR L)) (CADR L))
07570		(T (LIST (Q *APPEND) (CADR L) (CONS (CAR L) (CDDR L))))))
07580	 INMACRO)
07590	
07600	(DEFPROP LIST
07610	 (LAMBDA (L)
07620		 (COND ((NULL (CDR L)) NIL)
07630		       ((NULL (CDDR L)) (CONS (Q NCONS) (CDR L)))
07640		       (T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
07650	 INMACRO)
07660	
07670	(DEFPROP NOT (LAMBDA (L) (CONS (Q NULL) (CDR L))) INMACRO)
07680	
07690	
07700	(DEFPROP ZEROP (LAMBDA (L) (LIST (Q EQ) (CADR L) (Q 0))) INMACRO)
07710	
07720	(ENDBLOCK INTERNALMACROS)
07730	
07740	(ENDBLOCK PASS1)
07750	
07760	(BEGINBLOCK PASS2)
07770	
07780	(DFUNC (ACEFFECTS FN)
07790	 (COND ((SETQ FN (SEEKPROP FN (Q ACS))) (PROPVAL FN)) (T ALLACS)))
07800	
07810	(DFUNC (ACNUMP X)
07820	       (AND (NUMBERP X) (GREATERP X 0) (LESSP X (ADD1 NACS))))
07830	
07840	(DFUNC (BINDARGS ARGS)
07850	       (PROG (ACNUM)
07860		     (SETQ ACNUM 1)
07870		LOOP (COND ((NULL ARGS) (RETURN NIL)))
07880		     (SETSLOT ACNUM (LIST (CAR ARGS)))
07890		     (SETQ ACNUM (ADD1 ACNUM))
07900		     (SETQ ARGS (CDR ARGS))
07910		     (GO LOOP)))
07920	
07930	(DFUNC (BOOLAND EXP VALAC TEST)
07940	 (PROG2 (BOOLARGS (CDR EXP) (CAR TEST) (CDR TEST) T) (INCR P2CNT)))
07950	
07960	(DFUNC (BOOLARGS ARGS FLAG TAG SWITCH)
07970	       (PROG (G)
07980		     (GUARDLOCS)
07990		     (CLEAR1)
08000		     (RST TAG)
08010		     (PUTPROP (SETQ G (NEXTSYM TAG)) (TOPCOPY PDL) (Q LEVEL))
08020		A    (COND ((NULL ARGS) (COND (FLAG (OUTJRST TAG))) (GO C)))
08030		     (COND ((AND FLAG (NULL (CDR ARGS))) (GO B)))
08040		     (COMPPRED (CAR ARGS)
08050			       (CONS (NOT SWITCH) (COND (FLAG G) (T TAG))))
08060		     (SETQ ARGS (CDR ARGS))
08070		     (GO A)
08080		B    (COMPPRED (CAR ARGS) (CONS SWITCH TAG))
08090		     (OUTENDTAG G)
08100		C    (CLEARBOTH)
08110		     (CLEARACS)))
08120	
08130	
08140	(DFUNC (BOOLEQ EXP VALAC TEST)
08150	 (PROG (ARG1 ARG2 LOC1 LOC2 AC MEM TAG F)
08160	       (SETQ EXP (CDR EXP))
08170	       (COND ((AND (NULL VALAC) (NULL TEST)) (COMPSTAT (CADR EXP))
08180						     (COMPSTAT (CADDR EXP))
08190						     (RETURN NIL)))
08200	       (COND ((OR (NOT (NULL VALAC)) (NULL TEST)) (SETQ F NIL)
08210							  (SETQ TAG NIL))
08220		     (T (SETQ F (CAR TEST)) (SETQ TAG (CDR TEST))))
08230	       (COND ((NOT (EQ (LENGTH EXP) 2)) (USERERR ARGNOERR-BOOLEQ)))
08240	       (SETQ ARG1 (COMPEXPR (CAR EXP) (FREEAC)))
08250	       (SETQ ARG2 (COMPEXPR (CADR EXP) (FREEAC)))
08260	       (SETQ LOC2 (LOC ARG2))
08270	       (SETQ LOC1 (LOC ARG1))
08280	       (RST TAG)
08290	       (COND ((ACNUMP LOC1) (SETQ AC LOC1) (SETQ MEM (LOC ARG2)))
08300		     ((ACNUMP LOC2) (SETQ AC LOC2) (SETQ MEM (LOC ARG1)))
08310		     (T	(LOADARG (SETQ AC (FREEAC)) ARG1)
08320			(SETQ MEM (LOC ARG2))))
08330	       (REMOVE ARG1)
08340	       (REMOVE ARG2)
08350	       (SAVEACS)
08360	       (OUT1 (COND (F (Q CAMN)) (T (Q CAME))) AC MEM)
08370	       (COND ((NOT (NULL VALAC)) (SETQ AC (BOOLVALUE VALAC TAG))))
08380	       (COND ((NOT (NULL TEST)) (OUTJRST (CDR TEST))))
08390	       (RETURN AC)))
08400	
08410	(DFUNC (BOOLEXPR XPR VALAC TEST)
08420	       ((GETPROP (CAR XPR) (Q P2BOOL)) XPR VALAC TEST))
08430	
08440	(DFUNC (BOOLNULL EXP VALAC TEST)
08450	       (COMPPRED (CADR EXP) (CONS (NOT (CAR TEST)) (CDR TEST))))
08460	
08470	(DFUNC (BOOLOR EXP VALAC TEST)
08480	       (PROG2 (BOOLARGS (CDR EXP) (NOT (CAR TEST)) (CDR TEST) NIL)
08490		      (INCR P2CNT)))
08500	
08510	(DFUNC (BOOLVALUE AC TAG)
08520	       (PROGN (OUT1 (Q TDZA) AC AC)
08530		      (OUTENDTAG TAG)
08540		      (OUT1 (Q MOVEI) AC (Q (QUOTE T)))
08550		      (MARKVAL AC AC)))
08560	
08570	
08580	(DFUNC (CALLFSUBR XPR VALAC TEST)
08590	       (PROG (FUN ARGS VAL)
08600		     (SETQ FUN (CAR XPR))
08610		     (SETQ ARGS (CDR XPR))
08620		     (CLEARBOTH)
08630		     (LOADARG FARGAC (CONS ARGS (Q QT)))
08640		     (PROTECTACS FUN)
08650		     (SETQ VAL (MARKVAL VALAC VALUEAC))
08660		     (OUTCALL 17 FUN)
08670		     (RETURN (TESTJUMP VAL TEST))))
08680	
08690	(DFUNC (CALLFUNARGS XPR VALAC TEST)
08700	       (PROG (FUN ARGS FUNARGS LOCS VAL)
08710		     (SETQ FUN (CAR XPR))
08720		     (SETQ ARGS (CDR XPR))
08730		     (SETQ FUNARGS (COMPEXPR FUN VALUEAC))
08740		     (SETQ LOCS (COMPARGS ARGS))
08750		     (CLRCCLST LOCS NIL)
08760		     (LOADSUBRARGS LOCS)
08770		     (CLEARBOTH)
08780		     (CLEARACS)
08790		     (SETQ VAL (MARKVAL VALAC VALUEAC))
08800		     (OUTCALLF (LENGTH LOCS) (LOC FUNARGS))
08810		     (REMOVE FUNARGS)
08820		     (RETURN (TESTJUMP VAL TEST))))
08830	
08840	
08850	(DFUNC (CALLLSUBR XPR VALAC TEST)
08860	       (PROG (FUN ARGS NARGS HOME INST RETTAG TEM VAL)
08870		     (SETQ FUN (CAR XPR))
08880		     (SETQ ARGS (CDR XPR))
08890		     (CLEAR1)
08900		     (SETQ NARGS (LENGTH ARGS))
08910		     (SLOTPUSH (Q (NIL . TAKEN)))
08920		     (OUTPUSH (GENCONST 0 0 (SETQ RETTAG (NEXTSYM TAG)) 0 0))
08930		LOOP (COND ((NULL ARGS) (GO CALL)))
08940		     (SETQ HOME (TOPCOPY PDL))
08950		     (SETQ INST (COMPEXPR (CAR ARGS) VALUEAC))
08960		     (RESTORE HOME)
08970		     (SETQ TEM (LOC INST))
08980		     (SLOTPUSH (Q (NIL . TAKEN)))
08990		     (OUTPUSH TEM)
09000		     (REMOVE INST)
09010		     (SETQ ARGS (CDR ARGS))
09020		     (GO LOOP)
09030		CALL (SETQ TEM (PDLDEPTH))
09040		     (SAVEACS)
09050		     (COND ((NOT (EQ (PDLDEPTH) TEM))
09060			    (COMPERR PDLTOOLONG-LSUBRCALL)))
09070		     (OUTINST (LIST (Q MOVNI) 6 NARGS))
09080		LLOOP(SLOTPOP)
09090		     (COND ((ZEROP NARGS) (GO CALL1)))
09100		     (SETQ NARGS (SUB1 NARGS))
09110		     (GO LLOOP)
09120		CALL1(CLEARBOTH)
09130		     (CLEARACS)
09140		     (SETQ VAL (MARKVAL VALAC VALUEAC))
09150		     (OUTJCALL 16 FUN)
09160		     (OUTTAG RETTAG)
09170		     (RETURN (TESTJUMP VAL TEST))))
09180	
09190	
09200	(DFUNC (CALLSUBR XPR VALAC TEST)
09210	       (PROG (FUN ARGS NARGS LOCS TEM VAL)
09220		     (SETQ FUN (CAR XPR))
09230		     (SETQ ARGS (CDR XPR))
09240		     (SETQ LOCS (COMPARGS ARGS))
09250		     (SETQ NARGS (LENGTH LOCS))
09260		     (COND ((AND (SETQ TEM (SEEKPROP FUN (Q COMMU)))
09270				 (EQ NARGS 2)
09280				 (EQ (ILOC (CAR LOCS) VALUEAC) VALUEAC))
09290			    (SETQ LOCS (REVERSE LOCS))
09300			    (SETQ FUN (PROPVAL TEM))))
09310		     (SETQ TEM (SIDEEFFECTS FUN))
09320		     (COND (TEM (CLRCCLST LOCS NIL)))
09330		     (LOADSUBRARGS LOCS)
09340		     (COND (TEM (CLEARBOTH)))
09350		     (PROTECTACS FUN)
09360		     (SETQ VAL (MARKVAL VALAC VALUEAC))
09370		     (OUTCALL NARGS FUN)
09380		     (RETURN (TESTJUMP VAL TEST))))
09390	
09400	(DFUNC (CLEAR1) (PROGN (CLEARBOTH) (SAVEACS) (CLRPVARS)))
09410	
09420	(DFUNC (CLEARBOTH) (PROGN (CLRCCLST NIL T) (CLRSPLD)))
09430	
09440	(DFUNC (CLEARAC ACNO) (PROGN (CPUSH ACNO) (SETSLOT ACNO NIL)))
09450	
09460	(DFUNC (CLEARITALL) (PROGN (CLEARBOTH) (CLEARACS)))
09470	
09480	(DFUNC (CLEARACS)
09490	       (PROG (ACNO)
09500		     (SETQ ACNO NACS)
09510		LOOP (COND ((ZEROP ACNO) (RETURN NIL)))
09520		     (CLEARAC ACNO)
09530		     (SETQ ACNO (SUB1 ACNO))
09540		     (GO LOOP)))
09550	
09560	(DFUNC (CLRCCLST DATA FL)
09570	 (PROG (CCL)
09580	       (SETQ CCL CCLST)
09590	  LOOP (COND ((NULL CCL) (COND (FL (SETQ CCLST NIL))) (RETURN NIL)))
09600	       (COND ((ASSOC (CAAR CCL) DATA) (GO ELOOP)))
09610	       (CSFUN (CAR CCL) VALUEAC)
09620	  ELOOP(SETQ CCL (CDR CCL))
09630	       (GO LOOP)))
09640	
09650	
09660	(DFUNC (CLRPVARS)
09670	       (PROG NIL
09680		     (COND ((NOT PROGSW) (RETURN NIL)))
09690		     (SETQ PROGSW NIL)
09700		LOOP (COND ((NULL PROGVARS) (SETQ PRSSL (TOPCOPY PDL))
09710					    (SETQ MINDEPTH (PDLDEPTH))
09720					    (RETURN NIL))
09730			   ((NOT (ILOC (CONS (CAR PROGVARS) P2CNT) VALUEAC))
09740			    (INITZ (CAR PROGVARS))))
09750		     (SETQ PROGVARS (CDR PROGVARS))
09760		     (GO LOOP)))
09770	
09780	(DFUNC (CLRSPLD)
09790	       (PROG (LDL)
09800		     (SETQ LDL LDLST)
09810		LOOP (COND ((NULL LDL) (RETURN NIL)))
09820		     (COND ((SPECVARP (CAAR LDL)) (CLRSPVAR (CAR LDL))))
09830		     (SETQ LDL (CDR LDL))
09840		     (GO LOOP)))
09850	
09860	(DFUNC (CLRSPVAR L)
09870	 (PROG (LOC)
09880	       (SETQ LOC (ILOC L VALUEAC))
09890	       (COND ((NOT (NUMBERP LOC))
09900		      (SLOTPUSH (CONS (CAR L) P2CNT))
09910		      (OUTPUSH (LIST (Q SPECIAL) (CAR L))))
09920		     ((ACNUMP LOC) (SLOTPUSH (SLOTCONT LOC)) (OUTPUSH LOC)))
09930	       (RETURN NIL)))
09940	
09950	(DFUNC (COMPARGS ARGS)
09960	       (PROG (ARGNO RESULT)
09970		     (SETQ ARGNO 0)
09980		LOOP (COND ((NULL ARGS) (RETURN RESULT)))
09990		     (SETQ ARGNO (ADD1 ARGNO))
10000		     (SETQ RESULT (CONS (COMPEXPR (CAR ARGS) ARGNO) RESULT))
10010		     (SETQ ARGS (CDR ARGS))
10020		     (GO LOOP)))
10030	
10040	(DFUNC (COMPEXPR XPR VALAC) (COMPFORM XPR VALAC NIL))
10050	
10060	(DFUNC (COMPPRED XPR TEST) (COMPFORM XPR NIL TEST))
10070	
10080	
10090	(DFUNC (COMPFORM XPR VALAC TEST)
10100	 (PROG (TEM)
10110	       (COND ((ATOM XPR) (GO ATOM)))
10120	       (COND ((ATOM (CAR XPR)) (GO ATOMC)))
10130	       (COND ((EQ (CAAR XPR) (Q LAMBDA))
10140		      (RETURN (INTERNALLAMBDA XPR VALAC TEST))))
10150	       (RETURN (CALLFUNARGS XPR VALAC TEST))
10160	  ATOM (SETQ TEM (CONS XPR (INCR P2CNT)))
10170	       (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
10180	       (RETURN (TESTJUMP TEM TEST))
10190	  ATOMC(COND ((SETQ TEM (GETGET (CAR XPR) (Q PASS2)))
10200		      (RETURN ((PROPVAL TEM) XPR VALAC TEST))))
10210	       (COND ((OR (SPECVARP (CAR XPR)) (ASSOC (CAR XPR) LOCVARS))
10220		      (RETURN (CALLFUNARGS XPR VALAC TEST))))
10230	       (COMPERR UNKNOWNFUNCTION-COMPFORM)))
10240	
10250	(DFUNC (COMPSTAT XPR) (COMPFORM XPR NIL NIL))
10260	
10270	(DFUNC (COPT FUN AC ARGLOC)
10280	       (PROG (CCL TEM YLOC)
10290		     (SETQ YLOC (ILOC ARGLOC AC))
10300		     (SETQ CCL CCLST)
10310		LOOP (COND ((NULL CCL) (RETURN NIL))
10320			   ((AND (EQ FUN (CADAR CCL))
10330				 (EQUAL (ILOC (CDDAR CCL) AC) YLOC)
10340				 (ILOC (SETQ TEM (LIST (CAAR CCL))) AC))
10350			    (RETURN TEM)))
10360		     (SETQ CCL (CDR CCL))
10370		     (GO LOOP)))
10380	
10390	
10400	(DFUNC (CPUSH ACNO)
10410	 (PROG (TEMPDL SLOTNO SLOTCON HOLDSLOT)
10420	       (COND ((NOT (DVP (SETQ SLOTCON (SLOTCONT ACNO))))
10430		      (RETURN NIL)))
10440	       (COND ((LESSP ACNO 1) (GO MAKE)))
10450	  START(SETQ SLOTNO 0)
10460	       (SETQ TEMPDL PDL)
10470	  LOOP (COND ((NULL TEMPDL) (GO NONE)))
10480	       (COND ((DVP (CAR TEMPDL)) (GO ELOOP)))
10490	       (COND ((OR (NOT (NUMBERP (CDAR TEMPDL)))
10500			  (SPECVARP (CAAR TEMPDL)))
10510		      (SETQ HOLDSLOT SLOTNO)))
10520	       (COND ((EQ (CAR SLOTCON) (CAAR TEMPDL)) (GO FOUND)))
10530	  ELOOP(SETQ TEMPDL (CDR TEMPDL))
10540	       (SETQ SLOTNO (SUB1 SLOTNO))
10550	       (GO LOOP)
10560	  FOUND(SETSLOT SLOTNO SLOTCON)
10570	       (COND ((NULL (CDR SLOTCON))
10580		      (SETSLOT ACNO (CONS (CAR SLOTCON) (Q DUP)))))
10590	       (OUTMOVEM ACNO SLOTNO)
10600	       (RETURN NIL)
10610	  NONE (COND (HOLDSLOT (SETQ SLOTNO HOLDSLOT) (GO FOUND)))
10620	  MAKE (COND ((AND PROGSW (NOT (ASSOC (CAR SLOTCON) LOCVARS)))
10630		      (SETQ TEMPDL (PDLDEPTH))
10640		      (CLRPVARS)
10650		      (COND ((LESSP ACNO 1)
10660			     (SETQ ACNO	(PLUS ACNO
10670					      (DIFFERENCE TEMPDL
10680							  (PDLDEPTH))))))))
10690	       (SLOTPUSH SLOTCON)
10700	       (SETSLOT	ACNO
10710			(COND ((NULL (CDR SLOTCON))
10720			       (CONS (CAR SLOTCON) (Q DUP)))
10730			      (T NIL)))
10740	       (OUTPUSH ACNO)
10750	       (RETURN NIL)))
10760	
10770	(DFUNC (CSFUN L AC)
10780	 (PROG (Y)
10790	       (COND ((AND (SETQ Y (ASSOC (CAR L) LDLST)) (NOT (ILOC Y AC)))
10800		      (LOADCARCDR L AC)))))
10810	
10820	(DFUNC (CSTEP FUN AC ARGLOC)
10830	 (PROG (TEM)
10840	       (COND ((NULL FUN) (RETURN (LIST ARGLOC))))
10850	       (COND ((SETQ TEM (COPT FUN AC ARGLOC)) (RETURN (LIST TEM))))
10860	       (RETURN (CONS (CAR (SETQ TEM (GETPROP FUN (Q CARCDR))))
10870			     (CSTEP (CDR TEM) AC ARGLOC)))))
10880	
10890	
10900	(DFUNC (DOP2BOOL XPR VALAC TEST)
10910	 (PROG (TG)
10920	       (CLEARBOTH)
10930	       (PUTPROP (SETQ TG (NEXTSYM TAG)) T (Q SET))
10940	       (COND ((NOT (NULL VALAC))
10950		      (RETURN (PROG (CTAG RSL)
10960				    (BOOLEXPR XPR VALAC (CONS T TG))
10970				    (RETURN (TESTJUMP (BOOLVALUE VALAC TG)
10980						      TEST))))))
10990	       (BOOLEXPR XPR VALAC (COND ((NULL TEST) (CONS T TG)) (T TEST)))
11000	       (COND ((NULL TEST) (OUTENDTAG TG)))))
11010	
11020	(DFUNC (DOP2ELSE XPR VALAC TEST)
11030	       ((GETPROP (CAR XPR) (Q P2ELSE)) XPR VALAC TEST))
11040	
11050	(DFUNC (DOP2VAL XPR VALAC TEST)
11060	 (TESTJUMP ((GETPROP (CAR XPR) (Q P2VAL)) XPR VALAC TEST) TEST))
11070	
11080	(DFUNC (DVP X)
11090	 (PROG (Y Z)
11100	       (COND ((NULL X) (RETURN NIL)))
11110	       (COND ((EQ (CDR X) (Q QT)) (RETURN NIL)))
11120	       (COND ((EQ (CDR X) (Q DUP)) (RETURN NIL)))
11130	       (COND ((EQ (CDR X) (Q TAKEN)) (RETURN T)))
11140	       (COND ((AND (SPECVARP (CAR X)) (NULL (CDR X))) (RETURN NIL)))
11150	       (COND ((AND (SETQ Y (ASSOC (CAR X) LOCVARS))
11160			   (NULL (CDR X))
11170			   (LESSP P2CNT (CDR Y)))
11180		      (RETURN T)))
11190	       (SETQ Z LDLST)
11200	  LOOP (COND ((NULL Z)
11210		      (RETURN (COND ((SETQ Z (ASSOC (CAR X) VARLIST))
11220				     (DVP (CONS (CDR Z) (CDR X))))
11230				    (T NIL)))))
11240	       (COND ((AND (EQ (CAAR Z) (CAR X))
11250			   (EQUAL (LOC (COND ((NUMBERP (CDR X)) X)
11260					     (T (CONS (CAR X) P2CNT))))
11270				  (LOC (CAR Z))))
11280		      (RETURN T)))
11290	       (SETQ Z (CDR Z))
11300	       (GO LOOP)))
11310	
11320	(DFUNC (EQUIVTAG PTAG)
11330	 (PROG (LTAG)
11340	       (COND ((SETQ LTAG (ASSOC PTAG GOLIST)) (RETURN (CDR LTAG))))
11350	       (USERWARN PTAG UNDEFINED TAG)
11360	       (RETURN EXIT)))
11370	
11380	
11390	(DFUNC (EXITBUM SPECFLAG)
11400	 (PROG (TEM1 TEM2)
11410	       (COND ((SETQ TEM1 (ASSOC	(CAAR LASTOUT)
11420					(Q ((CALL JCALL) (PUSHJ JRST)))))
11430		      (SETQ TEM2 (CAR LASTOUT))
11440		      (SETQ LASTOUT NIL)
11450		      (KILLPDL)
11460		      (OUTINST TEM2)
11470		      (COND ((NOT SPECFLAG)
11480			     (SETQ TEM2 (CAR LASTOUT))
11490			     (SETQ LASTOUT NIL)
11500			     (OUTINST (MCONS (CADR TEM1)
11510					     (SUBST 0 (Q P) (CADR TEM2))
11520					     (CDDR TEM2)))
11530			     (RETURN NIL)))))
11540	       (KILLPDL)
11550	       (COND (SPECFLAG (OUTINST (Q (JRST 0 SPECSTR))))
11560		     (T (OUTINST (Q (POPJ P)))))))
11570	
11580	(DFUNC (FREEAC) (FREEAC1 VALUEAC))
11590	
11600	(DFUNC (FREEAC1 BEST)
11610	 (PROG (ACNO ACCS)
11620	       (COND ((AND (NOT (NULL BEST)) (NOT (DVP (SLOTCONT BEST))))
11630		      (RETURN BEST)))
11640	       (SETQ ACCS ACS)
11650	       (SETQ ACNO 1)
11660	  LOOP (COND ((NULL ACCS) (COND	((NULL BEST) (RETURN NIL))
11670					(T (CPUSH BEST) (RETURN BEST)))))
11680	       (COND ((NOT (DVP (CAR ACCS))) (RETURN ACNO)))
11690	       (SETQ ACCS (CDR ACCS))
11700	       (SETQ ACNO (ADD1 ACNO))
11710	       (GO LOOP)))
11720	
11730	(DFUNC (FINDFREEAC) (FREEAC1 NIL))
11740	
11750	(DFUNC (FREEZE VAR) (PROGN (FREEZE1 VAR ACS) (FREEZE1 VAR PDL)))
11760	
11770	(DFUNC (FREEZE1 X Z)
11780	       (PROG NIL
11790		LOOP (COND ((NULL Z) (RETURN NIL)))
11800		     (COND ((EQ X (CAAR Z))
11810			    (COND ((NULL (CDAR Z)) (RPLACA Z (CONS X P2CNT)))
11820				  ((EQ (CDAR Z) (Q DUP)) (RPLACA Z NIL)))))
11830		     (SETQ Z (CDR Z))
11840		     (GO LOOP)))
11850	
11860	
11870	(DFUNC (GENCONST OP AC AD IN IB)
11880	       (PROG (ANS)
11890		     (COND ((NOT (ZEROP IB)) (SETQ ANS (LIST *AT))))
11900		     (SETQ ANS (APPEND ANS (LIST AC AD IN)))
11910		     (SETQ ANS (CONS OP ANS))
11920		     (RETURN (CONS (Q C) ANS))))
11930	
11940	(DFUNC (GETSLOT NO)
11950	 (COND ((NOT (NUMBERP NO)) (COMPERR NOTSLOT-GETSLOT))
11960	       ((GREATERP NO NACS) (PRINTMSG NO) (COMPERR NOTAC-GETSLOT))
11970	       ((GREATERP NO 0) (NTHCDR (SUB1 NO) ACS))
11980	       ((GREATERP (ABS NO) (PDLDEPTH)) (PRINTMSG NO)
11990					       (COMPERR NOTONPDL-GETSLOT))
12000	       ((NTHCDR (MINUS NO) PDL))))
12010	
12020	(DFUNC (GUARDLOCS)
12030	       (PROG (LDL VARLOC LOCCONT)
12040		     (SETQ LDL LDLST)
12050		LOOP (COND ((NULL LDL) (RETURN NIL)))
12060		     (COND ((ASSOC (CAAR LDL) LOCVARS) (GO ISVAR)))
12070		ELOOP(SETQ LDL (CDR LDL))
12080		     (GO LOOP)
12090		ISVAR(SETQ VARLOC (LOC (CAR LDL)))
12100		     (COND ((NOT (NUMBERP VARLOC)) (GO PUSH)))
12110		     (SETQ LOCCONT (SLOTCONT VARLOC))
12120		     (COND ((NOT (DVP LOCCONT))
12130			    (SETSLOT VARLOC (CONS (CAAR LDL) P2CNT))
12140			    (GO ELOOP))
12150			   ((NUMBERP (CDR LOCCONT)) (GO ELOOP)))
12160		PUSH (SLOTPUSH (CONS (CAAR LDL) P2CNT))
12170		     (OUTPUSH VARLOC)
12180		     (GO ELOOP)))
12190	
12200	
12210	(DFUNC (ILOC X AC)
12220	 (PROG (CNTR BEST BESTNO SL SLOT CNT XCNT)
12230	       (COND ((NULL AC) (GO LOOK)))
12240	       (COND ((EQUAL X (SLOTCONT AC)) (RETURN AC)))
12250	  LOOK (COND ((EQ (CDR X) (Q QT))
12260		      (RETURN (LIST (LIST (Q QUOTE) (CAR X))))))
12270	       (SETQ SL (APPEND ACS PDL))
12280	       (SETQ CNTR 1)
12290	       (SETQ BESTNO (ADD1 P2CNT))
12300	       (SETQ XCNT (COND ((NUMBERP (CDR X)) (CDR X)) (T P2CNT)))
12310	  LOOP (COND ((NULL SL) (GO EXIT)))
12320	       (SETQ SLOT (CAR SL))
12330	       (COND ((AND SLOT (EQ (CAR X) (CAR SLOT))) (GO ISONE)))
12340	  ELOOP(SETQ SL (CDR SL))
12350	       (SETQ CNTR (ADD1 CNTR))
12360	       (GO LOOP)
12370	  EXIT (COND ((NOT (GREATERP BESTNO P2CNT)) (GO RETN)))
12380	       (COND ((SPECVARP (CAR X))
12390		      (RETURN (LIST (Q SPECIAL) (CAR X)))))
12400	       (RETURN NIL)
12410	  ISONE(COND ((OR (EQUAL X SLOT)
12420			  (NOT (MEMQ (CDR SLOT) (Q (QT TAKEN)))))
12430		      (SETQ CNT	(COND ((NUMBERP (CDR SLOT)) (CDR SLOT))
12440				      (T P2CNT)))
12450		      (COND ((AND (NOT (LESSP CNT XCNT)) (LESSP CNT BESTNO))
12460			     (SETQ BESTNO CNT)
12470			     (SETQ BEST CNTR)))))
12480	       (GO ELOOP)
12490	  RETN (RETURN (COND ((NOT (GREATERP BEST NACS)) BEST)
12500			     (T (PLUS (MINUS BEST) NACS 1))))))
12510	
12520	(DFUNC (ILOC1 X AC)
12530	 (PROG (Z)
12540	       (COND ((SETQ Z (ILOC X AC)) (RETURN Z)))
12550	       (COND ((MEMBER (CAR X) PROGVARS) (RETURN (Q ((QUOTE NIL))))))
12560	       (COND ((SETQ Z (ASSOCR (CAR X) VARLIST))
12570		      (RETURN (ILOC1 (CONS (CAR Z) (CDR X)) AC))))
12580	       (COND ((SETQ Z (ASSOC (CAR X) CCLST))
12590		      (RETURN (LOADCARCDR Z
12600					  (COND	((NULL AC) (FREEAC))
12610						(T AC))))))
12620	       (PRINTMSG (LIST X))
12630	       (COMPERR LOSTVAR-ILOC1)))
12640	
12650	(DFUNC (INITZ X)
12660	       (PROGN (SLOTPUSH (LIST X)) (OUTPUSH (Q ((QUOTE NIL))))))
12670	
12680	
12690	(DFUNC (INTERNALLAMBDA XPR VALAC TEST)
12700	 (PROG (BODY ARGS SF VARS VAL LOC SAVCNT TEM)
12710	       (SETQ BODY (CADDAR XPR))
12720	       (SETQ VARS (CADAR XPR))
12730	       (SETQ ARGS (REVERSE (COMPARGS (CDR XPR))))
12740	       (SETQ SAVCNT P2CNT)
12750	       (INCR P2CNT)
12760	  A    (COND ((NULL VARS) (GO B)))
12770	       (SETQ LOC (LOC (CAR ARGS)))
12780	       (REMOVE (CAR ARGS))
12790	       (COND ((SPECVARP (CAR VARS))
12800		      (SETQ SF T)
12810		      (FREEZE (CAR VARS))
12820		      (SETQ LOC (PUTINAC (CAR ARGS) (FREEAC))))
12830		     ((OR (NOT (NUMBERP LOC)) (DVP (SETQ TEM (SLOTCONT LOC))))
12840		      (SLOTPUSH TEM)
12850		      (COND ((NULL (CDR TEM))
12860			     (SETSLOT LOC (CONS (CAR TEM) (Q DUP)))))
12870		      (OUTPUSH LOC)
12880		      (SETQ LOC 0)))
12890	       (SETSLOT LOC (CONS (CAR VARS) (Q TAKEN)))
12900	       (SETQ ARGS (CDR ARGS))
12910	       (SETQ VARS (CDR VARS))
12920	       (GO A)
12930	  B    (COND (SF (OUTINST (Q (JSP 6 SPECBIND)))))
12940	       (SETQ VARS (CADAR XPR))
12950	  C    (COND ((NULL VARS) (GO D)))
12960	       (SETQ LOC (ILOC (CONS (CAR VARS) (Q TAKEN)) NIL))
12970	       (COND ((SPECVARP (CAR VARS))
12980		      (OUTINST (LIST 0 LOC (LIST (Q SPECIAL) (CAR VARS))))))
12990	       (RPLACD (SLOTCONT LOC) NIL)
13000	       (SETQ VARS (CDR VARS))
13010	       (GO C)
13020	  D    (SETQ TEM (COMPEXPR BODY VALAC))
13030	       (SETQ LOC (LOC TEM))
13040	       (SETQ VAL (MARKVAL VALAC
13050				 (COND ((NUMBERP LOC) LOC)
13060				       (T (PUTINAC TEM (FREEAC))))))
13070	       (REMOVE TEM)
13080	       (COND (SF (OUTINST (Q (PUSHJ P SPECSTR)))))
13090	       (INCR P2CNT)
13100	       (SETQ VARS (CADAR XPR))
13110	       (INTLAM1 ACS VARS SAVCNT)
13120	       (INTLAM1 PDL VARS SAVCNT)
13130	       (RETURN (TESTJUMP VAL TEST))))
13140	
13150	
13160	(DFUNC (INTLAM1 LST VARS CNT)
13170	       (PROG NIL
13180		LOOP (COND ((NULL LST) (RETURN NIL)))
13190		     (COND ((AND (NOT (NULL (CAR LST)))
13200				 (SPECVARP (CAAR LST))
13210				 (MEMQ (CAAR LST) VARS)
13220				 (OR (NULL (CDAR LST))
13230				     (GREATERP (CDAR LST) CNT)))
13240			    (RPLACA LST NIL)))
13250		     (SETQ LST (CDR LST))
13260		     (GO LOOP)))
13270	
13280	(DFUNC (KILLPDL) (RESTORE NIL))
13290	
13300	(DFUNC (LISTNILS NUMBER)
13310	       (PROG (LIST)
13320		LOOP (COND ((ZEROP NUMBER) (RETURN LIST)))
13330		     (SETQ LIST (CONS NIL LIST))
13340		     (SETQ NUMBER (SUB1 NUMBER))
13350		     (GO LOOP)))
13360	
13370	
13380	(DFUNC (LOADARG ACNO VAR)
13390	 (PROG (DATAORG OLDACC DATACONT DAC DOD)
13400	       (REMOVE VAR)
13410	       (COND ((NULL ACNO) (RETURN NIL)))
13420	       (SETQ DATAORG (ILOC1 VAR ACNO))
13430	       (SETQ OLDACC (SLOTCONT ACNO))
13440	       (SETQ DATACONT (COND ((NUMBERP DATAORG) (SLOTCONT DATAORG))))
13450	       (SETQ DAC (DVP OLDACC))
13460	       (SETQ DOD (DVP DATACONT))
13470	       (COND ((EQ ACNO DATAORG)	(COND (DAC (CPUSH ACNO)))
13480					(RETURN NIL)))
13490	       (COND ((AND (EQ DATAORG 0)
13500			   (NOT DOD)
13510			   (NOT DAC)
13520			   (GREATERP (PDLDEPTH) MINDEPTH))
13530		      (GO POP)))
13540	       (COND ((AND (NOT DOD)
13550			   (NOT (NULL OLDACC))
13560			   (NUMBERP DATAORG)
13570			   (LESSP DATAORG ACNO))
13580		      (GO EXCH)))
13590	       (COND ((NOT DAC) (GO FREE)))
13600	       (GO PUSH)
13610	  EXCH (SETSLOT DATAORG OLDACC)
13620	       (SETSLOT ACNO DATACONT)
13630	       (OUT1 (Q EXCH) ACNO DATAORG)
13640	       (RETURN NIL)
13650	  PUSH (CPUSH ACNO)
13660	       (SETQ DATAORG (LOC VAR))
13670	  FREE (COND ((NOT (NUMBERP DATAORG)) (GO MOVE)))
13680	       (SETSLOT	ACNO
13690			(COND ((NULL (CDR DATACONT))
13700			       (CONS (CAR DATACONT) (Q DUP)))
13710			      (T DATACONT)))
13720	       (OUTMOVE ACNO DATAORG)
13730	       (RETURN NIL)
13740	  POP  (SETSLOT ACNO DATACONT)
13750	       (OUTPOP ACNO)
13760	       (RETURN NIL)
13770	  MOVE (SETSLOT	ACNO
13780			(COND ((EQ (CAAR DATAORG) (Q QUOTE))
13790			       (CONS (CADAR DATAORG) (Q QT)))
13800			      (T (LIST (CAR VAR)))))
13810	       (OUTMOVE ACNO DATAORG)
13820	       (RETURN NIL)))
13830	
13840	
13850	(DFUNC (LOADCARCDR ITEM AC)
13860	 (PROG (ARG PATH ORIG)
13870	       (COND ((EQ (ILOC1 (SETQ ARG (CDDR ITEM)) AC) AC)
13880		      (REMOVE ARG)))
13890	       (SETQ PATH (CSTEP (CADR ITEM) AC ARG))
13900	       (COND ((NULL (CDR PATH))
13910		      (SETQ VARLIST (CONS (CONS (CAR (CAR PATH)) (CAR ITEM))
13920					  VARLIST))
13930		      (REMOVE ARG)
13940		      (RETURN (LOC (CAR PATH)))))
13950	       (SETQ PATH (REVERSE PATH))
13960	       (CPUSH AC)
13970	       (SETQ ORIG (LOC (CAR PATH)))
13980	       (SETQ PATH (CDR PATH))
13990	       (REMOVE ARG)
14000	  L1   (COND ((NULL PATH) (GO RET)))
14010	       (COND ((NULL (CDR PATH)) (GO L2)))
14020	       (COND ((AND (EQ AC VALUEAC) (EQ ORIG VALUEAC))
14030		      (OUTCALL 1
14040			       (READLIST (CONS (Q C)
14050					       (REVERSE (CONS (Q R) PATH)))))
14060		      (GO RET)))
14070	  L2   (OUT1 (CADR (ASSOC (CAR PATH) (Q ((A HLRZ@) (D HRRZ@)))))
14080		     AC
14090		     ORIG)
14100	       (SETQ PATH (CDR PATH))
14110	       (SETQ ORIG AC)
14120	       (GO L1)
14130	  RET  (SETSLOT AC (LIST (CAR ITEM)))
14140	       (RETURN AC)))
14150	
14160	(DFUNC (LOADCOMP XPR AC) (LOADARG AC (COMPEXPR XPR AC)))
14170	
14180	(DFUNC (LOADSUBRARGS ARGS)
14190	       (PROG (ARGNO)
14200		     (SETQ ARGNO (LENGTH ARGS))
14210		LOOP (COND ((NULL ARGS) (RETURN NIL)))
14220		     (LOADARG ARGNO (CAR ARGS))
14230		     (SETQ ARGS (CDR ARGS))
14240		     (SETQ ARGNO (SUB1 ARGNO))
14250		     (GO LOOP)))
14260	
14270	(DFUNC (LOC X) (ILOC1 X NIL))
14280	
14290	(DFUNC (MARKVAL FLAG LOC)
14300	       (PROG (VAR GVAL)
14310		     (COND ((NULL LOC) (RETURN NIL)))
14320		     (SETQ GVAL (NEXTSYM VAL))
14330		     (SETQ VAR (CAR (SETSLOT LOC (LIST GVAL))))
14340		     (COND ((NOT (NULL FLAG)) (SETQ LDLST (CONS VAR LDLST))))
14350		     (RETURN VAR)))
14360	
14370	
14380	(DFUNC (NONSPECVARS VRS)
14390	       (PROG (ANS)
14400		LOOP (COND ((NULL VRS) (RETURN ANS))
14410			   ((SPECVARP (CAR VRS)))
14420			   (T (SETQ ANS (CONS (CAR VRS) ANS))))
14430		     (SETQ VRS (CDR VRS))
14440		     (GO LOOP)))
14450	
14460	(DFUNC (OUT1 OP AC AD) (OUTINST (TRANSOUT OP AC AD)))
14470	
14480	(DFUNC (OUTCALL NUM FUN) (OUTFUNCALL (Q CALL) NUM FUN))
14490	
14500	(DFUNC (OUTCALLF AC AD) (OUT1 (Q CALLF@) AC AD))
14510	
14520	(DFUNC (OUTCJMP FLAG AC ADRESS)
14530	       (OUTJMP (COND (FLAG (Q JUMPN)) (T (Q JUMPE))) AC ADRESS))
14540	
14550	(DFUNC (OUTENDTAG X)
14560	       (COND ((USEDTAGP X) (CLEARITALL) (RST X) (OUTTAG X))))
14570	
14580	(DFUNC (OUTFUNCALL TYPE NUM FUN)
14590	       (OUTINST (LIST TYPE NUM (LIST (Q E) FUN))))
14600	
14610	(DFUNC (OUTGOTAB X)
14620	 (PROG (ETAG)
14630	       (SETQ ETAG (NEXTSYM TAG))
14640	       (PUTPROP ETAG (TOPCOPY PDL) (Q LEVEL))
14650	       (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST))) (OUTJRST ETAG)))
14660	       (OUTTAG (CAR X))
14670	  LOOP (SETQ X (CDR X))
14680	       (COND ((NULL X) (OUTINST (Q (PUSHJ P *UDT)))
14690			       (OUTTAG ETAG)
14700			       (RETURN NIL)))
14710	       (OUTINST (LIST (Q CAIN) GOTABAC (LIST (Q QUOTE) (CAAR X))))
14720	       (OUTJRST (CDAR X))
14730	       (GO LOOP)))
14740	
14750	(DFUNC (OUTJCALL NUM FUN) (OUTFUNCALL (Q JCALL) NUM FUN))
14760	
14770	(DFUNC (OUTJMP OP AC ADR)
14780	       (PROGN (SAVEACS)
14790		      (CLEARBOTH)
14800		      (RST ADR)
14810		      (PUTPROP ADR T (Q USED))
14820		      (OUTINST (LIST OP AC ADR))))
14830	
14840	(DFUNC (OUTJRST ADR) (OUTJMP (Q JRST) 0 ADR))
14850	
14860	(DFUNC (OUTMOVE AC MEM) (OUT1 (Q MOVE) AC MEM))
14870	
14880	(DFUNC (OUTMOVEM AC MEM) (OUT1 (Q MOVEM) AC MEM))
14890	
14900	
14910	(DFUNC (OUTPOP L) (PROG2 (SLOTPOP) (OUT1 (Q POP) (Q P) L)))
14920	
14930	(DFUNC (OUTPUSH L) (OUT1 (Q PUSH) (Q P) L))
14940	
14950	(DFUNC (OUTPUTSTAT ST)
14960	       (PROG (ADD)
14970		     (COND ((ATOM ST) (GO PRINT)))
14980		     (COND ((EQ (CAR ST) (Q LAP)) (GO PRINT)))
14990		     (SETQ CODESIZE (ADD1 CODESIZE))
15000		     (SETQ ADD (CADDR ST))
15010		     (COND ((AND (NOT (ATOM ADD)) (EQ (CAR ADD) (Q C)))
15020			    (SETQ CONSTSIZE (ADD1 CONSTSIZE))))
15030		PRINT(PRINTSTAT ST)))
15040	
15050	(DFUNC (OUTSTAT ST)
15060	       (PROG (COL EXPRS)
15070		     (COND ((NULL LASTOUT) (GO SETIT)))
15080		     (OUTPUTSTAT (CAR LASTOUT))
15090		     (SETQ COL (CURCOL))
15100		     (SETQ EXPRS (CDR LASTOUT))
15110		TRACE(COND ((NULL EXPRS) (GO SETIT)))
15120		     (TABTO COL)
15130		     (PRINTEXPR (CAR EXPRS))
15140		     (SETQ EXPRS (CDR EXPRS))
15150		     (GO TRACE)
15160		SETIT(SETQ LASTOUT (CONS ST (LAPNOTES)))
15170		     (RETURN NIL)))
15180	
15190	(DFUNC (P2*EVAL XPR VALAC TEST)
15200	       (PROG (ARG TEM VAL)
15210		     (SETQ ARG (CADR XPR))
15220		     (COND ((AND (EQ (CAR ARG) (Q CONS))
15230				 (EQ (CAADR ARG) (Q QUOTE))
15240				 (GETL (SETQ TEM (CADADR ARG))
15250				       (Q (FEXPR FSUBR *FSUBR))))
15260			    (GO NOCONS)))
15270		     (RETURN (CALLSUBR XPR VALAC TEST))
15280		NOCONS
15290		     (LOADCOMP (CADDR ARG) VALUEAC)
15300		     (PROTECTACS TEM)
15310		     (SETQ VAL (MARKVAL (NOT (NULL VALAC)) VALUEAC))
15320		     (OUTINST (LIST (Q CALL) 17 (LIST (Q E) TEM)))
15330		     (RETURN VAL)))
15340	
15350	
15360	(DFUNC (P2ARG XPR VALAC TEST)
15370	       (PROG (ARG)
15380		     (SETQ ARG (COMPEXPR (CADR XPR) VALAC))
15390		     (COND ((EQ (CDR ARG) (Q QT))
15400			    (CPUSH VALAC)
15410			    (OUTMOVE VALAC (MINUS (ADD1 (PDLDEPTH))))
15420			    (REMOVE ARG)
15430			    (OUTINST (LIST (Q HRRZ) VALAC (CADR ARG) VALAC))
15440			    (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
15450		     (LOADARG VALAC ARG)
15460		     (OUT1 (Q ADD) VALAC (MINUS (ADD1 (PDLDEPTH))))
15470		     (OUTINST (LIST (Q HRRZ) VALAC (MINUS INUM0) VALAC))
15480		     (RETURN (MARKVAL (NOT (NULL VALAC)) VALAC))))
15490	
15500	(DFUNC (P2CARCDR XPR VALAC TEST)
15510	 (PROG (TEM AC)
15520	       (COND ((NOT (EQ (LENGTH (CDR XPR)) 1))
15530		      (USERERR ARGNOERR-P2CARCDR)))
15540	       (COND ((AND (NULL VALAC) (NULL TEST))
15550		      (RETURN (COMPSTAT (CADR XPR)))))
15560	       (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
15570	       (SETQ XPR (CONS (SETQ TEM (GENSYM))
15580			       (CONS (CAR XPR) (COMPEXPR (CADR XPR) AC))))
15590	       (SETQ CCLST (CONS XPR CCLST))
15600	       (SETQ TEM (LIST TEM))
15610	       (COND ((NOT (NULL VALAC)) (SETQ LDLST (CONS TEM LDLST))))
15620	       (RETURN (TESTJUMP TEM TEST))))
15630	
15640	(DFUNC (P2COND XPR VALAC TEST)
15650	       (PROG (AC CTAG RSL VALF)
15660		     (GUARDLOCS)
15670		     (CLEAR1)
15680		     (SETQ VALF (OR (NOT (NULL VALAC)) (NOT (NULL TEST))))
15690		     (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
15700		     (P2COND1 (CDR XPR) VALF AC MINDEPTH)
15710		     (INCR P2CNT)
15720		     (INCR P2CNT)
15730		     (RETURN (MARKVAL VALF AC))))
15740	
15750	
15760	(DFUNC (P2COND1 ARGS VALF AC MINDEPTH)
15770	 (PROG (CONDEXIT PAIREXIT H1 H2 RETNIL IRSSL ACNIL PAIR ATAG REST)
15780	       (SETQ CONDEXIT (NEXTSYM TAG))
15790	       (SETQ IRSSL (TOPCOPY PDL))
15800	       (SETQ MINDEPTH (PDLDEPTH))
15810	       (PUTPROP CONDEXIT IRSSL (Q LEVEL))
15820	  LOOP (SETQ RSL NIL)
15830	       (COND ((NULL ARGS) (COND (RETNIL (LOADARG AC (Q (NIL . QT)))))
15840				  (OUTENDTAG CONDEXIT)
15850				  (COND ((USEDTAGP PAIREXIT) (CLEARITALL)))
15860				  (RESTORE IRSSL)
15870				  (RETURN NIL)))
15880	       (SETQ PAIR (CAR ARGS))
15890	       (COND ((NULL (CDR PAIR))
15900		      (LOADCOMP (CAR PAIR) AC)
15910		      (COND ((NOT (NULL (CDR ARGS))) (OUTCJMP T AC CONDEXIT))
15920			    (T (RESTORE IRSSL)))
15930		      (GO NONIL)))
15940	       (COND ((AND (EQUAL (CDR PAIR) (Q ((QUOTE NIL))))
15950			   (EQ (CAAR PAIR) (Q NULL))
15960			   (OR (ATOM (CADAR PAIR))
15970			       (NOT (HASPROP (CAADAR PAIR) (Q BOOL)))))
15980		      (LOADCOMP (CADAR PAIR) AC)
15990		      (OUTCJMP NIL AC CONDEXIT)
16000		      (SETQ RETNIL T)
16010		      (GO ELOOP)))
16020	       (COND ((OR LDLST (NOT (NULL (CDDR PAIR)))) (GO L2)))
16030	       (COND ((AND (EQ (CAADR PAIR) (Q GO))
16040			   (ATOM (SETQ ATAG (CADADR PAIR))))
16050		      (COMPPRED (CAR PAIR) (CONS T (EQUIVTAG ATAG)))
16060		      (GO NONIL)))
16070	       (COND ((EQUAL (CADR PAIR) (Q (RETURN (QUOTE NIL))))
16080		      (COMPPRED (CAR PAIR) (CONS T EXITN))
16090		      (GO NONIL)))
16100	  L2   (SETQ PAIREXIT (SETQ CTAG (NEXTSYM TAG)))
16110	       (PUTPROP PAIREXIT IRSSL (Q LEVEL))
16120	       (SETQ RSL NIL)
16130	       (COMPPRED (CAR PAIR) (CONS NIL PAIREXIT))
16140	       (SETQ H2	(COND ((NOT (ATOM RSL)) RSL)
16150			      (T (LIST (TOPCOPY ACS) (TOPCOPY PDL)))))
16160	       (SETQ H1 (TOPCOPY CCLST))
16170	       (SETQ REST (CDR PAIR))
16180	  LP1  (COND ((NULL (CDR REST)) (GO L1)))
16190	       (COMPSTAT (CAR REST))
16200	       (SETQ REST (CDR REST))
16210	       (GO LP1)
16220	  L1   (COND ((NULL VALF) (COMPSTAT (CAR REST)))
16230		     (T (LOADCOMP (CAR REST) AC)))
16240	       (SAVEACS)
16250	       (SETQ CCLST H1)
16260	       (SETQ H1 ACS)
16270	       (SETQ ACS (CAR H2))
16280	       (SETQ ACNIL (EQUAL (SLOTCONT AC) (Q (NIL . QT))))
16290	       (SETQ ACS H1)
16300	       (SETQ RETNIL NIL)
16310	       (COND ((NOT (MEMQ (CAAR REST) (Q (GO RETURN))))
16320		      (COND ((OR (NOT (NULL (CDR ARGS)))
16330				 (AND VALF
16340				      (NOT ACNIL)
16350				      (SETQ RETNIL (USEDTAGP PAIREXIT))))
16360			     (OUTJRST CONDEXIT))
16370			    (T (RESTORE IRSSL)))))
16380	       (SETQ ACS (CAR H2))
16390	       (SETQ PDL (CADR H2))
16400	       (SETQ PDLDEPTH (LENGTH PDL))
16410	       (COND ((USEDTAGP PAIREXIT) (OUTTAG PAIREXIT)))
16420	       (GO ELOOP)
16430	  NONIL(SETQ RETNIL NIL)
16440	  ELOOP(SETQ ARGS (CDR ARGS))
16450	       (GO LOOP)))
16460	
16470	
16480	(DFUNC (P2GO XPR VALAC TEST)
16490	       (PROG (TAG)
16500		     (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
16510			    (USERERR GO FOR VALUE OR TEST P2GO)))
16520		     (SETQ TAG (CADR XPR))
16530		     (SAVEACS)
16540		     (CLRPVARS)
16550		     (COND ((ATOM TAG) (OUTJRST (EQUIVTAG TAG)))
16560			   (T (LOADCOMP TAG GOTABAC) (OUTJRST VGO)))
16570		     (RETURN (MARKVAL (NOT (NULL VALAC)) VALUEAC))))
16580	
16590	
16600	(DFUNC (P2PROG XPR VALAC TEST)
16610	 (PROG (PSFLG PVR)
16620	       (SETQ PVR (COND ((NOT (NULL VALAC)) VALAC)
16630			       ((NOT (NULL TEST)) (FREEAC))
16640			       (T NIL)))
16650	       (SETQ PSFLG (SPECBIND (CADDR XPR) NIL))
16660	       (SETQ PRGSPFLG NIL)
16670	       (CLEAR1)
16680	       (PROG (GOLIST EXIT EXITN PRSSL PROGSW VGO)
16690		     (GUARDLOCS)
16700		     (INCR P2CNT)
16710		     (SETQ PROGSW T)
16720		     (SETQ EXIT (NEXTSYM TAG))
16730		     (SETQ EXITN (NEXTSYM TAG))
16740		     (SETQ VGO (NEXTSYM TAG))
16750		     (SETQ GOLIST (CONS	(CONS NIL EXIT)
16760					(CONS (CONS NIL EXITN)
16770					      (CONS (CONS NIL VGO)
16780						    (CADR XPR)))))
16790		     (SETQ PROGVARS (NONSPECVARS (CADDR XPR)))
16800		     (SETQ XPR (CDDDR XPR))
16810		LOOP (COND ((NULL XPR) (GO EXITN)))
16820		     (INCR P2CNT)
16830		     (COND ((NOT PROGSW) (RESTORE PRSSL)))
16840		     (COND ((TAGP (CAR XPR)) (PROGTAG (CAR XPR)))
16850			   ((AND (NULL (CDR XPR)) (EQ (CAAR XPR) (Q RETURN)))
16860			    (COND ((EQUAL (CDAR XPR) (Q ((QUOTE NIL))))
16870				   (GO EXITN))
16880				  (T (LOADCOMP (CADAR XPR) PVR)
16890				     (COND ((USEDTAGP EXITN) (OUTJRST EXIT)
16900							     (GO EXITN))
16910					   (T (GO EXIT))))))
16920			   (T (COMPSTAT (CAR XPR))))
16930		     (SETQ XPR (CDR XPR))
16940		     (GO LOOP)
16950		EXITN(OUTENDTAG EXITN)
16960		     (COND ((NOT (EQ (CAAR LASTOUT) (Q JRST)))
16970			    (LOADARG PVR (Q (NIL . QT)))))
16980		EXIT (OUTENDTAG EXIT)
16990		     (INCR P2CNT)
17000		     (INCR P2CNT)
17010		     (COND ((USEDTAGP VGO)
17020			    (OUTGOTAB (CONS VGO (CDDDR GOLIST))))))
17030	       (COND (PSFLG (OUTINST (Q (PUSHJ P SPECSTR)))))
17040	       (RETURN (MARKVAL (NOT (NULL PVR)) PVR))))
17050	
17060	
17070	(DFUNC (P2PROG2 XPR VALAC TEST)
17080	 (PROG (ARGS ARG2)
17090	       (SETQ ARGS (CDR XPR))
17100	       (COND ((LESSP (LENGTH ARGS) 2) (USERERR TOFEWARGS-P2PROG2)))
17110	       (COMPSTAT (CAR ARGS))
17120	       (COND ((NULL (CDDR ARGS))
17130		      (RETURN (COMPFORM (CADR ARGS) VALAC TEST))))
17140	       (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
17150		      (SETQ ARG2 (COMPEXPR (CADR ARGS) VALAC)))
17160		     (T (COMPSTAT (CADR ARGS))))
17170	       (SETQ ARGS (CDDR ARGS))
17180	  LOOP (COND ((NULL ARGS) (RETURN (TESTJUMP ARG2 TEST))))
17190	       (COMPSTAT (CAR ARGS))
17200	       (SETQ ARGS (CDR ARGS))
17210	       (GO LOOP)))
17220	
17230	(DFUNC (P2PROGN XPR VALAC TEST)
17240	       (PROG (ARGS)
17250		     (COND ((NULL (SETQ ARGS (CDR XPR))) (RETURN NIL)))
17260		LOOP (COND ((NULL (CDR ARGS))
17270			    (RETURN (COMPFORM (CAR ARGS) VALAC TEST))))
17280		     (COMPSTAT (CAR ARGS))
17290		     (SETQ ARGS (CDR ARGS))
17300		     (GO LOOP)))
17310	
17320	(DFUNC (P2QUOTE XPR VALAC TEST)
17330	       (PROG2 (COND ((NOT (NULL TEST))
17340			     (BOOLARGS NIL
17350				       (IFIF (CAR TEST) (CADR XPR))
17360				       (CDR TEST)
17370				       NIL)))
17380		      (CONS (CADR XPR) (Q QT))))
17390	
17400	(DFUNC (P2RETURN XPR VALAC TEST)
17410	       (COND ((OR (NOT (NULL VALAC)) (NOT (NULL TEST)))
17420		      (USERERR RETURN FOR VALUE OR TEST P2RETURN))
17430		     (T	(SAVEACS)
17440			(CLRPVARS)
17450			(COND ((EQUAL (CADR XPR) (Q (QUOTE NIL))) (OUTJRST EXITN))
17460			      (T (LOADCOMP (CADR XPR) PVR) (OUTJRST EXIT))))))
17470	
17480	
17490	(DFUNC (P2RPLAC XPR VALAC TEST)
17500	       (PROG (ARG1 ARG2)
17510		     (SETQ ARG1 (COMPEXPR (CADR XPR) (FREEAC)))
17520		     (SETQ ARG2 (COMPEXPR (CADDR XPR) (FREEAC)))
17530		     (ILOC1 ARG1 VALAC)
17540		     (LOC ARG2)
17550		     (CLEARBOTH)
17560		     (COND ((EQUAL ARG2 (Q (NIL . QT)))
17570			    (OUT1 (CADR	(ASSOC (CAR XPR)
17580					       (Q ((RPLACA HRRZS@)
17590						   (RPLACD HLLZS@)))))
17600				  0
17610				  (LOC ARG1)))
17620			   (T (OUT1 (CADR (ASSOC (CAR XPR)
17630						 (Q ((RPLACA HRLM@)
17640						     (RPLACD HRRM@)))))
17650				    (PUTINAC ARG2 (FREEAC))
17660				    (LOC ARG1))))
17670		     (REMOVE ARG2)
17680		     (COND ((NULL VALAC) (REMOVE ARG1)))
17690		     (RETURN ARG1)))
17700	
17710	(DFUNC (P2SETARG XPR VALAC TEST)
17720	       (PROG (TEM)
17730		     (LOC (SETQ TEM (COMPEXPR (CADDR XPR) VALAC)))
17740		     (COND ((EQ (CAADR XPR) (Q QUOTE))
17750			    (OUT1 (Q MOVE) 2 (MINUS (ADD1 (PDLDEPTH))))
17760			    (RETURN (OUTINST (LIST (Q HRRM)
17770						   (PUTINAC TEM VALAC)
17780						   (CADADR XPR)
17790						   2)))))
17800		     (LOADCOMP (COMPEXPR (CADR XPR)) 2)
17810		     (CLEARACS)
17820		     (OUT1 (Q ADD) 2 (MINUS (ADD1 (PDLDEPTH))))
17830		     (OUTINST (LIST (Q HRRM)
17840				    (PUTINAC TEM VALAC)
17850				    (MINUS INUM0)
17860				    2))))
17870	
17880	
17890	(DFUNC (P2SETQ XPR VALAC TEST)
17900	 (PROG (NVAR VALLOC HOME VAR VAL TEM AC)
17910	       (SETQ AC (COND ((NULL VALAC) (FREEAC)) (T VALAC)))
17920	       (SETQ VAR (CADR XPR))
17930	       (SETQ VAL (COMPEXPR (CADDR XPR) AC))
17940	       (ILOC1 VAL AC)
17950	       (COND ((AND (SPECVARP VAR) (SETQ TEM (ASSOC VAR LDLST)))
17960		      (CLRSPVAR TEM)))
17970	       (REMOVE VAL)
17980	       (FREEZE VAR)
17990	       (SETQ VALLOC (LOC VAL))
18000	       (SETQ HOME (COND	((SPECVARP VAR) T)
18010				((NOT (ILOC (SETQ NVAR (CONS VAR P2CNT)) AC))
18020				 NIL)
18030				(T (NOT (DVP (SLOTCONT (LOC NVAR)))))))
18040	       (INCR P2CNT)
18050	       (COND ((AND (NULL VALAC) (NOT HOME))
18060		      (COND ((AND (NUMBERP VALLOC)
18070				  (NOT (DVP (SLOTCONT VALLOC))))
18080			     (SETSLOT VALLOC (LIST VAR))
18090			     (GO EXIT))
18100			    (T (SLOTPUSH (LIST VAR))
18110			       (OUTPUSH VALLOC)
18120			       (GO EXIT)))))
18130	       (COND ((AND HOME (EQUAL VAL (Q (NIL . QT))))
18140		      (SETQ VAL	(COND ((SPECVARP VAR) (LIST (Q SPECIAL) VAR))
18150				      (T (ILOC (CONS VAR (SUB1 P2CNT)) AC))))
18160		      (COND ((NUMBERP VAL) (SETSLOT VAL (LIST VAR))))
18170		      (COND ((OR (NULL VALAC) (DVP (SLOTCONT AC)))
18180			     (OUT1 (Q CLEARM) 0 VAL))
18190			    (T (SETSLOT AC (CONS VAR (Q DUP)))
18200			       (OUT1 (Q CLEARB) AC VAL)))
18210		      (GO EXIT)))
18220	       (COND ((OR (NOT (NUMBERP VALLOC))
18230			  (LESSP VALLOC 0)
18240			  (DVP (SLOTCONT VALLOC)))
18250		      (LOADARG AC VAL)
18260		      (SETQ VALLOC AC)))
18270	       (SETSLOT VALLOC (LIST VAR))
18280	       (COND ((SPECVARP VAR)
18290		      (COND ((ZEROP VALLOC) (OUTPOP (LIST (Q SPECIAL) VAR)))
18300			    (T (OUTMOVEM VALLOC (LIST (Q SPECIAL) VAR))))))
18310	  EXIT (RETURN (COMPFORM VAR VALAC TEST))))
18320	
18330	
18340	(DFUNC (P2STORE XPR VALAC TEST)
18350	       (PROG (TEM)
18360		     (LOC (SETQ TEM (COMPEXPR (CADDR XPR)
18370					      (COND ((NULL VALAC) (FREEAC))
18380						    (T VALAC)))))
18390		     (COMPSTAT (CADR XPR))
18400		     (LOADARG ARRAYAC TEM)
18410		     (OUTINST (Q (PUSHJ P NSTR)))
18420		     (RETURN TEM)))
18430	
18440	(DFUNC (PASS2 NAME EXPR FLAG)
18450	 (PROG (ACS PDL PDLDEPTH MINDEPTH LDLST SPECFLAG PRGSPFLG CCLST
18460		VARLIST PROGVARS PROGSW GOLIST CTAG RSL)
18470	       (SETQ P2CNT 1)
18480	       (SETQ ACS (LISTNILS NACS))
18490	       (SETQ ALLACS (SUB1 (LSH 1 NACS)))
18500	       (SETQ PDL NIL)
18510	       (SETQ PDLDEPTH (LENGTH PDL))
18520	       (SETQ MINDEPTH (PDLDEPTH))
18530	       (BINDARGS (CADR EXPR))
18540	       (COND ((NOT (ATMARGIN)) (LINEF 2)))
18550	       (OUTPSOP (LIST (Q LAP) NAME FLAG))
18560	       (COND ((EQ (CAR EXPR) (Q FSUBR))
18570		      (COND ((NOT (NULL (CDADR EXPR)))
18580			     (OUTINST (Q (PUSHJ P *AMAKE))))))
18590		     ((EQ (CAR EXPR) (Q LSUBR))
18600		      (OUTINST (Q (JSP 3 *LCALL)))
18610		      (INITPROP (Q ARG) (Q P2) (Q P2ARG))))
18620	       (SETQ SPECFLAG (SPECBIND (CADR EXPR) T))
18630	       (COND ((NOT (EQ (CAADDR EXPR) (Q PROG))) (SETQ PRGSPFLG NIL)))
18640	       (LOADCOMP (CADDR EXPR) VALUEAC)
18650	       (EXITBUM SPECFLAG)
18660	       (OUTINST (OUTINST NIL))
18670	       (COND ((EQ (CAR EXPR) (Q LSUBR)) (DELETEPROP (Q ARG) (Q P2))))
18680	       (COND (LDLST (COMPERR LDLSTLEFT-PASS2)))
18690	       (RETURN NIL)))
18700	
18710	(DFUNC (PROGTAG TAG)
18720	       (PROGN (CLEARBOTH)
18730		      (CLEARACS)
18740		      (CLRPVARS)
18750		      (RESTORE PRSSL)
18760		      (OUTTAG (EQUIVTAG TAG))))
18770	
18780	
18790	(DFUNC (PROTECTACS X)
18800	 (PROG (WHICHACS ACNO)
18810	       (SETQ WHICHACS (ACEFFECTS X))
18820	       (SETQ ACNO 0)
18830	  LOOP (SETQ ACNO (ADD1 ACNO))
18840	       (COND ((ZEROP WHICHACS) (RETURN NIL))
18850		     ((NOT (ZEROP (BOOLE 1 1 WHICHACS))) (CLEARAC ACNO)))
18860	       (SETQ WHICHACS (LSH WHICHACS -1))
18870	       (GO LOOP)))
18880	
18890	(DFUNC (PUTINAC X AC)
18900	       (PROG (Z)
18910		     (SETQ Z (LOC X))
18920		     (COND ((NOT (ACNUMP Z)) (LOADARG (SETQ Z AC) X)))
18930		     (REMOVE X)
18940		     (CPUSH Z)
18950		     (RETURN Z)))
18960	
18970	(DFUNC (REMOVE DATA)
18980	       (PROG (TEM)
18990		     (SETQ TEM (GETPROP (Q LDLST) (Q VALUE)))
19000		LOOP (COND ((NULL (CDR TEM)) (RETURN NIL)))
19010		     (COND ((EQUAL (CADR TEM) DATA) (RPLACD TEM (CDDR TEM)))
19020			   (T (SETQ TEM (CDR TEM))))
19030		     (GO LOOP)))
19040	
19050	
19060	(DFUNC (RESTORE OLDPDL)
19070	 (PROG (C V R TEM OLDDEPTH DEPTHDIF)
19080	       (SETQ OLDDEPTH (LENGTH OLDPDL))
19090	       (COND ((GREATERP OLDDEPTH (PDLDEPTH))
19100		      (PRINTMSG (LIST OLDPDL PDL))
19110		      (COMPERR PDLSHORT-RESTORE)))
19120	  A1   (SETQ C 0)
19130	  A    (COND ((EQUAL OLDDEPTH (PDLDEPTH)) (RETURN (SHRINKPDL C)))
19140		     ((DVP (SETQ R (CAR PDL))) (GO CPP)))
19150	       (SETQ C (ADD1 C))
19160	       (SLOTPOP)
19170	       (GO A)
19180	  CPP  (SHRINKPDL C)
19190	  CPP1 (SETQ V OLDPDL)
19200	       (SETQ C 0)
19210	       (SETQ DEPTHDIF (*DIF (PDLDEPTH) OLDDEPTH))
19220	  CPP3 (COND ((NULL V) (SETQ V (FINDFREEAC))
19230			       (COND ((NULL V) (COMPERR NOAC-RESTORE)))
19240			       (SETSLOT V R)
19250			       (OUTPOP V)
19260			       (GO A1))
19270		     ((AND (CAR V)
19280			   (EQ (CAAR V) (CAR R))
19290			   (NOT	(DVP (SLOTCONT (SETQ TEM
19300						(MINUS (PLUS C
19310							     DEPTHDIF)))))))
19320		      (GO CPP2)))
19330	       (SETQ C (ADD1 C))
19340	       (SETQ V (CDR V))
19350	       (GO CPP3)
19360	  CPP2 (SETSLOT TEM R)
19370	       (OUTPOP TEM)
19380	       (GO A1)))
19390	
19400	(DFUNC (RSLSET X)
19410	 (COND ((EQ X CTAG)
19420		(SETQ RSL (COND	((AND RSL
19430				      (NOT (AND	(EQUAL (CAR RSL) ACS)
19440						(EQUAL (CADR RSL) PDL))))
19450				 (Q LOSE))
19460				(T (LIST (TOPCOPY ACS) (TOPCOPY PDL))))))))
19470	
19480	(DFUNC (RST TAG)
19490	 (COND ((NULL TAG) NIL)
19500	       ((ASSOCR TAG GOLIST) (RESTORE PRSSL))
19510	       ((REMPROP TAG (Q SET)) (SAVEACS)
19520				      (PUTPROP TAG (TOPCOPY PDL) (Q LEVEL))
19530				      (SETQ MINDEPTH (PDLDEPTH)))
19540	       ((SETQ TAG (SEEKPROP TAG (Q LEVEL))) (RESTORE (PROPVAL TAG)))
19550	       (T (COMPERR NIL-RST))))
19560	
19570	
19580	(DFUNC (SAVEACS)
19590	       (PROG (K)
19600		     (SETQ K 0)
19610		LOOP (COND ((EQ K NACS) (RETURN NIL)))
19620		     (CPUSH (SETQ K (ADD1 K)))
19630		     (GO LOOP)))
19640	
19650	(DFUNC (SETSLOT X Y) (RPLACA (GETSLOT X) Y))
19660	
19670	(DFUNC (SHRINKPDL C)
19680	       (COND ((NOT (ZEROP C))
19690		      (OUTINST (LIST (Q SUB) (Q P) (GENCONST 0 0 C C 0))))))
19700	
19710	(DFUNC (SIDEEFFECTS FUN) (NOT (HASPROP FUN (Q ACS))))
19720	
19730	(DFUNC (SLOTCONT X) (CAR (GETSLOT X)))
19740	
19750	(DFUNC (SLOTPOP)
19760	       (PROGN (SETQ PDLDEPTH (SUB1 PDLDEPTH)) (SETQ PDL (CDR PDL))))
19770	
19780	(DFUNC (SLOTPUSH SC)
19790	 (PROGN (SETQ PDLDEPTH (ADD1 PDLDEPTH)) (SETQ PDL (CONS SC PDL))))
19800	
19810	(DFUNC (SPECBIND VARS LAMBDAP)
19820	       (PROG (ACNUM SPFLG)
19830		     (SETQ ACNUM 1)
19840		LOOP (COND ((NULL VARS) (RETURN SPFLG)))
19850		     (COND ((NOT (SPECVARP (CAR VARS))) (GO ELOOP)))
19860		     (COND ((NOT PRGSPFLG) (SETQ PRGSPFLG (SETQ SPFLG T))
19870					   (OUTINST (Q (JSP 6 SPECBIND)))))
19880		     (OUTINST (LIST 0
19890				    (COND (LAMBDAP ACNUM) (T 0))
19900				    (LIST (Q SPECIAL) (CAR VARS))))
19910		ELOOP(SETQ ACNUM (ADD1 ACNUM))
19920		     (SETQ VARS (CDR VARS))
19930		     (GO LOOP)))
19940	
19950	(DFUNC (SPECVARP VAR) (MEMBER VAR SPECVARS))
19960	
19970	
19980	(DFUNC (TESTJUMP ITEM TEST)
19990	       (PROG (AC FLAG TAG)
20000		     (COND ((NULL TEST) (RETURN ITEM)))
20010		     (SETQ FLAG (CAR TEST))
20020		     (SETQ TAG (CDR TEST))
20030		     (SETQ AC (PUTINAC ITEM (FREEAC)))
20040		     (OUTCJMP FLAG AC TAG)
20050		     (COND (FLAG (RSLSET TAG) (SETSLOT AC (Q (NIL . QT))))
20060			   (T (SETQ FLAG (SLOTCONT AC))
20070			      (SETSLOT AC (Q (NIL . QT)))
20080			      (RSLSET TAG)
20090			      (SETSLOT AC FLAG)))
20100		     (RETURN ITEM)))
20110	
20120	(DFUNC (TRANSOUT OP AC AD)
20130	 (PROG (TEM IND)
20140	       (COND ((OR (ATOM AD) (ATOM (CAR AD))) (GO DONE)))
20150	       (SETQ AD (CAR AD))
20160	       (COND ((SETQ TEM (SEEKPROP OP (Q IMMED)))
20170		      (SETQ OP (PROPVAL TEM))
20180		      (GO DONE)))
20190	       (SETQ AD (GENCONST 0 0 AD 0 0))
20200	  DONE (SETQ IND (COND ((OR (NOT (NUMBERP AD)) (GREATERP AD 0)) NIL)
20210			       (T (LIST (Q P)))))
20220	       (RETURN (MCONS OP AC AD IND))))
20230	
20240	(DFUNC (USEDTAGP TAG) (HASPROP TAG (Q USED)))
20250	
20260	(MAPDEF PASS2 (EXPR CALLSUBR) (SUBR CALLSUBR) (*SUBR CALLSUBR)
20270		      (*UNDEF CALLSUBR) (LSUBR CALLLSUBR) (*LSUBR CALLLSUBR)
20280		      (FEXPR CALLFSUBR) (FSUBR CALLFSUBR) (*FSUBR CALLFSUBR)
20290		      (FUNVAR CALLFUNARGS) (CARCDR P2CARCDR)
20300		      (P2BOOL DOP2BOOL) (P2ELSE DOP2ELSE) (P2VAL DOP2VAL))
20310	
20320	(MAPDEF P2BOOL (AND BOOLAND) (NULL BOOLNULL) (OR BOOLOR))
20330	
20340	(MAPDEF P2ELSE (EQ BOOLEQ) (GO P2GO) (QUOTE P2QUOTE) (PROG2 P2PROG2)
20350		       (RETURN P2RETURN) (SETQ P2SETQ))
20360	
20370	(MAPDEF P2VAL (ARG P2ARG) (*EVAL P2*EVAL) (COND P2COND) (PROG P2PROG)
20380		      (PROGN P2PROGN) (RETURN P2RETURN) (RPLACA P2RPLAC)
20390		      (RPLACD P2RPLAC) (SETARG P2SETARG) (STORE P2STORE))
20400	
20410	(SETQ CARCDRDEPTH 4)
20420	
20430	
20440	(PROG (BASE COUNT LIMIT MIDDLE NAME)
20450	      (SETQ BASE 2)
20460	      (SETQ LIMIT (SUB1 (LSH 1 (ADD1 CARCDRDEPTH))))
20470	      (SETQ COUNT (LSH 1 1))
20480	 LOOP (COND ((GREATERP COUNT LIMIT) (RETURN NIL)))
20490	      (SETQ MIDDLE (SUBST (QUOTE A)
20500				  0
20510				  (SUBST (QUOTE D) 1 (CDR (EXPLODE COUNT)))))
20520	      (SETQ NAME (READLIST (APPEND (QUOTE (C)) MIDDLE (QUOTE (R)))))
20530	      (PUTPROP NAME
20540		       (CONS (CAR MIDDLE)
20550			     (COND ((CDR MIDDLE)
20560				    (READLIST (APPEND (QUOTE (C))
20570						      (CDR MIDDLE)
20580						      (QUOTE (R)))))))
20590		       (QUOTE CARCDR))
20600	      (SETQ COUNT (ADD1 COUNT))
20610	      (GO LOOP))
20620	
20630	(MAPDEF ACS (*APPEND 37) (ATOM 1) (CONS 3) (GENSYM 7) (GET 1)
20640		    (LAST 3) (LENGTH 7) (MEMBER 37) (NCONS 3) (XCONS 3))
20650	
20660	(MAPDEF COMMU (CONS XCONS) (EQUAL EQUAL) (*GREAT *LESS)
20670		      (*LESS *GREAT) (*PLUS *PLUS) (*TIMES *TIMES))
20680	
20690	(MAPDEF IMMED (CAME CAIE) (CAMN CAIN) (HLLZS@ HLLZS) (HLRZ@ HLRZ)
20700		      (HRLM@ HRLM) (HRRM@ HRRM) (HRRZ@ HRRZ) (HRRZS@ HRRZS)
20710		      (MOVE MOVEI))
20720	
20730	(SETQ NACS 5)
20740	
20750	(SETQ VALUEAC 1)
20760	
20770	(SETQ FARGAC 1)
20780	
20790	(SETQ GOTABAC 1)
20800	
20810	(SETQ ARRAYAC 1)
20820	
20830	(SETQ INUM0 (MAKNUM 0 (QUOTE FIXNUM)))
20840	
20850	(ENDBLOCK PASS2)
20860	
20870	(BEGINBLOCK DEBUG)
20880	
20890	
20900	(DFUNC (CMPBREAK TYPE MESSAGE)
20910	       (PROG NIL
20920		     (INC NIL T)
20930		     (OUTC NIL T)
20940		     (COND ((ATMARGIN) (LINEF 1)) (T (LINEF 2)))
20950		     (PRINL (APPEND TYPE MESSAGE))
20960		     (LINEF 1)
20970		LOOP (COND ((EQUAL (ERRSET (EVALREAD)) (Q (PROCEED)))
20980			    (RETURN (Q DONE))))
20990		     (GO LOOP)))
21000	
21010	(DEFPROP COMPERR
21020		 (LAMBDA (L) (CMPBREAK (Q (*COMPILER ERROR*)) L))
21030		 FEXPR)
21040	
21050	(DFUNC (EVALREAD)
21060	       (PROG (EX)
21070		     (LINEF 1)
21080		     (SETQ EX (READ))
21090		     (PRINC *SP)
21100		     (RETURN (PRINC (EVAL EX)))))
21110	
21120	(DFUNC (LAPNOTES) (COPY (MAPCAR (FUNCTION EVAL) TRACELIST)))
21130	
21140	(DEFPROP USERERR (LAMBDA (L) (CMPBREAK (Q (*USER ERROR*)) L)) FEXPR)
21150	
21160	(SETQ TRACELIST NIL)
21170	
21180	(ENDBLOCK DEBUG)
21190	
21200	(BEGINBLOCK IO)
21210	
21220	(DFUNC (ATMARGIN) (EQ (CHRCT) (LINELENGTH NIL)))
21230	
21240	(DFUNC (CARRETN) (COND ((NOT (ATMARGIN)) (LINEF 1))))
21250	
21260	(DFUNC (CURCOL) (*DIF (ADD1 (LINELENGTH NIL)) (CHRCT)))
21270	
21280	(DFUNC (FORMF) (PROGN (PRINC *FF) (SETQ LINCNT PAGEHEIGHT)))
21290	
21300	(DFUNC (LINEF N)
21310	       (PROG NIL
21320		LOOP (COND ((ZEROP N) (RETURN NIL)))
21330		     (TERPRI)
21340		     (SETQ N (SUB1 N))
21350		     (GO LOOP)))
21360	
21370	(DFUNC (PRINL L) (MAPC (FUNCTION PRINS) L))
21380	
21390	
21400	(DFUNC (PRINS FN)
21410	 (PROG2	(COND ((GREATERP (ADD1 (FLATSIZE FN)) (CHRCT)) (LINEF 1)))
21420		(PRINTEXPR FN)))
21430	
21440	(DFUNC (PRINTEXPR XPR) (PROG2 (PRIN1 XPR) (PRINC *SP)))
21450	
21460	(DFUNC (PRINTN CHAR NUM)
21470	       (PROG (NO)
21480		     (SETQ NO 1)
21490		LOOP (COND ((LESSP NUM NO) (RETURN NUM)))
21500		     (PRINC CHAR)
21510		     (SETQ NO (ADD1 NO))
21520		     (GO LOOP)))
21530	
21540	(DFUNC (PRINTSTAT STAT)
21550	 (PROG2 (COND ((NULL STAT) (CARRETN) (TABTO 10))
21560		      ((ATOM STAT) (TABTO 2))
21570		      ((EQ (CAR STAT) (Q LAP)) (TABTO 1))
21580		      (T (TABTO 10)))
21590		(PRINTEXPR STAT)))
21600	
21610	(DFUNC (TABTO COL)
21620	 (PROGN	(COND ((GREATERP (CURCOL) COL) (LINEF 1)))
21630		(PRINTN	*TB
21640			(*DIF (LSH (SUB1 COL) -3) (LSH (SUB1 (CURCOL)) -3)))
21650		(PRINTN *SP (*DIF COL (CURCOL)))))
21660	
21670	
21680	(MAPCAR	(FUNCTION (LAMBDA (PAIR)
21690				  (PROG2 (SET (CAR PAIR)
21700					      (INTERN (ASCII (CADR PAIR))))
21710					 (CAR PAIR))))
21720		(QUOTE ((*SP 40) (*TB 11)
21730				 (*CR 15)
21740				 (*LF 12)
21750				 (*VT 13)
21760				 (*FF 14)
21770				 (*CO 54)
21780				 (*PT 56)
21790				 (*LP 50)
21800				 (*RP 51)
21810				 (*SL 57)
21820				 (*AM 33)
21830				 (*AT 100)
21840				 (*RO 177)
21850				 (*COLON 72))))
21860	
21870	(SETQ LINCNT 0)
21880	
21890	(SETQ PAGEHEIGHT 74)
21900	
21910	(SETQ PAGEWIDTH 120)
21920	
21930	(ENDBLOCK IO)
21940	
21950	(BEGINBLOCK GENERAL)
21960	
21970	(DFUNC (ADDTOLIST X Y) (COND ((MEMBER X Y) Y) (T (CONS X Y))))
21980	
21990	(DFUNC (ASSOCR X Y)
22000	       (PROG NIL
22010		LOOP (COND ((NULL Y) (RETURN NIL))
22020			   ((EQ X (CDAR Y)) (RETURN (CAR Y))))
22030		     (SETQ Y (CDR Y))
22040		     (GO LOOP)))
22050	
22060	(DFUNC (CONSTANTP XPR) (OR (NUMBERP XPR) (MEMBER XPR (Q (T NIL)))))
22070	
22080	(DFUNC (COPY EX) (SUBST 0 0 EX))
22090	
22100	(DFUNC (DEINITSYM NAME) (DELETEPROP NAME (Q SYMNO)))
22110	
22120	(DFUNC (FSUBRP FUN) (GETL FUN (Q (FEXPR *FSUBR FSUBR))))
22130	
22140	
22150	(DFUNC (GETGET ATOM PROP)
22160	       (PROG (TEM PTAB)
22170		     (SETQ PTAB (FIRSTPROP ATOM))
22180		LOOP (COND ((LASTPROP PTAB) (RETURN NIL)))
22190		     (COND ((SETQ TEM (SEEKPROP (PROPNAM PTAB) PROP))
22200			    (RETURN TEM)))
22210		     (SETQ PTAB (NEXTPROP PTAB))
22220		     (GO LOOP)))
22230	
22240	(DFUNC (LSUBRP FUN) (GETL FUN (Q (LSUBR *LSUBR))))
22250	
22260	(DFUNC (MAKESPECIAL VAR)
22270	       (PROGN (COND ((HASPROP VAR (Q LOCAL))
22280			     (PRINTMSG (CONS VAR (Q (LOCAL AND SPECIAL))))))
22290		      (SETPROP VAR (Q SPECIAL) T)
22300		      VAR))
22310	
22320	(DFUNC (MAKESYM IDENT NUMBER)
22330	 (PROG (*NOPOINT)
22340	       (SETQ *NOPOINT T)
22350	       (RETURN (MAKNAM (APPEND (EXPLODE IDENT) (EXPLODE NUMBER))))))
22360	
22370	(DFUNC (MAKEUNSPECIAL VAR) (COND ((REMPROP VAR (Q SPECIAL)) VAR)))
22380	
22390	(DEFPROP NEXTSYM
22400		 (LAMBDA (NAME)
22410			 (PROG (NUM)
22420			       (SETQ NUM (GETPROP (CAR NAME) (Q SYMNO)))
22430			       (PUTPROP (CAR NAME) (ADD1 NUM) (Q SYMNO))
22440			       (RETURN (MAKESYM (CAR NAME) NUM))))
22450		 FEXPR)
22460	
22470	(DFUNC (NTHCDR NUM EXP)
22480	       (PROG NIL
22490		     (COND ((MINUSP NUM) (COMPERR NEGNUM-NTHCDR)))
22500		LOOP (COND ((ZEROP NUM) (RETURN EXP)))
22510		     (COND ((ATOM EXP) (COMPERR ATOM-NTHCDR)))
22520		     (SETQ EXP (CDR EXP))
22530		     (SETQ NUM (SUB1 NUM))
22540		     (GO LOOP)))
22550	
22560	(DEFPROP PROGN (LAMBDA L (ARG L)) EXPR)
22570	
22580	(DEFPROP STARTSYM
22590		 (LAMBDA (SYMS)
22600			 (PROG NIL
22610			  LOOP (COND ((NULL SYMS) (RETURN NIL)))
22620			       (INITPROP (CAR SYMS) (Q SYMNO) 1)
22630			       (SETQ SYMS (CDR SYMS))
22640			       (GO LOOP)))
22650		 FEXPR)
22660	
22670	
22680	(DEFPROP STOPSYM
22690		 (LAMBDA (SYMS)
22700			 (PROG NIL
22710			  LOOP (COND ((NULL SYMS) (RETURN NIL)))
22720			       (DELETEPROP (CAR SYMS) (Q SYMNO))
22730			       (SETQ SYMS (CDR SYMS))
22740			       (GO LOOP)))
22750		 FEXPR)
22760	
22770	(DFUNC (SUBRP FUN) (GETL FUN (Q (EXPR SUBR ARRAY *SUBR *UNDEF))))
22780	
22790	(DFUNC (TOPCOPY SXP) (APPEND SXP NIL))
22800	
22810	(ENDBLOCK GENERAL)
22820	
22830	(ENDBLOCK COMPILER)
22840