perm filename BAIL.SAI[X,AIL]9 blob sn#231280 filedate 1976-08-13 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
C00018 00004	ENTRY BAIL,B!
C00035 00005	# MEMSTRING CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTND NONULL PDFIND ADDSTR ADDCHR DUMPSTR MAKPPN
C00044 00006	# WRITEON PACKAGE
C00051 00007	# OPERATOR CODES, REFITEM TYPE DEFINITIONS
C00067 00008	# TYPEMUNGE
C00073 00009	# INSERT
C00075 00010	# FIND
C00084 00011	# CVNAME PREDEC
C00086 00012	# STBAIL
C00096 00013	
C00106 00014	# SUPER OUTER BLOCK, FOR PREDECLARED STUFF
C00118 00015	# LINED DBANG !!EQU EVALERR
C00125 00016	# GET!TOKEN
C00128 00017	# INTARRAY, CRD!PC, FTEXT, SHOW, CRDFND, GETTEXT
C00137 00018	# N!PARAMS DEFINE HELP
C00139 00019	# CVINTEGR, CVREAL, CVSTRNG
C00142 00020	# INCOR
C00153 00021	# GETLSCOPE, PRLSCOPE
C00157 00022	# GETDSCOPE,PRDSCOPE
C00163 00023	# TFIND,BREAK1,SWAP!BREAKS,PLANT!BREAKS,UNPLANT!BREAKS,LOC!PC,BREAK,COORD,TRAPS
C00175 00024	# PRARGS, TRACER, TRACE
C00183 00025	# UNBREAK1,UNBREAK,UNTRACE,CLRTBK,STEPPING
C00193 00026	# BAILOR,!!TEXT,!!ARGS,EVAL,PSH,OPPSH,SETLEX,X1TEMP,X1TEMP,NEWTEMP,NEWSTRTEMP
C00198 00027	# EVAL1
C00204 00028	# INTERPRETATION OF OPERATORS
C00211 00029
C00219 00030	$COMMA:	BEGIN
C00225 00031	$ARRYREF:BEGIN
C00232 00032	# $MEMRY,$DATUM,$SWAP,$GETS,$SUBFLD,$AR,$APPLY,$CPRINT,$PRINT,$NEWREC
C00241 00033	# PARSER
C00249 00034	# SETSCOPE !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV
C00261 00035	# BAIL,UBINIT,DDBAIL,B!
C00273 ENDMK
C⊗;
COMMENT








		BAIL -- A DEBUGGER FOR SAIL

			by

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







		March 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>

	At runtime, the format of the first word is changed to
	BYTE	(12)<file #> (24)<char # in file>.

    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+1>, (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>/
		SIXBIT	/<extension>/
		SIXBIT	/<PPN>/
		SIXBIT	/<device>/	>.,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 using the files generated by RTRAN as a
	side effect of creating the builtin symbol table for the compiler.

	After running RTRAN:
	.R FAIL
	*BAICLC←BPDAHD,BAICLC   .,the   files   containing   procedure
	*BAIIO1←BPDAHD,BAIIO1	.,  descriptors
	*BAIIO2←BPDAHD,BAIIO2
	*BAIMSC←BPDAHD,BAIMSD
	*BAIPRC←BPDAHD,BAIPRC
	
	*BAISM1←BSM1HD,BAISM1	.,the program  to  construct  the  .SM1
				.,  files

	*BAIPDn←BAIPDn		.,does a .LOAD on all the procedure
				., files
	*↑C
	.R LOADER
	*/E BAISM1$

	Now transfer the .REL and .SM1 files to SYS: or <SAIL>.

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;
IFCR EQU(COMPILER!BANNER[LENGTH(SCANC(COMPILER!BANNER,"-",NULL,"IA"))+1 FOR 8]
	 ,"TYMSHARE") THENC
    DEFINE TYMSW(A)=[A],NOTYMSW(A)=[]; ELSEC
    DEFINE TYMSW(A)=[],NOTYMSW(A)=[A]; ENDC
NOTENX([  DEFINE DEC(A)=[A], STANFO(A)=[];	])

STANFO([DEFINE CH!SETC=['176],CH!ALT=['175];	COMMENT RIGHT BRACE, ALTMODE;
	DEFINE CORE!IMAGE!EXTENSION=["DMP"];
	DEFINE MAX#TXTFIL=[31];
	REQUIRE "
STANFORD VERSION" MESSAGE;
])
DEC([	DEFINE CH!SETC=['175],CH!ALT=['33];
	DEFINE CORE!IMAGE!EXTENSION=["SAV"];
	DEFINE MAX#TXTFIL=[31];
NOTYMSW([REQUIRE "
DEC TOPS-10 VERSION" MESSAGE;])
TYMSW([	REQUIRE "
TYMSHARE VERSION" MESSAGE;])
])
TENX([	DEFINE CH!SETC=['175],CH!ALT=['33];
	DEFINE CORE!IMAGE!EXTENSION=["SAV"];
	DEFINE MAX#TXTFIL=[99];
	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 SAFE 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)";
FORWARD SIMPLE STRING PROCEDURE CATCRLF(STRING A);

EXTERNAL INTEGER INIACS;
STRING RUNDEV,RUNPPN;	# set from INIACS if RUN or GET;

SIMPLE INTEGER PROCEDURE OPENFILE(REFERENCE STRING FILNAM; STRING MODES);
BEGIN "OPENFILE"
# like TENEX-SAIL, extended if errors;
EXTERNAL INTEGER !SKIP!;
INTEGER CHN,FLAG,R,W,E,TRIAL; LABEL BAD,TRY,TRY2; STRING DEV,FIL;
	PRESET!WITH
	"no such file ", "illegal PPN ", "protection ",	"busy ", "???";
	OWN SAFE STRING ARRAY REASON[0:4];
IF (CHN←GETCHAN)<0 THEN GOTO BAD;
QUICK!CODE SETZM TRIAL; END;
TRY: DEV←"DSK";
TRY2:
START!CODE LABEL LOOP1,LOOP2,TEST1,TEST2,USEDFLT;
	SETZB	1,2;		# R,W;
	SETZM	E;
	HRRZ	3,-1(SP);	# LENGTH(MODES);
	MOVE	5,(SP);		# BP;
	JRST	TEST1;
    LOOP1:ILDB	4,5;
	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;

	MOVEI	4,FIL;		# FIL←FILNAM;
	MOVE	5,-1(P);	# ADDR(FILNAM);
	HRRZ	1,-1(5);	# LENGTH(FILNAM);
	MOVEM	1,-1(4);
	MOVE	2,(5);		# BP;
	MOVEM	2,(4);
	JRST	TEST2;
    LOOP2:ILDB	3,2;
	CAIE	3,":";
    TEST2:SOJGE	1,LOOP2;
	JUMPL	1,USEDFLT;	# NO COLON, USE DEFAULT;
	EXCH	1,-1(4);	# 1←ORIG LEN, -1(4)←LEN OF NAME;
	EXCH	2,(4);		# 2←DEV BP, (4)←NAME BP;
	MOVEI	3,DEV;
	MOVEM	2,(3);		# DEVICE BP TO CORE;
	SUB	1,-1(4);	# 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;
RELEASE(CHN); OPEN(CHN,DEV,'10,R,W,FLAG,FLAG,FLAG); IF FLAG THEN GOTO BAD;
IF W THEN ENTER(CHN,FIL,!SKIP!) ELSE
IF R THEN LOOKUP(CHN,FIL,!SKIP!);
IF !SKIP! AND TRIAL=0 THEN BEGIN
    # try harder; IF LENGTH(RUNDEV) THEN DEV←RUNDEV; CVFIL(FIL,TRIAL,FLAG);
    IF NOT(FLAG) THEN
	# originally, no PPN; FILNAM←FILNAM&RUNPPN; QUICK!CODE SETOM TRIAL; END;
    GOTO TRY2 END;
IF !SKIP! AND NOT(E) THEN BEGIN
	OUTSTR("
File error, "&REASON[RIGHT(!SKIP!) MIN 4]& DEV&":"&FIL& "
Try again, ALT to ignore:");
	CLRBUF; STANFO([PTOSTR(0,DEV&":"&FIL);])
	FILNAM←INCHWL; IF !SKIP! NEQ CH!ALT THEN GOTO TRY END;
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;
# Dot (period) must be last for BK!ID2. Can save space by not mentioning
  lowercase because BK!ID and BK!ID2 convert to upper first ("K" mode);
DEFINE LETTERS=["ABCDEFGHIJKLMNOPQRSTUVWXYZ!" & "αβπλ⊂⊃∀∃→_~#$\|."],
	DIGITS=["0123456789"], SAILID=[(DIGITS & LETTERS)],
	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);
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;
PRELOAD!WITH [8]0;
SAFE INTEGER ARRAY BK!TBL[0:7];		# 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]],
BK!ID2=[BK!TBL[7]];
# tab,delimiters,quote,octal digits,floating decimal,
    decimal digits,identifiers,ids without period;
# 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:MAX#TXTFIL];	# NAMES OF TEXT FILES;
PRELOAD!WITH [MAX#TXTFIL+1] 0;
INTEGER ARRAY STATUS[0:MAX#TXTFIL];	# FOR STATUS OF THESE FILES;
PRELOAD!WITH [N!CACHE] 0;
INTEGER ARRAY CACHE[0:N!CACHE-1];	# 20 MOST RECENT NAMES (5 WORDS PER);
PRELOAD!WITH [256] 0;
INTEGER ARRAY TARRAY[0:255];	# TEMPORARY ARRAY;
PRELOAD!WITH [N!BK] 0;
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;
PRELOAD!WITH ['17+'12+1+1+1] 0;
INTEGER ARRAY TEMP!ACS[0:'17+'12+1+1];	# HOLDING TANK UNTIL RECURSIVE SAIVING;
PRELOAD!WITH [8] 0;
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;
PRELOAD!WITH [16] 0;
INTEGER ARRAY TLSCOPE[0:15];	# KLUGE FOR TFIND;
INTEGER CRDCTR; # "GLOBAL" COUNTER OF COORDINATE NUMBERS;
PRELOAD!WITH ["G"-"A"] NULL," !!GO;",["P"-"H"] NULL," !!GO;",
    ["S"-"Q"] NULL," !!STEP;",["X"-"T"] NULL," !!GSTEP;",["Z"-"Y"+1] NULL;
SAFE STRING ARRAY MACTAB["A":"Z"];	# MACRO TABLE;
INTEGER PRGSM1;			# ptr to "main program" on .SM1 BALNK chain;
# MEMSTRING CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTND NONULL PDFIND ADDSTR ADDCHR DUMPSTR MAKPPN;

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( NOTYMSW([ ((TARRAY[1] LAND '700000) LSH 8) LOR])
		TYMSW([ ((TARRAY[1] LAND '140000) LSH 9) LOR])
		((TARRAY[2] LAND '7777) LSH 11) LOR
		((TARRAY[2] LSH -12) LAND '3777)	)])
END;

SIMPLE INTEGER PROCEDURE LAST!WRITTEN(REFERENCE STRING FILENAME; STRING MODES);
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,MODES)); 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("BAIL: No core")	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 EXTND(REFERENCE INTEGER ADDR, OLEN, INCR); BEGIN "EXTND"
INTEGER TMPJFN;	LABEL OK; STRING T;
    SIMPLE PROCEDURE GETTEMP(STRING MODE); BEGIN
    TMPJFN←OPENFILE(T←"BBBBBB.TMP",MODE); IF !SKIP! THEN BEGIN BAILOFF←TRUE;
    FATAL("BBBBBB.TMP problems") 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 "EXTND";


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;

SIMPLE STRING PROCEDURE MAKPPN(INTEGER PPN);
RETURN(IF PPN=0 THEN NULL ELSE
     STANFO([	"["&CVXSTR(PPN)[1 TO 3]&","&CVXSTR(PPN)[4 TO 6]&"]"	])
	DEC([	"["&CVOS(LEFT(PPN))    &","&CVOS(RIGHT(PPN))   &"]"	])
	TENX([	MEMSTRING(PPN)						])	);
# WRITEON PACKAGE;
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)];

PRELOAD!WITH 0; INTEGER #$FSTR;
PRELOAD!WITH 0; INTEGER #$PROU;

SIMPLE PROCEDURE SWAP!FSTR; GOGTAB[$$FSTR] SWAP #$FSTR;

SIMPLE PROCEDURE SWAP!PROU; GOGTAB[$$PROU] SWAP #$PROU;

SIMPLE PROCEDURE $PLBL(INTEGER CHAN,LOC); BEGIN
SWAP!FSTR; CPRINT(CHAN,"'"&CVOS(RIGHT(LOC))); SWAP!FSTR END;

SIMPLE PROCEDURE $PARY(INTEGER CHAN,LOC); BEGIN "$PARY"
INTEGER I;
SWAP!FSTR; LOC←RIGHT(MEMORY[LOC])-(IF GETTYPE(LOC)=(ARRY+STRNG) THEN 1 ELSE 0);
IF LOC LEQ 0 THEN CPRINT(CHAN,"Deallocated array") ELSE BEGIN
    CPRINT(CHAN,"<array>["); FOR I←1 UPTO ABS(MEMORY[LOC-1] ASH -18) DO
    CPRINT(CHAN," ",MEMORY[LOC-3*I-1],":",MEMORY[LOC-3*I]); CPRINT(CHAN,"]"); END;
SWAP!FSTR END "$PARY";

SUPERCOMMENT([	# use $PREC to get $CLASS.nnnnn for the moment;
SIMPLE PROCEDURE $PRCL(INTEGER CHAN,LOC); BEGIN "$PRCL"
SWAP!FSTR; CPRINT(CHAN,MEMSTRING(MEMORY[LOC+4])); SWAP!FSTR END "$PRCL";])

SIMPLE PROCEDURE MYPRINT(INTEGER CHAN; STRING S); ADDSTR(S);

SIMPLE STRING PROCEDURE FSTR(STRING STR);
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];
	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:POPJ	P,;
END;

SIMPLE PROCEDURE PREFIT(INTEGER CHAN,REFIT); BEGIN "PREFIT"
# CPRINT(CHAN,MEMORY[REFIT,TYPE(REFIT)]);
INTEGER TYPE;
START!CODE
EXTERNAL INTEGER $PSTR,$PREL,$PINT,$PSET,$PLST,$PITM,$PREC;
LABEL JTAB,NARRY,LAB1,LAB2; DEFINE R=['13],S=['14],T=['15], L40=[0+('40 LSH 18)];
	MOVE	R,REFIT;
	LDB	T,[('270600 LSH 18)+R];	# 6 BIT TYPE;
	CAIGE	T,0+ARRY LSH -23;
	 JRST	NARRY;
	MOVEI	T,'11;		# RECODE ARRAYS TO '11;
	TLZ	R,'20+(ITEMB LSH -18);	# AND IGNORE ITEMness AND INDIRECT;
	JRST	LAB1;
NARRY:
	CAIL	T,8;		# 8,9,10,11,12 ARE DATUMS OF STRANGE ITEMS;
	CAILE	T,12;
	 JRST	LAB2;
	MOVEI	T,'16;		# FAKE TYPE LABEL, PRINT IN OCTAL;
	JRST	LAB1;
LAB2:	TLNE	R,0+ITEMB LSH -18;
	 MOVEI	T,'10;		# RECODE ITEMS TO '10;
LAB1:
	CAIGE	T,3;
	 MOVEI	T,'16;		# 0,1,2 STRANGE. USE OCTAL;
	CAILE	T,'11;
	 SUBI	T,3;		# CONDENSE RANGE TO 3:'11,('15-3):('17-3);
	MOVEM	T,TYPE;
	PUSH	P,CHAN;		# WHICH CHANNEL TO USE;
	HLLZ	S,JTAB(T);	# NOW WORRY ABOUT ARGUMENT;
	LSH	S,-1;		# WHETHER DO GO DIRECT OR INDIRECT;
	HRRI	S,R;
	PUSH	P,@S;		# STACK THING TO PRINT;
	CAIN	T,'14;
	 HRRZS	(P);		# TURN RCLASS DSCR INTO PLAIN RPTR;
	CAIN	T,0+STRNG LSH -23;
	 PUSHJ	P,MEMSTRING;	# GET STRING ON CORRECT STACK;
	PUSHJ	P,@JTAB(T);	# FORMAT AND DISPOSE;
	MOVE	T,TYPE;		# CPRINT BUILTINS DON'T REMOVE CHANNEL FROM STACK;
	CAIE	T,'11;		# BUT $PARY;
	CAIN	T,'13;		# AND $PLBL;
	SKIPA;			# AREN'T BUILTIN, HAVE ALREADY REMOVED CHANNEL;
JTAB:	 POP	P,(P);		# SO MUST DO IT HERE;
	SUB	P,['3000003];
	JRST	@3(P);
	0	$PSTR;	# 3;
	L40	$PREL;	# 4;
	L40	$PINT;	# 5;
	L40	$PSET;	# 6;
	L40	$PLST;	# 7;
	L40	$PITM;	# '10;
	0	$PARY;	# '11;
	L40	$PREC;	# '15;
	0	$PLBL;	# '16;
	0	$PREC;	# '17;
	END;
END "PREFIT";

SIMPLE PROCEDURE WR!TON(INTEGER DSCR); BEGIN "WR!TON"
INTEGER FSTR$#;
    SIMPLE PROCEDURE SWFSTR; GOGTAB[$$FSTR] SWAP FSTR$#;
FSTR$#←RIGHT(LOCATION(FSTR)); #$PROU←LOCATION(MYPRINT);
SWFSTR; SWAP!PROU; ADDSTR("   "); PREFIT(0,DSCR); SWAP!PROU; SWFSTR END "WR!TON";
# 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(NEW!R),A(ECORD),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:128];
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,		'151,		'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:43];
DEFINE N!RWORD=[43];

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;	048 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;	272 Q1	270 Q2	001 Q3	000 Q4,	# NEW!RECORD;
# '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;	000 Q1	001 Q2	000 Q3	000 Q4;	# END-OF-FILE;
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 REPLACED BY SOME 
  FIDDLING ON P. 14;
NOHAND([
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)))],
	REFSETSCOPE=[(PROCB+PDFIND(LOCATION(SETSCOPE)))],
	REF!!DEFINE=[(PROCB+PDFIND(LOACTION(!!DEFINE)))],
	REFDDT=[(PROCB+PDFIND(LOCATION(DDT)))];
]) # NOHAND;
DEFINE F=[('12 LSH 18)], INDIR=[(1 LSH 22)];


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;
	'265000000000,	# JSP;
	'344000000000,	# AOJA;
	'364000000000;	# SOJA;
INTEGER ARRAY STEPINSTR[0:7];
PRESET!WITH
	'777000000000,
	'777000000000,
	'777020000000,
	'777000000000,
	'770000000000,
	'777000000000,
	'777000000000,
	'777000000000;
INTEGER ARRAY STEPMASK[0:7];

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

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 PROCEDURE SETSCOPE(ITEMVAR PROCITM);
EXTERNAL STRING PROCEDURE !!ARGS;
EXTERNAL STRING PROCEDURE !!TEXT;
FORWARD STRING PROCEDURE SHOW(INTEGER FIRST,LAST(0)); 
FORWARD PROCEDURE !!DEFINE(INTEGER CHAR; STRING MAC);
# 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,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;
# 7-11-76 EXTERNAL STRINGS ALSO REFER TO FIRST WORD;
IF SIMPL=3 # BSTRNG; AND (ACCES=0 # BBILTN; OR ACCES=4 # BEXTRN;)
     AND COMPLX=0 # BSIMPL; AND RBITS NEQ 0 THEN RBITS←RBITS+1;
RETURN(LBITS LOR RBITS) 
]) # NOHAND;
HAND([
	CAIE	ACCES,5;
	 JRST	BOT1;
	PUSH	P,1;		# SAVE A COPY OF LEFT HALF BITS;
	PUSH	P,1;		# ENTRY ADDR;
	PUSHJ	P,PDFIND;
	HLL	1,(P);		# INSERT SAVED LEFT HALF BITS;
	POP	P,(P);		# ADJUST STACK;
	JRST	UNALLOC;
BOT1:	JUMPN	COMPLX,UNALLOC;
	CAIE	ACCES,4;	# BEXTRN;
	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 EXTND(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,EXTND;
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,W;
INTEGER ARRAY FILMAP[0:MAX#TXTFIL];	# TRANSLATES FROM LOCAL FILE NUMBER TO GLOBAL;
STRING T,PROGNAM,BAINAM,SM1NAM;
LABEL DONESTBAIL;


SIMPLE INTEGER PROCEDURE HORSECART(INTEGER HTIM; STRING HORSE;
    REFERENCE STRING CART); BEGIN INTEGER T; T←0;
IF LENGTH(CART) AND ((T←LAST!WRITTEN(CART,"R"))>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 EXTND(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 EXTND(C!CRDIDX,N!CRDIDX,64);
T!CRDIDX(L!CRDIDX)←I END "AD!CRDIDX";


SIMPLE INTEGER PROCEDURE INW; BEGIN
NOHAND([RETURN(W←WORDIN(SM1JFN))])
HAND([	START!CODE EXTERNAL INTEGER WORDIN;
	PUSH	P,SM1JFN;
	PUSHJ	P,WORDIN;
	MOVEM	1,W;
	POPJ	P,;
	END;	])
END;


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


SIMPLE STRING PROCEDURE FILSPC(BOOLEAN R); BEGIN "FILSPC"
# IF R THEN [READ L WORDS INTO TARRAY] ELSE [FILL TARRAY FROM SM1PNT BLOCK].
  GIVEN TARRAY[0:3]=SIXBIT DEV,NAM,EXT,PPN, RETURN STRING OF SAME.
  ON TENEX, USE L WORDS OF ASCII;
STRING A;
IF R THEN SYMIN
ELSE BEGIN
    L←RIGHT(SM1LNK(2));
    NOTENX([
	TARRAY[4]←IF LEFT(SM1LNK(2)) THEN CVSIX("SYS") ELSE CVSIX("DSK");
	TARRAY[2]←CVSIX("SM1"); TARRAY[3]←0;
	ARRBLT(TARRAY[1],SM1LNK(3),L); TARRAY[0]←TARRAY[4];
    ]) # NOTENX;
    TENX([
	ARRBLT(TARRAY[0],SM1LNK(3),L);
    ]) # TENX;
END;
NOTENX([ RETURN(CV6STR(TARRAY[0]) & ":" &CVXSTR(TARRAY[1]) & "." &
    (CVXSTR(TARRAY[2])[1 TO 3]) & MAKPPN(TARRAY[3]));	]) # NOTENX;
TENX([ A←NULL; FOR I←0 UPTO L-1 DO A←A&CVASTR(TARRAY[I]);
	RETURN(NONULL(A)) ]) # TENX;
END "FILSPC";


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

	SIMPLE PROCEDURE IND; D←TYPEMUNGE(INW,LZERO,HZERO);

INW; L←W LAND '77; LEVEL←W LSH -6 LAND '77;
CRDNO←LEFT(W);
NOHAND([
INW; IF RIGHT(W)=0 THEN W←W+LEFT(W); # Bullet-proofing for RIGHT(W)=0;
]) HAND([START!CODE		# THE ABOVE IS JUST TOO INEFFICIENT;
	PUSHJ	P,INW;
	TRNN	1,-1;
	 HLR	1,1;
	MOVEM	1,W;	END;
]) # HAND;
D←ADDR1←HRELOC(RIGHT(W));
ADDR2←HRELOC(LEFT(W)) MAX ADDR1;	# Bullet-proofing for LEFT(W)=0;

IF INPRC THEN IND;

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 INW NEQ 0 DO BEGIN "IDENTIFIERS"
	L←W LAND '77; IND; 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;

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) LAND '377777;
SM1NAM←FILSPC(FALSE);	# USE BALNK BLOCK AND FETCH FILE NAME;
SM1JFN←OPENFILE(SM1NAM,"R"); SM1TIM←FILTIM(SM1JFN);
IF NOT(!SKIP!) THEN BEGIN "SM1FILE"
    OUTSTR(CRLFCAT(SM1NAM));
    WHILE INW NEQ -1 DO CASE W OF BEGIN "CASES"
    [1]	BEGIN "FILE INFO"
	STRING TEXTFILE; INTEGER FILN;	LABEL OLDCHAP;
	INW; L←RIGHT(W); FILN←LEFT(W);
	TEXTFILE←FILSPC(TRUE);	# READ WORDS AND GET FILE NAME;
	FOR I←0 UPTO L!TXTFIL DO IF EQU(TEXTFILE,T!TXTFIL[I]) THEN BEGIN
	    FILMAP[FILN]←I; GOTO OLDCHAP; END;
	IF L!TXTFIL=MAX#TXTFIL-1 THEN 
	    NONFATAL("More than "&CVS(MAX#TXTFIL-1)&" text files.
Rest ignored.");
	FILMAP[FILN]←L!TXTFIL←(L!TXTFIL+1) MIN MAX#TXTFIL;
	STATUS[L!TXTFIL]←IF HORSECART(SM1TIM,SM1NAM,TEXTFILE)=0 THEN -'1000 ELSE -1;
	T!TXTFIL[L!TXTFIL]←TEXTFILE;
OLDCHAP:OUTSTR(CRLFCAT("  " & TEXTFILE));
	END "FILE INFO";

    [2]	BEGIN "COORDINATES"
	WHILE INW NEQ 0 DO BEGIN
	# CONVERT TO CHARACTER COUNT AND MAPPED FILE NUMBER;
	WORDOUT(BAIJFN,(RIGHT(W)-1)*640 + (LEFT(W) LAND '177)*5 +
	    (((W LSH -30)LAND 7)XOR 4)-1 LOR
	    (FILMAP[W LSH -25 LAND '37] LSH 24));
	WORDOUT(BAIJFN,W←HRELOC(INW LAND '400000777777)+
	    (CRDCTR LSH 18)); # USE GLOBAL COORD NUMBERS;
	CRDCTR←CRDCTR+1;
	AD!CRDIDX(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. 5-Aug-76");

IF BALNK=0 THEN BEGIN
    NONFATAL("No /B switch used"); RETURN END;

IF NOT PRGSM1 THEN BEGIN "NAMPRG"
# Record the name of the program which was loaded first as the main program
  name.  It could change when the .SM1 link is sorted by address.  In order
  to find the program which was loaded first, we must go to the end of the
  linked list;
NOHAND([
PRGSM1←BALNK; WHILE MEMORY[PRGSM1] NEQ 0 DO PRGSM1←MEMORY[PRGSM1];
]) # NOHAND;
HAND([START!CODE LABEL T,B;
	MOVE	1,BALNK;
T:	SKIPN	(1);
	 JRST	B;
	MOVE	1,(1);
	JRST	T;
B:	MOVEM	1,PRGSM1;
	END;
]) # HAND;
END "NAMPRG";

SM1PNT←PRGSM1;	# need to reconstruct string, since restart zeroes all strings;
NOTENX([PROGNAM←CV6STR(SM1LNK(3));])
TENX([ PROGNAM←FILSPC(FALSE); ])

# The loader linked list needs to be sorted by first word address of code
  so that we process files in ascending order of load address.
  $#$#$#$#$# THIS MEANS THAT THE LINK BLOCKS MUST BE IN THE LOWSEG #$#$#$#$#$;

NOHAND([		# insertion sort of non-null linked list headed at BALNK;
I←0; I SWAP MEMORY[BALNK];	# BALNK gets first element, I gets rest;
WHILE I NEQ 0 DO BEGIN
    J←LOCATION(BALNK); L←MEMORY[J];	# top of what's already sorted;
    WHILE L NEQ 0 AND LEFT(MEMORY[I+1])>LEFT(MEMORY[L+1]) DO
	L←MEMORY[J←L];	# find L=first which has FWA code > FWA I;
    J←MEMORY[J]←I;	# link in I, advance J to it;
    I←MEMORY[I];	# CDR down stuff not yet processed;
    MEMORY[J]←L;	# tack on rest of sorted list;
    END;
]) # NOHAND;
HAND([
START!CODE LABEL TOP1,TOP2,BOT1,BOT2,OUT1,OUT2;
DEFINE T=[0],T1=[1],I=['13],J=['14],L=['15];
	MOVEI	I,0;
	EXCH	I,@BALNK;
	JRST	BOT1;
TOP1:	MOVEI	J,BALNK;
	HRRZ	L,(J);
	JRST	BOT2;
TOP2:	HLRZ	T,1(I);
	HLRZ	T1,1(L);
	CAIG	T,(T1);
	 JRST	OUT2;
	MOVEI	J,(L);
	HRRZ	L,(J);
BOT2:	JUMPN	L,TOP2;
OUT2:	HRRZM	I,(J);
	MOVEI	J,(I);
	HRRZ	I,(I);
	HRRZM	L,(J);
BOT1:	JUMPN	I,TOP1;
OUT1:	END;
]) # HAND;

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

# Establish special break tables.  Kluge for BK!ID2 to save space;
J←BK!PRV(TRUE);
NOHAND([	FOR I←0 UPTO 7 DO BEGIN INTEGER K; K←IF I=7 THEN 6 ELSE I;
    RELBREAK(BK!TBL[I]); IF (BK!TBL[I]←GETBREAK) GEQ 0 THEN FATAL("Brktbl ov.");
    SETBREAK(BK!TBL[I],BK!SBR[K,0],BK!SBR[K,1],BK!SBR[K,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,-8;		# 8 TABLES TO BE SET;
NEWTBL:	PUSH	P,BK!TBL[0](2);
	PUSHJ	P,RELBREAK;
	PUSHJ	P,GETBREAK;
	JUMPL	1,GOOD;
	PUSH	SP,[10];
	PUSH	SP,["Brktbl ov."];
	PUSHJ	P,FATAL;
GOOD:	PUSH	P,1;		# TABLE NUMBER;
	MOVEM	1,BK!TBL[0](2);
	HLRZ	4,2;
	CAIN	4,-1;
	 SUBI	3,6;		# BK!ID2 KLUGE;
	HRLI	3,-6;		# 6 WORDS ONTO SP;
SPLOOP:	PUSH	SP,-1(3);
	AOBJN	3,SPLOOP;
	CAIN	4,-1;
	 SOS	-5(SP);		# BK!ID2 KLUGE;
	PUSHJ	P,SETBREAK;
	AOBJN	2,NEWTBL;
	END;
]) # HAND;
BK!PRV(J);

# Guess at where the core image originated;
NOTENX([
STANFO([DEFINE AC!DEV=[6],  AC!PPN=[3],AC!EXT=[1];  ])
DEC([   DEFINE AC!DEV=['11],AC!PPN=[7],AC!EXT=['17];])
IF LEFT(MEMORY[LOCATION(INIACS)+AC!EXT])=LEFT(CVSIX(CORE!IMAGE!EXTENSION))
THEN BEGIN RUNDEV←CV6STR(MEMORY[LOCATION(INIACS)+AC!DEV]);
    RUNPPN←MAKPPN(MEMORY[LOCATION(INIACS)+AC!PPN]) END;
]) # NOTENX;
TENX([ J←BK!PRV(TRUE); PROGNAM←SCAN(PROGNAM,BK!DEC,BRCHAR); BK!PRV(J); ])

# NOW MAKE LIKE RPG -- SEE IF WE CAN USE AN EXISTING .BAI FILE;
ENROLL←FALSE; SM1PNT←BALNK;
IF (BAITIM←LAST!WRITTEN(BAINAM←PROGNAM & ".BAI","RE"))<
	(DMPTIM←LAST!WRITTEN(PROGNAM←PROGNAM & ("."&CORE!IMAGE!EXTENSION),"RE"))
    OR DMPTIM=0
THEN ENROLL←TRUE;
WHILE SM1PNT AND NOT ENROLL DO BEGIN
    SM1NAM←FILSPC(FALSE);	# USE SM1LNK AND GET FILE NAME;
    SM1PNT←SM1LNK(0);	# FOLLOW DOWN LINK;
    IF LAST!WRITTEN(SM1NAM,"RE") GEQ BAITIM THEN ENROLL←TRUE END;


IF NOT ENROLL THEN BEGIN "NOROLL"
    BAIJFN←OPENFILE(BAINAM,"R"); IF !SKIP! THEN BEGIN
	OUTSTR(" reconstructing .BAI file");
	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←TARRAY[15] ASH -18; 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,"W"); IF !SKIP! THEN BEGIN BAILOFF←TRUE;
	OUTSTR("
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);
PREDEC("SETSCOPE"	,PRC,L,REFSETSCOPE);
PREDEC("DEFINE"		,PRC,L,REF!!DEFINE);
]) # NOHAND;
HAND([
BEGIN
DEFINE Z(B)=[CVASC("] & [B] & [")],NPD=[26];
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,
	Z(SETSC),Z(OPE),0,
	Z(DEFIN),Z(E),0		;
OWN SAFE INTEGER ARRAY PRENAM[0:3*NPD-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,NPD-1;# NPD SYMBOLS TO BE PREDECLARED, 0 THRU NPD;
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;
	PROC	!!UP;
	PROC	SETSCOPE;
	PROC	!!DEFINE;
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,MAX#TXTFIL LSH 24); # ILLEGAL FILE FLAG;
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) LEQ 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,BOT1A;
DEFINE I=['14],L=['15],T1=[1],T2=[2];
	MOVE	I,L!BLKADR;
	SUBI	I,1;
	ADD	I,C!BLKADR;
	SETO	L,;
TOP2:	JUMPL	L,BOT1A;
BOT2:	HLRZ	T1,1(I);		# LWA (I);
	MOVE	T2,TARRAY[0](L);
	HRRZ	T2,1(T2);		# FWA(TARRAY[L]);
	CAIG	T1,(T2);
	 SOJA	L,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];
BOT1A:	MOVEM	I,TARRAY[1](L);
	SUBI	I,2;
	CAML	I,C!BLKADR;
	 AOJA	L,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←!!QUERY; !!QUERY←NULL; RETURN(RESULT) 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 !SKIP!=CH!ALT OR !SKIP! GEQ '200 THEN BEGIN "MACRO EXPAND"
	    CHAR←(IF !SKIP!=CH!ALT THEN INCHRW ELSE !SKIP!) LAND '137;
	    IF "A" LEQ CHAR LEQ "Z" THEN RESULT←RESULT & MACTAB[CHAR];
	    !SKIP!←0 END "MACRO EXPAND";
	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,NOQ,CATR,TSEMI,TMAC;
NOTENX([EXTERNAL INTEGER INCHWL;])
TENX([EXTERNAL INTEGER INTTY;])
EXTERNAL INTEGER INCHRW;
DEFINE L=[1],T=[2],QC=[3],BP=[4];	# DO NOT CHANGE L=1;
	MOVEI	T,!!QUERY;
	HRRZ	L,-1(T);	# LENGTH OF !!QUERY;
	JUMPE	L,NOQ;
	PUSH	SP,-1(T);	# USE !!QUERY;
	PUSH	SP,(T);
	SETZM	-1(T);		# !!QUERY←NULL;
	POPJ	P,;

NOQ:	PUSH	SP,[0];
	PUSH	SP,[0];	# NULL STRING;
LOOP1:
	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,TMAC;
	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;
TMAC:	MOVE	L,#SKIP#;	# CHECK FOR MACRO;
	CAIE	L,CH!ALT;
	CAIL	L,'200;
	 SKIPA;			# IT'S A MACRO;
	JRST	TSEMI;
	CAIN	L,CH!ALT;
	 PUSHJ	P,INCHRW;	# ALTMODE STYLE, GET NEXT CHAR;
	ANDI	L,'137;
	CAIL	L,"A";
	CAILE	L,"Z";
	 JRST	TSEMI;		# NOT IN RANGE;
	ADDI	L,-1-2*"A"(L);	# 2*L-1, TO GET WD1 OF STRING;
	PUSH	SP,MACTAB["A"](L);
	MOVEI	L,1(L);		# 2*L, TO GET WD2;
	PUSH	SP,MACTAB["A"](L);
	SETZM	#SKIP#;
	JRST	CATR;		# CAT ON MACRO AND CONTINUE;
TSEMI:	HRRZ	L,-1(SP);	# LENGTH SO FAR;
	JUMPE	L,LOOP1;
	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!; OUTSTR(DUMPSTR);
    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"
# CLASS: 0: use BK!ID for identifiers. NEQ 0: use BK!ID2;
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 withoug
    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("String quote added")
	ELSE STRVAL←STRVAL[1 TO INF-1]; 	# REMOVE TERMINATING QUOTE;
	CLASS←STRCON; END

# Check for octal;
ELSE IF ARG="'" THEN BEGIN
	A←LOP(ARG);
	IVAL←CVO(SCAN(ARG,BK!OCT,BRCHAR)); CLASS←INTVAL; END

# Check for integer or real;
# 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,IF CLASS=0 THEN BK!ID ELSE BK!ID2,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
PC←RIGHT(PC);	# In case someone forgot;
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;
	HRRZS	PC;		# SAFETY FIRST;
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 coords");
CRDNO←0 MAX CRDNO MIN CRDCTR;	# Clip bounds;
INTARRAY(BAIJFN,(CRDNO LSH -6)+2);
RETURN((CRDNO LAND '77) LSH 1) END "CRDFND";


SIMPLE STRING PROCEDURE FTEXT(INTEGER CRDPNTR); BEGIN "FTEXT"
# CONSTRUCT STRING CONTAINING TEXT OF COORDINATE GIVEN BY TARRAY[CRDPNTR];
INTEGER ALLSTO,COORD1,NCHR;
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;
FILN←PNTR1 LSH -24; PNTR1←PNTR1 LAND '77777777;
PNTR2←TARRAY[CRDPNTR+2];
NCHR←IF FILN=(PNTR2 LSH -24) THEN (PNTR2-PNTR1) LAND '77777777 ELSE 400;
NOTENX([
	MEMORY[LOCATION(TEXT)-1]←NCHR; MEMORY[LOCATION(TEXT)]←
	    LOCATION(TARRAY[0]) + PNTR1%640%5 + (7 LSH 24) + 
	    ((5-(PNTR1 MOD 5))*7+1) LSH 30;
]) # NOTENX;
]) # NOHAND;
HAND([
START!CODE DEFINE T=[1],T2=[2],CP=[3],U=['14];
	MOVE	CP,CRDPNTR;
	MOVE	T,TARRAY[0](CP);
	LDB	T2,[('301400 LSH 18)+T];	# FILE NUMBER OF PNTR1;
	MOVEM	T2,FILN;
	TLZ	T,'777700;	# ISOLATE CHAR NUMBER;
	MOVEM	T,PNTR1;
	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,[('301400 LSH 18)+T];	# FILE NUMBER OF PNTR2;
	SUB	T,PNTR1;	# PNTR2-PNTR1;
	TLZ	T,'777700;	# BOTTOM 24 BITS;
	CAME	T2,FILN;
	 MOVEI	T,400;		# DIFFERENT FILES;
TENX([	MOVEM	T,NCHR;	])
NOTENX([MOVEI	CP,TEXT;	# ADR OF WD2;
	MOVEM	T,-1(CP);	# STRING CHAR COUNT;
# COMPUTE BYTE POINTER;
	MOVE	T,PNTR1;
	IDIVI	T,640;		# BLOCK OFFSET IN T, CHAR OFFSET IN T+1;
	ADDI	T,1;		# USETI NUMBER;
	MOVEM	T,PNTR1;	# SAVE USETI BLOCK NUMBER;
	MOVEI	T,(T+1);	# CHAR OFFSET;
	IDIVI	T,5;		# WORD OFFSET IN T, BYTE OFFSET IN T+1;
	MOVEI	U,'400;		# ADJUST LENGTH TO NO MORE THAN WE READ IN;
	SUBI	U,(T);		# 128+ WORDS TO NEXT BLOCK BOUNDARY;
	IMULI	U,5;		# CHARS;
	SUBI	U,(T+1);	# SOME WERE COUNTED ALREADY;
	CAMGE	U,-1(CP);	# L←L MIN U;
	 MOVEM	U,-1(CP);
	MOVEI	T,TARRAY[0](T);	# WORD ADDRESS;
	XORI	T+1,7;		# 0,1,2,3,4 BECOMES 7,6,5,4,3;
	IMULI	T+1,'70000;	# BYTE POINTER "P" OF 49,42,35,28,21;
	HRLI	T,'630700(T+1);
	MOVEM	T,(CP);		# BYPTE POINTER AT LAST;
]) # NOTENX;
	END;
]) # HAND;
# STATUS OF FILES
	-'1000	NOT ACCESSIBLE (DETERMINED AT INITIALIZATION TIME)
	    -1	ACCESSIBLE, NOT OPEN
	     1	OPEN;
IF FILN=MAX#TXTFIL 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;
    IF TMPJFN NEQ BAIJFN THEN 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; NOTENX([ INTARRAY(TMPJFN,PNTR1); ])
TENX([ SCHPTR(TMPJFN,PNTR1); ])
TEXT←"#" & CVS(COORD1) & (IF ALLSTO THEN " " ELSE "+") & TAB &
    NONULL(TENX([SINI(TMPJFN,NCHR,-1)]) NOTENX([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;
START!CODE HRRZS PC; END;	# PC←RIGHT(PC);
# 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 DEFINE 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;


PROCEDURE !!DEFINE(INTEGER CHAR; STRING MAC); BEGIN "DEFINE"
CHAR←CHAR LAND '137; # CONVERT TO UPPER CASE;
IF "A" LEQ CHAR LEQ "Z" THEN MACTAB[CHAR]←MAC END "DEFINE";


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));		DEFINE(char,""string"");
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+1)
    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+1) 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;
	HRRZ	T3,2(FREG);
	ADDI	REFIT,1(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;
	MOVEI	T3,["
Warning: value string parameter,
simple procedure not at top of stack"];
	PUSH	SP,-1(T3);
	PUSH	SP,(T3);
	PUSHJ	P,OUTSTR;
RET1:	HRRZ	T3,2(FREG);
	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, 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;

PC←RIGHT(PC);
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))=1+PC THEN GOTO EXACT;
    IF T>PC THEN U←I-1 ELSE L←I+1 END;
IF LWA((I←L) LSH 1) LEQ 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;
	HRRZS	PC;
TOP1:	ADDI	I,2;
	HLRZ	LWA,(I);
	CAMG	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,BOT1;
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);
	JUMPE	QFR,BOT1;	# IN CASE WE RUN OUT (PROCESSES, FOR EXAMPLE);
	CAIE	QFR,-1;
	 JRST	TOP1;
BOT1:	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].[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].
  If more than oneE [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 consructed,,
  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←-1,I);
    IF LENGTH(STRVAL)=0 THEN EVALERR("Bad location",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 L!BLKADR+1 NEQ PNTR 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
  Left half of LOC has bit(s) which may flag temporary breakpoints.
  Indirect through LOC should work;
NOHAND ([
INTEGER I; EXTERNAL PROCEDURE !UINIT;
# DO NOT BREAK THE CALL ON !UINIT (WHICH IS THE FIRST INSTRUCTION IN THE OUTER BLOCK);
IF RIGHT(MEMORY[LOC])=LOCATION(!UINIT) THEN LOC←LOC+1;
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("Brkpt ov.")
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;
EXTERNAL INTEGER !UINIT;
	HRRZ	I,@LOC;
	CAIN	I,!UINIT;
	 AOS	LOC;
	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("Brkpt ov.");
]) # 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 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] & TAB & BK!COND[I] & TAB
	& BK!ACT[I] & TAB & (IF BK!COUNT[I]>0 THEN CVS(BK!COUNT[I]) ELSE NULL)))
    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;
	HRRZM	I,BL;
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. 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. 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 JSP '14,STEP!ATJRST;
DEFINE KEY=['14],I=['13],J=['15]; LABEL LOOP;
	MOVEI	KEY,-1(KEY);	# ADDR OF JSP;
	MOVSI	I,-N!BK;
LOOP:	HRRZ	J,BK!LOC[0](I);
	CAIE	J,(KEY);
	AOBJN	I,LOOP;
	MOVEI	I,@BK!INSTR[0](I);	# THE EFFECTIVE ADDRESS;
	TLO	I,'20;		# JRST MODE BREAK;
	PUSH	P,I;		# A COPY FOR BAIL TO POP;
	PUSH	P,KEY;		# LOCATION OF JSP '14,;
	PUSHJ	P,CLRTBK;	
	JRST	BAIL;
END;

SIMPLE PROCEDURE STEPIT(INTEGER PC; INTEGER ARRAY INSTR,MASK); BEGIN "STEPIT"
DEFINE PUSHJ=['260000000000],POPJ=['263000000000],PUSH=['261000000000],
       JSP14=['265600000000];
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 BREAK1((1 LSH 23)+I,"","","",0,('265 LSH 27)+('14 LSH 23)+
		    LOCATION(STEP!ATJRST))
	    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;
	MOVSI	A,0+JSP14 LSH -18;
	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:63,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); ADDSTR("
AT SETLEX("&CVS(DISPLVL)&");"); 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;
DISPLVL←DEPTH←0 MAX DEPTH MIN DDEPTH;	# Clip bounds;
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,$NEWREC;

    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 (ITEMB+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 NOT(LEAPFLAG) OR (TYP1 NEQ TYP2)
	THEN BEGIN # TAKE MAX ALGEBRAIC DOMAIN BUT KEEP RESULT BOOLEAN;
	    IF TYP1=TYP2=RECTYP AND (OP="=" OR OP="≠") THEN ELSE 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	$NEWREC;# '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	DONE;	# BS, END-OF-FILE;
# 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 IF TOOPS GEQ 0 THEN EV1ERR("Syntax error");
	FOR I←0 UPTO TOS-1 DO PRINT(STACK[I]); OUTSTR(DUMPSTR);
	N!TSTRVAL←N!TEMPVAL←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;
		    IF (FRMTYP=NOTYPE) OR (FRMTYP=NOTYPE+ITEMB) OR (FRMTYP=NOTYPE+ARRY)
		    THEN STACK[TOS]←STACK[TOS] LAND LNOT('77 LSH 23) LOR FRMTYP
		    ELSE BEGIN
		    # MAKE SURE WE ASSIGN A TEMP;
		    ACTREF←ACTREF LAND (LNOT REFB);
		    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;
		CAIE	FRMTYP,0+NOTYPE LSH -23;
		CAIN	FRMTYP,0+(NOTYPE+ITEMB) LSH -23;
		 JRST	FIXTYP;
		CAIN	FRMTYP,0+(NOTYPE+ARRY) LSH -23;
		 JRST	FIXTYP;
		CAIL	FRMTYP,0+STRNG LSH -23;
		CAILE	FRMTYP,0+INTEGR LSH -23;
		 JRST	BAD;
		TLZ	ACTREF,0+REFB LSH -18;
		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("# 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,$NEWREC;
$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("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 PREFIT(MEMORY[STACK[0]],STACK[I]);
	TOS←-1;		# CLEAR STACK;
	GOTO $AR END;

$NEWREC:BEGIN
	EXTERNAL INTEGER PROCEDURE $RECFN(INTEGER OP,R); # Type hacking;
	IF GETTYPE(TEMP←STACK[TOS-1]) NEQ RCLTYP THEN EV1ERR("Invalid class name");
	TEMP←$RECFN(1,RIGHT(TEMP)); RSLTTYP←RECTYP 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; ARG←ARG&'177;	# PUT ON "END-OF-FILE";
N!TSTRVAL←N!TEMPVAL←TOS←TOOPS←-1;

WHILE LENGTH(ARG) DO BEGIN "PARSE"
GET!TOKEN(ARG,STRVAL,CLASS←0,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;
	    TLDEPTH←LDEPTH; ARRTRAN(TLSCOPE,LCHAIN);	# FOR TFIND KLUGE;
	    IF (PNTR←TFIND(STRVAL,FALSE,IVAL))<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"
	    IF RIGHT(REFIT)<'140 THEN EV1ERR("Procedure descriptor missing");
	    # 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 PSH(REFIT) # Probably a call to NEW!RECORD;
	    ELSE BEGIN LOPARG; # Remove colon;
		# LOOK FOR SUBFIELD NAME;
		MEMLOC(RPREFIT,INTEGER)←REFIT;	# KLUGEY TYPE COERCION;
		GET!TOKEN(ARG,STRVAL,CLASS←0,IVAL); OLDARG←OLDARG&STRVAL;
		IF CLASS NEQ ID OR (0>IVAL←FNDSBFLD(RPREFIT,STRVAL))
		    THEN EV1ERR("No such subfield");
		IF GETTYPE($CLASS:TYPARR[RPREFIT][IVAL])=STRNG THEN IVAL←-IVAL;
		PSH(IVAL); PSH(REFIT) END 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 )");
	    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";
# SETSCOPE !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV;

INTEGER NXTINSTR,PCSHADOW;

INTERNAL PROCEDURE SETSCOPE(ITEMVAR PROCITM); BEGIN "SETSCOPE"
DEFINE PCW=['23],ACF=['15],ACP=['22],STATUS=['30];
INTEGER PB;
IF TYPEIT(PROCITM) NEQ '11 THEN EV1ERR("Not a process item");
START!CODE EXTERNAL INTEGER DATM;
	MOVE	3,PROCITM;	# PB←DATUM(PROCITM);
	MOVE	5,@DATM;	# PROCITM must be untyped to work at runtime;
	MOVEM	5,PB;		# but compiler gives message UNTYPED ITEMVAR;
END;
IF (PB LAND '1000000) OR MEMORY[PB+STATUS]=2 THEN
    EV1ERR("Terminated");
GETLSCOPE(LCHAIN,LDEPTH,MEMORY[PB+PCW]);
GETDSCOPE(MEMORY[PB+ACF],MEMORY[PB+ACP],MEMORY[PB+PCW],DDEPTH,DCHAIN);
END "SETSCOPE";

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;
	MOVE	T1,PCSHADOW;
	MOVEM	T1,-1(F);	# CORRECT THE FAKE RETURN ADDR;
	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;
LEVEL←0 MAX LEVEL MIN DDEPTH;	# Clip bounds;
WHILE (BACKF←DCHAIN[LEVEL,0])<0 DO LEVEL←LEVEL+1;	# AVOID GOING TO SIMPLE LEVEL;
PC←DCHAIN[LEVEL,1]+1;
START!CODE DEFINE LPSA=['13];
LABEL LUP,DUN,DUN1; EXTERNAL INTEGER STKUWD;
LUP:	HRRZ	LPSA,BACKF;	# DESIRED DESTINATION;
	CAIN	LPSA,(F);	# VS. CURRENT;
	 JRST	DUN;
	HRRZ	LPSA,(F);	# UP DYNAMIC LINK;
	HLRO	LPSA,1(LPSA);	# LEVEL 777777,,PDA -- THUS NO DEALLOCATION AT DEST;
	HRLM	F,BACKF;	# REMEMBER F BEFORE STKUWD;
	PUSHJ	P,STKUWD;	# ATTEMPT IT;
	HLRZ	LPSA,BACKF;	# OLD F;
	CAIE	LPSA,(F);	# VS. CURRENT;
	 JRST	LUP;		# MADE IT;
	HRRZ	LPSA,(F);	# DIDN'T MAKE IT, MUST FORCE IT;
	HLRZ	LPSA,1(LPSA);	# LEVEL 0,,PDA -- THUS EVERYTHING DEALLOCATED;
	PUSHJ	P,STKUWD;	# DEALLOCATE;
	HRRZ	F,(F);		# FORCE BACK;
	JRST	LUP;
DUN:				# RESTORE ACS IF F REGISTER MATCHES;
	HRRZ	LPSA,TEMP!ACS[F];
	CAIE	LPSA,(F);
	 JRST	DUN1;		# DON'T KNOW WHAT'S GOING ON HERE;
	MOVSI	'17,TEMP!ACS[0];
	BLT	'17,'17;
DUN1:	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;


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;
START!CODE DEFINE T=['14];
	AOS	BKLEV;		# RECURSION LEVEL;
	MOVE	T,PC;		# Make it look like BAILOR was called from;
	MOVEI	T,1(T);		#  PC  rather than BAIL+16, but remember return;
	HLL	T,-1(F);	# word so that CLNRET can put it back together;
	EXCH	T,-1(F);
	MOVEM	T,PCSHADOW;
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
    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,SIMXCT;
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,'105740;	# ADJSP P,;
	CAIN	1,'105700;	# ADJSP 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,'105740;	# ADJSP P,;
	CAIN	1,'105700;	# ADJSP SP,;
	 JRST	SIMXCT;
	CAIE	1,'274740;	# SUB P,;
	CAIN	1,'274700;	# SUB SP,;
	 SKIPA;			# MUST SIMULATE THIS ONE;
	JRST	BOT1;		# DONE INTERPRETING;
SIMXCT:	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;

FORWARD INTERNAL SIMPLE PROCEDURE B!;

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;
	SKIPE	2,!JBDDT;
	CAIN	2,B!;		# IF (.JBDDT)=B., THEN RESET IT ANYWAY;
	 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.

Non-TENEX sites: When loaded, .JBDDT (location '74) will be set to LOCATION(B.)
by some external means.  This is so that GET followed by DD works.  Attempt to
!!GO from this first entry will start the program.
;
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:
	HRRZ	'13,!JBDDT;
	SKIPE	'13;		# IF !JBDDT=0 THEN WE ARE AT FUNNY TENEX;
	CAIN	'13,B!;		# IF !JBDDT=B. THEN USER TYPED  GET  THEN  DDT;
	HRRZ	'13,JOBSA;	# IN EITHER CASE, START PROGRAM;
	JRST	('13);

DOINIT:	JSR SAILOR;		! INITIALIZE;
	HRLOI 	RF,1;		! SET UP RF;
	PUSH	P,RF;
	HRRZ	'13,OJOBSA;	# OLD STARTING ADDRESS;
	PUSH	P,@4('13);	# PDA,,0 FOR OUTER BLOCK;
	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"