perm filename BAIL.SAI[X,AIL]3 blob sn#197163 filedate 1976-01-16 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00035 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002
C00005 00003	Data Structures Used by BAIL
C00017 00004	ENTRY BAIL,B!
C00031 00005	# MEMSTRING CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTEND NONULL PDFIND ADDSTR ADDCHR DUMPSTR
C00039 00006	# WRITEON PACKAGE
C00047 00007	# OPERATOR CODES, REFITEM TYPE DEFINITIONS
C00062 00008	# TYPEMUNGE
C00068 00009	# INSERT
C00070 00010	# FIND
C00079 00011	# CVNAME PREDEC
C00081 00012	# STBAIL
C00091 00013	
C00099 00014	# SUPER OUTER BLOCK, FOR PREDECLARED STUFF
C00111 00015	# LINED DBANG !!EQU EVALERR
C00117 00016	# GET!TOKEN
C00120 00017	# INTARRAY, CRD!PC, FTEXT, SHOW, CRDFND, GETTEXT
C00129 00018	# N!PARAMS, HELP
C00131 00019	# CVINTEGR, CVREAL, CVSTRNG
C00134 00020	# INCOR
C00145 00021	# GETLSCOPE, PRLSCOPE
C00149 00022	# GETDSCOPE,PRDSCOPE
C00155 00023	# TFIND,BREAK1,SWAP!BREAKS,PLANT!BREAKS,UNPLANT!BREAKS,LOC!PC,BREAK,COORD,TRAPS
C00166 00024	# PRARGS, TRACER, TRACE
C00173 00025	# UNBREAK1,UNBREAK,UNTRACE,CLRTBK,STEPPING
C00183 00026	# BAILOR,!!TEXT,!!ARGS,EVAL,PSH,OPPSH,SETLEX,X1TEMP,X1TEMP,NEWTEMP,NEWSTRTEMP
C00188 00027	# EVAL1
C00194 00028	# INTERPRETATION OF OPERATORS
C00201 00029
C00209 00030	$COMMA:	BEGIN
C00215 00031	$ARRYREF:BEGIN
C00222 00032	# $MEMRY,$DATUM,$SWAP,$GETS,$SUBFLD,$AR,$APPLY,$CPRINT,$PRINT
C00232 00033	# PARSER
C00240 00034	# !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV
C00250 00035	# BAIL,UBINIT,DDBAIL,B!
C00261 ENDMK
C⊗;
COMMENT








		BAIL -- A DEBUGGER FOR SAIL

			by

		John F. Reiser
		Computer Science Department
		Stanford University
		Stanford, California 94305







		January 1976



	This work was supported in part by a National Science Foundation Graduate
Fellowship.  Computer facilities provided by the Stanford Artificial Intelligence
Laboratory and the Institute for Mathematical Studies in the Social Sciences,
Stanford.
;
COMMENT Data Structures Used by BAIL

I.  The .SM1 file
	This file is produced by the compiler.  It corresponds in a rough way
	to a .REL file, except that is has information for the debugger rather
	than for the loader.  The file is a sequence of tables.  Each table 
	begins with a word containing a non-zero number which indicates the
	type of the table.  Following this are an arbitrary number of words,
	and then a word which is zero.  Then comes the identifying number for
	the next table, and so on.  The end of the file is indicated by a 	
	table number of -1.

	The current table types are  BAIFIL [1],  BAICRD [2],  and BAIBLK [3],
	and BAIPRC [4].

    A. BAIFIL -- text file (source/listing) name
	The format of the table is:
		XWD	file #, # of words which follow
	NOTENX<
		SIXBIT	/device/
		SIXBIT	/name/
		SIXBIT	/extension/
		SIXBIT	/ppn/	>.,NOTENX
	TENX<
		ASCII	/<string returned by JFNS>/	>.,TENX

    B. BAICRD -- coordinate to text index
	This table contains two words for each coordinate of the source program.
	[The coordinate counter starts at zero for each compilation and is 
	increased by one for each semicolon and ELSE seen by the parser,
	provided that some code has been generated since the previous coordinate.
	The semicolons of COMMENTs and DEFINEs are ignored in this counting.]
	The words specify where the text for the coordinate is located, the
	address of the first word of code for the coordinate, and whether the
	accumulators have any carry-over information from the previous coordinate.

	BYTE	(6)<byte pointer "P">, (5)<file #>, (7)<word #>, (18)<USETI #>
	BYTE	(1)<ALLSTO>, (17)<coordinate #>, (18)<address of code>

    C. BAIBLK -- block structure and symbol information
	This table contains information on a block, followed by 
	information describing the symbols declared inside that block.
	The tables for the various blocks of a compilation occur in the
	order in which their ENDs were seen--i.e., inner-most block first.

	BYTE	(18)<coord #>, (1)0, (11)<DDT level>, (6)<# of words in name>
	BYTE	(18)<last word of code>, (18)<first word of code>
	ASCII	/name of block/

	For each symbol:
	BYTE	(18)0, (12)<DDT level>, (6)<# of words in name>
	BYTE	(36)<pre-REFITEM datum for this symbol>
	ASCII	/name of symbol/

    D. BAIPRC -- procedure and parameter information
	This table is very similar to a BAIBLK table, except that there is one
	more word for the type bits and the pda of the procedure.

	BYTE	(18)<coord #>, (1)1, (11)<DDT level>, (6)<# of words in name>
	BYTE	(18)<location of last word of code>, (18)<pcnt at prdec>
	BYTE	(18)<type bits for procedure>, (18)<pda>
	ASCII	/name of procedure/

	For each parameter:
	BYTE	(18)0, (12)<DDT level>, (6)<# of words in name>
	BYTE	(36)<pre-REFITEM datum for this symbol>
	ASCII	/name of symbol/

II. The .BAI file
	The first disk block of the .BAI file is a header index block.
	WORD	MEANING
	0-7	unused
	8	USETI pointer to beginning of T!CRDIDX
	9	CRDCTR,,N!CRDIDX
	10	USETI pointer to beginning of T!BLKADR
	11	N!BLKADR
	12	USETI pointer to beginning of T!NAME
	13	N!NAME
	14	USETI pointer to text file names
	15	N!TXTFIL,,# of words taken up by names
	16-127	unused

III. Runtime data structures

    A. The NAME table.
	All symbols known to BAIL are kept in the NAME table.  This is a hash
	table of 31 buckets, with collisions resolved by separate chaining.
	Since its ultimate size is not known until it has been constructed,
	is is maintained as a MEMORY-LOCATION type table, constructed out
	of a CORGET block.  All pointers are relative to the zero-th location
	of the CORGET block.

	0: BYTE	(2)<type>, (16)<father>, (18)<next symbol in this bucket>
	1: BYTE	(36)<REFITEM datum>
	2: ASCI3	/name/		.,three words, zero fill

	The twenty most recently referenced symbols are kept in the CACHE
	to try to speed things up.  The cache is maintained by the "climb"
	algorithm--when referenced, a symbol is exchanged with the one
	above it in the table, thus the most commonly used symbols appear
	towards the top of the table.  An entry in the CACHE is the same
	as an entry in the NAME table, except that the <next symbol> pointer
	is replaced with the first word address of the block which you
	must be in to make the cache entry valid.  [Think about homonyms.]

    B. The block locator table BLKADR
	This table contains two words for every block and procedure, and
	enables one to determine the block structure corresponding to
	an arbitrary address.  This is a linear table in a CORGET block.

	0: BYTE	(18)<father (in BLKADR)>, (18)<pointer to NAME table>
	1: BYTE	(18)<last word of code>, (18)<first word of code>

    C. The coordinate index CRDIDX
	The whole coordinate table is likely to be very large, so it is
	kept on disk and only an index is kept in core.  Since displaying
	the source text requires a disk access anyway, we might as well
	perform two of them--one to get the right coordinate pointer,
	and one to read the text.  The table CRDIDX contains the first
	word of every 64-th coordinate pointer. This is a linear table
	kept in a CORGET block, and the index of an entry directly 
	corresponds to the disk block of the .BAI file which contains
	the full 64-coordinate section of the table.

	BYTE	(1)<ALLSTO>, (17)<coord #>, (18)<core address>

    D. The BALNK loader link block
	This block is generated in the data portion of the code.  It 
	contains relocation information and the name of the .SM1 file.
	It is in the data portion since the loader linked chain must be
	reversed before BAIL can use it.

		<link word>
		XWD	<high-segment one>,<low-segment one>
		XWD	<0 for user, 1 for runtimes>,<# of words which follow>
	NOTENX<
		SIXBIT	/<.SM1 file name>/	>.,NOTENX
	TENX<
		ASCII	/<string returned by JFNS for .SM1 file name>/	>.,TENX

    E. Descriptors ("refitems")
	Each object known to BAIL is described by one word which has the
	format of the datum of a reference item.  No items are actually used,
	but the bits mean the same thing.  These bits are:

	bit		    name		meaning
	0	400000,,0   TEMPB	simple procedure or defaultable parameter
	1	200000,,0   REFB	effective address is not a temp location
	2	100000,,0   QUESB	? itemvar
	3	 40000,,0   BINDB	binding itemvar
	4	 20000,,0   PROCB	procedure. addr is pda (entry if simple)
	5	 10000,,0   ITEMB	item or itemvar
	6	  4000,,0   ARY2B	λ array itemvar array
	7-12	  3740,,0		type code, same as leap datum type (TYPEIT)
	13-35	    37,,-1		effective address.  indirect and index
					fields used mostly to indicate arrays or
					parameters to procedures

  IV.  The symbols for SAIL predeclared runtimes

	The SAIL predeclared runtimes can be made known to BAIL.  This requires
	that procedure descriptors for the runtimes be loaded.  The procedure
	descriptors are created by the following process.

	.EXEC RTRAN.SAI
	*JUNK←PROD,FOO2			.,edit FOO2 first to get rid of anything
					., not in your SAIL segment.
	*↑C
	.DEL JUNK
	.COM BPDAHD.FAI+BAIPD8.FAI	.,result is BAIPD8.REL, the procedure descriptors
	.EXEC %Y BSM1HD.FAI+BAISM1.FAI	.,result is BAIPD8.SM1, the symbols
	.COPY SYS:BAIPD8.SM1←BAIPD8.SM1	.,residence of the symbol table file
	.COPY SYS:BAIPD8.REL←BAIPD8.REL	.,residence of relocatable for descriptors

ENDCOMMENT ;
ENTRY BAIL,B!;
BEGIN "BILGE" 
REQUIRE "[][]" DELIMITERS;
REQUIRE 64 STRING!PDL; COMMENT STANDARD IS 40;

LET DEFINE=REDEFINE;

COMMENT INSTALLATION DEPENDENT MACROS AND SETTINGS.
	STANFORD	sets STANFO on, DEC off
	DEC		sets STANFO off, DEC on
	TENEX		taken care of automatically by testing for GTJFN;
IFCR DECLARATION(GTJFN)
    THENC DEFINE TENX(A)=[A], NOTENX(A)=[], STANFO(A)=[], DEC(A)=[];
    ELSEC DEFINE TENX(A)=[], NOTENX(A)=[A]; ENDC;
NOTENX([  DEFINE DEC(A)=[A], STANFO(A)=[];	])

STANFO([	DEFINE CH!SETC=['176];	COMMENT RIGHT BRACE;
	DEFINE CORE!IMAGE!EXTENSION=[".DMP"];
	REQUIRE "
STANFORD VERSION" MESSAGE;
])
DEC([	DEFINE CH!SETC=['175];
	DEFINE CORE!IMAGE!EXTENSION=[".SAV"];
	REQUIRE "
DEC TOPS-10 VERSION" MESSAGE;
])
TENX([	DEFINE CH!SETC=['175];
	DEFINE CORE!IMAGE!EXTENSION=[".SAV"];
	REQUIRE "
TENX VERSION" MESSAGE;
])


DEFINE HAND(A)=[A], NOHAND(A)=[];
DEFINE FUTURE(A)=[],PAST(A)=[];
DEFINE UPTO=[STEP 1 UNTIL], #=[COMMENT], CRLF=[('15 & '12)], LF=['12],TAB=['11];
DEFINE SUPERCOMMENT(A)=[];
DEFINE CHECK(A)=[NOW!UNSAFE A],NOCHECK(A)=[NOW!SAFE A];
DEFINE MEMLOC(A,B)=[MEMORY[LOCATION(A),B]];
DEFINE LEFT(A)=[((A) LSH -18)], RIGHT(A)=[((A) LAND '777777)];
DEFINE	P=['17], SP=['16],
    ATJRST=['254020000000],ARERR=['007000000000],FIX=['003000000000];
DEFINE JRSTF=['254100000000],!JBDDT=['74],!JBOPC=['130],!JBSYM=['116],
    !JBHRL=['115],HALT=[JRST 4,];
DEFINE PD!NPW=[4],PD!DSP=[5],PD!DLW=[7],PD!PPD=['11],PD!PCW=['12];
EXTERNAL INTEGER !SKIP!,!ERRP!,!ERRJ!,BALNK;
INTEGER !RECOVERY!,#ERRP#,#SKIP#;
EXTERNAL INTEGER PDLNK;
EXTERNAL INTEGER ARRAY GOGTAB[0:'300];
REQUIRE NOTENX(["SYS:GOGTAB.DEF"]) TENX(["<SAIL>GOGTAB.DEF"]) SOURCE!FILE;
SUPERCOMMENT([
	# ABOVE REQUIRE IS MOSTLY A TEST OF THE NEW WAY TO DO AWAY WITH USERCON.
	  GOGTAB.DEF IS PRODUCED BY SCISS WHEN A NEW LIBRARY IS MADE, AND CONTAINS
	  DEFINITIONS OF THE USER TABLE ENTRY NAMES AND THEIR VALUES. IF THE FILE
	  IS NOT AROUND, TRY THESE:
    DEFINE REMCHR=['12],TOPBYT=['11],UUO1=['0],BKTPRV=['34];
    STANFO([DEFINE RACS=['135],BAILOC=['243];])
    DEC([DEFINE RACS=['133],BAILOC=['241];])
    TENX([DEFINE RACS=['133],BAILOC=['246];])
]) # END SUPERCOMMENT;
EXTERNAL RECORD!CLASS $CLASS(INTEGER RECRNG,HNDLER,RECSIZ;
    INTEGER ARRAY TYPARR; STRING ARRAY TXTARR);

SIMPLE PROCEDURE FATAL(STRING A); USERERR(0,0,A);
SIMPLE PROCEDURE NONFATAL(STRING A); USERERR(0,1,A);

NOTENX([
DEFINE CFILE(A)="RELEASE(A)";

SIMPLE INTEGER PROCEDURE OPENFILE(STRING FILNAM,MODES); BEGIN "OPENFILE"
COMMENT EMULATION OF TENEX-SAIL RUNTIME, AS FAR AS POSSIBLE;
EXTERNAL INTEGER !SKIP!;
INTEGER CHN,FLAG,R,W,E,T; LABEL BAD; STRING DEV;
IF (CHN←GETCHAN)<0 THEN GOTO BAD; DEV←"DSK";
START!CODE LABEL LOOP1,LOOP2,TEST1,TEST2,USEDFLT;
	SETZB	1,2;		# R,W;
	SETZM	E;
	HRRZ	3,-1(SP);	# LENGTH(MODES);
	JRST	TEST1;
    LOOP1:ILDB	4,(SP);
	CAIN	4,"R";
	 MOVEI	1,2(1);
	CAIN	4,"W";
	 MOVEI	2,2(2);
	CAIN	4,"E";
	 SETOM	E;
    TEST1:SOJGE	3,LOOP1;
	MOVEM	1,R;
	MOVEM	2,W;

	HRRZ	1,-3(SP);	# LENGH(FILNAM);
	MOVE	2,-2(SP);	# BP;
	JRST	TEST2;
    LOOP2:ILDB	3,2;
	CAIE	3,":";
    TEST2:SOJGE	1,LOOP2;
	JUMPL	1,USEDFLT;	# NO COLON, USE DEFAULT;
	EXCH	1,-3(SP);	# 1←ORIG LEN, -3(SP)←LEN OF NAME;
	EXCH	2,-2(SP);	# 2←DEV BP, -2(SP)←NAME BP;
	MOVEI	3,DEV;
	MOVEM	2,(3);		# DEVICE BP TO CORE;
	SUB	1,-3(SP);	# LEN+1 OF DEV=ORIG LEN - LEN OF NAME;
	SUBI	1,1;		# CORRECT FOR COLON;
	MOVEM	1,-1(3);	# LENGTH TO CORE;
    USEDFLT:SETZM FLAG;
	END;
OPEN(CHN,DEV,'10,R,W,E,FLAG,FLAG); IF FLAG THEN GOTO BAD;
IF W THEN ENTER(CHN,FILNAM,!SKIP!) ELSE
IF R THEN LOOKUP(CHN,FILNAM,!SKIP!);
RETURN(CHN);
BAD:	CFILE(CHN); RETURN(!SKIP!←TRUE);
END "OPENFILE";
]);	# NOTENX;

TENX([	DEFINE USETOUT(CHAN,BLOCK)=[USETO(CHAN,BLOCK)],
		USETIN(CHAN,BLOCK)=[USETI(CHAN,BLOCK)];
]) # TENX;
NOTENX([
STANFO([	DEFINE USETOUT(CHAN,BLOCK)=[USETO(CHAN,BLOCK)],
			USETIN(CHAN,BLOCK)=[USETI(CHAN,BLOCK)];
]);	# STANFO;
DEC([
SIMPLE PROCEDURE USETOUT(INTEGER CHAN,BLOCK); BEGIN
START!CODE
	HRLZ	1,CHAN;
	LSH	1,5;
	TLO	1,'067000;		# MAKE AN "OUTPUT" INSTRUCTION;
	XCT	1;		# FORCE OUT PARTIAL BUFFER;
END;
USETO(CHAN,BLOCK); END;
SIMPLE PROCEDURE USETIN(INTEGER CHAN,BLOCK); BEGIN
# THIS IS MORE COMPLICATED, SINCE WE MAY HAVE TO FLUSH SEVERAL BUFFERS;
START!CODE
DEFINE ICOWNT=['12],BUFHED=[2];	LABEL TOPP,NOBUF;
EXTERNAL INTEGER CHNCDB;
	HRLZ	1,CHAN;
	LSH	1,5;
	IOR	1,['10+('047 LSH 27)];	# CALLI 10, WAIT;
	XCT	1;		# WAIT TILL DISK STOPS;
	PUSH	P,CHAN;
	PUSHJ	P,CHNCDB;	# AC! GETS ADDR OF CHAN DATA BLOCK;
	SETZM	ICOWNT(1);	# SO SAIL WILL DO AN IN NEXT TIME;
	HRRZ	3,BUFHED(1);	# ADDR OF INPUT BUFFER HEADER;
	JUMPE	3,NOBUF;
	HRRZ	2,(3);		 # AC2=BUFFER POINTED TO BY HEADER;
	MOVEI	3,(2);		# AC3=BUFFER IN WHICH TO CLEAR USE BIT;
	MOVSI	4,'400000;	# BIT TO CLEAR;
TOPP:	ANDCAM	4,(3);		# CLEAR BIT;
	HRRZ	3,(3);		# NEXT BUFFER;
	CAIE	2,(3);		# SAME AS FIRST?;
	 JRST	TOPP;		# NO;
NOBUF:	END;
USETI(CHAN,BLOCK); END;
# ALL THIS IS NECESSARY BECAUSE THE DEC UUOs DO NOT FLUSH THE BUFFER,
WHILE STANFORD IS NICE AND DOES;
])	# DEC;
])	# NOTENX;

# SPECIAL BREAKTABLE STUFF;
DEFINE DELIMS=[('00 & '11 & '12 & '13 & '14 & '15 & '40)];
	# NULL,TAB,LF,VT,FF,CR,SP;
DEFINE LETTERS=["ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!"
		& "αβπλ⊂⊃∀∃→_~#$\|"],
	DIGITS=["0123456789"], SAILID=[(LETTERS & DIGITS)],
	NUMBER=[(DIGITS & ".@")];
	# THE ASCII FOR THOSE STANFORD CHARACTERS UNDER LETTERS IS:
	002 (ALPHA), 003 (BETA), 007 (PI), 010 (LAMBDA),
	020 (SUBSET), 021 (REVERSE SUBSET), 024 (FOR ALL), 025 (THERE EXISTS)
	030 (UNDERSCORE), 031 (RIGHT ARROW), 032 (TILDE), 043 (HASH SIGN),
	DOLLAR, BACKSLASH, VERT;
DEFINE QUOTE=['042];

PRESET!WITH
	TAB,NULL,"INS",
	DELIMS,NULL,"XNR",
	QUOTE,NULL,"INA",
	"01234567",NULL,"XNR",
	NUMBER,NULL,"XNR",
	".@",NULL,"INR",
	SAILID,NULL,"XNRK";
SAFE STRING ARRAY BK!SBR[0:6,0:2];	# SETBREAK WILL BE DONE WITH THESE;
SAFE INTEGER ARRAY BK!TBL[0:6];		# TABLE NUMBERS STORED HERE;
DEFINE BK!TAB=[BK!TBL[0]],BK!DLM=[BK!TBL[1]],BK!QUO=[BK!TBL[2]],
BK!OCT=[BK!TBL[3]],BK!NUM=[BK!TBL[4]],BK!DEC=[BK!TBL[5]],BK!ID=[BK!TBL[6]];
# TAB,DELIMITERS,QUOTE,OCTAL DIGITS,FLOATING DECIMAL,
    DECIMAL DIGITS,IDENTIFIERS;
# EXTERNAL INTEGER BKTPRV;	# BREAKTABLE PRIVILEGE WORD;
SIMPLE INTEGER PROCEDURE BK!PRV(BOOLEAN MODE);
# USERCON(BKTPRV,MODE,TRUE);
BEGIN GOGTAB[BKTPRV] SWAP MODE; RETURN(MODE) END;
# SETS BREAKTABLE PRIVILEGE;

DEFINE SM1LNK(I)=[MEMORY[SM1PNT+I]], T!NAME(I)=[MEMORY[C!NAME+I]],
    T!BLKADR(I)=[MEMORY[C!BLKADR+I]], T!CRDIDX(I)=[MEMORY[C!CRDIDX+I]];
DEFINE PAGEIT(A,B)=[T!NAME(B)];
DEFINE N!CACHE=[100], BOTTOM!SLOT=[95], N!BK=[16], L!BK=[(N!BK-1)];
DEFINE HRELOC(A)=[(A+HZERO)], LRELOC(A)=[(A+LZERO)];
INTEGER BAIJFN,TMPJFN;	# CHANNEL NUMBERS FOR .BAI FILE AND TEXT FILES;
INTEGER C!NAME,		# ADDRESS OF NAME TABLE;
	C!BLKADR,	# ADDRESS OF BLKADR TABLE;
	C!CRDIDX,	# ADDRESS OF COORDINATE INDEX TABLE;
	L!NAME,		# INDEX OF LAST ENTRY CURRENTLY USED IN NAME TABLE;
	L!BLKADR,	#					BLKADR TABLE;
	L!CACHE,	#					CACHE;
	L!CRDIDX,	#					COORDINATE INDEX;
	L!TXTFIL,	#					TEXTFILE TABLE;
	N!NAME,		# NUMBER OF ENTRIES ALLOCATED IN NAME  TABLE;
	N!BLKADR,	# 				BLKADR;
	N!CRDIDX	#				COORDINATE INDEX;
	;
INTEGER BKLEV;		# BREAKPOINT RECURSION LEVEL;
INTEGER PJPBAIL;	# CONTAINS  PUSHJ P,BAIL  AT RUNTIME;
INTERNAL STRING !!QUERY;	# TO BE SET BY USER ON EXPLICIT CALL TO BAIL;
INTEGER BAILOFF,NAME!POINTER;	# ANOTHER SWITCH, USETI POINTER TO NAME TABLE IN .BAI FILE;
STRING ARRAY T!TXTFIL[0:32];	# NAMES OF TEXT FILES;
INTEGER ARRAY STATUS[0:32];	# FOR STATUS OF THESE FILES;
INTEGER ARRAY CACHE[0:N!CACHE-1];	# 20 MOST RECENT NAMES (5 WORDS PER);
INTEGER ARRAY TARRAY[0:255];	# TEMPORARY ARRAY;
INTEGER ARRAY BK!LOC, BK!INSTR,BK!COUNT[0:L!BK]; 
	# BREAK LOCATIONS, SAVED INSTRUCTIONS, MULTIPLE PROCEED COUNTS;
STRING ARRAY BK!COND,BK!ACT,BK!NAME[0:L!BK]; 
	# TO BE EVALUATED FOR CONDITIONAL BREAK, AUTOMATIC ACTION. ID;
INTEGER ARRAY TEMP!ACS[0:'17+'12+1+1];	# HOLDING TANK UNTIL RECURSIVE SAIVING;
INTEGER ARRAY TRAP[0:8];	# PLACE TO DO INTERCEPTIONS;
STRING !STR!;			# GLOBAL ACCUMULATOR FOR PIECE-WISE OUTPUT;
BOOLEAN SSF;			# SPECIAL STRING FLAG, TRUE→NO QUOTE-IZE;
INTEGER MULDEF;			# FALSE→TOTALLY UNKNOWN, TRUE→MULTIPLY DEFINED;
INTEGER TLDEPTH;
INTEGER ARRAY TLSCOPE[0:15];	# KLUGE FOR TFIND;
INTEGER ATJRSTINS,ATJRSTLOC;	# KLUGE FOR STEPPING JRST@ (ONLY ONE AT A TIME);
INTEGER CRDCTR; # "GLOBAL" COUNTER OF COORDINATE NUMBERS;
# MEMSTRING CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTEND NONULL PDFIND ADDSTR ADDCHR DUMPSTR;

SIMPLE STRING PROCEDURE MEMSTRING(INTEGER ADDR); START!CODE
# MEMSTRING(ADDR) IS A LEGAL WAY TO DO MEMORY[ADDR,STRING];
DEFINE T=['14];
	MOVE	T,ADDR;
	PUSH	SP,-1(T);
	PUSH	SP,0(T);
	SUB	P,['2000002];
	JRST	@2(P);
	END;

SIMPLE STRING PROCEDURE CATCRLF(STRING ARG); BEGIN
NOHAND([RETURN(ARG&CRLF)]);
HAND([	START!CODE EXTERNAL INTEGER CAT;
	PUSH	SP,[2];
	PUSH	SP,[CRLF];
	JRST	CAT;
	END;
]);END;

SIMPLE STRING PROCEDURE CRLFCAT(STRING ARG); BEGIN
NOHAND([RETURN(CRLF&ARG)]);
HAND([	START!CODE EXTERNAL INTEGER CAT!RV;
	PUSH	SP,[2];
	PUSH	SP,[CRLF];
	JRST	CAT!RV;
	END;
]);END;

SIMPLE STRING PROCEDURE STRCOPY(STRING ARG); BEGIN
# COPY THE TEXT, TOO, NOT JUST THE DESCRIPTOR;
NOHAND([ RETURN((ARG&".")[1 TO INF-1]); ])
HAND([	START!CODE EXTERNAL INTEGER CATCHR;
	PUSH	P,[0+"."];
	PUSHJ	P,CATCHR;
	SOS	-1(SP);
	POPJ	P,;
	END;
]);END;

SIMPLE INTEGER PROCEDURE FILTIM(INTEGER JFN); BEGIN
TENX([	GTFDB(JFN,TARRAY); RETURN(TARRAY['14])])
NOTENX([FILEINFO(TARRAY);
	RETURN( ((TARRAY[1] LAND '700000) LSH 8) LOR
		((TARRAY[2] LAND '7777) LSH 11) LOR
		((TARRAY[2] LSH -12) LAND '3777)	)])
END;

SIMPLE INTEGER PROCEDURE LAST!WRITTEN(STRING FILENAME); BEGIN "LAST!WRITTEN"
TENX([	INTEGER JFN; JFN←GTJFN(FILENAME,1 LSH 33); IF !SKIP! THEN RETURN(0);
	GTFDB(JFN,TARRAY); RLJFN(JFN); RETURN(TARRAY['14])	])
NOTENX([CFILE(OPENFILE(FILENAME,"R")); RETURN(IF !SKIP! THEN 0 ELSE
	    FILTIM(0))])
END "LAST!WRITTEN";

EXTERNAL PROCEDURE CORGET;
SIMPLE INTEGER PROCEDURE COREGET(INTEGER LENGTH); BEGIN "COREGET"
INTEGER LOC;	LABEL FOOEY;
START!CODE
	MOVE	3,LENGTH;	# PLACE WHERE CORGET TAKES ITS ARG;
	PUSHJ	P,CORGET;	# CALL THE STEWARD;
	 JRST	FOOEY;		# UNSUCCESSFUL RETURN;
	MOVEI	3,(2);		# ISOLATE ADDRESS;
	MOVEM	3,LOC;		# STORE ADDRESS OF BLOCK;
	ADD	3,LENGTH;
	SETZM	0,0(2);		# ZERO THE FIRST WORD FOR BLT;
	HRLI	2,(2);
	HRRI	2,1(2);
	BLT	2,-1(3);	# WE LIKE ZEROED BLOCKS BETTER!;
	END;
RETURN(LOC);
FOOEY:	FATAL("No core for BAIL")	END "COREGET";


EXTERNAL PROCEDURE CORREL;
SIMPLE PROCEDURE COREFREE(INTEGER ADDR);
START!CODE "COREFREE"
	SKIPE	2,ADDR;		# PLACE WHERE CORREL GETS ITS ARG;
	PUSHJ	P,CORREL;
END "COREFREE";


SIMPLE STRING PROCEDURE NONULL(STRING ARG); BEGIN "NONULL"
# RETURN ARG WITH ALL OCCURRANCES OF NULL BYTES REMOVED;
NOHAND([
INTEGER T,BRCHAR; STRING RESULT;
T←BK!PRV(TRUE); RESULT←SCAN(ARG,BK!NONULL,BRCHAR); BK!PRV(T);
RETURN(RESULT);
]) # NOHAND;
HAND([
START!CODE LABEL LOOP,BOT; DEFINE T=['13],OBP=['14],NBP=['15],CT=[1];
	MOVE	OBP,(SP);	# OLD BYTE POINTER;
	MOVE	NBP,(SP);	# NEW BYTE POINTER;
	HRRZ	CT,-1(SP);	# CHAR COUNT;
	HLLZS	-1(SP);		# NEW COUNT. PRESERVE CONSTANTNESS OF STRING;
	JRST	BOT;		# IN CASE NULL STRING;
LOOP:	ILDB	T,OBP;		# GET CHAR;
	JUMPE	T,BOT;		# DON'T PUT IT BACK IF IT'S A NULL;
	AOS	-1(SP);		# ANOTHER CHAR;
	IDPB	T,NBP;
BOT:	SOJGE	CT,LOOP;	# CONTINUE UNTIL DONE;
	POPJ	P,;		# WE'RE DONE;
END;
]) # HAND;
END "NONULL";


SIMPLE INTEGER PROCEDURE PDFIND(INTEGER ENTAD);
# GIVEN ENTRY ADDRESS, RETURN ADDRESS OF PROCEDURE DESCRIPTOR;
NOHAND([
BEGIN INTEGER I;
I←PDLNK; WHILE I NEQ 0 AND MEMORY[I+1] NEQ RIGHT(ENTAD) DO I←MEMORY[I];
RETURN(I+1) END;
]) # NOHAND;
HAND([
START!CODE LABEL LOOP,BOT;
	MOVE	1,PDLNK;
	HRRZ	2,ENTAD;
LOOP:	CAMN	2,1(1);
	 JRST	BOT;
	SKIPE	1,(1);
	 JRST	LOOP;
BOT:	ADDI	1,1;
	SUB	P,['2000002];
	JRST	@2(P);
END;]) # HAND;


SIMPLE PROCEDURE EXTEND(REFERENCE INTEGER ADDR, OLEN, INCR); BEGIN "EXTEND"
INTEGER TMPJFN;	LABEL OK;
    SIMPLE PROCEDURE GETTEMP(STRING MODE); BEGIN
    TMPJFN←OPENFILE("BBBBBB.TMP",MODE); IF !SKIP! THEN BEGIN BAILOFF←TRUE;
    FATAL("Can't access BBBBBB.TMP. Restart (without BAIL)") END END;
START!CODE	EXTERNAL INTEGER CORINC;
	MOVE	2,ADDR;
	MOVE	3,INCR;
	PUSHJ	P,CORINC;	# ATTEMPT TO INCREASE THE CURRENT BLOCK;
	 SKIPA;
	JRST	OK;
END;
  GETTEMP("RWE" TENX([&"T"]) ); ARRYOUT(TMPJFN,MEMORY[ADDR],OLEN); COREFREE(ADDR);
  ADDR←COREGET(OLEN+INCR); CFILE(TMPJFN);
  GETTEMP("RE"); ARRYIN(TMPJFN,MEMORY[ADDR],OLEN);
  NOTENX([	RENAME(TMPJFN,NULL,0,TMPJFN); CFILE(TMPJFN);	])
  TENX([	CLOSF(TMPJFN); DELF(TMPJFN); CFILE(TMPJFN);	])
OK: OLEN←OLEN+INCR;
END "EXTEND";


SIMPLE PROCEDURE ADDSTR(STRING A);BEGIN
!STR!←!STR! & A;	END;


SIMPLE PROCEDURE ADDCHR(INTEGER CHR);
START!CODE	EXTERNAL INTEGER PUTCH;
	POP	P,1;	# RET ADDR THIS PROC;
	PUSHJ	P,PUTCH;# CONVERT CHR TO STRING;
	PUSH	P,1;	# REPLACE RET ADDR;
	JRST	ADDSTR;	# SOLVE SUBPROBLEM;
END;


SIMPLE STRING PROCEDURE DUMPSTR;BEGIN
NOHAND([BEGIN STRING T; T←!STR!; !STR!←NULL; RETURN(T) END	]);
HAND([	START!CODE	DEFINE T=['14];
	MOVEI	T,!STR!;
	PUSH	SP,-1(T);
	PUSH	SP,(T);
	SETZM	-1(T);
	SETZM	(T);
	POPJ	P,;
END	]);	# HAND;
END;
# WRITEON PACKAGE;
PRESET!WITH "ANY", "MAINPI", "BINDIT", "EVENT!TYPE";
SAFE STRING ARRAY ITMSTR[0:3];

SIMPLE PROCEDURE WRITEM(ITEMVAR X); BEGIN "WRITEM"
INTEGER FLAG; STRING NAME; NAME←CVIS(X,FLAG);
IF FLAG THEN BEGIN "NO PNAME" INTEGER WID,DIG,ITN;
    ITN←CVN(X); IF ITN LEQ 3 THEN ADDSTR(ITMSTR[ITN])
    ELSE BEGIN
    GETFORMAT(WID,DIG); SETFORMAT(0,0);
    ADDSTR("ITEM!"&CVS(ITN)); SETFORMAT(WID,DIG) END END "NO PNAME"
ELSE ADDSTR(NAME) END "WRITEM";

SIMPLE PROCEDURE WRSL(INTEGER Y; BOOLEAN LISTF); BEGIN "WRSL"
# Y IS REALLY A SET OR LIST, BUT LEAP PERFORMS UNNECESSARY COPYING;
INTEGER Q; LABEL TOPP,DONE,NOTNUL,BOT;
START!CODE DEFINE T=['14];
	HLRZ	T,Y;		# LENGTH OF SET OR LIST;
	MOVEM	T,Q;
	JUMPN	T,NOTNUL;
	PUSH	SP,[3];		# IT'S EMPTY;
	MOVE	T,["NIL"];	# ASSUME LIST;
	SKIPN	LISTF;
	 MOVE	T,["PHI"];	# WRONG, SET;
	PUSH	SP,T;
	JRST	BOT;
NOTNUL:	PUSH	SP,[2];		# ASSUME LIST;
	PUSH	SP,["{{"];
	SKIPN	LISTF;
	 SOS	-1(SP);		# WRONG, SET;
	PUSHJ	P,ADDSTR;
	HRRZ	1,Y;		# AC1=POINTER TO WD2;
	JUMPE	1,DONE;		# QUIT IF POINTER IS ZERO;
	HRRZ	1,(1);		# POINTER TO FIRST DATA WORD;
	MOVEM	1,Q;
TOPP:	HLRZ	2,(1);		# AC2=ITEM NUMBER;
	PUSH	P,2;
	PUSHJ	P,WRITEM;	# WRITE ELEMENT;
	HRRZ	1,@Q;		# POINT TO NEXT WORD;
	JUMPE	1,DONE;		# QUIT IF POINTER IS ZERO;
	MOVEM	1,Q;
	PUSH	SP,[2];
	PUSH	SP,[", "];
	PUSHJ	P,ADDSTR;
	MOVE	1,Q;		# RESTORE POINTER;
	JRST	TOPP;
DONE:	PUSH	SP,[2];
	PUSH	SP,[CH!SETC & CH!SETC];
	SKIPN	LISTF;
	 SOS	-1(SP);
BOT:	PUSHJ	P,ADDSTR;
	END
END "WRSL";

SIMPLE PROCEDURE WR!TON(INTEGER DSCR); BEGIN "WRITEON"
# FORMAT OF DSCR:
	BIT 1:	REFB	"REFERENCE" BIT
	BIT 2:	QUESB	ON IF ? ITEMVAR
	BIT 3:	BINDB	ON IF BINDING ITEMVAR
	BIT 4:	PROCB	"PROCEDURE" BIT
	BIT 5:	ITEMB	ON IF ITEM OR ITEMVAR
	BIT 6:	ARY2B	ON IF LAMBDA ARRAY ITEMVAR ARRAY
	BITS 7-12:	MMSK6BT	TYPE CODE, SAME AS LEAP DATUM TYPE (TYPEIT)
	BITS 13-35:	EFFECTIVE ADDRESS= POINTER TO THING REFERENCED
			( IF NOT REFB THEN POINTS AT A 1 OR 2 WORD TEMP);

INTEGER MSK6BT,ITEMB,ARY2B,ADDR,ARY,TOTSIZ,I;

ADDSTR("   ");

START!CODE			# UNPACK THE DESCRIPTOR;
	MOVE	1,DSCR;
	LDB	2,['002700000001];	# EFFECTIVE ADDRESS PORTION;
	MOVEM	2,ADDR;
	LDB	2,['270600000001];
	MOVEM	2,MSK6BT;
	LDB	2,['350100000001];
	MOVEM	2,ARY2B;
	LDB	2,['360100000001];
	MOVEM	2,ITEMB;
END;
ARY←ARY2B OR (MSK6BT GEQ '24);

IF NOT ARY THEN BEGIN "NARRAY"
	IF ITEMB THEN
	    WRITEM(MEMORY[IF MSK6BT=0 THEN LOCATION(I←ADDR) ELSE ADDR,ITEMVAR])
	ELSE CASE MSK6BT OF BEGIN "TYPE"
	[3] START!CODE LABEL LOOP,INNER,BOT; EXTERNAL INTEGER STRNGC;
		# EXTERNAL INTEGER REMCHR,TOPBYT,GOGTAB;
	    DEFINE BP=['14],T=[1],QUOTE=['042],USER=['15],CNT=['13],OBP=[2],F=['12];
		PUSH	P,ADDR;
		PUSHJ	P,MEMSTRING;	# GET STRING ON TOP OF STACK;
		SKIPE	SSF;
		 JRST	BOT;		# SPECIAL STRING MODE, DONT FIDDLE;
		HRRZ	T,-1(SP);	# CHAR COUNT;
		ADDI	T,2(T);		# POTENTIALLY THIS MANY CHARS GO OUT;
		MOVE	USER,GOGTAB;
		MOVEM	F,RACS+F(USER);	# KEEP STRNGC HAPPY;
		ADDM	T,REMCHR(USER);
		SKIPL	REMCHR(USER);
		 PUSHJ	P,STRNGC;	# THE OUT-OF-SPACE DANCE;
		HRRZ	CNT,-1(SP);
		MOVE	BP,TOPBYT(USER);
		MOVE	OBP,BP;		# REMEMBER WHERE WE STARTED;
		EXCH	BP,(SP);
		MOVEI	T,QUOTE;
		JRST	INNER;
	    LOOP:ILDB	T,BP;
		IDPB	T,(SP);
		CAIN	T,QUOTE;
	    INNER:IDPB	T,(SP);
		CAIN	T,QUOTE;
		 AOS	-1(SP);
		SOJGE	CNT,LOOP;
		MOVEI	T,QUOTE;
		IDPB	T,(SP);
		AOS	-1(SP);
		EXCH	OBP,(SP);
		MOVEM	OBP,TOPBYT(USER);
	    BOT:PUSHJ	P,ADDSTR;
		END;
	[4] ADDSTR(CVG(MEMORY[ADDR,REAL]));
	[5] ADDSTR(CVS(MEMORY[ADDR,INTEGER]));
	[6] WRSL(MEMORY[ADDR],FALSE);
	[7] WRSL(MEMORY[ADDR],TRUE);
	['15] START!CODE "RECORD" EXTERNAL INTEGER CVS;
	    LABEL NULLREC,ENDREC;
		MOVE	3,@ADDR;	# RECORD POINTER;
		JUMPE	3,NULLREC;
		MOVE	2,(3);		# PTR TO CLASS;
		PUSH	P,5(2);		# PTR TO WD2 OF STRING DESCR FOR CLASS NAME;
		PUSHJ	P,MEMSTRING;
		PUSHJ	P,ADDSTR;	# NAME OF CLASS;
		PUSH	P,[0+"."];
		PUSHJ	P,ADDCHR;	# SEPARATOR CHAR;
		PUSH	P,@ADDR;	# RECORD POINTER;
		PUSHJ	P,CVS;
		JRST	ENDREC;
	NULLREC:PUSH	SP,[11];
		PUSH	SP,["NULL!RECORD"];
	ENDREC:	
		PUSHJ	P,ADDSTR;
		END "RECORD";
	['16] START!CODE "LABEL" EXTERNAL INTEGER CVOS;
		PUSH	P,[0+"'"];
		PUSHJ	P,ADDCHR;
		PUSH	P,ADDR;
		PUSHJ	P,CVOS;
		PUSHJ	P,ADDSTR;
		END "LABEL"
	END "TYPE" END "NARRAY"
ELSE BEGIN "ARRAY"
	INTEGER NDIMS;
	# ADDR POINTS TO ALLOCATION CELL;
	START!CODE
	HRRZ	2,ADDR;
	HRRZ	2,(2);		# ADDR OF FIRST DATA WORD. CAN'T DO @ BECAUSE
				  STRING ARRAYS HAVE  -1,,addr  ;
	MOVE	3,MSK6BT;	# CHECK FOR STRING ARRAY;
	CAIN	3,'24+3;
	 SUBI	2,1;
	MOVEM	2,ADDR;
	HLRE	3,-1(2);	# NDIMS;
	MOVMM	3,NDIMS;
	END;
	ADDSTR("<array>["); FOR I←1 STEP 1 UNTIL NDIMS DO ADDSTR(" "&
	    CVS(MEMORY[ADDR-3*I-1])&":"&CVS(MEMORY[ADDR-3*I])); ADDCHR("]");
END "ARRAY";
END "WRITEON";
# OPERATOR CODES, REFITEM TYPE DEFINITIONS;
DEFINE A(B)=[CVASC("] & [B] & [")];
PRESET!WITH
	A(ABS),0,0,	A(AND),0,0,	A(ANY),0,0,	A(ASH),0,0,
	A(ASSOC),0,0,	A(CPRIN),A(T),0,A(DATUM),0,0,	A(DIV),0,0,
	A(EQV),0,0,	A(FALSE),0,0,	A(FOR),0,0,	A(GEQ),0,0,
	A(IN),0,0,	A(INF),0,0,	A(INTER),0,0,	A(LAND),0,0,
	A(LENGT),A(H),0,A(LEQ),0,0,	A(LNOT),0,0,	A(LOCAT),A(ION),0,
	A(LOR),0,0,	A(LSH),0,0,	A(MAX),0,0,	A(MIN),0,0,
	A(MOD),0,0,	A(NEQ),0,0,	A(NIL),0,0,	A(NOT),0,0,
	A(NULL),0,0,	A(NULL!),A(RECOR),A(D),
					A(OR),0,0,	A(PHI),0,0,
	A(PRINT),0,0,	A(PROPS),0,0,	A(ROT),0,0,	A(SETC),0,0,
	A(SETO),0,0,	A(SWAP),0,0,	A(TO),0,0,	A(TRUE),0,0,
	A(UNION),0,0,	A(XOR),0,0;
INTEGER ARRAY RWORD0[0:125];
REDEFINE A=[NOMAC A];

PRESET!WITH
	'120,		'004,		'142,		'101,
	'140,		'147,		'126,		'102,
	'036,		'103,		'121,		'035,
	'006,		'016,		'022,		'104,
	'144,		'034,		'105,		'145,
	'106,		'107,		'110,		'111,
	'112,		'033,		'132,		'005,
	'114,		'143,		'037,		'131,
	'150,		'127,		'115,	STANFO(['176,])
						DEC([	'175,])
						TENX([	'175,])
	'173,		'027,		'122,		'117,
	'023,		'026,	0;
INTEGER ARRAY RWORD1[0:42];
DEFINE N!RWORD=[42];

DEFINE Q1=[LSH 27+], Q2=[LSH 18+], Q3=[LSH 9+], Q4=[];

PRESET!WITH 
# '000;	0,
# '001;	0,
# '002;	0,
# '003;	0,
# '004;	0,	# 220 Q1	222 Q2	002 Q3	000 Q4,	# AND;
# '005;	232 Q1	230 Q2	001 Q3	000 Q4,	# NOT;
# '006;	240 Q1	242 Q2	002 Q3	006 Q4,	# IN;
# '007;	0,
# '010;	0,
# '011;	0,
# '012;	0,
# '013;	0,
# '014;	0,
# '015;	0,
# '016;	300 Q1	302 Q2	000 Q3	007 Q4,	# INF;
# '017;	272 Q1	448 Q2	001 Q3	000 Q4,	# PARTIAL "∂", EQUIVALENT TO "DATUM";
# '020;	0,
# '021;	0,
# '022;	220 Q1	222 Q2	002 Q3	008 Q4,	# INTER;
# '023;	210 Q1	212 Q2	002 Q3	008 Q4,	# UNION;
# '024;	0,
# '025;	0,
# '026;	250 Q1	252 Q2	002 Q3	010 Q4,	# XOR;
# '027;	310 Q1	312 Q2	002 Q3	000 Q4,	# SWAP;
# '030;	0,
# '031;	0,
# '032;	0,
# '033;	240 Q1	242 Q2	002 Q3	012 Q4,	# NEQ;
# '034;	220 Q1	222 Q2	002 Q3	012 Q4,	# LEQ;
# '035;	240 Q1	242 Q2	002 Q3	012 Q4,	# GEQ;
# '036;	250 Q1	252 Q2	002 Q3	010 Q4,	# EQV;
# '037;	0,	# 210 Q1	212 Q2	002 Q3	000 Q4,	# OR;
# '040;	0,
# '041;	0,
# '042;	0,
# '043;	0,
# '044;	0,
# '045;	260 Q1	262 Q2	002 Q3	009 Q4,	# COMPATIBLE DIVIDE;
# '046;	260 Q1	262 Q2	002 Q3	003 Q4,	# CAT "&";
# '047;	0,
# '050;	448 Q1	000 Q2	000 Q3	000 Q4,	# LEFT PARENTHESIS "(";
# '051;	000 Q1	448 Q2	000 Q3	000 Q4,	# RIGHT PARENTHESIS ")";
# '052;	260 Q1	262 Q2	002 Q3	009 Q4,	# TIMES "*";
# '053;	250 Q1	252 Q2	002 Q3	009 Q4,	# PLUS "+";
# '054;	100 Q1	102 Q2	000 Q3	000 Q4,	# COMMA ",";
# '055;	250 Q1	252 Q2	002 Q3	009 Q4,	# MINUS "-";
# '056;	0,
# '057;	260 Q1	262 Q2	002 Q3	002 Q4,	# DIVIDE "/";
# '060;	0,
# '061;	0,
# '062;	0,
# '063;	0,
# '064;	0,
# '065;	0,
# '066;	0,
# '067;	0,
# '070;	0,
# '071;	0,
# '072;	448 Q1	450 Q2	002 Q3	010 Q4,	# COLON ":";
# '073;	040 Q1	448 Q2	000 Q3	000 Q4,	# SEMICOLON ;
# '074;	240 Q1	242 Q2	002 Q3	012 Q4,	# LESS THAN SIGN "<";
# '075;	240 Q1	242 Q2	002 Q3	012 Q4,	# EQUALS "=";
# '076;	240 Q1	242 Q2	002 Q3	012 Q4,	# GREATER THAN SIGN ">";
# '077;	0,
# '100;	0,
# '101;	260 Q1	262 Q2	002 Q3	005 Q4,	# ASH;
# '102;	260 Q1	262 Q2	002 Q3	001 Q4,	# DIV;
# '103;	504 Q1	504 Q2	000 Q3	000 Q4,	# FALSE;
# '104;	250 Q1	252 Q2	002 Q3	000 Q4,	# LAND;
# '105;	272 Q1	270 Q2	001 Q3	000 Q4,	# LNOT;
# '106;	250 Q1	252 Q2	002 Q3	000 Q4,	# LOR;
# '107;	260 Q1	262 Q2	002 Q3	005 Q4,	# LSH;
# '110;	240 Q1	242 Q2	002 Q3	009 Q4,	# MAX;
# '111;	240 Q1	242 Q2	002 Q3	009 Q4,	# MIN;
# '112;	260 Q1	262 Q2	002 Q3	001 Q4,	# MOD;
# '113;	0,
# '114;	504 Q1	504 Q2	000 Q3	000 Q4,	# NULL;
# '115;	260 Q1	262 Q2	002 Q3	005 Q4,	# ROT;
# '116;	0,
# '117;	504 Q1	504 Q2	000 Q3	000 Q4,	# TRUE;
# '120;	272 Q1	270 Q2	001 Q3	000 Q4,	# ABS;
# '121;	110 Q1	108 Q2	002 Q3	001 Q4,	# FOR (SUBSTRINGER);
# '122;	110 Q1	108 Q2	002 Q3	001 Q4,	# TO (SUBSTRINGER);
# '123;	272 Q1	270 Q2	000 Q3	000 Q4,	# UNARY MINUS (SPECIAL);
# '124;	272 Q1	270 Q2	000 Q3	000 Q4,	# ARRAY REFERENCE;
# '125;	272 Q1	270 Q2	002 Q3	001 Q4,	# MEMORY;
# '126;	272 Q1	448 Q2	001 Q3	000 Q4,	# DATUM;
# '127;	272 Q1	270 Q2	001 Q3	000 Q4,	# PROPS;
# '130;	272 Q1	270 Q2	000 Q3	000 Q4,	# PERFORM STUBSTRINGING;
# '131;	504 Q1	504 Q2	000 Q3	000 Q4,	# PHI;
# '132;	504 Q1	504 Q2	000 Q3	000 Q4,	# NIL;
# '133;	448 Q1	000 Q2	000 Q3	000 Q4,	# LEFT BRACKET [;
# '134;	0,
# '135;	000 Q1	448 Q2	000 Q3	000 Q4,	# RIGHT BRACKET ];
# '136;	270 Q1	272 Q2	002 Q3	009 Q4,	# UP ARROW "↑";
# '137;	440 Q1	050 Q2	002 Q3	004 Q4,	# GETS "←";
# '140;	100 Q1	102 Q2	002 Q3	010 Q4,	# ASSOC "`";
# '141;	272 Q1	270 Q2	001 Q3	000 Q4,	# RECORD SUBFIELD REFERENCE;
# '142;	504 Q1	504 Q2	000 Q3	000 Q4,	# ANY;
# '143;	504 Q1	504 Q2	000 Q3	000 Q4,	# NULL!RECORD;
# '144;	272 Q1	270 Q2	001 Q3	000 Q4,	# LENGTH;
# '145;	272 Q1	270 Q2	001 Q3	011 Q4,	# LOCATION;
# '146;	100 Q1	448 Q2	000 Q3	000 Q4,	# LSTC "}}";
# '147;	272 Q1	270 Q2	000 Q3	000 Q4,	# CPRINT;
# '150;	272 Q1	270 Q2	000 Q3	000 Q4,	# PRINT;
# '151;	0,
# '152;	0,
# '153;	0,
# '154;	0,
# '155;	0,
# '156;	0,
# '157;	0,
# '160;	0,
# '161;	0,
# '162;	0,
# '163;	0,
# '164;	0,
# '165;	0,
# '166;	0,
# '167;	0,
# '170;	0,
# '171;	0,
# '172;	0,
# '173;	448 Q1	100 Q2	000 Q3	000 Q4,	# SETO "{";
# '174;	0,
STANFO([
# '175;	0,
# '176;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "}";
]) # STANFO;
DEC([
# '175;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "}";
# '176;	0,
]) # DEC;
TENX([
# '175;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "}";
# '176;	0,
]) # TENX;
# '177;	0;
INTEGER ARRAY OPS1[0:'177];
	# CHAR CODE FOR OPERATOR, LEFT BINDING POWER, RIGHT BINDING POWER,
	  DEGREE (NULLARY, UNARY, BINARY), AND CONFORMITY CLASS;
DEFINE OPMEMORY=['125],OPARRY=['124],OPSUBST=['130],OPCOMMA=[","],OPSUBFLD=['141],
	OPLSTC=['146],RBNDCOMMA=[102];
DEFINE N!OPS=['200];


DEFINE REFMEMORY=[(REFB+ARRY+NOTYPE)+'777777];

# FOR HAND CODING, THE REFxxx CONSTRUCTS HAVE BEEN MOSTLY REPLACED BY SOME 
  FIDDLING ON P. 14;
DEFINE REFTRACE=[(PROCB+PDFIND(LOCATION(TRACE)))],
	REFBREAK=[(PROCB+PDFIND(LOCATION(BREAK)))],
	REFCOORD=[(PROCB+INTEGR+PDFIND(LOCATION(COORD)))],
	REFUNTRACE=[(PROCB+PDFIND(LOCATION(UNTRACE)))],
	REFUNBREAK=[(PROCB+PDFIND(LOCATION(UNBREAK)))],
	REFSETLEX=[(PROCB+PDFIND(LOCATION(SETLEX)))],
	REF!!STEP=[(PROCB+PDFIND(LOCATION(!!STEP)))],
	REF!!GSTEP=[(PROCB+PDFIND(LOCATION(!!GSTEP)))],
	REF!!GOTO=[(PROCB+PDFIND(LOCATION(!!GOTO)))],
	REF!!ARGS=[(PROCB+STRNG+PDFIND(LOCATION(!!ARGS)))],
	REF!!TEXT=[(PROCB+STRNG+PDFIND(LOCATION(!!TEXT)))],
	REFSHOW=[(PROCB+STRNG+PDFIND(LOCATION(SHOW)))],
	REFHELP=[(PROCB+STRNG+PDFIND(LOCATION(HELP)))],
	REFTRAPS=[(PROCB+STRNG+PDFIND(LOCATION(TRAPS)))],
	REF!!UP=[(PROCB+PDFIND(LOCATION(!!UP)))],
	REFDDT=[(PROCB+PDFIND(LOCATION(DDT)))];
DEFINE F=[('12 LSH 18)], INDIR=[(1 LSH 22)];

DEFINE TEMPB=[(1 LSH 35)],REFB=[(1 LSH 34)], QUESB=[(1 LSH 33)], BINDB=[(1 LSH 32)],
	PROCB=[(1 LSH 31)], ITEMB=[(1 LSH 30)], ARY2B=[(1 LSH 29)],
	ARRY=[('24 LSH 23)];
DEFINE GETTYPE(A)=[((A) LAND (ITEMB+('77 LSH 23)))],INTEGR=[(5 LSH 23)],
	FLOTNG=[(4 LSH 23)],STRNG=[(3 LSH 23)],LBLTYP=[('16 LSH 23)],
	CTXTYP=[('13 LSH 23)],RCLTYP=[('17 LSH 23)],LSTYPE=[(7 LSH 23)],
	SETYPE=[(6 LSH 23)],NOTYPE=[(1 LSH 23)],ITVTYP=[('20 LSH 23)],
	RECTYP=[('15 LSH 23)],RNGTYP=[('22 LSH 23)];

PRESET!WITH	0,		# BSIMPLE;
ARRY+INDIR,			# BARRY;
		ITEMB,		# BITMV---ITEMVAR;
		ITEMB+  ARY2B,	# BARITM--ITEMVAR WHOSE DATUM IS AN ARRAY;
ARRY+INDIR+	ITEMB,		# BITMAR--ARRAY OF ITEMVARS;
ARRY+INDIR+	ITEMB+	ARY2B,	# BARITA--ARRAY OF ITEMVARS WHOSE ∂ ARE ARRAYS;
			PROCB,	# BPROCED;
		ITEMB;		# BITEM;
INTEGER ARRAY COMPLEXTYPE[0:7];

PRESET!WITH 0,INTEGR,FLOTNG,STRNG,LSTYPE,SETYPE,
	ARRY,LBLTYP,RECTYP,RCLTYP;
INTEGER ARRAY SIMPLETYPE[0:9];
# BLAMDA,BINTGR,BREAL,BSTRNG,BLIST,BSET,BCNTXT,BLABEL,BRPNTR,BRCLAS;

PRESET!WITH	0,	# BBILTN;
	F+	INDIR,	# BREF;
		0,	# BALLOC. ZERO FOR SETS, LISTS. ARRAYS GET  INDIR  SET
					BY COMPLEXTYPE;
	F,		# BSTAK;
	0,		# BEXTRN;
	PROCB,		# BXPROC;
	PROCB;		# BBLTPRC;
INTEGER ARRAY ACCESSTYPE[0:6];

PRESET!WITH
	'260000000000,	# PUSHJ;
	'263000000000,	# POPJ;
	'254020000000,	# JRST @;
	'254000000000,	# JRST;
	'320000000000,	# JUMPx;
	'344000000000,	# AOJA;
	'364000000000;	# SOJA;
INTEGER ARRAY STEPINSTR[0:6];
PRESET!WITH
	'777000000000,
	'777000000000,
	'777020000000,
	'777000000000,
	'770000000000,
	'777000000000,
	'777000000000;
INTEGER ARRAY STEPMASK[0:6];

PRESET!WITH
	'263000000000,	# POPJ;
	'254020000000,	# JRST @;
	'254000000000,	# JRST;
	'320000000000,	# JUMPx;
	'344000000000,	# AOJA;
	'364000000000;	# SOJA;
INTEGER ARRAY GSTEPINSTR[0:5];
PRESET!WITH
	'777000000000,
	'777020000000,
	'777000000000,
	'770000000000,
	'777000000000,
	'777000000000;
INTEGER ARRAY GSTEPMASK[0:5];

INTEGER ARRAY NAME[0:2];



FORWARD PROCEDURE BREAK(STRING LOCNAME,COND(""),ACT(""); INTEGER MPC(0));
FORWARD PROCEDURE TRACE(STRING PROCNAME);
FORWARD PROCEDURE UNBREAK(STRING LOCNAME);
FORWARD INTEGER PROCEDURE COORD(STRING LOCNAME);
FORWARD PROCEDURE UNTRACE(STRING PROCNAME);
FORWARD SIMPLE INTERNAL PROCEDURE BAIL;
NOTENX([FORWARD SIMPLE INTERNAL PROCEDURE DDBAIL;])
FORWARD STRING PROCEDURE HELP;
FORWARD PROCEDURE DDT;
FORWARD STRING PROCEDURE TRAPS;
EXTERNAL RECURSIVE PROCEDURE SETLEX(INTEGER DEPTH);
EXTERNAL PROCEDURE !!STEP;
EXTERNAL PROCEDURE !!GOTO;
EXTERNAL PROCEDURE !!GSTEP;
EXTERNAL PROCEDURE !!UP(INTEGER LEVEL);
EXTERNAL STRING PROCEDURE !!ARGS;
EXTERNAL STRING PROCEDURE !!TEXT;
FORWARD STRING PROCEDURE SHOW(INTEGER FIRST,LAST(0)); 
# TYPEMUNGE;
SIMPLE INTEGER PROCEDURE TYPEMUNGE(INTEGER D,LZERO,HZERO); BEGIN "TYPIT"
# CONVERT FROM BAIL TYPES TO REFITEM DATUMS. SIMPLE PROCEDURES WILL HAVE
  THE "TEMPORARY" BIT ON IN THEIR REFITEMS;
NOHAND([
INTEGER COMPLX,SIMPL,ACCES,LBITS,RBITS,SW;
	

COMPLX←D LSH -18 LAND '7; SIMPL←(D LSH -21 LAND '7) LOR (D LSH -25 LAND '10);
ACCES←D LSH -24 LAND '7;
LBITS←COMPLEXTYPE[COMPLX] + SIMPLETYPE[SIMPL] LOR ACCESSTYPE[ACCES] LOR REFB;
# CHECK FOR SIMPLE PROCEDURES;
IF D<0 THEN LBITS←LBITS LOR (1 LSH 35);
# DISTINGUISH BETWEEN ITEMS AND ITEMVARS.
  ITEMS WILL HAVE LBITS=REFB+ITEMB, RBITS=ITEM NUMBER,
  ITEMVARS WILL HAVE LBITS=REFB+ITEMB+TYPE CODE, RBITS=ADDR;
IF (COMPLX=2 OR COMPLX=4) # BITMV OR BITMAR; AND SIMPL=0 THEN LBITS←LBITS + NOTYPE;
RBITS←RIGHT(D);
]) # NOHAND;
HAND([
START!CODE LABEL XHRELOC,NRELOC,JTAB,XBBILTN,XBXPROC,TOPP,BOT1,UNALLOC;
DEFINE COMPLX=[2],SIMPL=[3],ACCES=[4],LNK=[5];
	MOVE	1,D;
	LDB	COMPLX,['220300000001];
	LDB	SIMPL,['250300000001];
	TLNE	1,'2000;
	 ADDI	SIMPL,8;
	LDB	ACCES,['300300000001];
	HLL	1,SIMPLETYPE[0](SIMPL);
	TLO	1,0+REFB LSH -18;
	ADD	1,COMPLEXTYPE[0](COMPLX);
	IOR	1,ACCESSTYPE[0](ACCES);
	SKIPGE	D;
	 TLO	1,'400000;
	CAIE	COMPLX,2;
	CAIN	COMPLX,4;
	 SKIPE	SIMPL;
	 SKIPA;
	ADD	1,[NOTYPE];
]) # HAND;
NOHAND([
# NOW CORRECT THE ADDRESS. WATCH OUT FOR ITEMS, PROCEDURES, LABELS,
  AND HIGHSEG ARRAYS. ALSO PARAMETERS AND RECURSIVE LOCALS.
  ALSO, IF THE ADDRESS IS ZERO, DON'T CHANGE IT.  THIS OCCURS FOR VARIABLES
  WHICH ARE DECLARED BUT NEVER USED OR INTERNALED. CONSEQUENTLY THEY ARE NOT
  ALLOCATED.  THIS IS A FEATURE OF SAIL;
IF COMPLX NEQ 7 # BITEM; AND RBITS NEQ 0 THEN RBITS←CASE ACCES OF (
  #[0]BBILTN;	IF COMPLX=6 OR SIMPL=7 OR
		    ((GETTYPE(LBITS) GEQ ARRY) AND (RBITS LAND '400000))
		THEN HRELOC(RBITS) ELSE LRELOC(RBITS),
  #[1]BREF;	RBITS LAND '377777,
  #[2]BALLOC;	LRELOC(RBITS),
  #[3]BSTAK;	RBITS,
  #[4]BEXTRN;	RIGHT(MEMORY[HRELOC(RBITS)]),
  #[5]BXPROC;	RIGHT(MEMORY[HRELOC(RBITS)]),
  #[6]BBLTPRC;	HRELOC(RBITS)			);
]) # NOHAND;
HAND([
	TRNE	1,-1;		# IF ZERO ADDRESS;
	CAIN	COMPLX,7;	# OR ITEM;
	 JRST	UNALLOC;	# DON'T MANGLE;
	XCT	JTAB(ACCES);
	JRST	NRELOC;
JTAB:	JRST	XBBILTN;
	ANDCMI	1,'400000;
	ADD	1,LZERO;
	JFCL;
	JRST	XBXPROC;
	JRST	XBXPROC;
	ADD	1,HZERO;
XBBILTN:CAIE	COMPLX,6;
	CAIN	SIMPL,7;
	 JRST	XHRELOC;
	HLRZ	5,1;
	ANDI	5,'77 LSH 5;
	CAIL	5,0+ARRY LSH -18;	# IF TYPE GEQ ARRY;
	TRNN	1,'400000;	# AND FLAG;
	SKIPA	5,LZERO;	# ELSE LRELOC;
XHRELOC:MOVE	5,HZERO;	# THEN HRELOC;
	ADDI	1,(5);
	JRST	NRELOC;
XBXPROC:ADD	1,HZERO;
	HRR	1,(1);		# SUBSTITUTE BITS;
NRELOC:
]) # HAND;
NOHAND([
IF ACCES=5 THEN RBITS←PDFIND(RBITS);

# SHOULDN'T HAVE TO DO THIS. KLUGE TO FIX A BUG SOMEWHERE;
IF SIMPL=3 # BSTRNG; AND ACCES=0 # BBILTN; AND COMPLX=0 # BSIMPL;
    AND RBITS NEQ 0 THEN RBITS←RBITS+1;
RETURN(LBITS LOR RBITS) 
]) # NOHAND;
HAND([
	CAIE	ACCES,5;
	 JRST	BOT1;
	MOVEI	6,(1);
	SKIPA	LNK,PDLNK;
TOPP:	SKIPE	LNK,(LNK);
	CAMN	6,1(LNK);
	 SKIPA;
	JRST	TOPP;
	HRRI	1,1(LNK);	# PDA;
BOT1:	JUMPN	COMPLX,UNALLOC;
	JUMPN	ACCES,UNALLOC;
	CAIN	SIMPL,3;
	 ADDI	1,1;
UNALLOC:SUB	P,['4000004];
	JRST	@4(P);
END;]) # HAND;
END "TYPIT";
# INSERT;
SIMPLE INTEGER PROCEDURE INSERT(INTEGER TYPE,FATHER,DATA; INTEGER ARRAY NAME);
BEGIN "INSERT"
NOHAND([
INTEGER K,I;

# HASH TO FIND BUCKET;
K←ABS(NAME[0] MOD 31);

IF L!NAME+5 GEQ N!NAME THEN EXTEND(C!NAME,N!NAME,500);
L!NAME←L!NAME+1;
T!NAME(L!NAME)←T!NAME(K) LOR (FATHER LSH 18) LOR (TYPE LSH 34);
T!NAME(K)←L!NAME;	# CHAINING;
T!NAME(L!NAME+1)←DATA; FOR I←0 UPTO 2 DO T!NAME(L!NAME+2+I)←NAME[I];
L!NAME←L!NAME+4;
RETURN(L!NAME-4)
]) # NOHAND;
HAND([
START!CODE LABEL ROOM; DEFINE I=[1],K=[2],T=[0],LN=[3],T2=[4];
	MOVE	T,L!NAME;
	ADDI	T,5;
	CAMGE	T,N!NAME;
	 JRST	ROOM;
	MOVEI	T,C!NAME;
	PUSH	P,T;
	MOVEI	T,N!NAME;
	PUSH	P,T;
	MOVEI	T,[500];
	PUSH	P,T;
	PUSHJ	P,EXTEND;
ROOM:	MOVM	I,@NAME;		# ABS(NAME[0]);
	IDIVI	I,31;
	AOS	LN,L!NAME;
	ADD	K,C!NAME;
	ADD	LN,C!NAME;
	MOVE	T,(K);		# T!NAME(K);
	HRL	T,FATHER;	# LOR (FATHER LSH 18);
	MOVE	T2,TYPE;
	LSH	T2,34;
	IOR	T,T2;		# LOR (TYPE LSH 34);
	MOVEM	T,(LN);
	MOVEI	T,(LN);
	SUB	T,C!NAME;
	MOVEM	T,(K);		# CHAINING;
	MOVE	T,DATA;
	MOVEM	T,1(LN);
	HRLI	T,@NAME;	# FWA DATA;
	HRRI	T,2(LN);
	BLT	T,4(LN);	# XFER 3 WORD NAME;
	ADDI	LN,4;
	SUB	LN,C!NAME;
	MOVEM	LN,L!NAME;
	MOVEI	1,-4(LN);
	SUB	P,['5000005];
	JRST	@5(P);
END;]) # HAND;
END "INSERT";
# FIND;
SIMPLE INTEGER PROCEDURE FIND(INTEGER ARRAY NAME,LCHAIN; INTEGER LDEPTH,
			ANYNAM);
BEGIN "FIND"
NOHAND ([
INTEGER K,I,FATHER,P!CACHE,HOMONYMN;
DEFINE CURBLK=[LCHAIN[0]];

# RETURN -1	 IF NAME NOT FOUND
	+PNTR	TO CACHE TABLE IF FOUND;
# ANYNAM IS A FLAG.  FALSE MEANS MUST RETURN A VARIABLE OR A PROCEDURE.
  TRUE MEANS THAT A BLOCKNAME IS ALLOWED;

# CHECK CACHE FIRST;
FOR I←0 STEP 5 UNTIL L!CACHE-4 DO BEGIN "SEARCH CACHE"
	K←-1; WHILE (K←K+1) LEQ 2 AND NAME[K]=CACHE[I+2+K] DO;
	IF K=3 AND RIGHT(CACHE[I])=RIGHT(LCHAIN[0]) AND
	    (ANYNAM OR (CACHE[I+1] LAND ('77 LSH 23 +PROCB+ITEMB)) NEQ 0)
	THEN BEGIN "CLIMB"
	IF I=0 THEN RETURN(0) ELSE FOR K←0 UPTO 4 DO
	  CACHE[I+K] SWAP CACHE[I+K-5]; RETURN(I-5) END"CLIMB"
END "SEARCH CACHE";

# COULD NOT FIND IT IN CACHE, LOOK IN REGULAR PLACE;
HOMONYMN←0;
K←PAGEIT(T!NAME,ABS(NAME[0] MOD 31));	# INITIAL HASH;
WHILE K NEQ 0 DO BEGIN "CHAIN"
    I←-1; WHILE(I←I+1)<3 AND NAME[I]=PAGEIT(T!NAME,K+2+I) DO;
    IF I NEQ 3 THEN K←RIGHT(PAGEIT(T!NAME,K))	# FOLLOW DOWN CHAIN;
    ELSE BEGIN "HOM"
	# FOUND A LIKE SPELLING;
	HOMONYMN←K; FATHER←LEFT(PAGEIT(T!NAME,K)) LAND '177777;
	I←-1; WHILE (I←I+1) LEQ LDEPTH AND LEFT(LCHAIN[I]) NEQ FATHER DO;
	IF I=LDEPTH+1 OR (NOT ANYNAM AND
		(PAGEIT(T!NAME,K+1) LAND (PROCB+ITEMB+('77 LSH 23))=0)	)
	    THEN K←RIGHT(PAGEIT(T!NAME,K))	# TRY AGAIN;
	ELSE BEGIN "GOTCHA"
	    # FOUND OUR MAN, SINCE INNER-MOST OCCURS FIRST IN CHAIN;
	    # PUT IN CACHE;
	    IF L!CACHE<N!CACHE-1 THEN BEGIN P!CACHE←L!CACHE+1; L!CACHE←
		L!CACHE+5 END ELSE P!CACHE←BOTTOM!SLOT;
	    FOR I←1 UPTO 4 DO CACHE[P!CACHE+I]←PAGEIT(T!NAME,K+I);
	    CACHE[P!CACHE]←LEFT(PAGEIT(T!NAME,K)) LSH 18 LOR RIGHT(CURBLK);
	    RETURN(P!CACHE)
	END "GOTCHA"
    END "HOM"
END "CHAIN";
IF HOMONYMN AND ANYNAM THEN BEGIN
	    IF L!CACHE<N!CACHE-1 THEN BEGIN P!CACHE←L!CACHE+1; L!CACHE←
		L!CACHE+5 END ELSE P!CACHE←BOTTOM!SLOT;
	    FOR I←1 UPTO 4 DO CACHE[P!CACHE+I]←PAGEIT(T!NAME,K+I);
	    CACHE[P!CACHE]←LEFT(PAGEIT(T!NAME,K)) LSH 18 LOR RIGHT(CURBLK);
	    RETURN(P!CACHE) END;
RETURN(-1)
]) # NOHAND;
HAND ([
INTEGER RETVAL,HOMONYMN;
START!CODE
LABEL LOOP1,LSWAP,INC1,TEST1,LOOP2,LOOP3,BOTSLOT,RET,SUGAR,GOTCHA,LP3A;
DEFINE N1=[2],N2=[3],N3=[4],I=[1],K=[5],CN=[6],FATHER=[8],LD=[9],T=[0],
    PCACHE=['14],CURBLK=['15];
	HRLI	T,@NAME;	# ADDR OF FIRST DATA WORD IN  NAME;
	HRRI	T,N1;
	BLT	T,N3;		# GET THE NAME INTO N1,N2,N3;
	MOVE	I,L!CACHE;
	MOVEI	I,CACHE[0](I);
	HRRZ	CURBLK,@LCHAIN;	# RIGHT HALF OF LCHAIN[0];
	JRST	TEST1;
LOOP1:	CAME	N1,2(I);	# FIRST 5 CHARS;
	 JRST	INC1;
	CAMN	N2,3(I);	# SECOND 5;
	CAME	N3,4(I);	# LAST 5;
	 JRST	INC1;
	HRRZ	T,0(I);		# BLOCK WHICH OWNS OBJECT IN CACHE;
	CAME	CURBLK,T;	# SAME AS CURRENT?;
	 JRST	INC1;		# NO;
	MOVE	T,1(I);		# TYPE BITS OF REFITEM DATUM;
	TLNN	T,'77 LSH 5 + ITEMB LSH -18 + PROCB LSH -18;
	SKIPE	ANYNAM;		# IF ONLY VAR OR ITEM OR PROC WILL DO;
	 SKIPA;			# IT'S OK;
	JRST	INC1;		# IT'S BAD;
	MOVEI	T,(I);		# POINT TO WORD 0, RELATIVE TO CACHE[0];
	SUBI	T,CACHE[0];
	MOVEM	T,RETVAL;
# CLIMB;
	CAMN	T,L!CACHE;	# AT END ALREADY?;
	 JRST	RET;		# YES;
	MOVEI	K,5;		# SWAP 5 WORDS;
LSWAP:	MOVE	T,(I);
	EXCH	T,5(I);
	MOVEM	T,(I);
	ADDI	I,1;
	SOJG	K,LSWAP;
	SUBI	I,CACHE[0];	# POINT TO WORD 0;
	MOVEM	I,RETVAL;
	JRST	RET;
INC1:	SUBI	I,5;
TEST1:	CAIL	I,CACHE[0];	# REACHED BOTTOM YET?;
	 JRST	LOOP1;		# NO;
]) # HAND;
HAND([
# SEARCH NAME TABLE;
	SETOM	RETVAL;		# NOT FOUND;
	SETZM	HOMONYMN;
	SETZM	MULDEF;
	MOVE	CN,C!NAME;
	MOVE	T,N1;		# COMPUTE BUCKET NUMBER;
	IDIVI	T,31;
	MOVM	K,1;
	ADDI	K,(CN);
LOOP2:	HRRZ	K,(K);		# DOWN ONE LINK IN CHAIN;
	JUMPE	K,SUGAR;	# LAST ONE;
	ADDI	K,(CN);		# GET MEMORY ADDRESS;
	CAME	N1,2(K);	# FIRST 5 CHARS MATCH?;
	 JRST	LOOP2;		# NO;
	CAMN	N2,3(K);
	CAME	N3,4(K);
	 JRST	LOOP2;
				# NEXT TWO COMMENTED OUT BY RHT;
	# MOVSS	HOMONYMN;	# SAVE ANYTHING THAT MIGHT BE THERE ALREADY;
	# HRRM	K,HOMONYMN;	# AND REMEMBER THIS ONE;
	LDB	FATHER,[('222000+K) LSH 18];
	MOVN	LD,LDEPTH;	# PREPARE FOR SEARCH ALONG LCHAIN;
	HRLI	LD,-1(LD);	# CONSTRUCT AOBJN POINTER IN LD;
	HRRI	LD,@LCHAIN;	# POINT TO LCHAIN[0];
LOOP3:	HLRZ	T,(LD);
	CAME	FATHER,T;
	AOBJN	LD,LOOP3;
	# JUMPGE LD,LOOP2; # RHT -- CHANGES TO AVOID CONFUSION BY "SAME" OBJECTS;
	MOVE	T,1(K);		# TYPE BITS OF REFITEM DATUM;
	MOVE	FATHER,HOMONYMN;# IF 0 THEN TEST WITH AC1 WILL ALWAYS SKIP.;
	CAMN	T,1(FATHER);	# CURRENT REFITEM DATUM WITH PREVIOUS;
	JRST	LP3A;		# THEY ARE SAME, IGNORE THIS ONE;
	MOVSI	FATHER,(FATHER);# SAVE OLD IN LEFT HALF;
	HRRI	FATHER,(K);	# REMEMBER NEW;
	MOVEM	FATHER,HOMONYMN;# TUCK IT AWAY;
LP3A:	JUMPGE	LD,LOOP2;	# IF AOBJN COUNTED OUT THEN ITERATE;
			   # RHT -- END OF PATCH;
	TLNN	T,'77 LSH 5 + ITEMB LSH -18 + PROCB LSH -18;
	SKIPE	ANYNAM;
	 SKIPA;
	JRST	LOOP2;
GOTCHA:	MOVE	I,L!CACHE;
	CAIL	I,N!CACHE-5;
	 JRST	BOTSLOT;
	ADDI	I,5;
	MOVEM	I,L!CACHE;
	MOVEI	PCACHE,(I);
	SKIPA;
BOTSLOT:SETZ	PCACHE,;
	MOVEM	PCACHE,RETVAL;
	HRLI	T,1(K);
	HRRI	T,CACHE[1](PCACHE);
	BLT	T,CACHE[4](PCACHE);
	HLL	CURBLK,(K);
	MOVEM	CURBLK,CACHE[0](PCACHE);
RET:	MOVE	1,RETVAL;
	SUB	P,['5000005];
	JRST	@5(P);
SUGAR:	SKIPN	K,HOMONYMN;	# IF SPELLING NOT FOUND;
	 JRST	RET;		# THEN GIVE UP;
	MOVE	T,1(K);		# TYPE BITS;
	TLNE	T,0+PROCB LSH -18;# IF NOT A PROCEDURE;
	TLNE	T,'17;		# OR IF PARAMETER;
	 SKIPA;			# KEEP TRYING;
	 JRST	GOTCHA;		# USE OUTER-MOST PROCEDURE;
	TLNE	K,-1;
	 SETOM	MULDEF;
	TLNN	K,-1;		# IF MULTIPLY DEFINED;
	TLNE	T,'17;		# OR NOT A FIXED CORE ADDRESS;
	 JRST	RET;		# GIVE UP;
	JRST	GOTCHA;		# OTHERWISE, TRY THIS;
	END;
]) # HAND;
END "FIND";
# CVNAME PREDEC;


SIMPLE PROCEDURE CVNAME(STRING STRVAL; INTEGER ARRAY NAME);BEGIN "CVNAME"
NOHAND([
INTEGER I; FOR I←0 UPTO 2 DO NAME[I]←CVASC(STRVAL[5*I+1 FOR 5])	]) # NOHAND;
HAND([
START!CODE DEFINE R=[1], L=[2], I=[3], D=[4], T=[5]; LABEL LOOP;
	MOVEI	R,@NAME;	# ADDRESS OF FIRST DATA WORD IN  NAME;
	SETZM	(R);	SETZM	1(R);	SETZM	2(R);	# CLEAR RESULT;
	HRLI	R,'440700;	# POINT 7, ;
	HRRZ	L,-1(SP);	# LENGTH OF SOURCE;
	MOVE	I,(SP);		# BYTE POINTER TO SOURCE;
	MOVEI	D,15;		# MAX LENGTH;
LOOP:	ILDB	T,I;
	IDPB	T,R;
	SOSLE	D;
	SOJG	L,LOOP;
	END;			]) # HAND;
END "CVNAME";


SIMPLE INTEGER PROCEDURE PREDEC(STRING NM; INTEGER TYPE,FATHER,DATA); BEGIN
NOHAND([
CVNAME(NM,NAME); RETURN(INSERT(TYPE,FATHER,DATA,NAME))
]) # NOHAND;
HAND([
START!CODE DEFINE T=['13];
	PUSH	P,NAME;	# FWA;
	PUSHJ	P,CVNAME;	# REMOVES NM FROM STACK UPON RETRUN;
	MOVE	T,NAME;	# FWA;
	EXCH	T,(P);	# BECOMES LAST ARG TO INSERT;
	PUSH	P,T;	# RETURN ADDR;
	JRST	INSERT;	# SICK 'EM;
	END;
]) # HAND;
END;
# STBAIL;
PROCEDURE STBAIL; BEGIN"STBAIL"
INTEGER SM1PNT,BAITIM,DMPTIM,SM1TIM,N!BYTE,SM1JFN;
INTEGER LZERO,HZERO,BPDALZERO,BPDAHZERO;
      #	LZERO	LOW SEGMENT RELOCATION CONSTANT
	HZERO	HIGH SEGMENT RELOCATION CONSTANT;
INTEGER CRDNO,LEVEL,DAD,D;
DEFINE ID=[0], BLK=[1], SIMPRC=[2], PRC=[3];
BOOLEAN ENROLL;		# WHETHER TO READ ALL .SM1 FILES;
INTEGER I,L,J,ADDR1,ADDR2,BRCHAR,BAILPDAFLAG,W;
INTEGER ARRAY FILMAP[0:31];	# TRANSLATES FROM LOCAL FILE NUMBER TO GLOBAL;
STRING T,PROGNAM,BAINAM;
LABEL DONESTBAIL;

SIMPLE INTEGER PROCEDURE HORSECART(INTEGER HTIM; STRING HORSE,CART); BEGIN
INTEGER T; T←0; IF LENGTH(CART) AND ((T←LAST!WRITTEN(CART))>HTIM OR T=0) THEN
	NONFATAL(CART & " written after " & HORSE);
RETURN(T); END;

SIMPLE PROCEDURE AD!BLKADR(INTEGER I,J); BEGIN "AD!BLKADR"
IF (L!BLKADR←L!BLKADR+2) GEQ N!BLKADR THEN EXTEND(C!BLKADR,N!BLKADR,128);
T!BLKADR(L!BLKADR-1)←I; T!BLKADR(L!BLKADR)←J END "AD!BLKADR";

SIMPLE PROCEDURE AD!CRDIDX(INTEGER I); BEGIN "AD!CRDIDX"
N!BYTE←N!BYTE+2; IF N!BYTE LAND '177 THEN RETURN;
IF (L!CRDIDX←L!CRDIDX+1) GEQ N!CRDIDX THEN EXTEND(C!CRDIDX,N!CRDIDX,64);
T!CRDIDX(L!CRDIDX)←I END "AD!CRDIDX";

SIMPLE PROCEDURE EATSYM(BOOLEAN INPRC; INTEGER $RUN$); BEGIN "EATSYM"
# PROCESS SYMBOLS FOR BLOCK TYPES 3 AND 4 (BAIBLK AND BAIPRC);

    SIMPLE PROCEDURE SYMIN;
    NOHAND([BEGIN TARRAY[1]←TARRAY[2]←0;
	FOR I←1 UPTO L DO TARRAY[I-1]←WORDIN(SM1JFN) END;]) # NOHAND;
    HAND([START!CODE LABEL LOOP; EXTERNAL INTEGER WORDIN;
	SETZM	TARRAY[1];
	SETZM	TARRAY[2];
	MOVN	2,L;
	HRLZI	2,(2);
    LOOP:PUSH	P,SM1JFN;
	PUSHJ	P,WORDIN;
	MOVEM	1,TARRAY[0](2);
	AOBJN	2,LOOP;
	POPJ	P,;
	END;]) # HAND;

W←WORDIN(SM1JFN); L←W LAND '77; LEVEL←W LSH -6 LAND '77;
CRDNO←LEFT(W); D←ADDR1←HRELOC(RIGHT(W←WORDIN(SM1JFN))); ADDR2←HRELOC(LEFT(W));

IF INPRC THEN D←TYPEMUNGE(WORDIN(SM1JFN),LZERO,HZERO);

SYMIN;
# USE FATHER FIELD FOR LEVEL INFO UNTIL FATHER CHAIN IS BUILT;
DAD←INSERT(IF INPRC THEN IF D<0 THEN SIMPRC ELSE PRC ELSE BLK,LEVEL+$RUN$,D,TARRAY);
IF NOT $RUN$ THEN AD!BLKADR(DAD,ADDR2 LSH 18 LOR ADDR1);
WHILE (W←WORDIN(SM1JFN)) NEQ 0 DO BEGIN "IDENTIFIERS"
	L←W LAND '77; D←TYPEMUNGE(WORDIN(SM1JFN),LZERO,HZERO);
	SYMIN; INSERT(ID,DAD,D,TARRAY) END "IDENTIFIERS"
END "EATSYM";

SIMPLE PROCEDURE DOSM1(INTEGER $RUN$); BEGIN "DOSM1"
# Go down the BALNK loader chain and process the files on it.  If $RUN$ is zero,
  process only user files., if $RUN$ is not zero, then process predeclared runtime
  files, which have a 1 in the left half of the word which tells how many words
  the file name takes;
SM1PNT←BALNK;
WHILE SM1PNT DO BEGIN "ONE COMPILATION"
LABEL EOC;
STRING SM1NAM;	# FILE NAME OF .SM1 FILE;

IF $RUN$ AND NOT(LEFT(SM1LNK(2))) THEN GOTO EOC;
IF NOT($RUN$) AND LEFT(SM1LNK(2)) THEN GOTO EOC;
	# Do runtimes iff correct to do so;
LZERO←RIGHT(SM1LNK(1))-1; HZERO←LEFT(SM1LNK(1))-1;
IF HZERO GEQ '400000 THEN HZERO←HZERO-'400000;	# SET PHASE CONSTANT CORRECTLY;
TENX([L←RIGHT(SM1LNK(2)); SM1NAM←NULL; FOR I←1 UPTO L DO
	SM1NAM←SM1NAM & CVASTR(SM1LNK(2+I)); SM1NAM←NONULL(SM1NAM);
])
NOTENX([SM1NAM←CVXSTR(SM1LNK(3)) & ".SM1";
IF $RUN$ THEN SM1NAM←"SYS:"&SM1NAM;
])
SM1JFN←OPENFILE(SM1NAM,"RE"); SM1TIM←FILTIM(SM1JFN); IF !SKIP! THEN NONFATAL(
"Can't access symbol file " & SM1NAM) ELSE BEGIN "SM1FILE"
    OUTSTR(CRLFCAT(SM1NAM));
    WHILE (W←WORDIN(SM1JFN)) NEQ -1 DO CASE W OF BEGIN "CASES"
    [1]	BEGIN "FILE INFO"
	STRING TEXTFILE,PPN; INTEGER L,FILN;	LABEL OLDCHAP;
	W←WORDIN(SM1JFN); L←RIGHT(W); FILN←LEFT(W);
	TENX([TEXTFILE←NULL; FOR I←1 UPTO L DO
		TEXTFILE←TEXTFILE & CVASTR(WORDIN(SM1JFN));])
	NOTENX([
		TEXTFILE←CV6STR(WORDIN(SM1JFN)) & ":" &
		    CVXSTR(WORDIN(SM1JFN)) & "." &
		    (CVXSTR(WORDIN(SM1JFN))[1 TO 3]);
	    STANFO([
		PPN←CVXSTR(W←WORDIN(SM1JFN));
		IF W THEN TEXTFILE←
		    TEXTFILE & "[" & PPN[1 TO 3] & "," & PPN[4 TO 6] & "]"; ])
	    DEC([
		IF W←WORDIN(SM1JFN) THEN TEXTFILE←
		    TEXTFILE & "[" & CVOS(LEFT(W)) & "," & CVOS(RIGHT(W)) & "]"; ])
	 ]) # NOTENX;
	FOR I←0 UPTO L!TXTFIL DO IF EQU(TEXTFILE,T!TXTFIL[I]) THEN BEGIN
	    FILMAP[FILN]←I; GOTO OLDCHAP; END;
	IF L!TXTFIL=30 THEN NONFATAL("More than 30 text files.
Text from remaining files can't be displayed.");
	L!TXTFIL←(L!TXTFIL+1) MIN 31; T!TXTFIL[L!TXTFIL]←TEXTFILE;
	FILMAP[FILN]←L!TXTFIL;
	STATUS[L!TXTFIL]←IF HORSECART(SM1TIM,SM1NAM,TEXTFILE)=0 THEN -'1000 ELSE -1;
OLDCHAP:OUTSTR(CRLFCAT("  " & TEXTFILE));
	END "FILE INFO";

    [2]	BEGIN "COORDINATES"
	WHILE (W←WORDIN(SM1JFN)) NEQ 0 DO BEGIN
	I←W LSH -25 LAND '37; W←(W LAND '770177777777) LOR (FILMAP[I] LSH 25);
	WORDOUT(BAIJFN,W);
	W←(WORDIN(SM1JFN) LAND '400000777777)+(CRDCTR LSH 18); # USE GLOBAL COORD NUMBERS;
	CRDCTR←CRDCTR+1; WORDOUT(BAIJFN,HRELOC(W));
	AD!CRDIDX(HRELOC(W)); END
	END "COORDINATES";

    [3]	BEGIN "BLOCKS" EATSYM(FALSE,$RUN$) END "BLOCKS";

    [4] BEGIN "PRC" EATSYM(TRUE,$RUN$) END "PRC"

    END "CASES";
    CFILE(SM1JFN);

# There is some monkey business with outer blocks.  They act like procedures
with no parameters, in that they put out the name twice, once for the params
and once for the delcatations inwide the procedure.  The trouble is, the
declarations should be treated as global in this case.  So kill the "params"
block name, and set the FWA of the other one to HRELOC(0).  Also kill the
outer block procedure name in the NAME table, to prevent confusion;
IF NOT($RUN$) THEN BEGIN
    T!NAME(RIGHT(T!BLKADR(L!BLKADR-1))+2)←0;	# KILLS THE NAME TABLE ENTRY;
    L!BLKADR←L!BLKADR-2;	# THAT KILLS THE PARAM NAME BLOCK;
    T!BLKADR(L!BLKADR)←T!BLKADR(L!BLKADR) LAND '777777000000 LOR HRELOC(0); END;
END "SM1FILE";

EOC:SM1PNT←SM1LNK(0);	# NEXT LINK;	END "ONE COMPILATION" 
END "DOSM1";



#SKIP#←!SKIP!;
OUTSTR("
BAIL ver. 15-Jan-76");

IF BALNK=0 THEN BEGIN
    NONFATAL("Program compiled without /B switch"); RETURN END;

# THE LOADER LINKED LIST IS LINKED BACKWARDS (I.E., THE .REL FILE WHICH IS
  LOADED FIRST IS LAST ON THE LIST).  IT IS ESSENTIAL TO PROCESS THE FILES
  IN THE ORDER IN WHICH THEY ARE LOADED, SO THE LIST MUST BE REVERSED.
  $#$#$#$#$# THIS MEANS THAT THE LINK BLOCKS MUST BE IN THE LOWSEG #$#$#$#$#$;
# DON'T REVERSE IT IF IT DOES NOT NEED TO BE REVERSED;
NOHAND([
IF MEMORY[BALNK]<BALNK THEN BEGIN
    L←J←0; I←BALNK; WHILE I NEQ 0 DO BEGIN
	J←I; I←MEMORY[I]; MEMORY[J]←L; L←J END;
    BALNK←J; END;
]) # NOHAND;
HAND([
START!CODE LABEL LOOP,OUT1; DEFINE I=['13],J=['14],L=['15];
	MOVE	I,BALNK;
	CAMG	I,(I);
	 JRST	OUT1;
	SETZB	J,L;
LOOP:	MOVEI	J,(I);
	MOVE	I,(I);
	MOVEM	L,(J);
	MOVEI	L,(J);
	JUMPN	I,LOOP;
	MOVEM	J,BALNK;
OUT1:	END;
]) # HAND;

# MAKE FOR NICE RENTRANCY;
ARRCLR(STATUS); COREFREE(C!NAME); COREFREE(C!BLKADR); COREFREE(C!CRDIDX);
BKLEV←0; BAILPDAFLAG←FALSE;

# ESTABLISH SPECIAL BREAK TABLES;
J←BK!PRV(TRUE);
NOHAND([	FOR I←0 UPTO 6 DO BEGIN RELBREAK(BK!TBL[I]);
    IF (BK!TBL[I]←GETBREAK) GEQ 0 THEN FATAL("Privileged breaktable overflow.");
    SETBREAK(BK!TBL[I],BK!SBR[I,0],BK!SBR[I,1],BK!SBR[I,2]) END;	]) # NOHAND;
HAND([ START!CODE LABEL NEWTBL,SPLOOP,GOOD;
EXTERNAL INTEGER GETBREAK,SETBREAK,RELBREAK;
	MOVEI	3,BK!SBR[0,0];	# ADDR OF WD2 OF FIRST STRING TO BE PUSHED;
	MOVSI	2,-7;		# 7 TABLES TO BE SET;
NEWTBL:	PUSH	P,BK!TBL[0](2);
	PUSHJ	P,RELBREAK;
	PUSHJ	P,GETBREAK;
	JUMPL	1,GOOD;
	PUSH	SP,[31];
	PUSH	SP,["Privileged breaktable overflow."];
	PUSHJ	P,FATAL;
GOOD:	PUSH	P,1;		# TABLE NUMBER;
	MOVEM	1,BK!TBL[0](2);
	HRLI	3,-6;		# 6 WORDS ONTO SP;
SPLOOP:	PUSH	SP,-1(3);
	AOBJN	3,SPLOOP;
	PUSHJ	P,SETBREAK;
	AOBJN	2,NEWTBL;
	END;
]) # HAND;
BK!PRV(J);

# NOW MAKE LIKE RPG -- SEE IF WE CAN USE AN EXISTING .BAI FILE;
ENROLL←FALSE; SM1PNT←BALNK;
NOTENX([PROGNAM←CV6STR(SM1LNK(3));])
TENX([L←RIGHT(SM1LNK(2)); PROGNAM←NULL; FOR I←1 UPTO L DO PROGNAM←PROGNAM &
    CVASTR(SM1LNK(I+2)); J←BK!PRV(TRUE); PROGNAM←SCAN(PROGNAM,BK!DEC,BRCHAR);
    BK!PRV(J);])
IF (BAITIM←LAST!WRITTEN(BAINAM←PROGNAM & ".BAI"))<(DMPTIM←LAST!WRITTEN(PROGNAM & 
    CORE!IMAGE!EXTENSION)) OR DMPTIM=0 THEN ENROLL←TRUE;
WHILE SM1PNT AND NOT ENROLL DO BEGIN
    STRING SM1NAM;
    TENX([L←RIGHT(SM1LNK(2)); SM1NAM←NULL; FOR I←1 UPTO L DO
	SM1NAM←SM1NAM & CVASTR(SM1LNK(2+I));])
    NOTENX([SM1NAM←CVXSTR(SM1LNK(3)) & ".SM1";])
    SM1PNT←SM1LNK(0);	# FOLLOW DOWN LINK;
    IF LAST!WRITTEN(SM1NAM) GEQ BAITIM THEN ENROLL←TRUE END;


IF NOT ENROLL THEN BEGIN "NOROLL"
    BAIJFN←OPENFILE(BAINAM,"RE"); IF !SKIP! THEN BEGIN
	NONFATAL("Can't open existing .BAI file; will reconstruct it.");
	ENROLL←TRUE END	
    ELSE BEGIN
	OUTSTR(" using " & BAINAM);
	# FIRST DISK BLOCK OF .BAI FILE IS A HEADER INDEX BLOCK.
	WORD	0-7    UNUSED
		8	USETI POINTER TO BEGINNING OF T!CRDIDX
		9	CRDCTR,,N!CRDIDX
		10	USETI POINTER TO BEGINNNG OF T!BLKADR
		11	N!BLKADR
		12	USETI POINTER TO BEGINNING OF T!NAME
		13	N!NAME
		14	USETI POINTER TO TEXT FILE NAMES
		15	N!TXTFIL,,# OF WORDS TAKEN UP BY NAMES
		16-127	UNUSED;
	# READ THE FIRST BLOCK TO GET THE INDEX INFO;
	ARRYIN(BAIJFN,TARRAY[0],128);
	# SET UP THE VARIOUS ARRAYS;
	C!CRDIDX←COREGET(N!CRDIDX←RIGHT(TARRAY[9])); CRDCTR←LEFT(TARRAY[9]);L!CRDIDX←N!CRDIDX-1;
	    USETIN(BAIJFN,TARRAY[8]); ARRYIN(BAIJFN,T!CRDIDX(0),N!CRDIDX);
	C!BLKADR←COREGET(N!BLKADR←TARRAY[11]); L!BLKADR←N!BLKADR-1;
	    USETIN(BAIJFN,TARRAY[10]); ARRYIN(BAIJFN,T!BLKADR(0),N!BLKADR);
	C!NAME←COREGET(N!NAME←TARRAY[13]); L!NAME←N!NAME-1;
	    USETIN(BAIJFN,TARRAY[12]); ARRYIN(BAIJFN,T!NAME(0),N!NAME);
	L!TXTFIL←LEFT(TARRAY[15]); L←RIGHT(TARRAY[15]);
	    USETIN(BAIJFN,TARRAY[14]); T←NULL; FOR I←0 UPTO L DO T←T &
	    CVASTR(WORDIN(BAIJFN)); J←BK!PRV(TRUE);
	    FOR I←0 UPTO L!TXTFIL DO
		HORSECART(BAITIM,BAINAM,T!TXTFIL[I]←SCAN(T,BK!TAB,BRCHAR));
	    BK!PRV(J);

	# NOW WE ARE IN BUSINESS;
	GOTO DONESTBAIL; END END "NOROLL";

# HERE TO CONSTRUCT THE .BAI FILE;
BAIJFN←OPENFILE(BAINAM,"WE"); IF !SKIP! THEN BEGIN BAILOFF←TRUE;
	NONFATAL("Device error or not available for .BAI file;
Bailor abandons ship.");RETURN END;

# NOW GET SOME CORE FOR THE VARIABLE LENGTH TABLES;
C!NAME←COREGET(N!NAME←2000);  L!NAME←32;	# FOR BUCKETS;
C!BLKADR←COREGET(N!BLKADR←256);	L!BLKADR←-1;
C!CRDIDX←COREGET(N!CRDIDX←64);	L!CRDIDX←-1;

N!BYTE←0;CRDCTR←0;

# WRITE A DUMMY FIRST BLOCK;	ARRYOUT(BAIJFN,TARRAY[0],128);

L!TXTFIL←-1;
DOSM1(0);	# PROCESS THOSE FILES WHICH DO NOT POINT TO PREDECLARED RUNTIMES;
# SUPER OUTER BLOCK, FOR PREDECLARED STUFF;
# FIRST THE BLOCK;
L←PREDEC("$RUN$",BLK,0,0); AD!BLKADR(L,'777777000000);
# NOW THE OTHER STUFF;
NOHAND([
PREDEC("!SKIP!"		,ID,L,REFB+INTEGR+LOCATION(!SKIP!));
PREDEC("MEMORY"		,ID,L,REFMEMORY);
PREDEC("INTEGER"	,ID,L,INTEGR+LOCATION(INTEGR));
PREDEC("REAL"		,ID,L,INTEGR+LOCATION(FLOTNG));
PREDEC("STRING"		,ID,L,INTEGR+LOCATION(STRNG));
PREDEC("SET"		,ID,L,INTEGR+LOCATION(SETYPE));
PREDEC("LIST"		,ID,L,INTEGR+LOCATION(LSTYPE));
PREDEC("GOGTAB"		,ID,L,REFB+ARRY+INTEGR+LOCATION(GOGTAB));
PREDEC("TRACE"		,PRC,L,REFTRACE);
PREDEC("UNTRACE"	,PRC,L,REFUNTRACE);
PREDEC("BREAK"		,PRC,L,REFBREAK);
PREDEC("UNBREAK"	,PRC,L,REFUNBREAK);
PREDEC("SETLEX"		,PRC,L,REFSETLEX);
PREDEC("HELP"		,PRC,L,REFHELP);
PREDEC("!!STEP"		,PRC,L,REF!!STEP);
PREDEC("!!GOTO"		,PRC,L,REF!!GOTO);
PREDEC("!!GSTEP"	,PRC,L,REF!!GSTEP);
PREDEC("ARGS"		,PRC,L,REF!!ARGS);
PREDEC("TEXT"		,PRC,L,REF!!TEXT);
PREDEC("TRAPS"		,PRC,L,REFTRAPS);
PREDEC("SHOW"		,PRC,L,REFSHOW);
PREDEC("DDT"		,PRC,L,REFDDT);
PREDEC("COORD"		,PRC,L,REFCOORD);
PREDEC("!!UP"		,PRC,L,REF!!UP);
]) # NOHAND;
HAND([
BEGIN
DEFINE Z(B)=[CVASC("] & [B] & [")];
PRESET!WITH 
	Z(!SKIP),Z(!),0,
	Z(MEMOR),Z(Y),0,
	Z(INTEG),Z(ER),0,
	Z(REAL),0,0,
	Z(STRIN),Z(G),0,
	Z(SET),0,0,
	Z(LIST),0,0,
	Z(GOGTA),Z(B),0,
	Z(TRACE),0,0,
	Z(UNTRA),Z(CE),0,
	Z(BREAK),0,0,
	Z(UNBRE),Z(AK),0,
	Z(SETLE),Z(X),0,
	Z(HELP),0,0,
	Z(!!STE),Z(P),0,
	Z(!!GOT),Z(O),0,
	Z(!!GST),Z(EP),0,
	Z(ARGS),0,0,
	Z(TEXT),0,0,
	Z(TRAPS),0,0,
	Z(SHOW),0,0,
	Z(DDT),0,0,
	Z(COORD),0,0,
	Z(!!UP),0,0	;
OWN SAFE INTEGER ARRAY PRENAM[0:3*24-1];
START!CODE DEFINE T=['13],T2=['14];
EXTERNAL INTEGER SETLEX,!!STEP,!!GSTEP,!!ARGS,!!TEXT;
DEFINE	REFINT=	['200240000000],
	REFMEM=	['201240777777],
	INT=	['000240000000],
	INTARY=	['001440000000],
	PROC=	['020000000000],
	STRPRC=	['020140000000],
	INTPRC=	['020240000000];
# REFB+INTEGR;
# REFB+ARRY+NOTYPE;
# INTEGR;
# INTEGR ARRY;
# PROCB;
# PROCB+STRNG;
# PROCB+INTEGR;
LABEL LUP,REFTAB,BOT,NOTPRC;
	MOVEI	T,23;	# 24 SYMBOLS TO BE PREDECLARED, 0 THRU 23;
LUP:	MOVEM	T,I;	# TUCK IT AWAY IN MEMORY;
	MOVEI	T2,PRC;	# ASSUME PROCEDURE;
	CAIGE	T,8;
	 MOVEI	T2,ID;	# WRONG ASSUMPTION;
	PUSH	P,T2;
	PUSH	P,L;
	PUSH	P,REFTAB(T);	# MAGIC BITS FOR THIS NAME;
	CAIGE	T,8;
	 JRST	NOTPRC;
	PUSHJ	P,PDFIND;	# FIND PDA FOR THIS PROC;
	MOVE	T,I;	# RETRIEVE DESTROYED AC;
	HLL	1,REFTAB(T);	# REINSERT PROCEDURE TYPE BITS;
	PUSH	P,1;	# STACK IT;
NOTPRC:	IMULI	T,3;	# 3 WORDS PER NAME IN PRENAM ARRAY;
	MOVEI	T,PRENAM[0](T);
	PUSH	P,T;	# FWA;
	PUSHJ	P,INSERT;	# STICK IT IN MAGIC TABLE;
	MOVE	T,I;	# RESTORE DESTROYED AC;
	SOJGE	T,LUP;
	JRST	BOT;
REFTAB:	REFINT	!SKIP!;
	REFMEM;
	INT	0,[INTEGR];
	INT	0,[FLOTNG];
	INT	0,[STRNG];
	INT	0,[SETYPE];
	INT	0,[LSTYPE];
	INTARY	GOGTAB;
	PROC	TRACE;
	PROC	UNTRACE;
	PROC	BREAK;
	PROC	UNBREAK;
	PROC	SETLEX;
	STRPRC	HELP;
	PROC	!!STEP;
	PROC	!!GOTO;
	PROC	!!GSTEP;
	STRPRC	!!ARGS;
	STRPRC	!!TEXT;
	STRPRC	TRAPS;
	STRPRC	SHOW;
	PROC	DDT;
	INTPRC	COORD;
	INTPRC	!!UP;
BOT:
	END;
END;
]) # HAND;

DOSM1(L);	# Process those .SM1 files for predecalred runtimes, if any;

# PUT A FLAG AT THE END OF THE COORDINATES ON THE .BAI FILE;
WORDOUT(BAIJFN,'350200000001); # BP='35, FILE=1, WORD=0, BLOCK=1;
WORDOUT(BAIJFN,'377777777777); # ALLSTO=0, CRDNO='377777, ADDR='777777;
N!BYTE←((N!BYTE+'200) LAND LNOT '177)-2;	# FORCE NEW ENTRY IN INDEX,TOO;
AD!CRDIDX('377777777777);

# CONSTRUCT THE FATHER CHAINS IN THE BLKADR TABLE AND NAME TABLE;
NOHAND([
DEFINE FWA(I)=[RIGHT(T!BLKADR(I+1))], LWA(I)=[LEFT(T!BLKADR(I+1))];
DEFINE NAMPTR(I)=[RIGHT(T!BLKADR(I))], FATHERBLOCK(I)=[LEFT(T!BLKADR(I))];
L←0; TARRAY[L]←L!BLKADR-1;
FOR I←L!BLKADR-3 STEP -2 UNTIL 0 DO BEGIN "FBLK"
    # DESCEND TO PROPER LEVEL. QUIT UPON REACHING ANY OUTER BLOCK;
    WHILE LWA(I)<FWA(TARRAY[L]) DO IF L NEQ 0 THEN L←L-1 ELSE BEGIN
	TARRAY[0]←I; CONTINUE "FBLK" END;
    T!BLKADR(I)←T!BLKADR(I) LOR TARRAY[L] LSH 18;  # INSERT FATHER;
    PAGEIT(T!NAME,NAMPTR(I))←PAGEIT(T!NAME,NAMPTR(I)) LAND '600000777777
	LOR (NAMPTR(FATHERBLOCK(I)) LSH 18);	# TAKE CARE OF NAME TABLE, TOO;
    TARRAY[L←L+1]←I;	# UP A NEW LEVEL AND RECORD; END "FBLK";
]) # NOHAND;
HAND([
START!CODE LABEL TOP2,BOT2,BOT1;
DEFINE I=['14],L=['15],T1=[1],T2=[2];
	SETZ	L,;
	MOVE	I,L!BLKADR;
	SUBI	I,1;
	ADD	I,C!BLKADR;
	MOVEM	I,TARRAY[0];
	JRST	BOT1;
TOP2:	SKIPE	L;
	 SOJA	L,BOT2;
	MOVEM	I,TARRAY[0];
	JRST	BOT1;
BOT2:	HLRZ	T1,1(I);		# LWA (I);
	SKIPGE	T2,L;
	 ARERR	1,["TARRAY"];
	MOVE	T2,TARRAY[0](L);
	HRRZ	T2,1(T2);		# FWA(TARRAY[L]);
	CAIGE	T1,(T2);
	 JRST	TOP2;
	MOVE	T1,TARRAY[0](L);
	SUB	T1,C!BLKADR;
	HRLM	T1,(I);		# T!BLKADR(I)← ... LOR TARRAY[L] LSH 18;
	ADD	T1,C!BLKADR;	# FATHERBLOCK(I);
	MOVE	T1,(T1);	# NAMPTR(   );
	MOVE	T2,(I);		# NAMPTR(I);
	ADD	T2,C!NAME;
	DPB	T1,[('222000+T2)LSH 18];
	AOJ	L,;
	MOVEM	I,TARRAY[0](L);
BOT1:	SUBI	I,2;
	CAML	I,C!BLKADR;
	 JRST	BOT2;
END;
]) # HAND;

# REVERSE THE HASH CHAINING IN THE NAME TABLE, SO THAT THE INNERMOST 
  OCCURRENCES OCCUR FIRST IN A CHAIN;
NOHAND([
FOR I←0 UPTO 31 DO BEGIN
    INTEGER FATHER, SON;
    FATHER←T!NAME(I); L←0;
    WHILE FATHER NEQ 0 DO BEGIN
	SON←RIGHT(T!NAME(FATHER));
	T!NAME(FATHER)←T!NAME(FATHER) LAND '777777000000 LOR L;
	L←FATHER; FATHER←SON END;
    T!NAME(I)←L END;
]) # NOHAND;
HAND([
START!CODE LABEL TOP1,TOP2,BOT1;
DEFINE F=['14],S=['15],L=[0],I=[2];
	MOVSI	I,-32;
	HRR	I,C!NAME;
TOP1:	MOVE	F,(I);
	SETZ	L,;
	JRST	BOT1;
TOP2:	ADD	F,C!NAME;	# RELOC FATHER;
	HRRZ	S,(F);		# SON←RIGHT(T!NAME(FATHER));
	HRRM	L,(F);
	MOVEI	L,(F);
	SUB	L,C!NAME;
	MOVEI	F,(S);
BOT1:	JUMPN	F,TOP2;
	MOVEM	L,(I);
	AOBJN	I,TOP1;
END;
]) # HAND;

# NOW WRITE THE VARIABLE LENGTH TABLES TO THE .BAI FILE;
USETOUT(BAIJFN,TARRAY[8]←(N!BYTE + '577) LSH -7);	# PAST HEADER BLOCK AND COORDS;
    ARRYOUT(BAIJFN,T!CRDIDX(0),RIGHT(TARRAY[9]←(CRDCTR LSH 18)+L!CRDIDX+1));
USETOUT(BAIJFN,TARRAY[10]←TARRAY[8]+((L!CRDIDX+'200) LSH -7));
    ARRYOUT(BAIJFN,T!BLKADR(0),TARRAY[11]←L!BLKADR+1);
USETOUT(BAIJFN,TARRAY[12]←TARRAY[10]+((L!BLKADR+'200) LSH -7));
    ARRYOUT(BAIJFN,T!NAME(0),TARRAY[13]←L!NAME+1);
T←NULL; FOR I←0 UPTO L!TXTFIL DO T←T & T!TXTFIL[I] & TAB; L←(LENGTH(T)+4) DIV 5;
    USETOUT(BAIJFN,TARRAY[14]←TARRAY[12]+((L!NAME+'200) LSH -7));
    TARRAY[15]←L!TXTFIL LSH 18 LOR L;
    FOR I←1 UPTO L DO WORDOUT(BAIJFN,CVASC(T[5*I-4 FOR 5]));

# WRITE THE HEADER INDEX BLOCK AND CLOSE OUR GLORIOUS FILE;
USETOUT(BAIJFN,1); ARRYOUT(BAIJFN,TARRAY[0],128); CFILE(BAIJFN);

# NOW REOPEN IT FOR BUSINESS;
BAIJFN←OPENFILE(BAINAM, "R"); # RELEASE T!NAME CORE HERE IF
		YOU ARE PAGING THE NAME TABLE;

DONESTBAIL:
NOHAND([L!CACHE←-1;]) HAND([L!CACHE←-5;])
# INITIALIZE THE BREAKPOINT TRAP;
PJPBAIL←'260000000000 # PUSHJ; +(P LSH 23)+LOCATION(BAIL);



START!CODE DEFINE USER=['15],TEMP=['14];
	MOVE	USER,GOGTAB;
	MOVSI	TEMP,'400000;
	IORM	TEMP,BAILOC(USER);	# SIGN BIT IFF INITIALIZED,,LOC(BAIL);
	SETZM	BAILOFF;
END;
OUTSTR("
End of BAIL initialization.
");
!SKIP!←#SKIP#;
END "STBAIL";
# LINED DBANG !!EQU EVALERR;
DEFINE INTVAL=[1], REALVAL=[2], STRCON=[3], ID=[4], SPCHAR=[5];

SIMPLE STRING PROCEDURE LINED; BEGIN "LINED"
DEFINE QUOTE=['042], SEMI=['073];
# RETURN A STRING WHICH ENDS IN A SEMICOLON AND IS BALANCED WITH
	RESPECT TO STRING QUOTES;
NOHAND([
STRING RESULT; INTEGER CHAR, QUOTECOUNT,#SKIP#;

QUOTECOUNT←0; RESULT←NULL; #SKIP#←!SKIP!;
WHILE TRUE DO BEGIN
    IF LENGTH(!!QUERY) THEN BEGIN
	RESULT←RESULT&!!QUERY; !!QUERY←NULL END
    ELSE
	NOTENX([RESULT←RESULT & INCHWL;]) TENX([RESULT←RESULT & INTTY;])
    QUOTECOUNT←0; J←LENGTH(RESULT);
    FOR I←1 UPTO J DO IF RESULT[I FOR 1]=QUOTE THEN QUOTECOUNT←LNOT (QUOTECOUNT);
    IF NOT QUOTECOUNT THEN BEGIN
	IF RESULT[INF FOR 1]='073 THEN BEGIN
	    !SKIP!←#SKIP#;
	    # SYNTACTIC SUGAR;
	    IF RESULT="?" THEN RETURN("HELP;")
	    ELSE RETURN(RESULT) END;
	IF !SKIP!='15 OR !SKIP!='12 THEN RESULT←CATCRLF(RESULT)
	   ELSE IF !SKIP!>0 THEN RESULT←RESULT&!SKIP!;
END END;
]) # NOHAND;
HAND([
EXTERNAL INTEGER CAT,CATCHR;
STRING RESULT,TSTR,TSTR1; INTEGER I,J;
START!CODE LABEL LOOP1,LOOP2,CCRLF,NORAISE,SUGAR,CCRLF1,USETTY,CATR;
NOTENX([EXTERNAL INTEGER INCHWL;])
TENX([EXTERNAL INTEGER INTTY;])
DEFINE L=[1],T=[2],QC=[3],BP=[4];
	PUSH	SP,[0];
	PUSH	SP,[0];	# NULL STRING;
LOOP1:
	MOVEI	T,!!QUERY;
	HRRZ	L,-1(T);	# LENGTH OF !!QUERY;
	JUMPE	L,USETTY;
	PUSH	SP,-1(T);	# USE !!QUERY;
	PUSH	SP,(T);
	SETZM	-1(T);		# !!QUERY←NULL;
	SETZM	#SKIP#;
	JRST	CATR;
USETTY:	PUSH	P,!SKIP!;	# PRESERVE OVER CALL WHICH MUNGES IT;
	PUSHJ	P,NOTENX([INCHWL]) TENX([INTTY]);
	POP	P,T;	# PREVIOUS !SKIP!;
	EXCH	T,!SKIP!;
	MOVEM	T,#SKIP#;
CATR:	PUSHJ	P,CAT;
	SETZ	QC,0;
	HRRZ	L,-1(SP);	# LENGTH OF STRING;
	JUMPE	L,LOOP1;
	MOVE	BP,(SP);	# BYTE POINTER TO STRING;
	MOVE	T,(SP);		# BYTE POINTER;
	ILDB	T,T;		# FIRST CHAR;
	CAIN	T,"?";		# CHECK FIRST CHAR FOR HELP;
	 JRST	SUGAR;
LOOP2:	ILDB	T,BP;
	CAIN	T,QUOTE;
	 SETCA	QC,QC;
	JUMPN	QC,NORAISE;	# IF IN STRING QUOTE, DON'T MUNGE;
	CAIN	T,"_";		# CHECK FOR UNDERBAR;
	 MOVEI	T,"!";		# CHANGE TO BANG;
	DPB	T,BP;
NORAISE:
	SOJG	L,LOOP2;
	JUMPN	QC,CCRLF;
	CAIN	T,SEMI;
	 POPJ	P,;
CCRLF:
	MOVE	T,#SKIP#;	# GET BREAK CHAR;
	JUMPLE	T,LOOP1;	# IF NO BREAK CHAR, JUST CONTINUE;
	CAIE	T,'15;
	CAIN	T,'12;
	 JRST	CCRLF1;		# IF CR OR LF, THEN PUT CRLF ON END;
	PUSH	P,T;		# SOME CHAR OTHER THAN CR OR LF;
	PUSHJ	P,CATCHR;
	JRST	LOOP1;
CCRLF1:	PUSHJ	P,CATCRLF;
	JRST	LOOP1;
SUGAR:	MOVEI	T,5;
	MOVEM	T,-1(SP);
	MOVE	T,["HELP;"];
	MOVEM	T,(SP);
	POPJ	P,;
END;
]) # HAND;
END "LINED";

SIMPLE STRING PROCEDURE DBANG(STRING ARG); START!CODE "DBANG"
# CHANGE STANFORD UNDERBAR TO EXCLAMATION MARK;
LABEL LOOP,LAB;
	HRRZ	1,-1(SP);	# LENGTH;
	SKIPN	1;
	 POPJ	P,;		# NULL STRING;
	MOVE	2,(SP);		# BYTE POINTER TO STRING;
LOOP:	ILDB	3,2;		# GET CHAR;
	CAIN	3,"_";		# CHECK FOR STANFORD UNDERBAR;
	 MOVEI	3,"!";		# CHANGE TO BANG;
LAB:	DPB	3,2;
	SOJG	1,LOOP;		# UNTIL DONE;
	POPJ	P,;
END "DBANG";


SIMPLE INTEGER PROCEDURE !!EQU(STRING A,B);
    EQU(DBANG(STRCOPY(A)),DBANG(STRCOPY(B)));
    # SAME AS EQU EXCEPT THAT STANFORD UNDERBARS EQUAL EXCLAMATION POINTS;


SIMPLE PROCEDURE EVALERR(STRING WHY,OLDARG,ARG); BEGIN
    !ERRP! SWAP !RECOVERY!;
    NONFATAL(WHY & ":  " & OLDARG & LF & ARG);END;
SIMPLE PROCEDURE EV1ERR(STRING WHY); EVALERR(WHY,NULL,NULL);
# GET!TOKEN;
SIMPLE PROCEDURE GET!TOKEN(REFERENCE STRING ARG,STRVAL; REFERENCE INTEGER CLASS,
	IVAL); BEGIN "GET!TOKEN"
INTEGER BRCHAR,T,#SKIP#;		STRING A;
DEFINE XDELIMS=[SCAN(ARG,BK!DLM,BRCHAR)];

#SKIP#←!SKIP!;
# ESTABLISH BREAKTABLE PRIVILEGE AND SKIP OVER INITIAL DELIMITERS;
T←BK!PRV(TRUE); XDELIMS;

# CHECK FOR STRING CONSTANT. STRING CONSTANTS ARE RETURNED WITHOUT
    SURROUNDING QUOTES, AND WITH INTERNAL DOUBLE QUOTES REMOVED;
# NOTE HEAVY DEPENDENCE ON SAIL TYPE CONVERSION IN THIS "IF";
IF ARG=QUOTE THEN BEGIN
	STRVAL←NULL;
	WHILE ARG=QUOTE DO BEGIN A←LOP(ARG);
		STRVAL←STRVAL & SCAN(ARG,BK!QUO,BRCHAR) END;
	IF BRCHAR NEQ QUOTE THEN
	    NONFATAL("Inserting missing string quote")
	ELSE STRVAL←STRVAL[1 TO INF-1]; 	# REMOVE TERMINATING QUOTE;
	CLASS←STRCON; END

# CHECK FOR OCTAL CONSTANT;
ELSE IF ARG="'" THEN BEGIN
	A←LOP(ARG);
	IVAL←CVO(SCAN(ARG,BK!OCT,BRCHAR)); CLASS←INTVAL; END

# CHECK FOR INTEGER OR REAL CONSTANT;
# THIS IS A KLUGE BECAUSE INTSCAN WON'T STOP UPON SEEING A LETTER OR 
	SPECIAL CHAR OR DELIMITER.  INTSCAN INSISTS UPON FINDING A 
	NUMBER, EVEN THE "8" IN "K[I]←FN(SYM8T)";
ELSE IF LENGTH(A←SCAN(ARG,BK!NUM,BRCHAR)) THEN BEGIN
	# FOUND A NUMBER. RECONSTITUTE ARG, THEN DECIDE REAL OR INTEGER;
	T←LENGTH(STRVAL←ARG←A & ARG);
	SCAN(A,BK!DEC,BRCHAR);
	IF LENGTH(A) THEN BEGIN # REAL CONSTANT;
	    MEMLOC(IVAL,REAL)←REALSCAN(ARG,BRCHAR); CLASS←REALVAL; END
	ELSE BEGIN # INTEGER CONSTANT;
	    IVAL←INTSCAN(ARG,BRCHAR); CLASS←INTVAL; END;
	STRVAL←STRVAL[1 FOR T-LENGTH(ARG)] END

# CHECK FOR IDENTIFIER;
ELSE BEGIN STRVAL←SCAN(ARG,BK!ID,BRCHAR); 
IF STRVAL=NULL THEN BEGIN
	STRVAL←LOP(ARG); CLASS←SPCHAR; END
ELSE BEGIN
	XDELIMS; CLASS←ID; STRVAL←DBANG(STRVAL); CVNAME(STRVAL,NAME) END END;

# COMMON RETURN POINT;
BK!PRV(T); !SKIP!←#SKIP#; RETURN END "GET!TOKEN";
# INTARRAY, CRD!PC, FTEXT, SHOW, CRDFND, GETTEXT;
SIMPLE PROCEDURE INTARRAY(INTEGER CHAN,BLOCK); BEGIN
USETIN(CHAN,BLOCK); ARRYIN(CHAN,TARRAY[0],256) END;

SIMPLE INTEGER PROCEDURE CRD!PC(INTEGER PC);
# RETURN INDEX TO TARRAY OF COORDINATE WHICH IS FLOOR OF PC;
NOHAND([
BEGIN
I←-1; DO I←I+1 UNTIL RIGHT(T!CRDIDX(I))>PC;
INTARRAY(BAIJFN,I+2);
I←-1; DO I←I+2 UNTIL RIGHT(TARRAY[I])>PC; RETURN(I-3) END;
]) # NOHAND;
HAND([
BEGIN
START!CODE LABEL LOOP1,LOOP2; DEFINE I=[1],T=['15];
	MOVE	I,C!CRDIDX;	# FWA DATA;
LOOP1:	HRRZ	T,(I);		# PC FOR COORD;
	CAMG	T,PC;
	 AOJA	I,LOOP1;	# FIND FIRST WHICH IS GREATER;
	PUSH	P,BAIJFN;
	ADDI	I,2;		# USETI POINTER;
	SUB	I,C!CRDIDX;
	PUSH	P,I;
	PUSHJ	P,INTARRAY;
	SETO	I,;	
LOOP2:	ADDI	I,2;		# NEXT COORD;
	HRRZ	T,TARRAY[0](I);
	CAMG	T,PC;		# FIND FIRST WHICH IS GREATER;
	 JRST	LOOP2;
	SUBI	I,3;		# POINT TO RIGHT PLACE;
	SKIPGE	I;
	 SETZ	I,;		# JUST IN CASE;
	SUB	P,['2000002];
	JRST	@2(P);
END; END;
]) # HAND;


SIMPLE INTEGER PROCEDURE CRDFND(INTEGER CRDNO); BEGIN "CRDFND"
# RETURN INDEX TO TARRAY WHICH POINTS TO COORDINATE INFO FOR CRDNO;
IF L!CRDIDX<0 THEN EV1ERR("No coordinates");
IF 0 LEQ CRDNO LEQ CRDCTR THEN BEGIN
    INTARRAY(BAIJFN,(CRDNO LSH -6)+2);
    RETURN((CRDNO LAND '77) LSH 1) END;
EV1ERR("Coordinate out of range"); END "CRDFND";


SIMPLE STRING PROCEDURE FTEXT(INTEGER CRDPNTR); BEGIN "FTEXT"
# CONSTRUCT STRING CONTAINING TEXT OF COORDINATE GIVEN BY TARRAY[CRDPNTR];
INTEGER ALLSTO,COORD1;
INTEGER PNTR1,PNTR2,I,FILN,OFILN;	STRING TEXT;
#SKIP#←!SKIP!;
# PICK UP FILE,BLOCK,WORD NUMBERS FOR CURRENT AND NEXT COORDINATE;
NOHAND([
PNTR1←TARRAY[CRDPNTR]; COORD1←LEFT(TARRAY[CRDPNTR+1]) LAND '377777;
ALLSTO←TARRAY[CRDPNTR+1] LSH -35;
PNTR2←TARRAY[CRDPNTR+2]; IF RIGHT(PNTR2)<RIGHT(PNTR1) THEN PNTR2←
    PNTR1 LAND '17777777777 LOR '177000000;
FILN←PNTR1 LSH -25 LAND '37;
]) # NOHAND;
HAND([
START!CODE DEFINE T=[1],T2=[2],CP=[3];
	MOVE	CP,CRDPNTR;
	MOVE	T,TARRAY[0](CP);
	MOVEM	T,PNTR1;
	LDB	T,[('310500 LSH 18)+T];	# FILE NUMBER OF PNTR1;
	MOVEM	T,FILN;
	HLRZ	T,TARRAY[1](CP);
	ANDI	T,'377777;
	MOVEM	T,COORD1;
	SETZM	ALLSTO;
	SKIPGE	TARRAY[1](CP);
	 SETOM	ALLSTO;
	MOVE	T,TARRAY[2](CP);	# T HOLDS PNTR2;
	LDB	T2,[('310500 LSH 18)+T];	# FILE NUMBER OF PNTR2;
	MOVE	CP,PNTR1;
	TLO	CP,'177;	# WORD '177;
	TLZ	CP,'760000;	# BYTE POS 0 OR 1;
	CAME	T2,FILN;
	 MOVE	T,CP;		# DIFFERENT FILES;
# COMPUTE NUMBER OF CHARACTERS BETWEEN PNTR1 AND PNTR2;
	SUB	T,PNTR1;	# CANT OVERFLOW BECAUSE POS FIELDS CANT BE '44;
	MOVEI	CP,(T);		# DIFFERNCE OF BLOCK NUMBERS;
	LSH	CP,7;		# INTO WORDS;
	HLRS	T;
	LSH	T,10;		# SIGN EXTEND WORD DIFFERENCE;
	ASH	T,-10;
	MOVSS	T;		# old left half,,difference of word numbers;
	ADDI	CP,(T);		# MAY CARRY OVER INTO LEFT HALF OF CP. DONT CARE;
	IMULI	CP,5;		# INTO CHARACTERS;
	ASH	T,-30;		# BYTE POSITION DIFFERENCE;
	IDIVI	T,7;		# CHAR DIF IN T, CLOBBER T+1  **********;
	SUBI	T,(CP);		# NEG NUMBER OF CHARS;
	MOVEI	CP,TEXT;	# ADR OF WD2;
	MOVNM	T,-1(CP);	# STRING CHAR COUNT;
# COMPUTE BYTE POINTER;
	HLRZ	T,PNTR1;	# BYTE POS, FILE, WORD;
	MOVEI	CP,(T);		# SAVE WORD OFFSET;
	ANDCMI	T,'7777;	# ISOLATE POS FIELD;
	MOVSI	T,'070700(T);	# INSERT SIZE, BACK UP LDB POS FOR ILDB;
	ANDI	CP,'177;	# ISOLATE WORD OFFSET;
	HRRI	T,TARRAY[0](CP);
	MOVEM	T,TEXT;
	END;
]) # HAND;
# STATUS OF FILES
	-'1000	NOT ACCESSIBLE (DETERMINED AT INITIALIZATION TIME)
	    -1	ACCESSIBLE, NOT OPEN
	     1	OPEN;
IF FILN=31 OR STATUS[FILN]=-'1000 THEN
    RETURN("%%% File not viewable");
IF STATUS[FILN] NEQ 1 THEN BEGIN "NOPEN"	# FILE NOT OPEN;
    # CLOSE PREVIOUS FILE, IF ANY;
    CFILE(TMPJFN); STATUS[OFILN]←-1;
    # OPEN NEW FILE ON TMPJFN;
    TMPJFN←OPENFILE(T!TXTFIL[FILN],"RE"); IF !SKIP! THEN BEGIN
	!SKIP!←#SKIP#; RETURN("%%% File not viewable") END ELSE
	STATUS[FILN]←1 END "NOPEN";
# POSITION AND READ TEXT FILE;
OFILN←FILN; INTARRAY(TMPJFN,RIGHT(PNTR1));
NOHAND([
MEMORY[LOCATION(TEXT)]←(PNTR1 LAND ('77 LSH 30))+('0707 LSH 24)+
    LOCATION(TARRAY[0])+(LEFT(PNTR1) LAND '177);
MEMORY[LOCATION(TEXT)-1]←(RIGHT(PNTR2)-RIGHT(PNTR1))*('200*5) +
    ((LEFT(PNTR2)LAND '177)-(LEFT(PNTR1)LAND '177))*5 -
    ((PNTR2 LSH -30)-(PNTR1 LSH -30))%7;
]) # NOHAND;
TEXT←"#" & CVS(COORD1) & (IF ALLSTO THEN " " ELSE "+") & TAB & NONULL(TEXT);
!SKIP!←#SKIP#; RETURN(TEXT)
END "FTEXT";


STRING PROCEDURE SHOW(INTEGER FIRST,LAST(0));
BEGIN
# TYPE OUT TEXT FOR COORDINATE(S) GIVEN.
  FIRST IS THE FIRST COORDINATE TO BE SHOWN.
  IF LAST<FIRST THEN SHOW FROM FIRST TO FIRST+LAST,
  OTHERWISE SHOW FROM FIRST TO LAST.
;
IF LAST<FIRST THEN LAST←LAST+FIRST;
FOR FIRST←FIRST STEP 1 UNTIL LAST DO
	ADDSTR(CATCRLF(FTEXT(CRDFND(FIRST))));
SSF←TRUE; RETURN(DUMPSTR)
END;


SIMPLE STRING PROCEDURE GETTEXT(INTEGER PC); BEGIN "GETTEXT"
INTEGER T;

# TRY TO DO A FAVOR FOR BREAKS OF RECURSIVE PROCEDURES.  THE ENTRY POINT
  IS AFTER ALL THE CODE, SO THE ADDRESS IS NOT PARTICULARLY MEANINGFUL;
IF (MEMORY[PC] LAND '777777400000)='551517400000	# HRRZI F,-n(P);
    AND LEFT(T←MEMORY[PC+1])='254000			# JRST;
    AND RIGHT(T)<PC					# FWA<ENTRY;
  THEN PC←RIGHT(T);
T←CRD!PC(PC);
IF ABS(PC-RIGHT(TARRAY[T+1]))>'400 THEN
	RETURN("'" & CVOS(PC) &TAB& "%%% File not viewable");
RETURN(FTEXT(T)) END "GETTEXT";
# N!PARAMS, HELP;

SIMPLE INTEGER PROCEDURE N!PARAMS(INTEGER REFIT);
NOHAND([
BEGIN"N!PARAMS"
DEFINE PD(A)=[MEMORY[PDA+A]];
INTEGER PDA;

PDA←RIGHT(REFIT); RETURN(RIGHT(PD(PD!NPW))-1 + (LEFT(PD(PD!NPW)) LSH -1))
END "N!PARAMS";
]) # NOHAND;
HAND([
START!CODE
	HRRZ	2,REFIT;
	HRRZ	1,PD!NPW(2);
	SUBI	1,1;
	HLRZ	2,PD!NPW(2);
	LSH	2,-1;
	ADDI	1,(2);
	SUB	P,['2000002];
	JRST	@2(P);
END;]) # HAND;


STRING PROCEDURE HELP; BEGIN SSF←TRUE; RETURN("
	loc ::= procedure | block | label | # coordinate | ' octalnumber
expression;
procedure!call;
BREAK(""loc"",""condition""(null),""action""(null),count(0));
UNBREAK(""loc"");
TRACE(""procedure"");		UNTRACE(""procedure"");
SHOW(coord,coord(0));
SETLEX(level);			!!UP(level);
COORD(""loc"");			!!GOTO(""loc"");
ARGS;		DDT;		HELP;		TEXT;		TRAPS;
!!GO;		!!STEP;		!!GSTEP;	?
");
END;
# CVINTEGR, CVREAL, CVSTRNG;

INTEGER ARRAY EV1TEMP[1:2];	STRING ARRAY EV1STRTEMP[1:2];

SIMPLE INTEGER PROCEDURE CVINTEGR(INTEGER REFIT,T); BEGIN "CVINTEGR"
# CONVERT THE DATUM OF THE REFITEM TO INTEGER, USING TEMP CELL NUMBER T.
  RETURN THE REFITEM OF THE RESULT;
INTEGER TYP,LOC;

IF (TYP←GETTYPE(REFIT))=INTEGR OR REFIT=-1 THEN RETURN(REFIT);
# THE CHECK FOR REFIT=-1 IS TO ACCOMODATE THE  MEMORY  CONSTRUCT;
LOC←RIGHT(REFIT);
IF TYP=FLOTNG THEN MEMLOC(EV1TEMP[T],INTEGER)←MEMORY[LOC,REAL]
ELSE IF TYP=STRNG THEN EV1TEMP[T]←MEMSTRING(LOC)
ELSE EV1ERR("Can't convert to integer");
RETURN(INTEGR+LOCATION(EV1TEMP[T]))

END "CVINTEGR";


SIMPLE INTEGER PROCEDURE CVREAL(INTEGER REFIT,T); BEGIN"CVREAL"
# CONVERT REFIT DATUM TO REAL USING TEMP CELL T. RETURN REFITEM OF RESULT.;
INTEGER TYP;

IF (TYP←GETTYPE(REFIT))=FLOTNG THEN RETURN(REFIT);
IF TYP=STRNG THEN BEGIN
    REFIT←CVINTEGR(REFIT,T); TYP←INTEGR END;
IF TYP=INTEGR THEN MEMLOC(EV1TEMP[T],REAL)←MEMORY[REFIT,INTEGER]
ELSE EV1ERR("Can't convert to real");
RETURN(FLOTNG+LOCATION(EV1TEMP[T]))

END "CVREAL";


SIMPLE INTEGER PROCEDURE CVSTRNG(INTEGER REFIT,T); BEGIN "CVSTRNG"
# CONVERT THE DATUM OF THE REFIT TO STRING AND RETURN THE REFITEM OF THE RESULT;
INTEGER TYP;

IF (TYP←GETTYPE(REFIT))=STRNG THEN RETURN(REFIT);
IF TYP=FLOTNG THEN BEGIN
    REFIT←CVINTEGR(REFIT,T); TYP←INTEGR END;
IF TYP=INTEGR THEN EV1STRTEMP[T]←MEMORY[REFIT,INTEGER]
ELSE EV1ERR("Can't convert to string");
RETURN(STRNG+RIGHT(LOCATION(EV1STRTEMP[T])))

END "CVSTRNG";
# INCOR;
SIMPLE INTEGER PROCEDURE INCOR(INTEGER PCACHE;INTEGER ARRAY DCHAIN; INTEGER 
	DDEPTH,DISPLVL); BEGIN "INCOR"
# RETURN REFITEM DATUM WHICH HAS ABSOLUTE CORE ADDRESS OF THE OBJECT IN CACHE;
DEFINE SIMPRC=[2];
NOHAND([
INTEGER IND,FATHER,REFIT,PPDA,T,ADDR,PTYPE,FREG;

IF ((REFIT←CACHE[PCACHE+1]) LAND ('17 LSH 18))=0 THEN # FIXED CORE LOCATION;
    RETURN(REFIT);
]) # NOHAND;
HAND([
START!CODE LABEL ONSTACK,ON1T,UPPROC,LMSCP,SIMP,SERRCK,DONSIMP,TYCK,NSTR,PARAM,NSRP,
	NSTR2,RET,BAD1,BAD2,RET1,BADRET;
DEFINE DL=['14],DD=['15],DCH=[2],REFIT=[1],T3=[3],T4=[4],PPDA=[5],FREG=[6],
	FATHER=[7],PTYPE=[8];
EXTERNAL INTEGER OUTSTR,INCHWL;
	SKIPL	REFIT,PCACHE;
	CAILE	REFIT,N!CACHE;
	 ARERR	1,["CACHE"];
	MOVE	REFIT,CACHE[1](REFIT);	# REFITEM;
	TLZN	REFIT,'17;
	 JRST	RET;
]) # HAND;

# WE NOW KNOW THAT THE OBJECT IS ON THE STACK AND IS EITHER A PARAMETER TO 
  A PROCEDURE OR A LOCAL TO A RECURSIVE PROCEDURE.;
NOHAND([
IND←REFIT LAND(1 LSH 22); ADDR←RIGHT(REFIT); REFIT←REFIT LAND '777760000000;

# FOLLOW UP THE FATHER CHAIN IN THE NAME TABLE UNTIL COMING TO A PROCEDURE;
FATHER←LEFT(CACHE[PCACHE]) LAND '177777;
WHILE NOT(PAGEIT(T!NAME,FATHER+1) LAND PROCB) DO
	FATHER←LEFT(PAGEIT(T!NAME,FATHER)) LAND '177777;
# FETCH PDA FOR THE PROCEDURE;
PPDA←RIGHT(PAGEIT(T!NAME,FATHER+1)); PTYPE←LEFT(PAGEIT(T!NAME,FATHER)) LSH -16;
]) # NOHAND;
HAND([
ONSTACK:MOVE	FATHER,PCACHE;
	ADDI	FATHER,CACHE[0];
ON1T:	LDB	FATHER,[('222000+FATHER)LSH 18];
	ADD	FATHER,C!NAME;
	MOVE	PPDA,1(FATHER);
	TLNN	PPDA,0+PROCB LSH -18;
	 JRST	ON1T;
	LDB	PTYPE,[('420200+FATHER)LSH 18];
]) # HAND;
# IF PROCEDURE IS NON-simple,search from DISPLVL to DDEPTH to find FREG setting
  which matches PDA;
NOHAND([
IF PTYPE NEQ SIMPRC THEN BEGIN
    # go up DCHAIN until finding a non-simple procedure;
    WHILE DCHAIN[DISPLVL,0]<0 AND DISPLVL<DDEPTH DO DISPLVL←DISPLVL+1;
    IF DCHAIN[DISPLVL,0]<0 THEN
	EVALERR("BAIL error searching for procedure parameter",
	    CVASC(CACHE[PCACHE+2])&CVASC(CACHE[PCACHE+3])&CVASC(CACHE[PCACHE+4]),
	    NULL);
    FREG←DCHAIN[DISPLVL,0];
    # SEARCH BACK THROUGH THE STACK (ALONG THE STATIC LINKS) TO FIND THE MSCP;
    WHILE LEFT(T←MEMORY[FREG+1]) NEQ PPDA DO FREG←RIGHT(T); END
# if procedure is simple, search from DISPLVL to DDEPTH for match of PUSHJ on entry addr;
ELSE BEGIN
    FOR DISPLVL←DISPLVL UPTO DDEPTH DO BEGIN
	# Look for simple procedure activation and compare against
	    addr that was PUSHJ'ed to;
	IF DCHAIN[DISPLVL,0]<0 AND RIGHT(MEMORY[PPDA])=RIGHT(
	    MEMORY[DCHAIN[DISPLVL+1,1]]) THEN DONE;
	IF DISPLVL=DDEPTH THEN
	    EVALERR("BAIL error searching for simple procedure parameter",
		CVASC(CACHE[PCACHE+2])&CVASC(CACHE(PCACHE[PCACHE+3])&CVASC(CACHE[PCACHE+4]),
		NULL);
	END;
    # DCHAIN[DISPLVL,0] is now negative of P register at entry to proc. Simulate F reg;
    FREG←1-DCHAIN[DISPLVL,0]; END;
]) # NOHAND;
HAND([
	MOVE	DL,DISPLVL;
	CAIN	PTYPE,SIMPRC;
	 JRST	SIMP;
# GO UP DCHAIN UNTIL NON-SIMPLE;
UPPROC:	MOVEI	DCH,@DCHAIN;		# FWA DATA;
	ADDI	DCH,(DL);
	ADDI	DCH,(DL);
	SKIPGE	(DCH);
	CAML	DL,DDEPTH;
	SKIPA;
	AOJA	DL,UPPROC;
	SKIPGE	FREG,(DCH);
	 JRST	BAD1;
	SKIPA;
LMSCP:	HRRZ	FREG,1(FREG);
	JUMPE	FREG,BAD1;	# ANOTHER BUG TRAP;
	HLRZ	T3,1(FREG);
	CAIN	T3,(PPDA);
	JRST	TYCK;	# FOUND THE RIGHT ONE;
	CAIE	FREG,-1;# VALUE PUT ON STACK BY SAILOR;
	 JRST	LMSCP;	# HAVEN'T GONE OFF END YET;
	JRST	BAD1;	# TOO BAD;
SIMP:	MOVEI	DCH,@DCHAIN;
	ADDI	DCH,(DL);
	ADDI	DCH,(DL);
	SKIPL	(DCH);
	 JRST	SERRCK;
	HRRZ	T3,(PPDA);
	HRRZ	T4,@3(DCH);
	CAIN	T4,(T3);
	 JRST	DONSIMP;
SERRCK:	AOJ	DL,;
	CAMG	DL,DDEPTH;
	 JRST	SIMP;
	JRST	BAD2;
DONSIMP:MOVEI	FREG,1;
	SUB	FREG,(DCH);
]) # HAND;

# FIND OUT WHETHER THIS IS A PARAM OR A LOCAL.  LOCALS ARE FLAGGED WITH
	'400000 IN ADDR;
NOHAND([
IF ADDR LAND '400000 THEN BEGIN "LOCAL"
    ADDR←ADDR-'400000;
     # STRINGS CAUSE HAIR.  REFERENCE STRINGS ARE ON THE P-STACK, HENCE THE
	ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR IS IN A WORD 
	WHICH IS FOUND USING DISPLACEMENTS [POSITIVE FOR LOCALS, NEGATIVE
	FOR PARAMS] ON THE F REGISTER.  LOCAL AND VALUE STRINGS ARE ON THE
	SP-STACK, HENCE THE ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR
	IS COMPUTED USING DISPLACEMENTS FROM THE OLD SP-REGISTER.  THE OLD
	SP-REGISTER IS HANDILY SAVED AS THE LAST WORD OF THE 3-WORD MSCP.;
    IF GETTYPE(REFIT)=STRNG THEN	# RECURSIVE STRING LOCAL;
	RETURN(REFIT+RIGHT(MEMORY[FREG+2])+ADDR+ADDR)
    ELSE	# RECURSIVE NON-STRING LOCAL;
	RETURN(REFIT+FREG+ADDR) END "LOCAL"
ELSE BEGIN "PARAM"
    IF IND AND GETTYPE(REFIT)<ARRY THEN	# SIMPLE REFERENCE PARAM;
	RETURN((REFIT LAND '777740000000)+RIGHT(MEMORY[FREG-ADDR-1]))
    ELSE	# VALUE PARAM OR ARRAY;
	IF GETTYPE(REFIT)=STRNG THEN BEGIN
	    # check for simple procedure;
	    IF PTYPE=SIMPRC AND DISPLVL NEQ 0 THEN BEGIN OUTSTR("
		BAIL warning: attempt to access value string parameter of simple
		procedure which is not at top of stack"); INCHWL; END;
	RETURN(REFIT+RIGHT(MEMORY[FREG+2])-ADDR-ADDR+2) END
	ELSE RETURN(REFIT+FREG-ADDR-1) END "PARAM"
]) # NOHAND;
HAND([
TYCK:	TRZN	REFIT,'400000;
	 JRST	PARAM;
	TLZ	REFIT,'37;
	LDB	T3,['270600000000+REFIT];
	TLNN	REFIT,0+ITEMB LSH -18;	# STRING ITEM(var) IS NOT A STRING;
	CAIE	T3,0+STRNG LSH -23;
	 JRST	NSTR;
	ADDI	REFIT,(REFIT);
	HRRZ	T3,2(FREG);
	ADDI	REFIT,(T3);
	JRST	RET;
NSTR:	ADDI	REFIT,(FREG);
	JRST	RET;
PARAM:	LDB	T3,['270600000000+REFIT];
	CAIGE	T3,0+ARRY LSH -23;
	TLZN	REFIT,'20;
	 JRST	NSRP;		# NOT SIMPLE REF PARAM;
	SUBI	FREG,1(REFIT);	# -ADDR-1;
	HRR	REFIT,(FREG);
	JRST	RET;
NSRP:	CAIE	T3,0+STRNG LSH -23;
	 JRST	NSTR2;
	CAIN	PTYPE,SIMPRC;
	SKIPN	DL;
	 JRST	RET1;
	PUSH	SP,[106];
	PUSH	SP,["
BAIL warning: attempt to access value string parameter
of simple procedure which is not at top of stack"];
	PUSHJ	P,OUTSTR;
RET1:	HRRZ	T3,2(FREG);
	SUBI	T3,-1(REFIT);		# -ADDR+1;
	SUBI	T3,-1(REFIT);		# -ADDR+1;
	HRRI	REFIT,(T3);
	JRST	RET;
NSTR2:	SUBI	FREG,1(REFIT);
	HRRI	REFIT,(FREG);
RET:	SUB	P,['5000005];
	JRST	@5(P);
BAD1:
BAD2:		# IF WE NEED TO, WE CAN ALWAYS BREAK THE JRSTs TO HERE;
	MOVEI	T3,["
BAIL error searching for procedure parameter"];
	PUSH	SP,-1(T3);
	PUSH	SP,(T3);	# GENERAL MESSAGE;
	MOVE	T3,PCACHE;	# NOW FOR THE CULPRIT;
	ADDI	T3,CACHE[2];
	HRLI	T3,'440700;	# FABRICATE A BYTE POINTER;
	PUSH	SP,[15];
	PUSH	SP,T3;
	PUSH	SP,[0];
	PUSH	SP,[0];		# EVALERR TAKES 3 STRINGS;
	JRST	EVALERR;
END;]) # HAND;
END "INCOR";
# GETLSCOPE, PRLSCOPE;

SIMPLE PROCEDURE GETLSCOPE(INTEGER ARRAY LCHAIN; REFERENCE INTEGER LDEPTH;INTEGER PC);
BEGIN "GETLSCOPE"
NOHAND([
INTEGER I,U,L,T;	LABEL EXACT;
DEFINE LWA(I)=[LEFT(T!BLKADR(I+1))], FWA(I)=[RIGHT(T!BLKADR(I+1))];
# CONSTRUCT LEXICAL SCOPE CHAIN, MOST RECENT FIRST;

L←0; U←(L!BLKADR+1) ASH -1;
WHILE U GEQ L DO BEGIN
    I←(L+U) ASH -1;
    IF (T←LWA(I LSH 1))=PC THEN GOTO EXACT;
    IF T>PC THEN U←I-1 ELSE L←I+1 END;
IF LWA((I←L) LSH 1)<PC THEN I←L+1;
EXACT:	I←I LSH 1;
# GO UP FATHER CHAIN UNTIL PC IS GEQ FWA;
WHILE PC<FWA(I) DO I←LEFT(T!BLKADR(I));

LDEPTH←-1; DO BEGIN "UP"
    LCHAIN[LDEPTH←LDEPTH+1]←RIGHT(T!BLKADR(I)) LSH 18 LOR FWA(I);
    I←LEFT(T!BLKADR(I));	# FATHER (IN T!BLKADR) OF THIS BLOCK;
END "UP" UNTIL I=0;
]) # NOHAND;
HAND([
START!CODE LABEL TOP1,TOP2,TEST2,TOP3;
DEFINE I=[1],LCH=[2],LWA=[3],FWA=[3],T=[0];
	SETO	I,;
	ADD	I,C!BLKADR;	# RELOCATE;
TOP1:	ADDI	I,2;
	HLRZ	LWA,(I);
	CAMGE	LWA,PC;
	 JRST	TOP1;
	SUBI	I,1;		# I NOW POINTS AT WORD ZEROES;
	JRST	TEST2;
TOP2:	HLRZ	I,(I);
	ADD	I,C!BLKADR;
TEST2:	HRRZ	FWA,1(I);
	CAMLE	FWA,PC;
	 JRST	TOP2;
	MOVEI	LCH,@LCHAIN;	# FWA DATA;
	SUBI	LCH,1;
	SKIPA;
TOP3:	ADD	I,C!BLKADR;
	HRLZ	T,(I);
	HRR	T,1(I);
	ADDI	LCH,1;
	MOVEM	T,(LCH);
	HLRZ	I,(I);
	JUMPN	I,TOP3;
	SUBI	LCH,@LCHAIN;
	MOVEM	LCH,LDEPTH;
	MOVEI	FWA,@LCHAIN;	# FWA DATA;
	CAMLE	LCH,-3(FWA);	# BOUNDS CHECK;
	 ARERR	1,["LCHAIN"];
END;]) # HAND;
END "GETLSCOPE";


SIMPLE PROCEDURE PRLSCOPE(INTEGER ARRAY LCHAIN; INTEGER LDEPTH);BEGIN "PRLSCOPE"
NOHAND([
INTEGER I,T;
ADDSTR("
LEXICAL SCOPE, TOP DOWN:
");
FOR I←LDEPTH STEP -1 UNTIL 0 DO
	ADDSTR(NONULL(CVASTR(PAGEIT(T!NAME,2+(T←LEFT(LCHAIN[I])))) &
	CVASTR(PAGEIT(T!NAME,T+3)) & CATCRLF(CVASTR(PAGEIT(T!NAME,T+4))) ));
]) # NOHAND;
HAND([
ADDSTR("
LEXICAL SCOPE, TOP DOWN:
");
START!CODE LABEL LOOP; EXTERNAL INTEGER CAT,CVASTR;
DEFINE T=['14];
LOOP:	MOVEI	T,@LCHAIN;	# FWA DATA;
	ADD	T,LDEPTH;
	HLRZ	T,(T);
	ADD	T,C!NAME;
	PUSH	SP,[15];	# 15 CHARS IN 3 WORDS;
	ADD	T,['440700000002];	# MAKE B.P. TO WORD 2 IN CACHE;
	PUSH	SP,T;
	PUSHJ	P,CATCRLF;
	PUSHJ	P,NONULL;
	PUSHJ	P,ADDSTR;
	SOSL	LDEPTH;
	 JRST	LOOP;
END;]) # HAND;
END "PRLSCOPE";
# GETDSCOPE,PRDSCOPE;
SIMPLE PROCEDURE GETDSCOPE(INTEGER FR,PR,PC;REFERENCE INTEGER DDEPTH;
		INTEGER ARRAY DCHAIN); BEGIN "DSCOPE"
# DYNAMIC SCOPE UNWINDER ROUTINE.  FILLS ARRAY DCHAIN [*,0] WITH THE
  F (OR P) REGISTER VECTOR CORRESPONDING TO THE DYNAMIC ACTIVATIONS, AND
  DCHAIN [*,1] WITH THE CORRESPONDING PC, WITH THE MOST RECENT ACTIVATION
  FIRST.  THE ENTRIES [*,0] ARE THE F REGISTER VALUES FOR NON-SIMPLE
  PROCEDURES, AND THE NEGATIVE OF THE P REGISTER FOR SIMPLE PROCEDURES.
 I.E., DCHAIN[0,0] = VALUE OF F REGISTER FOR THE ROUTINE BEGIN BROKEN
	     [0,1] = PC AT INTERRUPTION
	     [1,0] = F REGISTER OF PARENT
	     [1,1] = RETURN ADDRESS -1;
NOHAND([
INTEGER I,K,T,PDA;

DDEPTH←-1; DCHAIN[0,1]←PC;
# '777777 IS THE VALUE PUT ON THE BOTTOM OF THE STACK BY SAILOR;
WHILE (FR←RIGHT(FR)) NEQ '777777 DO BEGIN
    K←FR+RIGHT(MEMORY[(PDA←LEFT(MEMORY[FR+1]))+PD!DSP])+1;
	# 1+RIGHT(P) AFTER PROLOG;
    FOR I←RIGHT(PR) STEP -1 UNTIL K DO BEGIN
	# SIMPLE PROCEDURE HAS BEEN CALLED, OR WE ARE IN THE MIDDLE OF
	  STACKING SOME ARGUMENTS.  PICK UP THE WORD ON THE STACK AND SEE
	  IF IT IS A REASONABLE RETURN ADDRESS.  THE INDIRECT AND
	  INDEX FIELDS MUST BE ZERO.  THE OPCODE AND ADDRESS FIELDS
	  MUST BE NON-ZERO.;
	T←MEMORY[I]; IF (T LAND '37000000)=0 AND (T LAND '777000000000)
	NEQ 0 AND (T LAND '777777) NEQ 0 THEN BEGIN
	    # THERE MUST BE A PUSHJ AT RIGHT(T)-1;
	    IF LEFT(MEMORY[T←RIGHT(T)-1])=LEFT(PUSHJ+(P LSH 23)) THEN BEGIN
		# SIMPLE PROCEDURE CALLED AT MEMORY[RIGHT(T)-1];
		DCHAIN[DDEPTH←DDEPTH+1,0]←-I;	# NEGATIVE OF P AT ENTRY;
		DCHAIN[DDEPTH+1,1]←T;		# PC OF CALL (IN PARENT);
		PR←I-1;	# PESSIMISTIC ESTIMATE; END
	    END
	END;
    # NON-SIMPLE PROCEDURE CALLED;
    DCHAIN[DDEPTH←DDEPTH+1,0]←FR;	# F REGISTER OF ROUTINE;
    DCHAIN[DDEPTH+1,1]←RIGHT(MEMORY[FR-1])-1;	# PC OF CALL (IN PARENT);
    PR←FR-2-(RIGHT(MEMORY[PDA+PD!NPW])-1);	# SUBTRACT P-STACK PARAMS;
    FR←MEMORY[FR];
    END;
]) # NOHAND;
HAND([
START!CODE LABEL TOP1,TEST2,OUT2,TEST1;
DEFINE I=[1],K=[2],QFR=[3],QPR=[4],PDA=[5],T=[6],T2=[7],DCH=['10];
	MOVEI	QFR,FR;
	MOVE	QPR,PR;
	MOVEI	DCH,@DCHAIN;	# FWA DATA;
	MOVE	T,PC;
	MOVEM	T,1(DCH);
	SUBI	DCH,2;		# ADJUST INITIAL VALUE;
	JRST	TEST1;
TOP1:	HLRZ	PDA,1(QFR);
	HRRZ	K,PD!DSP(PDA);	# P STACK DISPLACEMENT;
	ADDI	K,1(QFR);	# 1+RIGHT(P) AFTER PROLOG;
	HRRZI	I,(QPR);
TEST2:	CAIGE	I,(K);
	 JRST	OUT2;
	MOVE	T,(I);
	TLNN	T,'37;		# CHECK INDIR, INDEX;
	TLNN	T,'777000;	# CHECK OP CODE;
	 SOJA	I,TEST2;
	TRNN	T,-1;		# CHECK ADDR;
	 SOJA	I,TEST2;
	MOVEI	T,-1(T);
	HLRZ	T2,(T);		# GET LEFT HALF OF INSTR AT -1(T);
	CAIE	T2,'260740;	# PUSHJ P,;
	 SOJA	I,TEST2;
	ADDI	DCH,2;
	MOVNM	I,(DCH);
	MOVEM	T,3(DCH);
	MOVEI	QPR,-1(I);
	SOJA	I,TEST2;
OUT2:	ADDI	DCH,2;
	MOVEM	QFR,(DCH);
	HRRZ	T,-1(QFR);
	SUBI	T,1;
	MOVEM	T,3(DCH);
	MOVEI	QPR,-2(QFR);
	MOVE	T2,PD!NPW(PDA);
	SUBI	QPR,-1(T2);	# -# OF ARITH PARAMS;
TEST1:	HRRZ	QFR,(QFR);
	CAIE	QFR,-1;
	 JRST	TOP1;
	SUBI	DCH,@DCHAIN;	# CURRENT ADDR MINUS FWA;
	LSH	DCH,-1;
	MOVEM	DCH,DDEPTH;
	MOVEI	T,@DCHAIN;	# FWA DATA;
	CAMLE	DCH,-3(T);	# BOUNDS CHECK;
	 ARERR	1,["DCHAIN"];
END;]) # HAND;
END "DSCOPE";

SIMPLE PROCEDURE PRDSCOPE(INTEGER ARRAY DCHAIN; INTEGER DDEPTH); BEGIN "PRDSCOPE"
INTEGER I;
ADDSTR("
DYNAMIC SCOPE, MOST RECENT FIRST:
routine		text
");
FOR I←0 UPTO DDEPTH DO BEGIN
    ADDSTR(IF DCHAIN[I,0]<0 THEN ".simple."
	ELSE MEMSTRING(2+LEFT(MEMORY[DCHAIN[I,0]+1])));
    ADDSTR(CATCRLF(TAB & GETTEXT(DCHAIN[I,1]))) END;

END "PRDSCOPE";
# TFIND,BREAK1,SWAP!BREAKS,PLANT!BREAKS,UNPLANT!BREAKS,LOC!PC,BREAK,COORD,TRAPS;

SIMPLE INTEGER PROCEDURE TFIND(STRING LOCNAME; BOOLEAN ANYNAM;
	REFERENCE INTEGER CRDADDR); BEGIN "TFIND"
# SPECIAL FIND ROUTINE FOR TRACE, BREAK, ETC, SINCE ONE FREQUENTLY WANTS TO
  SPECIFY NAMES WHICH ARE NOT IN THE CURRENT ALGOL SCOPE.

  THE FORMAT OF LOCNAME IS
	[LOCNAME]:=[SAILID] or [BLOCKNAME] [DELIM] [LOCNAME]

  THE SEARCH FOR LOCNAME PROCEEDS AS FOLLOWS.  THE BLOCK TABLE [T!BLKADR]
  IS SEARCHED FROM THE END TO THE BEGINNING [BREADTH FIRST].  IF JUST
  [SAILID] APPEARS, THEN [SAILID] MUST BE A BLOCK OR PROCEDURE NAME, AND
  THE SEARCH IS FOR A MATCH ON THE NAME.  IF MORE THAN JUST [SAILID]
  APPEARS, THEN THE SEARCH IS FOR A MATCH ON THE [BLOCKNAME] PORTION OF
  [BLOCKNAME] [DELIM].  IF MORE THAN  ONE [BLOCKNAME] APPEARS, THE SEARCH
  IS CONTINUED FOR EACH SUCCEEDING [BLOCKNAME] AT THE POINT WHERE THE
  PREVIOUS SEARCH ENDED.  THIS IS CONTINUED UNTIL THE LAST [BLOCKNAME] IS
  LOCATED.  THEN THE ANCESTRY OF THE LAST [BLOCKNAME] IS CONSTRUCTED,
  AND FIND IS ASKED TO LOCATE [SAILID].

  THIS IS VERY FLEXIBLE AND POWERFUL.  THE COMPLETE HISTORY OF [SAILID]
  NEED NOT BE SPECIFIED IN LOCNAME.  INDEED, THE SEQUENCE OF [BLOCKNAME]S
  NEED NOT BE A TREELIKE PATH AT ALL.
;

INTEGER CLASS,PNTR,I,CRDNO;	STRING STRVAL;

PNTR←L!BLKADR-1; CRDADDR←0;
WHILE LENGTH(LOCNAME) DO BEGIN
    GET!TOKEN(LOCNAME,STRVAL,CLASS,I);
    IF CLASS NEQ ID THEN EVALERR("Incorrect location specification",STRVAL,LOCNAME);
    IF LENGTH(LOCNAME) THEN BEGIN "BLKNAM" LABEL NEXBLK;
	WHILE (PNTR←PNTR-2) GEQ 0 DO BEGIN "HUNT"
	    FOR I←0 UPTO 2 DO IF PAGEIT(T!NAME,RIGHT(T!BLKADR(PNTR))+2+I) NEQ
		NAME[I] THEN CONTINUE "HUNT";
	    I←LOP(LOCNAME); # GET RID OF DELIM;
	    GOTO NEXBLK END "HUNT"; NEXBLK: END "BLKNAM"
    ELSE BEGIN "SAILID"
	IF PNTR+1<L!BLKADR THEN GETLSCOPE(TLSCOPE,TLDEPTH,RIGHT(T!BLKADR(PNTR+1)));
	IF (I←FIND(NAME,TLSCOPE,TLDEPTH,ANYNAM))GEQ 0 OR STRVAL NEQ "#"
	    THEN RETURN(I);
	# COORDINATE SPECIFICATION;
	I←LOP(STRVAL);	# REMOVE LEADING "#";
	CRDADDR←RIGHT(TARRAY[CRDFND(INTSCAN(STRVAL,I))+1]); RETURN(-1)
	END "SAILID"
END
END "TFIND";


BOOLEAN BREAKPOINTS!PLANTED;

SIMPLE PROCEDURE SWAP!BREAKS; BEGIN "SWAPBR"
NOHAND([
INTEGER I; FOR I←0 UPTO L!BK DO IF BK!LOC[I] NEQ 0 THEN
    MEMORY[BK!LOC[I]] SWAP BK!INSTR[I];BREAKPOINTS!PLANTED←NOT BREAKPOINTS!PLANTED;
]) # NOHAND;
HAND([
START!CODE LABEL LOOP,BOT; DEFINE I=['14],T=[0];
	MOVSI	I,-N!BK;
LOOP:	SKIPN	BK!LOC[0](I);
	 JRST	BOT;
	MOVE	T,BK!INSTR[0](I);
	EXCH	T,@BK!LOC[0](I);
	MOVEM	T,BK!INSTR[0](I);
BOT:	AOBJN	I,LOOP;
	SETCMM	BREAKPOINTS!PLANTED;
END;
]) # HAND;
END "SWAPBR";

SIMPLE PROCEDURE PLANT!BREAKS;
    IF NOT BREAKPOINTS!PLANTED THEN SWAP!BREAKS;

SIMPLE PROCEDURE UNPLANT!BREAKS;
    IF BREAKPOINTS!PLANTED THEN SWAP!BREAKS;



SIMPLE PROCEDURE BREAK1(INTEGER LOC; STRING NAME,COND,ACT; INTEGER MPC,NEWINSTR);
BEGIN "BREAK1"
# INSERT A BREAKPOINT AT MEMORY[LOC], OVERWRITING ANY OLD BREAKPOINT;
NOHAND ([
INTEGER I;
UNPLANT!BREAKS;
# SEARCH FOR DUPLICATE OR FOR EMPTY SLOT;
FOR I←0 UPTO N!BK DO IF  I=N!BK OR BK!LOC[I]=0 OR RIGHT(BK!LOC[I])=RIGHT(LOC) THEN DONE;
IF I=N!BK THEN EV1ERR("Too many breakpoints.")
ELSE BEGIN
	BK!LOC[I]←LOC; BK!INSTR[I]←NEWINSTR;
	BK!COND[I]←COND; BK!ACT[I]←ACT; BK!COUNT[I]←MPC; BK!NAME[I]←NAME END
]) # NOHAND;
HAND ([
LABEL BAD;
START!CODE
DEFINE I=['14],T=['13],KEY=['15],R=[1]; LABEL LOOP,LOOP2,FOUND;
	PUSHJ	P,UNPLANT!BREAKS;
	MOVSI	I,-N!BK;
	HRRZ	R,LOC;
LOOP:	HRRZ	KEY,BK!LOC[0](I);
	CAIE	KEY,(R);
	AOBJN	I,LOOP;
	JUMPL	I,FOUND;	# WRITE OVER AN OLD BREAKPOINT;
	MOVSI	I,-N!BK;	# ELSE SEARCH FOR AN EMPTY SLOT;
LOOP2:	SKIPE	BK!LOC[0](I);
	AOBJN	I,LOOP2;
	JUMPGE	I,BAD;		# NONE LEFT;
FOUND:	MOVE	T,LOC;
	MOVEM	T,BK!LOC[0](I);
	MOVE	T,NEWINSTR;
	MOVEM	T,BK!INSTR[0](I);
	MOVE	T,MPC;
	MOVEM	T,BK!COUNT[0](I);
	LSH	I,1;
	HRROI	T,(SP);
	MOVEI	R,BK!ACT[0](I);
	POP	T,(R);
	POP	T,-1(R);
	MOVEI	R,BK!COND[0](I);
	POP	T,(R);
	POP	T,-1(R);
	MOVEI	R,BK!NAME[0](I);
	POP	T,(R);
	POP	T,-1(R);
END; RETURN;
BAD:	EV1ERR("Breaktable overflow");
]) # HAND;
END "BREAK1";


SIMPLE INTEGER PROCEDURE LOC!PC(STRING LOCNAME; INTEGER ANYNAM(TRUE));
BEGIN "LOC!PC"
# RETURNS THE PC ASSOCIATED WITH THE PLACE NAMED IN LOCNAME.
  IF ANYNAM IS FALSE THEN LOCNAME MUST BE A PROCEDURE AND THE PROCEDURE
  DESCRIPTOR ADDRESS IS RETURNED;
INTEGER PNTR,REFIT,T,CRDADDR;
PNTR←TFIND(LOCNAME,ANYNAM,CRDADDR);
IF PNTR=-1 AND CRDADDR=0 THEN EVALERR("Unknown " & (IF ANYNAM THEN "location"
    ELSE "procedure"),LOCNAME,NULL);
IF PNTR=-1 THEN REFIT←CRDADDR
ELSE IF (T←GETTYPE((REFIT←CACHE[PNTR+1]))) NEQ 0 AND
    NOT(REFIT LAND PROCB) AND T NEQ LBLTYP
    THEN EVALERR("Need a block, label, coordinate, or procedure",LOCNAME,NULL)
ELSE IF ANYNAM AND (REFIT LAND PROCB) THEN BEGIN
    # We want to break a procedure.  There was (is?) some confusion about where
    to put the break.  For a simple procedure (one with TEMPB on in its refitem)
    the break belongs on the JFCL 0 which the compiler inserted for this purpose
    at user request.  For a non-simple procedure the break belongs on the
    HRRZI F,-n(P) which sets the F register.  In the case of a non-recursive
    procedure (or a recursive procedure with no parameters) the location of the 
    HRRZI is given by the  pcnt at MKSEMT  in the procedure descriptor.
    In the case of a recursive procedure with parameters, a search must be
    made for the HRRZI, because the code which puts the locals on the stack
    and zeroes them is of undetermined length.  All this barf is made necessary
    in the first place because the first instruction inside a procedure might
    be a WHILE loop, and we want to break only on entry to the procedure, not
    everytime around the loop;
    PNTR←LEFT(MEMORY[RIGHT(REFIT)+PD!PPD]);    # PCNT AT MKSEMT;
    UNPLANT!BREAKS;	# MAKE SURE THE INSTR WE LOOK FOR WILL BE THERE;
    IF REFIT LAND TEMPB AND MEMORY[PNTR←PNTR-1]='255 LSH 27 # JFCL; THEN REFIT←PNTR
    ELSE WHILE LEFT(MEMORY[PNTR]) NEQ '551517 # HRRZI F,(P); DO PNTR←PNTR+1;
    REFIT←PNTR END;
RETURN(IF ANYNAM THEN RIGHT(REFIT) ELSE REFIT);	# RETURN FULL REFITEM FOR PROC;
END "LOC!PC";

PROCEDURE BREAK(STRING LOCNAME;STRING COND(""),ACT(""); INTEGER MPC(0));
BEGIN "BREAK"
# INSERT BREAKPOINT AT BEGINNING OF THING SPECIFIED IN LOCNAME.;
BREAK1(LOC!PC(LOCNAME),LOCNAME,COND,ACT,MPC,PJPBAIL)
END "BREAK";

INTEGER PROCEDURE COORD(STRING LOCNAME);
# RETURNS THE COORDINATE NUMBER OF THE PLACE NAMED BY LOCNAME.
  IF LOCNAME HAS FORM 'NNNN, THEN NNNN WILL BE TREATED AS AN OCTAL NUMBER.;
RETURN((TARRAY[1+CRD!PC(IF LOCNAME="'" THEN
		CVO(LOCNAME[2 TO INF]) ELSE LOC!PC(LOCNAME))] LSH -18) LAND '377777);

STRING PROCEDURE TRAPS; BEGIN INTEGER I;
FOR I←0 UPTO N!BK-1 DO
    IF LENGTH(BK!NAME[I]) THEN ADDSTR(CATCRLF(BK!NAME[I]))
    ELSE IF BK!LOC[I] THEN ADDSTR(CATCRLF(CVOS(BK!LOC[I])));
RETURN(DUMPSTR) END;
# PRARGS, TRACER, TRACE;

SIMPLE PROCEDURE PRARGS(INTEGER REFIT,PPNTR,SPPNTR); BEGIN "PRARGS"
# PRINT ARGUMENTS, GIVEN PROC DESCR AND STACK POINTERS;
INTEGER PARAMPNTR,NP;
START!CODE LABEL LOOP,NSTRV,BOT,OUT1,NARR,ARR; DEFINE T=['14],T2=['15];
	PUSH	P,REFIT;
	PUSHJ	P,N!PARAMS;
	JUMPLE	1,OUT1;
	MOVEM	1,NP;
	HRRZ	2,PPNTR;	# TOS;	
	MOVE	1,REFIT;
	HRRZ	3,PD!NPW(1);	# #ARITH PARAMS+1;
	SUBI	2,-1(3);
	MOVEM	2,PPNTR;	# BEGINNING OF PSTACK PARAMS;
	HRRZ	2,SPPNTR;
	HLRZ	3,PD!NPW(1);	# 2*#STRING PARAMS;
	SUBI	2,-2(3);
	MOVEM	2,SPPNTR;	# BEGINNING OF SPSTACK PARAMS;
	HRRZ	3,PD!DLW(1);	# POINTER TO PARAM INFO;
	MOVEM	3,PARAMPNTR;
LOOP:	MOVE	T,@PARAMPNTR;
	AOS	PARAMPNTR;
	LDB	T2,[('271000 LSH 18)+T];	# 8 BITS WIDE TO GET ITEMB, TOO;
	CAIN	T2,0+STRNG LSH -23;
	TLNE	T,0+REFB LSH -18;
	 JRST	NSTRV;
	HRR	T,SPPNTR;
	AOS	SPPNTR;
	AOS	SPPNTR;
	JRST	BOT;
NSTRV:	HRR	T,PPNTR;
	AOS	PPNTR;
	TLNE	T,0+ARY2B LSH -18;
	 JRST	ARR;			# λ ARRAY ITEMVAR ARRAY is an array;
	TLNN	T,0+ITEMB LSH -18;	# BUT PLAIN ITEMVAR IS NOT;
	CAIGE	T2,0+ARRY LSH -23;
	 JRST	NARR;
ARR:	TLO	T,'20;
	JRST	BOT;
NARR:	TLNE	T,0+REFB LSH -18;	# CHECK FOR REFERENCE PARAMS;
	 HRR	T,(T);
BOT:	PUSH	P,T;
	PUSHJ	P,WR!TON;
	SOSLE	NP;
	 JRST	LOOP;
OUT1:END;
END "PRARGS";

SIMPLE PROCEDURE TRACER;
BEGIN "TRACER"
# CALLED BY AN INSERTED PUSHJ FROM ENTRY ADDRESS OF ROUTINE BEING TRACED.
WHAT TO DO:
1.  PICK UP TOP WORD OF STACK AND GET THE REFITEM FROM THE MULTIPLE PROCEED	
	COUNT OF THE CORRESPONDING BREAK ENTRY.
2.  USE THE PDA INFO TO PRINT THE PROCEDURE NAME AND PARAMETERS.
3.  MASSAGE THE P STACK SO THAT THE TRACED PROCEDURE RETURNS TO TRACER.
4.  XCT THE DISPLACED INSTRUCTION.
5.  JUMP TO ENTRY ADDRESS+1.
6.  UPON RETURN FROM TRACED PROCEDURE, PRINT THE NAME (AND RESULT, IF ANY).
7.  RESTORE P STACK TO ITS PROPER STATE.
8.  RETURN.

THE P-STACK GETS TWO EXTRA WORDS IN STEP 3.  THE FIRST ONE IS THE ORIGINAL RETURN ADDRESS,
THE SECOND IS THE REFITEM FOR THE TRACED PROCEDURE, TO ALLOW PRINTING THE NAME AND RESULT;

INTEGER REFIT,REFITA,I,BL,PPNTR,SPPNTR,PARAMPNTR,TRLEV,NP,ENTAD,T;
DEFINE SPACES=["          "];

# STACK LOOKS LIKE
		(P)/	RETURN TO ENTRY+1
		-1(P)/	RETURN TO CALLING PROC
		-2(P)/	PARAM n
		.
		.
		.
		-n-3(P)/	PARAM 1;
START!CODE
	POP	P,0;		# REMOVE RETURN TO ENTRY+1;
	SUBI	0,1;		# ENTRY ADDRESS;
	MOVEM	0,ENTAD;
	AOS	TRLEV;		# DEPTH OF TRACE;
	END;
NOHAND([
FOR BL←0 UPTO L!BK DO IF BK!LOC[BL]=RIGHT(ENTAD) THEN DONE;
REFIT←BK!COUNT[BL];
]) # NOHAND;
HAND([START!CODE
DEFINE KEY=[0],I=['14]; LABEL LOOP,GOOD;
	HRRZ	KEY,ENTAD;
	MOVSI	I,-N!BK;
LOOP:	CAME	KEY,BK!LOC[0](I);
	AOBJN	I,LOOP;
	JUMPL	I,GOOD;
	PUSH	SP,[10];
	PUSH	SP,["TRACE sunk"];
	PUSHJ	P,FATAL;	# TRACER CALLED BUT TRACE LOCATION NOT IN TABLE;
GOOD:	MOVE	KEY,BK!COUNT[0](I);
	MOVEM	KEY,REFIT;
END;]) # HAND;
OUTSTR(CRLFCAT(SPACES[1 FOR TRLEV]&"Entering "&MEMSTRING(REFIT+2)));
START!CODE	EXTERNAL INTEGER OUTSTR;
	PUSH	P,REFIT;
	MOVEI	'14,-1(P);
	PUSH	P,'14;
	MOVEI	'14,(SP);
	PUSH	P,'14;
	PUSHJ	P,PRARGS;
	PUSHJ	P,DUMPSTR;
	PUSHJ	P,OUTSTR;
END;

# MASSAGE THE STACK;

START!CODE	LABEL TR!RET,TRRETW;
	MOVE	1,REFIT;
	HRRZ	2,PD!NPW(1);	# #ARITH PARAMS+1;
	HRRZ	3,P;
	SUBI	3,-1(2);	# AC3 POINTS AT FIRST PARAM;
	HRLI	4,(3);
	HRRI	4,TARRAY[0];
	BLT	4,TARRAY[0](2);	# UNSTACK;
	PUSH	P,0;		# SPACE FILLER;
	MOVE	0,-1(P);	# RETURN TO CALLING PROC;
	MOVEM	0,(3);		# PLANT IT;
	MOVEM	1,1(3);		# PLANT REFIT;
	HRLI	4,TARRAY[0];
	HRRI	4,2(3);
	BLT	4,(P);		# STACK;
	MOVE	4,BL;
	PUSH	P,TRRETW;	# PUT RETURN ON STACK;
	XCT	BK!INSTR[0](4);	# THIS IS EITHER A  PUSH P,F  OR A  JFCL;
	MOVE	2,ENTAD;
	JRST	1(2);		# CALL THE TRACED PROC;
TRRETW:	CAM	TR!RET;		# TYPICAL PUSHJ WORD;
TR!RET:	POP	P,REFIT;
	MOVEM	1,REFITA;
	END;
OUTSTR(CRLFCAT(SPACES[1 FOR TRLEV]&"Exiting "&MEMSTRING(REFIT+2)));
IF (T←GETTYPE(REFIT)) NEQ 0 THEN BEGIN "RESULT"
    OUTCHR("="); IF T=STRNG THEN
	START!CODE
	PUSH	SP,-1(SP);
	PUSH	SP,-1(SP);
	PUSHJ	P,OUTSTR;
	END
    ELSE BEGIN WR!TON(T LOR LOCATION(REFITA)); OUTSTR(DUMPSTR) END END "RESULT";
OUTSTR(CRLF);
START!CODE
	MOVE	1,REFITA;
	SOS	TRLEV;
	POPJ	P,0;		# FINALLY!;
	END;
END "TRACER";


PROCEDURE TRACE(STRING PROCNAME);
BEGIN"TRACE"
# BREAK ENTRY AND EXIT OF PROCEDURE;
INTEGER REFIT;	 DEFINE PUSHJ=['260000000000];
BREAK1(MEMORY[REFIT←LOC!PC(PROCNAME,FALSE)],PROCNAME,"","",REFIT,PUSHJ+(P LSH 23)+
    LOCATION(TRACER));
END "TRACE";
# UNBREAK1,UNBREAK,UNTRACE,CLRTBK,STEPPING;

SIMPLE PROCEDURE UNBREAK1(INTEGER LOC); BEGIN "UNBREAK1"
# REMOVE BREAKPOINT AT MEMORY[LOC];
NOHAND([
INTEGER I;
UNPLANT!BREAKS;
# SEARCH FOR THE BREAKPOINT;
FOR I←0 UPTO N!BK DO IF I=N!BK OR RIGHT(BK!LOC[I])=RIGHT(LOC) THEN DONE;
IF I=N!BK THEN EVALERR("UNBREAK1. Location not currently broken",
    CVOS(LOC),NULL);
BK!INSTR[I]←0; BK!LOC[I]←0; BK!NAME[I]←NULL
]) # NOHAND;
HAND([
LABEL BAD;
START!CODE	DEFINE I=['14],T=['13],KEY=['15]; LABEL LOOP;
	PUSHJ	P,UNPLANT!BREAKS;
	MOVSI	I,-N!BK;
	HRRZ	KEY,LOC;
LOOP:	HRRZ	T,BK!LOC[0](I);
	CAIE	T,(KEY);
	AOBJN	I,LOOP;
	JUMPGE	I,BAD;
	SETZM	BK!INSTR[0](I);
	SETZM	BK!LOC[0](I);
	ADDI	I,-1(I);	# 2*I-1;
	SETZM	BK!NAME[0](I);	# TURNS IT INTO A STRING OF LENGTH 0, HENCE NULL;
END; RETURN;
BAD:	EVALERR("UNBREAK1. Location not currently broken",CVOS(LOC),NULL)
]) # HAND;
END "UNBREAK1";


PROCEDURE UNBREAK(STRING LOCNAME);
UNBREAK1(LOC!PC(LOCNAME));


PROCEDURE UNTRACE(STRING PROCNAME);
# SIGNIFY "PROC ONLY", WHICH GETS PROCEDURE DESCRIPTOR ADDR FROM LOC!PC.
  THEN PICK UP ENTRY ADDR FROM PROCEDURE DESCRIPTOR;
UNBREAK1(MEMORY[LOC!PC(PROCNAME,FALSE)]);


SIMPLE PROCEDURE CLRTBK(INTEGER LOC); BEGIN "CLRTBK"
# (CLEAR GROUP OF TEMPORARY BREAKPOINTS)
  SEARCH THE BREAKPOINT TABLE FOR THE LOCATION.  IF NOT FOUND, EXIT.
  IF LOCATION IS ONE OF A SET OF TEMPORARY BREAK POINTS, CLEAR THE WHOLE SET.
  CLRTBK IS ALWAYS CALLED WITH THE BREAK-POINT INSTRUCTIONS IN.
  MUST BE START!CODE BECAUSE AC'S MUST BE SAVED;
START!CODE LABEL LOOP1,LOOP2,RET,BOT2; DEFINE I=['14],J=['15],KEY=['13];
	MOVSI	I,-N!BK;
	HRRZ	KEY,LOC;
LOOP1:	HRRZ	J,BK!LOC[0](I);
	CAIE	J,(KEY);
	AOBJN	I,LOOP1;
	JUMPGE	I,RET;
	HLRZ	J,BK!LOC[0](I);
	JUMPE	J,RET;
	MOVSI	I,-N!BK;
LOOP2:	HLRZ	KEY,BK!LOC[0](I);
	CAIE	KEY,(J);
	 JRST	BOT2;
	MOVE	KEY,BK!INSTR[0](I);
	MOVEM	KEY,@BK!LOC[0](I);
	SETZM	BK!INSTR[0](I);
	SETZM	BK!LOC[0](I);
BOT2:	AOBJN	I,LOOP2;
RET:	END;
END "CLRTBK";

SIMPLE PROCEDURE STEP!POPJ; START!CODE
# CALLED BY PUSHJ; DEFINE I=['14]; LABEL DOT1;
	SOS	(P);		# POINT TO BREAK THAT GOT US HERE;
	PUSHJ	P,CLRTBK;	# CLEAR TEMP BREAKS, REMOVE EXTRA RETURN WORD;
	JSP	I,DOT1;		# CURRENT FLAGS;
DOT1:	TLO	I,'20;		# "JRST MODE" BREAK;
	HLLM	I,(P);		# SUBSTITUTE FLAGS;
	JRST	BAIL;		# POPS STACK AS RETURN WORD, GETS INTO BAILOR;
END;

SIMPLE PROCEDURE STEP!ATJRST; START!CODE
# CALLED BY JRST; DEFINE I=['14];
	MOVEI	I,@ATJRSTINS;	# GET ADDR;
	TLO	I,'20;		# JRST MODE BREAK;
	PUSH	P,I;		# A COPY FOR BAIL TO POP;
	PUSH	P,ATJRSTLOC;
	PUSHJ	P,CLRTBK;	
	JRST	BAIL;
END;

SIMPLE PROCEDURE STEPIT(INTEGER PC; INTEGER ARRAY INSTR,MASK); BEGIN "STEPIT"
DEFINE PUSHJ=['260000000000],POPJ=['263000000000],PUSH=['261000000000];
NOHAND([
	SIMPLE PROCEDURE BREAK2(INTEGER LOC);
	BREAK1(RIGHT(LOC)+(1 LSH 23),"","","",0,PJPBAIL);
INTEGER I,L,U,U2,J,T;
U2←ARRINFO(INSTR,2);	# UPPER BOUND FOR FIRST DIMENSION;
# SEARCH COORDINATE INDEX AND THEN COORDINATE TABLE TO FIND PC OF CURRENT
  STATEMENT AND NEXT;
I←CRD!PC(PC);
L←RIGHT(TARRAY[I+1]); U←RIGHT(TARRAY[I+3]);	# PC OF CURRENT, NEXT STATEMENT;
IF U='777777 THEN U←L+'200;
UNPLANT!BREAKS;
FOR I←L UPTO U DO BEGIN
    FOR J←0 UPTO U2 DO BEGIN
	IF ((T←MEMORY[I]) XOR INSTR[J]) LAND MASK[J]=0 THEN BEGIN
	    IF INSTR[J]=POPJ 
	    THEN BREAK1((1 LSH 23)+I,"","","",0,PUSHJ+(P LSH 23)+LOCATION(STEP!POPJ)
	    ELSE IF INSTR[J]=ATJRST
	    THEN BEGIN 
		BREAK1((1 LSH 23)+I,"","","",0,('254 LSH 27)+LOCATION(STEP!ATJRST);
		ATJRSTINS←MEMORY[I]; ATJRSTLOC←I END
	    ELSE IF INSTR[J]=PUSHJ
	    THEN BEGIN # DON'T BREAK LOCATIONS IN SEGMENT OR CALLS ON BAIL;
		IF RIGHT(T)<NOTENX('400000) TENX('640000) 
		    AND RIGHT(T) NEQ LOCATION(BAIL)
		THEN BEGIN
			IF LEFT(MEMORY[T]) NEQ '255000
			THEN WHILE LEFT(MEMORY[T]) NEQ '551517 DO T←T+1;
			BREAK2(T) END END
	    ELSE BREAK2(T);
	    DONE END;
    END END;
BREAK2(U);
]) # NOHAND;
HAND([
INTEGER L,U,U2,J;
START!CODE LABEL STPBBRK,STPBRK,TOP2,LAB1,LAB2,INC2,INC1,CHK1,SP0LUP,HRRZL,LAB3,LAB4;
DEFINE A=[1],B=[2],I=[3],INS=[4];
	MOVE	A,INSTR;
	MOVE	A,-3(A);	# UPPER BOUND FOR FIRST DIM;
	MOVEM	A,U2;
	PUSH	P,PC;
	PUSHJ	P,CRD!PC;
	HRRZ	I,TARRAY[1](1);
	MOVEM	I,L;		# PC CURRENT STMT;
	HRRZ	B,TARRAY[3](1);
	MOVEM	B,U;		# PC NEXT STMT;
	MOVEI	A,'200(I);
	CAIN	B,-1;
	MOVEM	A,U;
	PUSHJ	P,UNPLANT!BREAKS;
	JRST	CHK1;
STPBBRK:MOVE	A,PJPBAIL;
STPBRK:	HRLI	B,'40;
	PUSH	P,B;		# B=WHERE;
	MOVEI	B,6;	# 6 ZEROES ON SP;
SP0LUP:	PUSH	SP,[0];
	SOJG	B,SP0LUP;
	PUSH	P,[0];
	PUSH	P,A;		# A=WHAT INSTR TO USE;
	PUSHJ	P,BREAK1;
	POPJ	P,;
TOP2:	MOVE	INS,INSTR;	# FWA INSTR ARRAY;
	ADDI	INS,(A);	# ADD J;
	MOVE	B,MASK;	# FWA MASK ARRAY;
	ADDI	B,(A);	# ADD J;
	MOVE	A,(INS);
	XOR	A,(I);
	AND	A,(B);
	JUMPN	A,INC2;	# INSTR NOT ONE WE WANT;
	HLRZ	INS,(INS);	# OPCODE IN RIGHT HALF;
	MOVE	A,PJPBAIL;	# GET PUSHJ P, IN TOP HALF OF A;
	HRRI	A,STEP!POPJ;
	MOVEI	B,(I);		# ADDR TO BREAK;
	CAIE	INS,0+ATJRST LSH -18;
	 JRST	LAB3;
	MOVEM	I,ATJRSTLOC;
	MOVE	INS,(I);
	MOVEM	INS,ATJRSTINS;
	MOVSI	A,'254000;
	HRRI	A,STEP!ATJRST;
	JRST	LAB4;
LAB3:	CAIE	INS,0+POPJ LSH -18;
	 JRST	LAB1;
LAB4:	PUSHJ	P,STPBRK;
	JRST	INC1;
LAB1:	HRRZ	B,(I);		# DEALING WITH PUSHJ, AOJA, SOJA, JUMPx, JRST;
	CAIE	INS,0+PUSHJ LSH -18;
	 JRST	LAB2;
	CAIGE	B,NOTENX('400000) TENX('640000);	# NOW PUSHJ ONLY;
	CAIN	B,BAIL;
	 JRST	INC1;
				# B CONTAINS ENTRY ADDR. FIND THE JFCL OR HRRZI;
HRRZL:	HLRZ	A,(B);		# OPCODE HALF;
	CAIE	A,'255000;	# JFCL;
	CAIN	A,'551517;	# HRRZI F,(P);
	 JRST	LAB2;		# FOUND THE ONE WE WANT;
	AOJA	B,HRRZL;	# KEEP LOOKING;
LAB2:	PUSHJ	P,STPBBRK;
	JRST	INC1;		# ONCE WE'VE BROKEN IT, DON'T TRY TO BREAK IT AGAIN;
INC2:	AOS	A,J;
	CAMG	A,U2;
	 JRST	TOP2;
INC1:	AOS	I,L;
CHK1:	SETOB	A,J;
	CAMG	I,U;
	 JRST	INC2;
	MOVE	B,U;
	PUSHJ	P,STPBBRK;
	END;
]) # HAND;
END "STEPIT";
# BAILOR,!!TEXT,!!ARGS,EVAL,PSH,OPPSH,SETLEX,X1TEMP,X1TEMP,NEWTEMP,NEWSTRTEMP;
INTERNAL RECURSIVE PROCEDURE BAILOR; BEGIN "BAILOR"
INTEGER ARRAY SAVED!ACS[0:'17+'12+1+1];
INTEGER PC,FLAGS,I,T,DISPLVL;
INTEGER LDEPTH,DDEPTH,CURBRK;	# LEXICAL DEPTH, DYNAMIC DEPTH,CURRENT
				BREAKPOINT NUMBER;
INTEGER ARRAY LCHAIN[0:15];	# MOST RECENT FIRST;
INTEGER ARRAY DCHAIN[0:31,0:1];	# MOST RECENT FIRST;
LABEL BRECOV;			# RECOVERY POINT FOR BAIL ERRORS;
LABEL RET;			# !!GO COMES HERE IMMEDIATELY;
DEFINE F=['12];


INTERNAL STRING PROCEDURE !!TEXT; BEGIN PRLSCOPE(LCHAIN,LDEPTH);
PRDSCOPE(DCHAIN,DDEPTH); SSF←TRUE; RETURN(DUMPSTR) END;


INTERNAL STRING PROCEDURE !!ARGS; BEGIN
INTEGER T,PDA;
IF (T←DCHAIN[DISPLVL,0])>0 THEN # NON-SIMPLE PROCEDURE;
    PRARGS(LEFT(MEMORY[T+1]),T-1,MEMORY[T+2])	# APPLAUD THE POWER OF DISPLAYS!!!;
	#	PDA	RIGHT(P)	SP;
ELSE BEGIN
    IF DDEPTH NEQ 0 THEN OUTSTR("
Warning: String parameters to simple procedure may be incorrect.
");
    IF (PDA←PDFIND(MEMORY[MEMORY[-T]-1]))=1 THEN OUTSTR("
Can't find procedure descriptor.  Use actual names.
")
    ELSE PRARGS(PDA,-T,SAVED!ACS[SP]) END;
SSF←TRUE; RETURN(DUMPSTR) END;


# EVAL, PSH, OPPSH, SETLEX, X1TEMP, EVAL1;
RECURSIVE INTEGER PROCEDURE EVAL(STRING ARG);
BEGIN"EVAL"
EXTERNAL PROCEDURE CAT;
STRING STRVAL,OLDARG;
INTEGER CLASS,IVAL,REFIT,PNTR,OP;
LABEL OPCHAR;
INTEGER ARRAY TEMPVAL[0:31]; STRING ARRAY TSTRVAL[0:31];
INTEGER ARRAY RBIND,STACK,OPSTACK[0:31];
INTEGER N!TEMPVAL,N!TSTRVAL,TOS,TOOPS,T;
BOOLEAN BINARYMINUSFLAG;

SIMPLE PROCEDURE PSH(INTEGER ARG); STACK[TOS←TOS+1]←ARG;

SIMPLE PROCEDURE OPPSH(INTEGER ARG,RBND); BEGIN
    OPSTACK[TOOPS←TOOPS+1]←ARG; RBIND[TOOPS]←RBND END;

INTEGER PROCEDURE NEWTEMP(INTEGER I);
    RETURN(LOCATION(TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←I));

INTEGER PROCEDURE NEWSTRTEMP(STRING I);
    RETURN(RIGHT(LOCATION(TSTRVAL[N!TSTRVAL←N!TSTRVAL+1]←I)));

PROCEDURE EV1ERR(STRING WHY); EVALERR(WHY,OLDARG,ARG);

INTERNAL RECURSIVE PROCEDURE SETLEX(INTEGER DEPTH); BEGIN "SETLEX"
# MOVE LEXICAL SCOPE UP AND DOWN THE DYNAMIC SCOPE CHAIN;
IF DEPTH <0 OR DEPTH>DDEPTH THEN EV1ERR("Argument must be 0 through "&CVS(DDEPTH));
DISPLVL←DEPTH; GETLSCOPE(LCHAIN,LDEPTH,DCHAIN[DEPTH,1]); PRLSCOPE(LCHAIN,LDEPTH);
END "SETLEX";

PROCEDURE X1TEMP(INTEGER REFIT);BEGIN
REFIT←RIGHT(REFIT);	# ISOLATE ADDRESS PORTION;
IF N!TEMPVAL GEQ 0 AND REFIT GEQ LOCATION(TEMPVAL[0]) AND
    REFIT LEQ LOCATION(TEMPVAL[N!TEMPVAL]) THEN N!TEMPVAL←N!TEMPVAL-1
ELSE IF N!TSTRVAL GEQ 0 AND REFIT GEQ RIGHT(LOCATION(TSTRVAL[0])) AND
    REFIT LEQ RIGHT(LOCATION(TSTRVAL[N!TSTRVAL])) THEN N!TSTRVAL←N!TSTRVAL-1; END;

# EVAL1;
RECURSIVE INTEGER PROCEDURE EVAL1; BEGIN "EVAL1"

# EVALUATE OPERATOR ON TOP OF STACK AND ADJUST STACK;

DEFINE PRINT=[WR!TON];	
DEFINE CONFORM(A)=[(OPS1[A] LAND '777)],DEGREE(A)=[(OPS1[A] LSH -9 LAND '777)];
INTEGER OP,ARG1,ARG2,TYP1,TYP2,MODE,TYP,I,DEG,RSLTTYP,LEAPFLAG;
INTEGER TEMP; STRING TEMPSTR;


IF ABS(OP←STACK[TOS]) LEQ N!OPS THEN BEGIN "PRIMITIVE"
LABEL $INF,$COMMA,$COLON,$SEMI,$LEN,
	$ARRYREF,$MEMRY,$DATUM,$PROPS,$SUBST,$GETS,$SWAP,
	$SUBFLD,$SETC,$LSTC,$AR,$ASSIGNRESULTS;
LABEL $CPRINT,$PRINT;

    SIMPLE PROCEDURE TYPERR; EV1ERR("Type mismatch, " & OP);

    SIMPLE PROCEDURE LEAP!TYPE!CHECK; BEGIN "LPTYCK"
	IF (LEAPFLAG←(ARG1 LOR ARG2) LAND ITEMB) THEN BEGIN	# ONE IS AN ITEM;
	    MODE←0;					# ITEMS COMPARE LIKE INTEGERS;
	    IF (ARG1 LAND ARG2 LAND ITEMB)=0		# BOTH MUST BE ITEMS;
		OR ((ARG1 XOR ARG2) LSH -(18+5+6)) NEQ 0	# SECOND ORDER TYPES MUST AGREE;
		OR (TYP1 NEQ TYP2)
		    AND  TYP1 NEQ NOTYPE
	    THEN TYPERR END
	ELSE IF TYP1=TYP2 AND (TYP1=SETYPE OR TYP1=LSTYPE)
	    THEN BEGIN MODE←2; LEAPFLAG←TRUE END END "LPTYCK";

    SIMPLE PROCEDURE MAKE!BOTH!STRING;
	BEGIN RSLTTYP←STRNG; MODE←0;
	ARG1←CVSTRNG(ARG1,1); ARG2←CVSTRNG(ARG2,2) END;

    SIMPLE PROCEDURE MAKE!BOTH!REAL;
	BEGIN RSLTTYP←FLOTNG; MODE←1;
	ARG1←CVREAL(ARG1,1); ARG2←CVREAL(ARG2,2) END;

    SIMPLE PROCEDURE MAKE!BOTH!INTEGER;
	BEGIN RSLTTYP←INTEGR; MODE←0;
	ARG1←CVINTEGR(ARG1,1); ARG2←CVINTEGR(ARG2,2) END;
	
    SIMPLE PROCEDURE MAX!DOMAIN;
	# FLOTNG > INTEGR > STRNG, AND MUST GET AT LEAST AN INTEGR;
	IF TYP1=FLOTNG OR TYP2=FLOTNG THEN MAKE!BOTH!REAL
	ELSE MAKE!BOTH!INTEGER;

    DEG←DEGREE(OP); IF TOS-DEG<0 THEN EV1ERR("Syntax error");
    # HANDLE TEMPORARY LOCATIONS ASSIGNED BY EVAL;
    IF DEG GEQ 2 THEN X1TEMP(ARG1←STACK[TOS-2]);
    IF DEG GEQ 1 THEN X1TEMP(ARG2←STACK[TOS-1]);

    # CONFORM THE OPERANDS TO THE OPERATOR. DEFAULT TO INTEGER;
    TYP1←GETTYPE(ARG1); TYP2←GETTYPE(ARG2);
    MODE←0; RSLTTYP←INTEGR;
    CASE CONFORM(OP) OF BEGIN "CONFORM"
    [0] "OPERATOR UNTYPED. RETURN TYPE OF FIRST ARG"
	RSLTTYP←GETTYPE(STACK[TOS-DEG]);
    [1]	MAKE!BOTH!INTEGER;
    [2] MAKE!BOTH!REAL;
    [3] "CAT &" IF TYP1=LSTYPE AND TYP2=LSTYPE THEN MODE←1
	ELSE MAKE!BOTH!STRING;
    [4] "SECOND GETS TYPE OF FIRST" BEGIN
	LEAP!TYPE!CHECK; IF NOT LEAPFLAG THEN BEGIN
	    IF (RSLTTYP←TYP1) NEQ TYP2 THEN BEGIN
		IF (TYP←RSLTTYP LSH -23)<3 OR TYP>5 THEN TYPERR
		ELSE CASE TYP OF BEGIN
		    [3] MAKE!BOTH!STRING;
		    [4] MAKE!BOTH!REAL;
		    [5] MAKE!BOTH!INTEGER
	END END END END;
    [5] "SECOND GETS INTEGER; FOR LSH, ASH, ROT"
	BEGIN RSLTTYP←TYP1; ARG2←CVINTEGR(ARG2,2) END;
    [6]	"MEMBERSHIP"
	IF NOT(ARG1 LAND ITEMB) OR (TYP2 NEQ SETYPE) THEN TYPERR;
    [7]	"INF" ;
    [8]	"SET"  BEGIN MODE←3; RSLTTYP←SETYPE END;
    [9]	MAX!DOMAIN;
   [10]	"ASSOCIATIVE POSSIBILITY"
	IF (ARG1 LAND ARG2 LAND ITEMB)	# BOTH ITEMS;
	THEN BEGIN MODE←1; RSLTTYP←SETYPE END	# DERIVED!SET←ITEM OP ITEM;
	ELSE IF OP="`"
	     THEN TYPERR	# ASSOC OF NON-ITEMS;
	     ELSE RSLTTYP←TYP1;		# BIT OPERATOR XOR, EQV;
   [11] ;		# LOCATION;
   [12] "RELATION" BEGIN
	LEAP!TYPE!CHECK; # TO SET MODE TO 2 FOR SET OR LIST;
	IF TYP1 NEQ TYP2
	THEN BEGIN # TAKE MAX ALGEBRAIC DOMAIN BUT KEEP RESULT BOOLEAN;
	    MAX!DOMAIN; MODE←0; RSLTTYP←INTEGR
	END END
    END "CONFORM";

# INTERPRETATION OF OPERATORS;
START!CODE	# JUMP TABLE FOR OPERATORS;
	LABEL $NOT,$AND,$OR;
	LABEL $EQ,$NEQ,$LEQ,$LESS;
	LABEL $JEQ,$JNEQ,$JLEQ,$JLESS;
	LABEL $LPEQ,$LPNEQ,$LPLEQ,$LPLES;
	LABEL $REVOP1,$REVOP2;
	LABEL $PLUS,$MINUS,$MUL,$CDIV,$EXP,$EXPI,$EXPR;
	LABEL $MIN,$MAX,$MOD,$LOC;
	LABEL $CAT,$LPCAT,$JCAT,$JSUBST,$SUBST,$LPSUBST,$STRNG;
	LABEL $ASSOC,$LPEQV,$LPXOR,$IN,$UNION,$INTER,$LPMINUS,
	    LPSET,LPREL,LPDRV,LPRL2,LPDO1;
	LABEL $XOR,$EQV;
	LABEL $FOR,$TO;
	LABEL $FALSE,$TRUE,$NULL,$PHI,$NIL,$ANY,$NLREC;
	LABEL BADOP,ZERO,ONES,DONE,JTAB,$UMINUS,ZCONST,SCONST,ONES$,ZERO$;
	EXTERNAL INTEGER LEAP,SUBST,CAT,POW,FLOGS;
	DEFINE A=[1],B=[2],M=[3],T=[4];
	PROTECT!ACS A,B,M,T;

	MOVE	A,@ARG1;	# FIRST OPERAND;
	MOVE	B,@ARG2;	# SECOND OPERAND;
	MOVE	M,MODE;		# SOME OPS: 0=INTEGER, 1=REAL, 2=BOOL←(SET,SET), 3=SET←(SET,SET);
	MOVE	T,OP;
	XCT	JTAB(T);
DONE:	MOVEM	A,TEMP;
BADOP:	JRST	$ASSIGNRESULTS;
ZERO:	TDZA	A,A;
ONES:	SETO	A,;
	JRST	DONE;
JTAB:
$JNEQ:	JRST	$NEQ;	# '000;
	JRST	$NEQ;	# '001;
	JRST	$LPNEQ;	# '002;
	JRST	BADOP;	# '003;
	JRST	$AND;	# "∧";
	JRST	$NOT;	# "¬";
	JRST	$IN;	# "ε";
$JEQ:	JRST	$EQ;	# '007;
	JRST	$EQ;	# '010;
	JRST	$LPEQ;	# '011;
$JLEQ:	JRST	$LEQ;	# '012;
	JRST	$LEQ;	# '013;
	JRST	$LPLEQ;	# '014;
	JRST	BADOP;	# '015;
	JRST	$INF;	# "∞";
	JRST	$DATUM;	# "∂";
	JRST	BADOP;	# '020;
	JRST	BADOP;	# '021;
	JRST	$INTER;	# "∩";
	JRST	$UNION;	# "∪";
	JRST	BADOP;	# '024;
	JRST	BADOP;	# '025;
	XCT	$XOR(M);# "⊗";
	JRST	$SWAP;	# "↔";
$JLESS:	JRST	$LESS;	# '030;
	JRST	$LESS;	# '031;
	JRST	$LPLES;	# '032;
	JRST @	$JNEQ(M);	# "≠";
	JRST @	$JLEQ(M);	# "≤";
	JRST	$REVOP1;	# "≥";
	XCT	$EQV(M);# "≡";
	JRST	$OR;	# "∨";
$MAX:	CAMGE	A,B;	# '040;
	MOVE	A,B;	# "!";
	JRST	DONE;	# quote;
$XOR:	XOR	A,B;	# "#";
	JRST	$LPXOR;	# "$";
	XCT	$CDIV(M);	# "%";
	JRST @	$JCAT(M);# "&";
$MIN:	CAMLE	A,B;	# "'";
	MOVE	A,B;	# "(";
	JRST	DONE;	# ")";
	XCT	$MUL(M);	# "*";
	XCT	$PLUS(M);	# "+";
	JRST	$COMMA;	# ",";
	XCT	$MINUS(M);	# "-";
	JRST	BADOP;	# ".";
	FDVR	A,B;	# "/";
$AND:	JUMPE	A,ZERO;	# "0";
	JUMPE	B,ZERO;	# "1";
	JRST	ONES;	# "2";
$NOT:	JUMPE	B,ONES;	# "3";
	JRST	ZERO;	# "4";
$NEQ:	CAMN	A,B;	# "5";
	JRST	ZERO;	# "6";
	JRST	ONES;	# "7";
$EXP:	JRST	$EXPI;	# "8";
	JRST	$EXPR;	# "9";
	JRST	$COLON;	# ":";
	JRST	$SEMI;	# '073;
	JRST @	$JLESS(M);	# "<";
	JRST @	$JEQ(M);	# "=";
	JRST	$REVOP2;	# ">";
$EQV:	EQV	A,B;	# "?";
	JRST	$LPEQV;	# "@";
	ASH	A,(B);	# '101;
	IDIV	A,B;	# DIV;
	JRST	$FALSE;	# '103;
	AND	A,B;	# LAND;
	SETCM	A,B;	# LNOT;
	IOR	A,B;	# LOR;
	LSH	A,(B);	# ' 107;
	JRST	$MAX;	# '110;
	JRST	$MIN;	# '111;
	JRST	$MOD;	# '112;
	JRST	BADOP;	# '113;
	JRST	$NULL;	# '114;
	ROT	A,(B);	# '115;
	JRST	BADOP;	# '116;
	JRST	$TRUE;	# '117;
	MOVM	A,B;	# ABS;
	JRST	$FOR;	# (SUBSTRINGER);
	JRST	$TO;	# (SUBSTRINGER);
	JRST	$UMINUS;# UNARY MINUS;
	JRST	$ARRYREF;	# '124;
	JRST	$MEMRY;	# '125;
	JRST	$DATUM;	# '126;
	JRST	$PROPS;	# '127;
	JRST @	$JSUBST(M);	# PERFORM SUBSTRINGING OR SUBSLITING;
	JRST	$PHI;	# '131;
	JRST	$NIL;	# '132;
	JRST	BADOP;	# LBRACKET;
	JRST	BADOP;	# BACKSLASH;
	JRST	BADOP;	# RBRACKET;
	XCT	$EXP(M);	# UP ARROW;
	JRST	$GETS;	# ASSIGN;
	JRST	$ASSOC;	# ASSOC;
	JRST	$SUBFLD;	# '141;
	JRST	$ANY;	# '142;
	JRST	$NLREC;	# '143;
	JRST	$LEN;	# '144;
	JRST	$LOC;	# '145;
	JRST	$LSTC;	# '146;
	JRST	$CPRINT;# '147;
	JRST	$PRINT;	# '150;
	JRST	BADOP;	# '151;
$MUL:	IMUL	A,B;	# '152;
	FMPR	A,B;	# '153;
$PLUS:	ADD	A,B;	# '154;
	FADR	A,B;	# '155;
$CDIV:	IDIV	A,B;	# '156;
	FDVR	A,B;	# '157;
$LESS:	CAML	A,B;	# '160;
	JRST	ZERO;	# '161;
	JRST	ONES;	# '162;
$EQ:	CAME	A,B;	# '163;
	JRST	ZERO;	# '164;
	JRST	ONES;	# '165;
$REVOP2:SUBI	T,1;	# '166;	# CONVERT ">" TO "<";
$REVOP1:SUBI	T,1;	# '167;	# CONVERT "≥" TO "≤";
	EXCH	A,B;	# '170;
	XCT	JTAB(T);# '171;
$LEQ:	CAMLE	A,B;	# '172;
	JRST	ZERO;	# '173;
	JRST	ONES;	# '174;
STANFO([JRST	BADOP;	# ALT;
	JRST	$SETC;	# '176;	])
DEC([	JRST	$SETC;	# '175;
	JRST	BADOP;	# '176;	])
TENX([	JRST	$SETC;	# '175;
	JRST	BADOP;	# '176;	])
	JRST	BADOP;	# BS;
# END OF 0:'177 JTAB;

$OR:	JUMPN	A,ONES;
	JUMPN	B,ONES;
	JRST	ZERO;
$MINUS:	SUB	A,B;
	FSBR	A,B;
	JRST	BADOP;
	JRST	$LPMINUS;
$JCAT:	JRST	$CAT;
	JRST	$LPCAT;
$JSUBST:JRST	$SUBST;
	JRST	$LPSUBST;

$MOD:	IDIV	A,B;
	MOVE	A,A+1;
	JRST	DONE;
$EXPR:	PUSH	P,B;	# EXPONENT;
	PUSH	P,A;	# BASE;
	PUSHJ	P,FLOGS;
	JRST	DONE;
$EXPI:	PUSH	P,B;
	PUSH	P,A;
	PUSHJ	P,POW;
	FIX	1,1;
	JRST	DONE;

$LOC:	HRRZ	A,ARG2;
	JRST	DONE;

SUPERCOMMENT([
$FOR:	"FOR (SUBSTRINGER)" BEGIN	# CONVERT INDICES TO "TO";
	    TEMP←MEMORY[ARG1]+MEMORY[ARG2]-1;	# COMPUTE END CHAR NUMBER;
	    TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←MEMORY[ARG1]; # BEGINNING CHAR #;
	    RSLTTYP←RNGTYP;
	    DEG←2; GOTO $AR END;
$TO:	"TO (SUBSTRINGER)" BEGIN DEG←2;
	    TEMP←MEMORY[ARG2];	# END CHAR #;
	    TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←MEMORY[ARG1]; # BEGINNING CHAR #;
	    RSLTTYP←RNGTYP; GOTO $AR END;
]) # SUPERCOMMENT;
$FOR:	ADD	B,A;
	SUBI	B,1;
$TO:	MOVEM	B,TEMP;		# END CHAR #;
	PUSH	P,A;		# BEGINNING CHAR #;
	PUSHJ	P,NEWTEMP;
	MOVEI	A,2;
	MOVEM	A,DEG;
	MOVSI	A,0+RNGTYP LSH -18;
	MOVEM	A,RSLTTYP;
	JRST	$AR;

$CAT:	PUSH	P,ARG1;
	PUSHJ	P,MEMSTRING;
	PUSH	P,ARG2;
	PUSHJ	P,MEMSTRING;
	PUSHJ	P,CAT;
$STRNG:	HRROI	T,ACCESS(TEMPSTR);
	POP	SP,(T);
	POP	SP,-1(T);
	MOVSI	T,0+STRNG LSH -18;
	MOVEM	T,RSLTTYP;
	JRST	$AR;

SUPERCOMMENT([
$SUBST:	"PERFORM SUBSTRINGING" BEGIN
	    EXTERNAL STRING PROCEDURE SUBST(STRING ARG; INTEGER ENDCHAR, STARTCHAR);
	    TEMPSTR←SUBST(MEMSTRING(OPSTACK[TOOPS]),MEMORY[STACK[TOS-1]],
		MEMORY[STACK[TOS-1]-1]);
	    X1TEMP(STACK[TOS-1]);
	    DEG←2; RSLTTYP←STRNG; GOTO $AR
	   END;
]) # SUPERCOMMENT;
$SUBST:	MOVE	B,ACCESS(STACK[TOS-1]);
	PUSH	P,(B);		# END CHAR;
	PUSH	P,-1(B);	# START CHAR;
	PUSH	P,ACCESS(OPSTACK[TOOPS]);	# ADDR OF STRING;
	PUSH	P,B;
	PUSHJ	P,X1TEMP;
	PUSHJ	P,MEMSTRING;	# GET STRING ON SP;
	PUSHJ	P,SUBST;
	MOVEI	T,2;
	MOVEM	T,DEG;
	JRST	$STRNG;

SUPERCOMMENT([
$UMINUS:BEGIN # CONVERT -X TO (0-X);
	STACK[TOS]←STACK[TOS-1];	# COPY X;
	STACK[TOS-1]←REFZERO;		# ZERO;
	STACK[TOS←TOS+1]←"-";		# BINARY MINUS;
	EVAL1;				# RECURSE;
	GOTO $AR END;
]) # SUPERCOMMENT;
$UMINUS:MOVEI	B,ACCESS(STACK[TOS]);
	MOVE	T,-1(B);
	MOVEM	T,(B);		# STACK[TOS]←STACK[TOS-1];
	MOVSI	T,0+INTEGR LSH -18;
	HRRI	T,ZERO$;
	MOVEM	T,-1(B);	# STACK[TOS-1]←REFZERO;
	MOVEI	T,"-";
	MOVEM	T,1(B);		# STACK[TOS+1]←binary minus;
	AOS	ACCESS(TOS);
	PUSHJ	P,EVAL1;
	JRST	$AR;

ONES$:	-1;
	0;
ZERO$:	0;

$TRUE:	MOVEI	A,ONES$;
	HRLI	A,0+INTEGR LSH -18;
	JRST	SCONST;
$FALSE:	MOVSI	A,0+INTEGR LSH -18;
	JRST	ZCONST;
$NULL:	MOVSI	A,0+STRNG LSH -18;
	JRST	ZCONST;
$ANY:	MOVSI	A,0+(ITEMB+NOTYPE) LSH -18;
	JRST	ZCONST;
$NLREC:	MOVSI	A,0+RECTYP LSH -18;
	JRST	ZCONST;
$PHI:	MOVSI	A,0+SETYPE LSH -18;
	JRST	ZCONST;
$NIL:	MOVSI	A,0+LSTYPE LSH -18;
ZCONST:	HRRI	A,ZERO$;
SCONST:	MOVEM	A,ACCESS(STACK[TOS]);
	SETZM	ACCESS(CLASS);		# SYMBOLIC CONSTANTS ARE NOT SPCHARs;
	JRST	$AR;

$LPLES:	MOVEI	5,'65;
	JRST	LPREL;
$LPEQ:	MOVEI	5,'67;
	JRST	LPREL;
$LPNEQ:	MOVEI	5,'70;
	JRST	LPREL;
$LPLEQ:	MOVEI	5,'71;
LPREL:	HRLI	5,'110;
LPRL2:	PUSH	P,A;
	PUSH	P,B;
	PUSHJ	P,LEAP;
	JUMPN	1,ONES;
	JRST	ZERO;

$UNION:	MOVEI	5,'56;
	JRST	LPSET;
$INTER:	MOVEI	5,'57;
	JRST	LPSET;
$LPMINUS:MOVEI	5,'60;
LPSET:	HRLI	5,'110;
	JRST	LPDRV;

$LPXOR:	MOVE	5,[('2 LSH 18)+'40];
	JRST	LPDRV;
$ASSOC:	MOVE	5,[('20 LSH 18)+'41];
	JRST	LPDRV;
$LPEQV:	MOVE	5,[('200 LSH 18)+'42];
LPDRV:	PUSH	P,A;
	PUSH	P,B;
LPDO1:	PUSHJ	P,LEAP;
	HRROI	'14,TEMP;
	MOVE	5,[('110 LSH 18)+'61];
	PUSHJ	P,LEAP;
	JRST	$AR;

$IN:	MOVE	5,[('10 LSH 18)+'63];
	JRST	LPRL2;

$LPCAT:	MOVE	5,[('110 LSH 18)+'121];
	JRST	LPDRV;
$LPSUBST:MOVE	B,ACCESS(STACK[TOS-1]);
	PUSH	P,@ACCESS(OPSTACK[TOOPS]);
	PUSH	P,-1(B);		# START EL;
	PUSH	P,(B);		# END EL;
	MOVE	5,[('100 LSH 18)+'125];
	JRST	LPDO1;

END;

$INF:	BEGIN
	    # SPECIAL OPERATOR MEANING LENGTH OF STRING, SET, LIST;
	CLASS←0;	# SYMBOLIC CONSTANTS ARE NOT SPCAHRS. CAUSES
			PROBLEMS WITH UNARY MINUS;
	FOR I←TOOPS STEP -1 UNTIL 0 DO
	    IF (TYP1←GETTYPE(OP←OPSTACK[I])) NEQ 0 THEN DONE;
	STACK[TOS]←INTEGR+NEWTEMP(IF TYP1=STRNG THEN LENGTH(MEMSTRING(OP))
	    ELSE LENGTH(MEMORY[OP,SET])); GOTO $AR END;
$LEN:	BEGIN TEMP←IF TYP2=STRNG THEN LENGTH(MEMSTRING(ARG2))
	ELSE LENGTH(MEMORY[ARG2,SET]); RSLTTYP←INTEGR; GOTO $AR END;
$COLON:	EV1ERR("No contexts in BAIL");
$SEMI:	BEGIN FOR I←0 UPTO TOS-1 DO PRINT(STACK[I]); OUTSTR(DUMPSTR);
	TOS←-1; GOTO $AR END;
$SETC:	BEGIN
	# STACK HAS	[CODE FOR SETC]
			[DESCR FOR LAST ITEMVAR]
				:
			[DESCR FOR FIRST ITEMVAR]
			[-1];
	MEMLOC(TEMP,SET)←PHI; FOR I←TOS-1 STEP -1 UNTIL 0 DO BEGIN
	    IF STACK[I]=-1 THEN DONE;
	    PUT MEMORY[STACK[I],ITEMVAR] IN MEMLOC(TEMP,SET) END;
	RSLTTYP←SETYPE; DEG←TOS-I; GOTO $AR END;
$LSTC:	BEGIN
	MEMLOC(TEMP,LIST)←NIL; FOR I←TOS-1 STEP -1 UNTIL 0 DO BEGIN
	    IF STACK[I]=-1 THEN DONE;
	    PUT MEMORY[STACK[I],ITEMVAR] IN MEMLOC(TEMP,LIST) BEFORE 1 END;
	RSLTTYP←LSTYPE; DEG←TOS-I; GOTO $AR END;

$PROPS:	"PROPS()" START!CODE
	    EXTERNAL INTEGER PROPS;
		MOVE	3,@ARG2;
		LDB	0,PROPS;
		MOVEM	0,TEMP;
		JRST	$AR;
		END;
$COMMA:	BEGIN
	    INTEGER FPNTR;
	    # REMOVE OPCOMMA FROM TOP OF STACK;
	    TOS←TOS-1;
	    # ARE WE PARSING PARAMETER LIST TO A PROCEDURE?;
	    IF TOOPS>0 AND (FPNTR←RBIND[TOOPS-1])<0 THEN
	    BEGIN
	    NOHAND([
	    INTEGER ACTREF,FRMREF,ACTTYP,FRMTYP;
		# WE ARE PARSING THE PARAMETER LIST OF A PROCEDURE.
		PERFORM TYPE COERCION.  ALSO ASSIGN VALUE PARAMETERS TO 
		TEMPORARIES, TO PREVENT MISHAPS SUCH AS
			EXTERNAL PROCEDURE A(INTEGER VALUE P,Q).,
			A(I←3,I←4);
		FRMTYP←GETTYPE(FRMREF←MEMORY[ABS FPNTR]);
		ACTTYP←GETTYPE(ACTREF←STACK[TOS]);
		IF FRMTYP NEQ ACTTYP THEN BEGIN # COERCION NECESSARY;
		    # MAKE SURE WE ASSIGN A TEMP;
		    ACTREF←ACTREF LAND (LNOT REFB);
		    IF FRMTYP=NOTYPE THEN STACK[TOS]←STACK[TOS] LAND
			LNOT ('77 LSH 23) LOR NOTYPE ELSE
		    IF FRMTYP=ARRY+NOTYPE THEN STACK[TOS]←STACK[TOS] LAND
			LNOT ('77 LSH 23) LOR (ARRY+NOTYPE) ELSE BEGIN
		    IF FRMTYP<STRNG OR FRMTYP>INTEGR THEN
			EV1ERR("Can't coerce types")
		    ELSE CASE FRMTYP LSH -23 OF BEGIN
		    [3] ACTREF←CVSTRNG(ACTREF,1);
		    [4] ACTREF←CVREAL(ACTREF,1);
		    [5] ACTREF←CVINTEGR(ACTREF,1) END; END; END;
		IF NOT (ACTREF LAND REFB) THEN BEGIN # ASSIGN TEMP;
		    X1TEMP(ACTREF); # GET RID OF OLD;
		    RSLTTYP←FRMTYP; # RESULT IS SAME TYPE AS FORMAL;
		    IF FRMTYP=STRNG THEN TEMPSTR←MEMSTRING(ACTREF)
		    ELSE TEMP←MEMORY[ACTREF];
		    # RESULT ASSIGNMENT TAKE CARE OF ALLOCATING THE TEMP;
		    # BUT REMEMBER THAT WE ALREADY ADJUSTED TOS;
		    TOS←TOS+1;
		    DEG←1; END;
		# SET UP POINTER TO NEXT PARAMETER REFITEM;
		RBIND[TOOPS-1]←RBIND[TOOPS-1]-1;
		END ]) # NOHAND;
	    HAND([
	    INTEGER !FRMTYP;
	    START!CODE LABEL COERCE,BAD,CHKTMP,OUT1,FIXTYP,NSTR;
	    DEFINE ACTREF=[1],FRMREF=[2],ACTTYP=[3],FRMTYP=[4],!STACK=[5],T=[6];
		MOVEI	!STACK,ACCESS(STACK[TOS]);
		MOVM	T,FPNTR;
		MOVE	FRMREF,(T);
		LDB	FRMTYP,[('271000 LSH 18)+FRMREF]; # 8 BITS INCLUDES ITEMB;
		MOVEM	FRMTYP,!FRMTYP;
		MOVE	ACTREF,(!STACK);
		LDB	ACTTYP,[('271000 LSH 18)+ACTREF]; # 8 BITS INCLUDES ITEMB;
		CAIN	FRMTYP,(ACTTYP);
		 JRST	CHKTMP;
		TLZ	ACTREF,0+REFB LSH -18;
		CAIE	FRMTYP,0+NOTYPE LSH -23;
		CAIN	FRMTYP,0+NOTYPE+ARRY LSH -23;
		 JRST	FIXTYP;
		CAIL	FRMTYP,0+STRNG LSH -23;
		CAILE	FRMTYP,0+INTEGR LSH -23;
		 JRST	BAD;
		PUSH	P,ACTREF;
		MOVEI	T,1;
	COERCE:	PUSH	P,T;
		PUSHJ	P,@COERCE(FRMTYP);
		JRST	CHKTMP;
		PUSHJ	P,CVSTRNG;
		PUSHJ	P,CVREAL;
		PUSHJ	P,CVINTEGR;
	BAD:	PUSH	SP,[18];
		PUSH	SP,["Can't coerce types"];
		PUSHJ	P,EV1ERR;
	FIXTYP:	DPB	FRMTYP,[('271000+!STACK)LSH 18]; # 8 BITS INCLUDES ITEMB;
	CHKTMP:	TLNE	ACTREF,0+REFB LSH -18;
		 JRST	OUT1;
		MOVE	FRMTYP,!FRMTYP;
		LSH	FRMTYP,23;
		MOVEM	FRMTYP,RSLTTYP;
		MOVE	T,(ACTREF);
		MOVEM	T,TEMP;
		CAME	FRMTYP,[0+STRNG];
		 JRST	NSTR;
		PUSH	P,ACTREF;
		PUSHJ	P,MEMSTRING;
		MOVEI	T,ACCESS(TEMPSTR);
		POP	SP,(T);
		POP	SP,-1(T);
	NSTR:	MOVEI	T,ACCESS(TOS);
		AOS	(T);
		MOVEI	T,1;
		MOVEM	T,DEG;
	OUT1:	MOVEI	T,ACCESS(RBIND[TOOPS]);
		SOS	-1(T);
	END END ]) # HAND;

	ELSE BEGIN # NOT AN ARG LIST. JUST ASSIGN TEMPORARY;
	    IF ARG1 LAND REFB THEN BEGIN
		RSLTTYP←TYP1;
		IF TYP1=STRNG THEN TEMPSTR←MEMSTRING(ARG1)
		ELSE TEMP←MEMORY[ARG1]; DEG←1 END END;
	GOTO $AR; END;
$ARRYREF:BEGIN
	    # THE STACK LOOKS LIKE
		[OPCODE FOR ARRAY REFERENCE]
		[REFIT FOR LAST SUBSCRIPT]
		.
		.
		[REFIT FOR FIRST SUBSCRIPT]
		-1
	      THE TOP WORD OF THE OPSTACK IS THE REFIT FOR THE ARRAY;

	    # TO SAVE STACK SPACE AT RUNTIME;
	    DEFINE REFIT=[ARG1],ADDR=[ARG2],NDIMS=[DEG],RNGFLG=[MODE],
		STRARRFLG=[TYP],SUBSBASE=[OP];
	    RECURSIVE PROCEDURE RNGPRNT(INTEGER SBPK,ADDRM3K,T); BEGIN "RNGPRNT"
		# SBPK=LOCATION(STACK[SUBSBASE+index])
		  ADDRM3K=ADDRESS-3*index
		  T=OFFSET;
	    NOHAND([
		INTEGER I,U;
		IF GETTYPE(MEMORY[SBPK])=RNGTYP THEN BEGIN RNGFLG←TRUE;
		    U←MEMORY[SBPK]; I←MEMORY[SBPK-1] END
		ELSE U←I←MEMORY[CVINTEGR(MEMORY[SBPK],1)];
		UB←MEMORY[ADDRM3K]; LB←MEMORY[ADDRM3K-1];
		T←T+(I-1)*(1-STRARRFLG)*MEMORY[ADDRM3K+1];
		FOR I←I UPTO U DO BEGIN
		    IF I<MEMORY[ADDRM3K-1] OR I>MEMORY[ADDRM3K] THEN
			EV1ERR("Subscripting error.  index  value   min   max
			"&CVS(SBPK-LOCATION(STACK[SUBSBASE]))&TAB&CVS(I)&TAB
			&CVS(LB)&TAB&CVS(UB));
		    T←T+(1-STRARRFLG)*MEMORY[ADDRM3K+1];
		    IF MEMORY[SBPK+1]=OPARRY THEN BEGIN
			STACK[SUBSBASE]←STACK[SUBSBASE]LAND '777777000000
			   LOR RIGHT(T);
			IF RNGFLG THEN PRINT(STACK[SUBSBASE]) END
		    ELSE RNGPRNT(SBPK+1,ADDRM3K-3,T) END
	    ]) # NOHAND;
	    HAND([
	    INTEGER I,U;
	    START!CODE LABEL NRNG,JOIN1,FORTOP,FORINC,FORCHK,BAD,NLDIM,BADCAT;
	    EXTERNAL INTEGER CVS,CAT,CATCHR;
	    DEFINE T1=[1],T2=[2],T3=[3],!STACK=[4],SBREF=[5];
	    PROTECT!ACS T1,T2,T3,!STACK,SBREF;
		MOVE	!STACK,SBPK;	# LOC OF SUBSCRIPT REFIT;
		MOVE	SBREF,(!STACK);	# REFIT FOR SUBSCRIPT;
		LDB	T1,[('270600 LSH 18)+SBREF];
		CAIE	T1,0+RNGTYP LSH -23;
		 JRST	NRNG;
		SETOM	ACCESS(RNGFLG);
		MOVE	T2,-1(SBREF);	# LOW LIMIT OF RANGE;
		MOVE	T3,(SBREF);	# HIGH LIMIT;
		JRST	JOIN1;
	    NRNG:PUSH	P,SBREF;
		PUSH	P,[1];
		PUSHJ	P,CVINTEGR;
		MOVE	T2,(1);
		MOVE	T3,(1);
	    JOIN1:MOVEM	T3,U;
		MOVE	T1,T2;		# L;
		SUBI	T1,1;
		MOVE	T3,ADDRM3K;
		IMUL	T1,1(T3);
		SKIPE	ACCESS(STRARRFLG);
		 ADD	T1,T1;		# CURSE YOU, STRING ARRAYS;
		ADDM	T1,T;
		JRST	FORCHK;
	    FORTOP:MOVE	T3,ADDRM3K;
		CAML	T2,-1(T3);	# LB/UB CHECK;
		CAMLE	T2,(T3);
		 JRST	BAD;
		MOVE	T2,1(T3);
		SKIPE	ACCESS(STRARRFLG);
		 ADD	T2,T2;		# DOUBLE FOR STRING ARRAYS;
		ADDB	T2,T;		# INCREMENT OFFSET;
		MOVE	T3,SBPK;	# CHECK FOR LAST DIMENSION;
		MOVE	T3,1(T3);
		CAIE	T3,OPARRY;
		 JRST	NLDIM;		# NOT LAST DIMENSION;
		MOVEI	!STACK,ACCESS(STACK[SUBSBASE]);
		HRRM	T2,(!STACK);
		SKIPN	ACCESS(RNGFLG);
		 JRST	FORINC;
		PUSH	P,(!STACK);
		PUSHJ	P,WR!TON;
		JRST	FORINC;
	    BADCAT:PUSHJ P,CVS;
		PUSHJ	P,CAT;
		PUSH	P,[TAB];
		PUSHJ	P,CATCHR;
		JRST	(T1);
	    BAD:PUSH	SP,[52];
		PUSH	SP,[
"Subscripting error.   index    value	min    max
			"];
		MOVE	T1,SBPK;
		SUBI	T1,ACCESS(STACK[SUBSBASE]);
		PUSH	P,T1;
		JSP	T1,BADCAT;
		PUSH	P,T2;
		JSP	T1,BADCAT;
		PUSH	P,-1(T3);
		JSP	T1,BADCAT;
		PUSH	P,(T3);
		JSP	T1,BADCAT;
		PUSHJ	P,EV1ERR;
	    NLDIM:MOVE	T1,SBPK;
		MOVE	T2,ADDRM3K;
		MOVE	T3,T;
		ADDI	T1,1;
		PUSH	P,T1;
		SUBI	T2,3;
		PUSH	P,T2;
		PUSH	P,T3;
		PUSHJ	P,RNGPRNT;
	    FORINC:AOS	T2,I;
	    FORCHK:MOVEM T2,I;
		CAMG	T2,U;
		 JRST	FORTOP;
		END;
	    ]) # HAND;
	    END "RNGPRNT";
		
	    REFIT←OPSTACK[TOOPS];
	    STRARRFLG←IF GETTYPE(REFIT)=STRNG+ARRY THEN -1 ELSE 0;
	    # THE ADDRESS IN REFIT IS THE ADDRESS OF THE [AN] ALLOCATION CELL;
	    ADDR←RIGHT(MEMORY[REFIT]);	# ADDR POINTS TO FIRST DATA WORD;
	    IF NOT ADDR THEN EV1ERR("Deallocated array");
	    # FIND BEGINNING OF DIMENSIONS;
	    I←TOS; DO I←I-1 UNTIL STACK[I]=-1; SUBSBASE←I;
	    # MAKE A REFIT WITH THE RIGHT ADDR AND THE ARRAY BIT OFF;
	    STACK[SUBSBASE]←(REFIT-ARRY) LAND '777740000000;
	    ADDR←ADDR+STRARRFLG; NDIMS←ABS(MEMORY[ADDR-1] ASH -18);
	    IF TOS-SUBSBASE-1 NEQ NDIMS THEN
		EV1ERR("Correct number of subscripts is "&CVS(NDIMS));

	    RNGPRNT(LOCATION(STACK[SUBSBASE+1]),ADDR-3,MEMORY[ADDR-3*NDIMS-2]);
	    FOR I←SUBSBASE UPTO TOS DO X1TEMP(STACK[I]);
	    TOS←SUBSBASE+RNGFLG; DEG←0;
	GOTO $AR; END;
# $MEMRY,$DATUM,$SWAP,$GETS,$SUBFLD,$AR,$APPLY,$CPRINT,$PRINT;
$MEMRY:	"MEMORY[]" BEGIN
	    # THE "ARGUMENTS" (EITHER ONE OR TWO) HAVE BEEN CONVERTED TO INTEGER
	    BY FUDGING ON THE DEGREE AND CONFOMITY CLASS.  IF THERE IS ONE ARG,
	    THEN ARG1=-1 AND ARG2=[REFIT FOR ADDRESS].  IF THERE ARE TWO ARGUMENTS,
	    THEN ARG1=[REFIT FOR ADDRESS] AND ARG2=[REFIT FOR TYPE BITS].  BEFORE
	    WE FALL THROUGH WE MUST SET DEG←0 AND FIX UP THE STACK;

	    IF ARG1=-1 THEN STACK[TOS←TOS-2]←REFB+INTEGR+
		(IF (I←RIGHT(MEMORY[ARG2]))<'20 THEN LOCATION(SAVED!ACS[I]) ELSE I)
	    ELSE STACK[TOS←TOS-3]←REFB+(MEMORY[ARG2] LAND (-1 LSH 23))+
		(IF (I←RIGHT(MEMORY[ARG1]))<'20 THEN LOCATION(SAVED!ACS[I]) ELSE I);
	    DEG←0; GOTO $AR END;
$DATUM:	"DATUM()" START!CODE
	    EXTERNAL INTEGER DATM,INFTB;
		MOVE	3,@ARG2;	# ITEM NUMBER;
		LDB	0,INFTB;	# ITEM TYPE BITS;
		MOVEI	1,@DATM;	# AC1←ADDR OF DATUM, UNLESS DATUM IS STRING;
		CAIN	0,0+STRNG LSH -23;# IS DATUM A STRING?;
		 HRRZ	1,(1);		# YES, FETCH ADDR OF WORD2;
		MOVEM	1,ARG1;		# LOCATION OF THIS OBJECT;
		MOVE	2,0;		# COPY;
		LSH	0,23;		# SHIFT OVER INTO PLACE;
		CAIL	2,0+ARRY LSH -23;# IS DATUM AN ARRAY?;
		 TLO	0,'20;		# YES, TURN ON INDIRECT BIT;
		TLO	0,0+REFB LSH -18;# WE HAVE A REFERENCE, NOT A VALUE;
		MOVEM	0,RSLTTYP;
		JRST	$AR;
		END;
$SWAP:	BEGIN IF NOT(ARG1 LAND ARG2 LAND REFB) THEN EV1ERR("Invalid assignment");
	RSLTTYP←ARG1 LAND '777777000000;
	MEMORY[ARG1] SWAP MEMORY[ARG2]; GOTO $AR END;
$GETS:	"GETS ←" BEGIN
DEFINE DOINT(OP)=[TEMP←MEMORY[ARG1] OP MEMORY[ARG2]];
	    IF NOT(ARG1 LAND REFB) THEN EV1ERR("Invalid assignment");
	    RSLTTYP←ARG1 LAND '777777000000;
	    IF RSLTTYP=REFB+STRNG THEN START!CODE
		MOVE	1,ARG2;		# →WORD 2 OR SOURCE;
		MOVE	2,ARG1;		# →WORD 2 OF DEST.;
		MOVE	0,(1);
		MOVEM	0,(2);
		MOVE	0,-1(1);
		MOVEM	0,-1(2);
		END
	    ELSE DOINT([←]); GOTO $AR END;
$SUBFLD:BEGIN
		# STACK LOOKS LIKE
		[OP CODE FOR SUBFIELDING]
		[REFITEM FOR RECORD LPOINTER] (ARG2 HAS ADDR OF RECORD POINTER)
		[-1]
		[SUBFIELD # (NEG. FOR STRINGS)]
		THE TOP OF OPSTACK IS A REFITEM FOR THE CLASS;
	    RECORD!POINTER(ANY!CLASS) RPCLASS;
	    INTEGER CLASS,SUBFIELD;
	    MEMLOC(RPCLASS,INTEGER)←CLASS←OPSTACK[TOOPS]; SUBFIELD←STACK[TOS-3];
	    IF MEMORY[ARG2]=0 THEN EV1ERR("Subfield of null record");
	    IF RIGHT(MEMORY[MEMORY[ARG2]]) NEQ RIGHT(CLASS) THEN
		EV1ERR("Record class-pointer mismatch");
	    # COMPUTE ADDRESS OF DATA;
	    ARG1←RIGHT(MEMORY[ARG2])+ABS(SUBFIELD); IF SUBFIELD<0 THEN ARG1←
		RIGHT(MEMORY[ARG1]);
	    RSLTTYP←REFB+$CLASS:TYPARR[RPCLASS][ABS(SUBFIELD)];
		COMMENT MEMORY[MEMORY[CLASS+4]+ABS(SUBFIELD)];
	    DEG←3; GOTO $AR END;

$PRINT:	BEGIN STACK[TOS←TOS+1]←0;	# Convert to CPRINT(-1, ... );
	ARRTRAN(TARRAY,STACK); ARRBLT(STACK[1],TARRAY[0],TOS);
	STACK[0]←INTEGR+LOCATION(-1);	END;
$CPRINT:BEGIN
	STACK[0]←CVINTEGR(STACK[0],1);
	FOR I←1 UPTO TOS-1 DO START!CODE LABEL JTAB,BOT,REG,PRERR;
	EXTERNAL INTEGER $PSTR,$PREL,$PINT,$PSET,$PLST,$PITM,$PREC;
	PROTECT!ACS 1,2,3;
	MOVE	1,ACCESS(STACK[I]);
	LDB	2,[('270600 LSH 18)+1];	# 6 BIT TYPE CODE;
	CAIGE	2,0+ARRY LSH -23;
	TLNE	1,0+(ARY2B LSH -18);	# Can't print any kind of array;
	 JRST	PRERR;
	TLNE	1,0+(ITEMB LSH -18);
	 MOVEI	2,'10;		# Recode items to '10;
	CAIN	2,'15;		# And RECORD!POINTERS to '11;
	 MOVEI	2,'11;
	CAIL	2,3;
	CAILE	2,'11;
	 JRST	PRERR;		# Bad type;
	HLRZ	3,JTAB(2);	# Usertable offset of user formatter procedure;
	ADD	3,GOGTAB;	# Addr within user table;
	SKIPN	3,(3);		# Fetch entry addr of user's proc;
	 MOVE	3,JTAB(2);	# Else use default;
	CAIE	2,3;		# STRINGs are special;
	 JRST	REG;
	PUSH	P,1;
	PUSHJ	P,MEMSTRING;
    REG:PUSH	P,@ACCESS(STACK[0]);	# Channel;
	CAIE	2,3;		# STRING value on SP;
	 PUSH	P,@1;		# Value;
    JTAB:PUSHJ	P,(3);		# Do it;
	POP	P,1;		# Remove channel;
	JRST	BOT;
	
	0+($$FSTR LSH 18) $PSTR;
	0+($$FREL LSH 18) $PREL;
	0+($$FINT LSH 18) $PINT;
	0+($$FSET LSH 18) $PSET;
	0+($$FLST LSH 18) $PLST;
	0+($$FITM LSH 18) $PITM;
	0+($$FREC LSH 18) $PREC;
    PRERR:MOVEI	1,["Bad type or channel"];
	PUSH	SP,-1(1);
	PUSH	SP,(1);
	PUSHJ	P,EV1ERR;
    BOT:
	END;
TOS←-1;		# CLEAR STACK;
END;
	

$AR: $ASSIGNRESULTS:
	# REMEMBER THE CASE  PROC(I←3)  WHERE I IS A REFERENCE PARAM;
    IF DEG>0 THEN STACK[TOS←TOS-DEG]←RSLTTYP+
	(IF RSLTTYP LAND REFB THEN RIGHT(ARG1)
	ELSE (IF RSLTTYP=STRNG THEN NEWSTRTEMP(TEMPSTR)
		ELSE NEWTEMP(TEMP)));

SSF←FALSE;
END "PRIMITIVE"


ELSE BEGIN "PROC"
    EXTERNAL PROCEDURE APPLY(REFERENCE STRING TEMPSTR;
	REFERENCE INTEGER TEMP; INTEGER PDA,ARGLIS);
    # SEARCH BACK THROUGH STACK TO MARKER,
	IN ORDER TO DETERMINE NUMBER OF PARAMS;
    I←TOS; DO I←I-1 UNTIL STACK[I]=-1;
    # CHECK NUMBER OF PARAMETERS. DEFAULTABLE PARAMS HAVE SIGN BIT ON;
    FOR ARG2←TOS-I UPTO (DEG←N!PARAMS(OP)) DO
	IF MEMORY[MEMORY[OP+PD!DLW]+ARG2-1]>0 THEN
	    EV1ERR(MEMSTRING(OP+2)&" takes "&CVS(DEG)&" arguments.");
    # DO IT;
    STACK[TOS]←0;
    PLANT!BREAKS;
    # SEARCH FOR CORRECT STATIC LINK;
    START!CODE	LABEL LUP,FOUND,BAD,OK;
    DEFINE F=['12],T1=['13],T2=['14],T3=['15];
	HRRZ	1,OP;		# PROC DESCR ADDR;
	SETZ	T2,;		# DEFAULT CONTEXT IS NULL;
	HRRZ	T1,PD!PPD(1);	# PARENT'S PDA;
	JUMPE	T1,FOUND;	# "PROCEDURE" IS REALLY OUTER BLOCK;
	HRRZ	T2,PD!PPD(T1);	# GRANDFATHER PDA;
	JUMPE	T2,FOUND;	# PROC IS AT TOP LEVEL OF SOME OUTER BLOCK;
	MOVEI	T2,F;		# NOT OUTER, MUST LOOK FOR PARENT;
    LUP:HRRZ	T2,(T2);	# UP DYNAMIC LINK;
	JUMPE	T2,BAD;		# F CHAIN RAN OUT;
	CAIN	T2,-1;
	 JRST	BAD;
	HLRZ	T3,1(T2);	# PDA FROM STACK;
	CAIE	T1,(T3);	# THE ONE WE WANT?;
	 JRST	LUP;
    FOUND:HRLI	1,(T2);		# CONTEXT,,PDA;
	MOVEM	1,ARG2;
	JRST	OK;
    BAD:MOVEI	T1,["Proper context does not exist"];
	PUSH	SP,-1(T1);
	PUSH	SP,(T1);
	PUSHJ	P,EV1ERR;
    OK:	END;
    APPLY(TEMPSTR,TEMP,ARG2,LOCATION(STACK[I]));
    # REMOVE PARAMS FROM TEMPORARY CELLS;
    FOR DEG←I+1 UPTO TOS-1 DO X1TEMP(STACK[DEG]);
    # IF TYPED PROCEDURE, RETURN VALUE;
    IF (TYP←GETTYPE(OP)) NEQ 0 THEN STACK[TOS←I]←TYP+
	(IF TYP=STRNG THEN NEWSTRTEMP(TEMPSTR)
	ELSE NEWTEMP(TEMP))
    ELSE TOS←I-1;
END"PROC";
    
END "EVAL1";

# PARSER;
PROCEDURE LOPARG; OLDARG←OLDARG & LOP(ARG);

OLDARG←NULL;
N!TSTRVAL←N!TEMPVAL←TOS←TOOPS←-1;

WHILE LENGTH(ARG) DO BEGIN "PARSE"
GET!TOKEN(ARG,STRVAL,CLASS,IVAL); OLDARG←OLDARG & STRVAL;
CASE CLASS OF BEGIN "CASES"
    [INTVAL] PSH(NEWTEMP(IVAL)+INTEGR);
    [REALVAL] PSH(NEWTEMP(IVAL)+FLOTNG);
    [STRCON] PSH(NEWSTRTEMP(STRVAL)+STRNG);
    [ID] BEGIN "ID"
	LABEL NOTRW;
	# CHECK IF THE ID IS EQUIVALENT TO A SPECIAL CHAR;
	START!CODE LABEL LOOP,INCR,FOUND;	DEFINE A=[1],K0=[2],K1=[3],K2=[4];
		MOVE	K0,NAME[0];
		MOVE	K1,NAME[1];
		MOVE	K2,NAME[2];
		MOVSI	A,-N!RWORD;
	LOOP:	CAMN	K0,RWORD0[0](A);
		CAME	K1,RWORD0[1](A);
		 JRST	INCR;
		CAMN	K2,RWORD0[2](A);
		 JRST	FOUND;
	INCR:	ADDI	A,2;
		AOBJN	A,LOOP;
		JRST	NOTRW;
	FOUND:	HLRE	A,A;
		MOVE	A,RWORD1[N!RWORD](A);
		MOVEM	A,OP;
		END;
	STRVAL←OP; CLASS←SPCHAR; GOTO OPCHAR;
	NOTRW:
	# CHECK FOR EVAL SPECIALS;
	IF EQU(STRVAL,"!!GO") THEN GOTO RET
	ELSE BEGIN
	    # SEARCH SYMBOL TABLE;
	    IF (PNTR←FIND(NAME,LCHAIN,LDEPTH,FALSE))<0
	    THEN BEGIN MEMLOC(REFIT,ITEMVAR)←CVSI(STRVAL,PNTR);
		IF PNTR THEN EV1ERR(IF MULDEF THEN "Mul. def. ID" ELSE "Unknown ID");
		REFIT←ITEMB+RIGHT(REFIT) END
	    ELSE IF RIGHT(CACHE[PNTR+1]) THEN
		REFIT←INCOR(PNTR,DCHAIN,DDEPTH,DISPLVL) ELSE
		EV1ERR("Unallocated variable") END;
	# CHECK FOR ITEMS;
	IF (REFIT LAND ITEMB) AND (REFIT LAND ('77 LSH 23))=0 THEN
	    PSH(REFB+ITEMB + (TYPEIT(MEMLOC(REFIT←RIGHT(REFIT),ITEMVAR)) LSH 23) +
		NEWTEMP(REFIT))
	# CHECK FOR PROCEDURE;
	ELSE IF REFIT LAND PROCB THEN BEGIN "PROCED"
	    # MARK STACK FOR CHECKING NUMBER OF PARAMS;
	    PSH(-1);
	    IF N!PARAMS(REFIT)>0 AND ARG="(" THEN BEGIN "WITH PARAMS"
		# REMOVE THE "(" AND PLACE PROCEDURE NAME ON OPSTACK;
		LOPARG;
		OPPSH(REFIT,-(RIGHT(MEMORY[REFIT+PD!DLW])));
		# ALSO STICK IN AN EXTRA COMMA.  THEN THERE WILL BE AS MANY
		COMMAS AS ARGUMENTS, AND TYPE CHECKING AND COERCION WORKS BETTER;
		OPPSH(OPCOMMA,RBNDCOMMA);
		# REMEMBER THAT WE HAVE SEEN A SPECIAL CHARACTER, SO THAT UNARY
		  MINUS WORKS IN  PROC(-1,-1);
		CLASS←SPCHAR;
		END "WITH PARAMS"
	    ELSE BEGIN PSH(REFIT); EVAL1 END END "PROCED"
	# CHECK FOR RECORD CLASS NAME;
	ELSE IF GETTYPE(REFIT)=RCLTYP THEN BEGIN
		RECORD!POINTER(ANY!CLASS) RPREFIT;
		SIMPLE INTEGER PROCEDURE FNDSBFLD(RECORD!POINTER($CLASS)C;
		    STRING NAM); BEGIN INTEGER I;
		FOR I←1 UPTO $CLASS:RECSIZ[C] DO
		    IF !!EQU($CLASS:TXTARR[C][I],NAM) THEN RETURN(I);
		RETURN(-1) END;
	    IF ARG NEQ ":" THEN EV1ERR("Missing colon"); LOPARG;
	    # LOOK FOR SUBFIELD NAME;
	    MEMLOC(RPREFIT,INTEGER)←REFIT;	# KLUGEY TYPE COERCION;
	    GET!TOKEN(ARG,STRVAL,CLASS,IVAL); OLDARG←OLDARG&STRVAL;
	    IF CLASS NEQ ID OR (0>IVAL←FNDSBFLD(RPREFIT,STRVAL))
		THEN EV1ERR("Incorrect subfield designator");
	    IF GETTYPE($CLASS:TYPARR[RPREFIT][IVAL])=STRNG THEN IVAL←-IVAL;
	    PSH(IVAL); PSH(REFIT) END
	ELSE PSH(REFIT)
	END "ID";

    [SPCHAR] OPCHAR: BEGIN "SPCHAR"
	# FIND WHICH OPERATOR IT IS AND ITS LEFT AND RIGHT BINDING POWER;
	DEFINE LBND=[(OPS1[OP] LSH -27)], RBND=[(OPS1[OP] LSH -18 LAND '777)];
	OP←STRVAL; IF OP="-" AND NOT BINARYMINUSFLAG THEN OP←'123;
	IF OPS1[OP]=0 THEN EV1ERR("Invalid operator");
	# EVALUATE OPERATORS OF HIGHER PRECEDENCE WHICH OCCUR TO THE LEFT;
	WHILE TOOPS NEQ -1 AND RBIND[TOOPS]>LBND DO BEGIN
	    PSH(OPSTACK[TOOPS]); EVAL1; TOOPS←TOOPS-1 END;
	# CHECK FOR  "[" OR ")" OR "]" AND PROCEDURES, ARRAYS, STRINGS;
	IF OP=")" THEN BEGIN
	    IF TOOPS<0 THEN EV1ERR("Too many right parentheses");
	    IF (REFIT←OPSTACK[TOOPS])="(" # OP NUMBER OF LEFT PAREN "(";
		THEN TOOPS←TOOPS-1
	    ELSE IF REFIT LAND PROCB THEN BEGIN "PROCS"
		PSH(REFIT); EVAL1; TOOPS←TOOPS-1 END "PROCS" END
	ELSE IF OP="]" THEN BEGIN
	    IF TOOPS<0 THEN EV1ERR("Misplaced ]");
	    PSH(IF (T←GETTYPE((REFIT←OPSTACK[TOOPS]))) GEQ ARRY THEN
		    (IF REFIT=REFMEMORY THEN OPMEMORY ELSE OPARRY)
		ELSE IF T=STRNG OR T=LSTYPE THEN OPSUBST
		ELSE IF T=RCLTYP THEN OPSUBFLD
		ELSE 0);
	    EVAL1; TOOPS←TOOPS-1;
	    END
	ELSE IF OP="[" THEN BEGIN
	    IF (T←GETTYPE((REFIT←STACK[TOS]))) GEQ ARRY OR T=STRNG OR T=RCLTYP
		OR T=LSTYPE THEN BEGIN OPPSH(REFIT,0); STACK[TOS]←-1 END
	    ELSE EV1ERR("Misplaced [");
	    END
	ELSE IF OP=";" THEN BEGIN PSH(OP); EVAL1 END
	ELSE IF OP="{" THEN BEGIN
	    IF ARG="{" THEN LOPARG;
	    OPPSH("{",0); PSH(-1) END
	ELSE IF OP=CH!SETC THEN BEGIN
	    IF ARG=CH!SETC THEN BEGIN OP←OPLSTC; LOPARG END;
	    IF OPSTACK[TOOPS] NEQ "{" THEN EV1ERR("Bad set or list");
	    PSH(OP); EVAL1; TOOPS←TOOPS-1 END
	ELSE OPPSH(OP,RBND)
	END "SPCHAR"
END "CASES";
BINARYMINUSFLAG←IF CLASS NEQ SPCHAR OR OP=")" OR OP="]" THEN TRUE
    ELSE FALSE
END "PARSE";
RETURN(STACK[0])
END "EVAL";
# !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV;

INTEGER NXTINSTR;
INTERNAL PROCEDURE !!STEP; BEGIN STEPIT(PC,STEPINSTR,STEPMASK);
    GOTO RET END;

INTERNAL PROCEDURE !!GSTEP; BEGIN STEPIT(PC,GSTEPINSTR,GSTEPMASK);
    GOTO RET END;

INTERNAL PROCEDURE !!GOTO(STRING WHERE); BEGIN
    PC←LOC!PC(WHERE); FLAGS←FLAGS LOR ('20 LSH 18); # JRST MODE; GOTO RET END;

PROCEDURE Q!BRECOV; GOTO BRECOV;

SIMPLE PROCEDURE CLNRET; BEGIN "CLNRET"
PLANT!BREAKS;
IF CURBRK=N!BK AND NOT(FLAGS LAND '20)
    THEN NXTINSTR←MEMORY[PC←PC+1];	# EXPLICIT USER CALL;
ARRTRAN(TEMP!ACS,SAVED!ACS);	# RESTORE ACS;
START!CODE LABEL LUP1,SIM1,SIMI2,SIM2,SIMDON;
DEFINE T1=['13],T2=['14],T3=['15];
	SOS	BKLEV;
	MOVS	T1,FLAGS;
	TLZ	T1,'37;
	HRRI	T1,TRAP[1];
	MOVEM	T1,TRAP[0];	# JRSTF @[FLAGS,,TRAP[1]] RESUMES;
	HRRZ	T2,PC;
	TLO	T2,'254000;	# JRST;
	MOVSI	T3,-6;
LUP1:	MOVEM	T2,TRAP[1](T3);	# JRST PC+i IN TRAP[i+1];
	ADDI	T2,1;
	AOBJN	T3,LUP1;
	HRRI	T1,-5(T2);	# FLAGS,,PC+1;
	MOVEM	T1,TRAP[7];	# RETURN WORD TO BE PUSHED;
	MOVE	T2,NXTINSTR;
	MOVEM	T2,TRAP[1];	# DONE FOR USUSAL CASE, NOW CHECK SUBROUTINE CALLS;
	MOVE	T3,T2;		# COPY OF NEXT INSTR;

	LDB	T1,[('331100 LSH 18)+T2];	# 9 BIT OPCODE;
	CAIE	T1,'260;	# PUSHJ;
	 JRST	SIM1;
	TLZ	T3,'000037;	# CLEAR INDEX AND INDIR;
	TLO	T3,'261000;	# TURN INTO PUSH;
	HRRI	T3,TRAP[7];
	MOVEM	T3,TRAP[1];	# FIRST HALF: PUSH RETURN WORD;
	TLZ	T2,'777740;	# LEAVE INDEX AND INDIR;
	TLO	T2,'254000;	# TURN INTO JRST;
	MOVEM	T2,TRAP[2];	# SECOND HALF: JUMP TO DESTINATION;
SIM1:	CAIE	T1,'264;	# JSR;
	 JRST	SIM2;
	TLZ	T2,'777740;	# LEAVE ONLY INDIRECT AND INDEX;
	TLO	T2,'202040;	# MOVEM 1,;
	MOVEM	T2,TRAP[1];	# SAVE AC1 IN JSR DESTINATION;
	MOVE	T3,SIMI2;
	MOVEM	T3,TRAP[2];	# GET ACTUAL RETURN WORD IN AC1;
	TLC	T2,'052000;	# TURN MOVEM INTO EXCH;
	MOVEM	T2,TRAP[3];	# PLANT RETURN WORD, RETRIEVE AC1;
	TLO	T2,'254000;	# TURN EXCH INTO JRST;
	HRRI	T2,1(T2);	# AND INCREMENT ADDR;
	MOVEM	T2,TRAP[4];
SIMI2:	MOVE	1,TRAP[7];	# A LITERAL;
SIM2:	CAIE	T1,'265;	# JSP;
	 JRST	SIMDON;
	TLZ	T3,'777037;	# LEAVE ONLY AC;
	TLO	T3,'200000;	# MOVE;
	HRRI	T3,TRAP[7];
	MOVEM	T3,TRAP[1];	# PLACE RETURN WORD IN AC;
	TLZ	T2,'777740;	# LEAVE INDEX AND INDIR;
	TLO	T2,'254000;	# JRST;
	MOVEM	T2,TRAP[2];
SIMDON:	END;
END "CLNRET";
CLEANUP CLNRET;


INTERNAL PROCEDURE !!UP(INTEGER LEVEL); BEGIN "!!UP"
# PEEL BACK TO LEVEL (CF SETLEX);
OWN INTEGER BACKF,PC;
IF LEVEL LEQ 0 OR LEVEL>DDEPTH THEN EV1ERR("Range 0 to "&CVS(DDEPTH));
PC←DCHAIN[LEVEL,1]+1;
WHILE (BACKF←DCHAIN[LEVEL,0])<0 DO LEVEL←LEVEL+1;	# AVOID GOING TO SIMPLE LEVEL;
START!CODE DEFINE LPSA=['13];
LABEL LUP,DUN; EXTERNAL INTEGER STKUWD;
LUP:	MOVE	LPSA,BACKF;
	CAIN	LPSA,(F);
	 JRST	DUN;
	HRRZ	LPSA,(F);
	HLRO	LPSA,1(LPSA);
	PUSHJ	P,STKUWD;
	JRST	LUP;
DUN:	PUSH	P,PC;
	JRST	BAIL;
	END;
END "!!UP";


SIMPLE INTEGER PROCEDURE P!BRECOV(INTEGER LOC; STRING MSG,RSP); BEGIN
LABEL PRUNE;
!ERRJ!←LOCATION(PRUNE); RETURN("C"+(2 LSH 18)); # CONTINUE, INHIBIT Called from;
PRUNE: !ERRP! SWAP !RECOVERY!;
START!CODE LABEL LUP; DEFINE T2=['14],T1=['13],T3=['15];
	MOVEI	T2,Q!BRECOV;		# ENTRY ADDR;
	PUSH	P,T2;
	PUSHJ	P,PDFIND;		# AC1←PDA;
	HRRZ	T3,PD!PPD(1);		# PARENT'S PDA;
	MOVEI	T2,(F);
LUP:	HRRZ	T2,(T2);		# UP DYNAMIC LINK;
	HLRZ	T1,1(T2);		# PDA FROM STACK;
	CAIE	T1,(T3);
	 JRST	LUP;
	PUSH	P,F;			# NEW DYNAMIC LINK;
	HRLI	T2,(1);
	PUSH	P,T2;			# PDA,,STATIC LINK;
	PUSH	P,SP;
	HLRZ	T2,PD!PPD(1);
	JRST	(T2);			# PCNT AT MKSEMT;
	END;
END;

BKLEV←BKLEV+1;		# RECURSION LEVEL IN BREAKPOINT;

ARRTRAN(SAVED!ACS,TEMP!ACS);	# RECURSIVE SAVE;
# There are three modes of calling: explicit user call via PUSHJ P,BAIL,
  call from a BAIL-planted breakpoint via PUSHJ P,BAIL with a displaced
  instruction, and "JRST MODE" in which a fake return word is put on the
  stack and then JRST BAIL.  In the case of JRST, the '20 bit is on
  (otherwise illegal as a flag bit);
IF (FLAGS←LEFT(TRAP[0])) LAND '20
THEN BEGIN PC←RIGHT(TRAP[0]); CURBRK←N!BK END
ELSE BEGIN
    PC←RIGHT(TRAP[0])-1;
    NOHAND([
    CURBRK←-1; WHILE (CURBRK←CURBRK+1)<N!BK AND RIGHT(BK!LOC[CURBRK])
	NEQ PC DO;
    ]) # NOHAND;
    HAND([
    START!CODE LABEL LOOP;
    DEFINE KEY=[0],I=['14];
	MOVSI	I,-N!BK;
    LOOP:HRRZ	KEY,BK!LOC[0](I);
	CAME	KEY,PC;
	AOBJN	I,LOOP;
	HRRZM	I,CURBRK;
    END;]) # HAND;
END;
CLRTBK(PC);	# CLEAR TEMPORARY BREAKPOINTS;
UNPLANT!BREAKS;
NXTINSTR←MEMORY[PC];

DISPLVL←0;
!RECOVERY!←LOCATION(P!BRECOV);	# GOTO BRECOV IF BAIL ERRORS OCCUR;
GETLSCOPE(LCHAIN,LDEPTH,PC);
IF (CURBRK=N!BK) THEN 	# EXPLICIT USER CALL;
    GETDSCOPE(SAVED!ACS[F],SAVED!ACS[P],PC,DDEPTH,DCHAIN)
ELSE BEGIN	# BAIL-PLANTED BREAKPOINT;
    IF LEFT(NXTINSTR)='551517 THEN
	# '551517 IS THE LEFT HALF OF  HRRZI F,(P).  IF THE BROKEN INSTR
	  IS THIS, ASSUME THAT WE HAVE BROKEN A NON-SIMPLE PROCEDURE AND THAT
	  THE INSTR IS THE ONE THAT SETS THE F REGISTER.  IN ORDER TO MAKE
	  PARAMETER ACCESSING CONSISTENT WITH BREAKS INSIDE THE PROCEDURE,
	  SET UP SAVED!ACS AS IF THE HRRZI HAD BEEN EXECUTED;
	SAVED!ACS[F]←RIGHT(SAVED!ACS[P])+
	    (RIGHT(NXTINSTR) LSH 18 ASH -18);
    GETDSCOPE(SAVED!ACS[F],SAVED!ACS[P],PC,DDEPTH,DCHAIN);
    IF LENGTH(BK!COND[CURBRK]) AND MEMORY[EVAL(BK!COND[CURBRK])]
	AND (BK!COUNT[CURBRK]←BK!COUNT[CURBRK]-1)<0 AND
	LENGTH(BK!ACT[CURBRK]) THEN EVAL(BK!ACT[CURBRK]) END;

# TELL USER HOW HE GOT HERE, BUT KEEP QUIET IF USER STUFFED REQUEST INTO !!QUERY;
IF NOT(LENGTH(!!QUERY)) THEN
OUTSTR(CRLFCAT(
    (IF CURBRK=N!BK OR NOT LENGTH(BK!NAME[CURBRK]) THEN GETTEXT(PC)
    ELSE BK!NAME[CURBRK])	));

BRECOV:
WHILE TRUE DO BEGIN
    TLDEPTH←LDEPTH; ARRTRAN(TLSCOPE,LCHAIN);	# FOR TFIND KLUGE;
    IF NOT(LENGTH(!!QUERY)) THEN OUTSTR(CRLFCAT(CVS(BKLEV)&":"));
    EVAL(LINED) END;

"BREAK RETURN"
RET:	# ALL THE WORK IS DONE IN THE CLEANUP;

RETURN
END "BAILOR";

# BAIL,UBINIT,DDBAIL,B!;
SIMPLE INTERNAL PROCEDURE BAIL; START!CODE "BAIL"
DEFINE TEMP=['14],USER=['15],F=['12];
	POP	P,TRAP[0];
	MOVEM	'17,TEMP!ACS['17];
	MOVEI	'17,TEMP!ACS[0];
	BLT	'17,TEMP!ACS['16];
	MOVE	'17,TEMP!ACS['17];
	MOVE	USER,GOGTAB;	# DAMN RUNTIMES AREN'T REENTRANT, MUST SAVE THEIR;
	HRRI	TEMP,TEMP!ACS['20];	# SAVED ACS;
	HRLI	TEMP,RACS(USER);
	BLT	TEMP,TEMP!ACS['20+F];
	MOVE	TEMP,UUO1(USER);	# AND THIS FUNNY RETURN LOCATION;
	MOVEM	TEMP,TEMP!ACS['20+F+1];
	SKIPL	BAILOC(USER);	# SIGN BIT SET IFF INITIALIZED;
	 PUSHJ	P,STBAIL;
	SKIPE	BALNK;		# IN CASE BAIL LOADED BUT NO /B COMPILATIONS;
	 PUSHJ	P,BAILOR;
	MOVE	USER,GOGTAB;
	MOVE	TEMP,TEMP!ACS['20+F+1];
	MOVEM	TEMP,UUO1(USER);
	HRRI	TEMP,RACS(USER);
	HRLI	TEMP,TEMP!ACS['20];
	BLT	TEMP,RACS+F(USER);
	HRLZI	'17,TEMP!ACS[0];
	BLT	'17,'17;
	JRSTF	@TRAP[0];
END "BAIL";


	
SIMPLE INTERNAL PROCEDURE DDBAIL; START!CODE
# Break the next location to be executed, except try to diagnose procedure
  returns which rely on positive stack displacements.  Use a "JRST MODE" break
  to avoid problems in case the location is in an upper segment.

  For TENEX, this procedure is entered only via ctrl-B pseudo interrupt, since
  TENEX always manages to find DDT somehow.  For non-TENEX, you get here
  when BAIL is your DDT and you say "DDT" to the monitor or "D" to the SAIL
  error handler.  The assumption is that !JBOPC contains the PC.  Thus you
  should not say "D" to the SAIL error handler, because the PC will be lost.;

LABEL BOT,LOOP,BOT1,BOT2,SIMSTK,STKCHK;
NOTENX([
	MOVEM	1,TEMP!ACS[1];
	MOVEM	2,TEMP!ACS[2];
	MOVE	2,!JBOPC;
]) # NOTENX;
TENX([		EXTERNAL INTEGER PS3ACS;	# ACS AT INTERRUPT;
	MOVEI	1,'400000;	# CURRENT FORK;
	RIR;			# READ INTERRUPT REGISTER?;
	MOVSS	2;		# CHNTAB,,LEVTAB;
	MOVE	2,@2(2);	# PC FOR LEVEL 2;
	MOVEI	1,PS3ACS;	# GET REAL P AND SP FOR A WHILE;
	EXCH	P,P(1);
	EXCH	SP,SP(1);
]) # TENX;
		# IF LAST INSTR EXECUTED KILLED THE STACK,
		  THEN MUST ALLOW THE STACK KILL TO FINISH, SINCE
		  4 INSTR COULD BE INVOLVED (MOVE F,(F)	  SUB SP,[m,,m]
		  SUB P,[n,,n]	JRST @k(P)	) AND WE DONT WANT
		  TO BE IN THE MIDDLE;
STKCHK:	HLRZ	1,-1(2);	# OPCODE HALF OF LAST INSTR;
	CAIE	1,'274740;	# SUB P,;
	CAIN	1,'274700;	# SUB SP,;
	 JRST	SIMSTK;		# BLETCH, STACK HAS BEEN WIPED;
	CAIE	1,'200512;	# MOVE F,(F);
	 JRST	BOT;		# WAS OK, NO WORRY;
SIMSTK:	HLRZ	1,(2);		# GET OPCODE HALF OF NEXT INSTR;
	CAIE	1,'274740;	# SUB P,;
	CAIN	1,'274700;	# SUB SP,;
	 SKIPA;			# MUST SIMULATE THIS ONE;
	JRST	BOT1;		# DONE INTERPRETING;
	XCT	(2);		# DO THE SUBTRACT;
	AOJA	2,SIMSTK;	# KEEP ON SIMULATING UNTIL NO MORE BAD ONES;
BOT1:	CAIE	1,'263740;	# POPJ P,;
	 JRST	BOT2;
	HRR	2,(P);		# MUST SIMULATE THIS ONE, TOO;
	SUB	P,['1000001];
BOT2:	CAIN	1,'254037;	# JRST @(P);
	 HRRI	2,@(2);		# AND THIS ONE;
	MOVEM	2,!JBOPC;	# LEAVE GOOD TRACKS;
BOT:	TLO	2,'20;		# JRST MODE;
	PUSH	P,2;		# CREATED RETURN WORD;
NOTENX([MOVE	1,TEMP!ACS[1];
	MOVE	2,TEMP!ACS[2];
	JRST	BAIL;
]) # NOTENX;
TENX([	MOVEI	1,'400000;	# ALL THIS BALONEY AGAIN;
	RIR;
	MOVS	1,2;
	MOVE	2,!JBOPC;
	HRRI	2,BAIL;		# THIS IS HOW WE GET INTO BAIL;
	MOVEM	2,@2(1);
	MOVEI	1,PS3ACS;
	EXCH	P,P(1);		# RESTORE ACS;
	EXCH	SP,SP(1);
]) # TENX;
	END;

SIMPLE PROCEDURE UBINIT; BEGIN # TRY TO LIVE WITH RESETS AND SAVED CORE IMAGES;
# USERCON(BAILOC,#SKIP#←LOCATION(BAIL),TRUE);	# INFORM ERROR HANDLER WE ARE HERE;
GOGTAB[BAILOC]←LOCATION(BAIL); C!NAME←C!BLKADR←C!CRDIDX←0;
NOTENX([			# SET !JBDDT IF NOT ALREADY SET;
	DEFINE SETDDT=['047000000002];
    START!CODE
	MOVEI	1,DDBAIL;
	SKIPN	!JBDDT;
	 SETZM	!JBSYM;		# WE REALLY DONT HAVE SYMBOLS;
	SKIPN	!JBDDT;
	 SETDDT	1,0;
	END;
]) # NOTENX;
TENX([
	PSIMAP(34,DDBAIL,0,3);	# USE CHANNEL 34, GOTO DDBAIL, , LEVEL 3;
	ENABLE(34); ATI(34,"B"-'100);	# <ctrl>B !!!!!!!!;
]) # TENX;
END;
REQUIRE UBINIT INITIALIZATION [0];

INTERNAL SIMPLE PROCEDURE B!;
BEGIN
COMMENT
	The location B! (B. in DDT or RAID) is meant to be
a universal entry to BAIL from DDT.  By typing B.$G, we get
to BAIL.  Upon exit from BAIL, we return to DDT.
	The main problem is that if the core image is
not initialized by the SAILOR call, then we must initialize it.
;
INTEGER SAVE13,OJOBSA;
EXTERNAL INTEGER JOBSA,SAILOR;
LABEL DOINIT,GO,B!DDT;
DEFINE !  = [COMMENT];
DEFINE P=['17],SP=['16],RF=['12];
    START!CODE
	MOVEM '13,SAVE13;
	MOVE '13,JOBSA;
	MOVEM '13,OJOBSA;	! SAVE IT;
	MOVS '13,('13);		! GET THE CONTENTS OF THE STARTING
				ADDRESS;
	CAIN '13,'334000;	! IS IT THE ORIGINAL STARTING ADDRESS?;
	  JRST DOINIT;		! GO THRU SAIL INITIALIZATION;
GO:	MOVE '13,SAVE13;
	ADD P,['12000012];	! ADD A FEW LOCATIONS TO THE P STACK;
	PUSHJ P,BAIL;		! CALL BAIL;
	SUB P,['12000012];	
B!DDT:	MOVE	'13,!JBDDT;
	SKIPE	'13;
	JRST	('13);		! GO BACK TO DDT;
	HALT;

DOINIT:	JSR SAILOR;		! INITIALIZE;
	HRLOI 	RF,1;		! SET UP RF;
	PUSH	P,RF;
	PUSH	P,['400102000000];
	PUSH	P,SP;
	HRRI	RF,-2(P);
	HRRZ 	'13,OJOBSA;	! GET THE OLD STARTING ADDRESS;
	ADDI 	'13,3;		! ADD 3;
	HRLI 	'13,'310000;	! PUT A "CAM" ON THE LEFT ;
	MOVEM 	'13,SAILOR;	! CONVINCE IT THAT THIS IS 
				THE USER'S STARTING ADDRESS;
	MOVE 	'13,SAVE13;	! GET BACK 13;
	PUSHJ	P,BAIL;					! CALL SDDT;
	SUB	P,['3000003];	! ADJUST P STACK, FOR PUSHING DONE ABOVE;
	JRST	B!DDT;		! RETURN TO DDT (PRESUMABLY);
END;  ! OF START!CODE;
END;

NOTENX([
PROCEDURE DDT; START!CODE LABEL DUMB,DONE;
EXTERNAL INTEGER OUTSTR;
	HRRZ	1,!JBDDT;	# PICK UP ADDRESS;
	CAIN	1,DDBAIL;
	 JRST	DUMB;
	PUSH	SP,[29];
	PUSH	SP,["
DDT  (POPJ 17,$X to return)"];
	PUSHJ	P,OUTSTR;
	PUSHJ	P,(1);
	JRST	DONE;
DUMB:	PUSH	SP,[18];
	PUSH	SP,["
BAIL is your DDT"];
	PUSHJ	P,OUTSTR;
DONE:	END;
]) # NOTENX;

TENX([
PROCEDURE DDT;
COMMENT
	Call from SAIL to go to DDT on a TENEX system.
Tries several ways.;
BEGIN
EXTERNAL INTEGER JOBDDT,JOBSYM;
DEFINE	DDTORG=['770000],
	DDTPAGE=['770];

SIMPLE PROCEDURE GO1(INTEGER ADDR);
BEGIN
OUTSTR("
DDT  POPJ 17,$x to return
");
START!CODE PUSHJ P,@ADDR; END;
END;


SIMPLE BOOLEAN PROCEDURE PAGE!EXISTS(INTEGER PAGE);
START!CODE
	MOVE	1,PAGE;
	HRLI	1,'400000;
	RPACS;
	TLNE	2,'010000;
	  SKIPA	1,[-1];
	SETZ	1,;
END;
	  

IF JOBDDT AND RIGHT(JOBDDT) NEQ LOCATION(DDBAIL)
THEN GO1(JOBDDT LAND '777777)
ELSE
   BEGIN
	IF PAGE!EXISTS(DDTPAGE) AND MEMORY[DDTORG]='254000000000+DDTORG+2 THEN
	GO1(DDTORG+2) ELSE
	    BEGIN
		INTEGER JFN;
		JFN ← GTJFN("<SAIL>UDDT.SAV",'100000000000);
		IF JFN=-1 THEN JFN ← GTJFN("<SUBSYS>UDDT.SAV",'100000000000);
		IF JFN=-1 THEN NONFATAL("CANNOT GO TO DDT") ELSE
		    BEGIN
			START!CODE
				PUSH	P,JFN;
				PUSHJ	P,CVJFN;
				HRLI	1,'400000;
				GET;
			END;
			COMMENT MOVE UP SYMBOL TABLE POINTER;
			MEMORY[MEMORY[DDTORG+1]]←JOBSYM;
			GO1(DDTORG+2);
		   END;
	    END;
    END;
END;


END;
]) # TENX;



END "BILGE"