Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap1_198111 - decus/20-0002/bail.sai
There is 1 other file named bail.sai in the archive. Click here to see a list.
00005	Comment 23-Feb-80  1:01AM Expand "?" to correct string;
00010	Comment  6-Feb-80  7:37PM Use $RUN$. in new top level to avoid confusion with program procedures;
00050	Comment  6-Feb-80  6:42PM Fix new top level to allow macros, parenthesized expressions;
00100	Comment  5-Feb-80  5:30PM Don't treat string proc's as strings;
00200	Comment 10-Jan-80  6:29PM Don't disambig. cmds ending in semi in new top level;
00300	Comment 28-Sep-79  3:54AM Make PRLSCOPE indent;
00400	Comment 28-Sep-79  3:29AM Add LEVEL printout to TEXT output;
00500	Comment 27-Sep-79  9:45PM RNG $N calls new top level, EXIT command;
00600	Comment 27-Sep-79  5:55PM RNG Install NEWTOP/OLDTOP conditionals;
00700	Comment 26-Sep-79  2:41PM Make COORD a string proc, put out #;
00800	Comment 26-Sep-79  2:06PM Fix COORD(NULL) bug;
00900	Comment 26-Sep-79  4:14AM Set SSF_TRUE in TRAPS for nicer output;
01000	Comment 26-Sep-79  3:57AM Make BREAK loc,cond BREAK iff cond;
01100	Comment 26-Sep-79  1:27AM Make break table initialization less kludgy;
01200	Comment 26-Sep-79  1:13AM RNG Fix SINI NUL problem and CRLF problem;
01300	Comment 25-Sep-79  0:51AM RNG Install new top level;
01400	
01500	COMMENT    VALID 00035 PAGES
01600	C REC  PAGE   DESCRIPTION
01700	C00001 00001
01800	C00004 00002
01900	C00005 00003	Data Structures Used by BAIL
02000	C00018 00004	ENTRY BAIL,B!
02100	C00035 00005	# MEMSTRING TTYREAD FLDREAD CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTND NONULL PDFIND ADDSTR ADDCHR DUMPSTR MAKPPN
02200	C00044 00006	# WRITEON PACKAGE
02300	C00051 00007	# OPERATOR CODES, REFITEM TYPE DEFINITIONS
02400	C00067 00008	# TYPEMUNGE
02500	C00073 00009	# INSERT
02600	C00075 00010	# FIND
02700	C00084 00011	# CVNAME PREDEC
02800	C00086 00012	# STBAIL
02900	C00096 00013	
03000	C00106 00014	# SUPER OUTER BLOCK, FOR PREDECLARED STUFF
03100	C00118 00015	# LINED DBANG !!EQU EVALERR
03200	C00125 00016	# GET!TOKEN
03300	C00128 00017	# INTARRAY, CRD!PC, FTEXT, SHOW, CRDFND, GETTEXT
03400	C00137 00018	# N!PARAMS DEFINE HELP
03500	C00139 00019	# CVINTEGR, CVREAL, CVSTRNG
03600	C00142 00020	# INCOR
03700	C00153 00021	# GETLSCOPE, PRLSCOPE
03800	C00157 00022	# GETDSCOPE,PRDSCOPE
03900	C00163 00023	# TFIND,BREAK1,SWAP!BREAKS,PLANT!BREAKS,UNPLANT!BREAKS,LOC!PC,BREAK,COORD,TRAPS
04000	C00175 00024	# PRARGS, TRACER, TRACE
04100	C00183 00025	# UNBREAK1,UNBREAK,UNTRACE,CLRTBK,STEPPING
04200	C00193 00026	# BAILOR,!!TEXT,!!ARGS,EVAL,PSH,OPPSH,SETLEX,X1TEMP,X1TEMP,NEWTEMP,NEWSTRTEMP
04300	C00198 00027	# EVAL1
04400	C00204 00028	# INTERPRETATION OF OPERATORS
04500	C00211 00029
04600	C00219 00030	$COMMA:	BEGIN
04700	C00225 00031	$ARRYREF:BEGIN
04800	C00232 00032	# $MEMRY,$DATUM,$SWAP,$GETS,$SUBFLD,$AR,$APPLY,$CPRINT,$PRINT,$NEWREC
04900	C00241 00033	# PARSER
05000		C00249 00034	# SETSCOPE !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV
05100	C00261 00035	# BAIL,UBINIT,DDBAIL,B!
05200	C00273 ENDMK
05300	C;
     
00100	COMMENT
00200	
00300	
00400	
00500	
00600	
00700	
00800	
00900	
01000			BAIL -- A DEBUGGER FOR SAIL
01100	
01200				by
01300	
01400			John F. Reiser
01500			Computer Science Department
01600			Stanford University
01700			Stanford, California 94305
01800	
01900	
02000	
02100	
02200	
02300	
02400	
02500			March 1976
02600	
02700	
02800	
02900		This work was supported in part by a National Science Foundation Graduate
03000	Fellowship.  Computer facilities provided by the Stanford Artificial Intelligence
03100	Laboratory and the Institute for Mathematical Studies in the Social Sciences,
03200	Stanford.
03300	;
     
00100	COMMENT Data Structures Used by BAIL
00200	
00300	I.  The .SM1 file
00400		This file is produced by the compiler.  It corresponds in a rough way
00500		to a .REL file, except that is has information for the debugger rather
00600		than for the loader.  The file is a sequence of tables.  Each table 
00700		begins with a word containing a non-zero number which indicates the
00800		type of the table.  Following this are an arbitrary number of words,
00900		and then a word which is zero.  Then comes the identifying number for
01000		the next table, and so on.  The end of the file is indicated by a 	
01100		table number of -1.
01200	
01300		The current table types are  BAIFIL [1],  BAICRD [2],  and BAIBLK [3],
01400		and BAIPRC [4].
01500	
01600	    A. BAIFIL -- text file (source/listing) name
01700		The format of the table is:
01800			XWD	file #, # of words which follow
01900		NOTENX<
02000			SIXBIT	/device/
02100			SIXBIT	/name/
02200			SIXBIT	/extension/
02300			SIXBIT	/ppn/	>.,NOTENX
02400		TENX<
02500			ASCII	/<string returned by JFNS>/	>.,TENX
02600	
02700	    B. BAICRD -- coordinate to text index
02800		This table contains two words for each coordinate of the source program.
02900		[The coordinate counter starts at zero for each compilation and is 
03000		increased by one for each semicolon and ELSE seen by the parser,
03100		provided that some code has been generated since the previous coordinate.
03200		The semicolons of COMMENTs and DEFINEs are ignored in this counting.]
03300		The words specify where the text for the coordinate is located, the
03400		address of the first word of code for the coordinate, and whether the
03500		accumulators have any carry-over information from the previous coordinate.
03600	
03700		BYTE	(6)<byte pointer "P">, (5)<file #>, (7)<word #>, (18)<USETI #>
03800		BYTE	(1)<ALLSTO>, (17)<coordinate #>, (18)<address of code>
03900	
04000			At runtime, the format of the first word is changed to
04100		BYTE	(12)<file #> (24)<char # in file>.
04200	
04300	    C. BAIBLK -- block structure and symbol information
04400		This table contains information on a block, followed by 
04500		information describing the symbols declared inside that block.
04600		The tables for the various blocks of a compilation occur in the
04700		order in which their ENDs were seen--i.e., inner-most block first.
04800	
04900		BYTE	(18)<coord #>, (1)0, (11)<DDT level>, (6)<# of words in name>
05000		BYTE	(18)<last word of code>, (18)<first word of code>
05100		ASCII	/name of block/
05200	
05300		For each symbol:
05400		BYTE	(18)0, (12)<DDT level>, (6)<# of words in name>
05500		BYTE	(36)<pre-REFITEM datum for this symbol>
05600		ASCII	/name of symbol/
05700	
05800	    D. BAIPRC -- procedure and parameter information
05900		This table is very similar to a BAIBLK table, except that there is one
06000		more word for the type bits and the pda of the procedure.
06100	
06200		BYTE	(18)<coord #>, (1)1, (11)<DDT level>, (6)<# of words in name>
06300		BYTE	(18)<location of last word of code>, (18)<pcnt at prdec>
06400		BYTE	(18)<type bits for procedure>, (18)<pda>
06500		ASCII	/name of procedure/
06600	
06700		For each parameter:
06800		BYTE	(18)0, (12)<DDT level>, (6)<# of words in name>
06900		BYTE	(36)<pre-REFITEM datum for this symbol>
07000		ASCII	/name of symbol/
07100	
07200	II. The .BAI file
07300		The first disk block of the .BAI file is a header index block.
07400		WORD	MEANING
07500		0-7	unused
07600		8	USETI pointer to beginning of T!CRDIDX
07700		9	CRDCTR,,N!CRDIDX
07800		10	USETI pointer to beginning of T!BLKADR
07900		11	N!BLKADR
08000		12	USETI pointer to beginning of T!NAME
08100		13	N!NAME
08200		14	USETI pointer to text file names
08300		15	N!TXTFIL,,# of words taken up by names
08400		16-127	unused
08500	
08600	III. Runtime data structures
08700	
08800	    A. The NAME table.
08900		All symbols known to BAIL are kept in the NAME table.  This is a hash
09000		table of 31 buckets, with collisions resolved by separate chaining.
09100		Since its ultimate size is not known until it has been constructed,
09200		is is maintained as a MEMORY-LOCATION type table, constructed out
09300		of a CORGET block.  All pointers are relative to the zero-th location
09400		of the CORGET block.
09500	
09600		0: BYTE	(2)<type>, (16)<father>, (18)<next symbol in this bucket>
09700		1: BYTE	(36)<REFITEM datum>
09800		2: ASCI3	/name/		.,three words, zero fill
09900	
10000		The twenty most recently referenced symbols are kept in the CACHE
10100		to try to speed things up.  The cache is maintained by the "climb"
10200		algorithm--when referenced, a symbol is exchanged with the one
10300		above it in the table, thus the most commonly used symbols appear
10400		towards the top of the table.  An entry in the CACHE is the same
10500		as an entry in the NAME table, except that the <next symbol> pointer
10600		is replaced with the first word address of the block which you
10700		must be in to make the cache entry valid.  [Think about homonyms.]
10800	
10900	    B. The block locator table BLKADR
11000		This table contains two words for every block and procedure, and
11100		enables one to determine the block structure corresponding to
11200		an arbitrary address.  This is a linear table in a CORGET block.
11300	
11400		0: BYTE	(18)<father (in BLKADR)>, (18)<pointer to NAME table>
11500		1: BYTE	(18)<last word of code+1>, (18)<first word of code>
11600	
11700	    C. The coordinate index CRDIDX
11800		The whole coordinate table is likely to be very large, so it is
11900		kept on disk and only an index is kept in core.  Since displaying
12000		the source text requires a disk access anyway, we might as well
12100		perform two of them--one to get the right coordinate pointer,
12200		and one to read the text.  The table CRDIDX contains the first
12300		word of every 64-th coordinate pointer. This is a linear table
12400		kept in a CORGET block, and the index of an entry directly 
12500		corresponds to the disk block of the .BAI file which contains
12600		the full 64-coordinate section of the table.
12700	
12800		BYTE	(1)<ALLSTO>, (17)<coord #>, (18)<core address>
12900	
13000	    D. The BALNK loader link block
13100		This block is generated in the data portion of the code.  It 
13200		contains relocation information and the name of the .SM1 file.
13300		It is in the data portion since the loader linked chain must be
13400		reversed before BAIL can use it.
13500	
13600			<link word>
13700			XWD	<high-segment one>,<low-segment one>
13800			XWD	<0 for user, 1 for runtimes>,<# of words which follow>
13900		NOTENX<
14000			SIXBIT	/<.SM1 file name>/
14100			SIXBIT	/<extension>/
14200			SIXBIT	/<PPN>/
14300		SFDS<	SIXBIT	/sfd list/	>.,SFDS
14400			SIXBIT	/<device>/	>.,NOTENX
14500		TENX<
14600			ASCII	/<string returned by JFNS for .SM1 file name>/	>.,TENX
14700	
14800	    E. Descriptors ("refitems")
14900		Each object known to BAIL is described by one word which has the
15000		format of the datum of a reference item.  No items are actually used,
15100		but the bits mean the same thing.  These bits are:
15200	
15300		bit		    name		meaning
15400		0	400000,,0   TEMPB	simple procedure or defaultable parameter
15500		1	200000,,0   REFB	effective address is not a temp location
15600		2	100000,,0   QUESB	? itemvar
15700		3	 40000,,0   BINDB	binding itemvar
15800		4	 20000,,0   PROCB	procedure. addr is pda (entry if simple)
15900		5	 10000,,0   ITEMB	item or itemvar
16000		6	  4000,,0   ARY2B	 array itemvar array
16100		7-12	  3740,,0		type code, same as leap datum type (TYPEIT)
16200		13-35	    37,,-1		effective address.  indirect and index
16300						fields used mostly to indicate arrays or
16400						parameters to procedures
16500	
16600	  IV.  The symbols for SAIL predeclared runtimes
16700	
16800		The SAIL predeclared runtimes can be made known to BAIL.  This requires
16900		that procedure descriptors for the runtimes be loaded.  The procedure
17000		descriptors are created by using the files generated by RTRAN as a
17100		side effect of creating the builtin symbol table for the compiler.
17200	
17300		After running RTRAN:
17400		.R FAIL
17500		*BAICLC_BPDAHD,BAICLC   .,the   files   containing   procedure
17600		*BAIIO1_BPDAHD,BAIIO1	.,  descriptors
17700		*BAIIO2_BPDAHD,BAIIO2
17800		*BAIMSC_BPDAHD,BAIMSD
17900		*BAIPRC_BPDAHD,BAIPRC
18000		
18100		*BAISM1_BSM1HD,BAISM1	.,the program  to  construct  the  .SM1
18200					.,  files
18300	
18400		*BAIPDn_BAIPDn		.,does a .LOAD on all the procedure
18500					., files
18600		*^C
18700		.R LOADER
18800		*/E BAISM1$
18900	
19000		Now transfer the .REL and .SM1 files to SYS: or <SAIL>.
19100	
19200	ENDCOMMENT ;
     
00100	ENTRY BAIL,B!;
00200	BEGIN "BILGE" 
00300	REQUIRE "[][]" DELIMITERS;
00400	REQUIRE 64 STRING!PDL; COMMENT STANDARD IS 40;
00500	require 300 system!pdl; comment standard is 192, needed for debugging recursive procs;
00600	
00700	LET DEFINE=REDEFINE;
00800	
00900	comment This macro controls the new BAIL top level command
01000		interpreter;
01100	define NEWTOP(A)=[A], OLDTOP(A)=[];
01200	
01300	COMMENT INSTALLATION DEPENDENT MACROS AND SETTINGS.
01400		STANFORD	sets STANFO on, DEC off
01500		DEC		sets STANFO off, DEC on
01600		TENEX		taken care of automatically by testing for GTJFN
01700		T20		must be done by hand, as can't tell T20 from
01800				tenex at compile time;
01900	IFCR DECLARATION(GTJFN)
02000	    THENC DEFINE TENX(A)=[A], NOTENX(A)=[], STANFO(A)=[], DEC(A)=[];
02100	      require "s:<sail.tops20>tenxsw.sai" source!file;  comment set site switches;
02200	      IFC TOPS20 THENC
02300	         DEFINE T20(A)=[A], NOT20(A)=[];
02400	        ELSEC
02500	         DEFINE T20(A)=[], NOT20(A)=[A];
02600	        ENDC;
02700	    ELSEC DEFINE TENX(A)=[], NOTENX(A)=[A]; ENDC;
02800	
02900	IFCR EQU(COMPILER!BANNER[LENGTH(SCANC(COMPILER!BANNER,"-",NULL,"IA"))+1 FOR 8]
03000		 ,"TYMSHARE") THENC
03100	    DEFINE TYMSW(A)=[A],NOTYMSW(A)=[]; ELSEC
03200	    DEFINE TYMSW(A)=[],NOTYMSW(A)=[A]; ENDC
03300	
03400	NOTENX([
03500	    IFCR DECLARATION(LODED) THENC DEFINE STANFO(A)=[A], DEC(A)=[];
03600				    ELSEC DEFINE STANFO(A)=[], DEC(A)=[A]; ENDC
03700	])
03800	
03900	STANFO([DEFINE CH!SETC=['176],CH!ALT=['175];	COMMENT RIGHT BRACE, ALTMODE;
04000		DEFINE CORE!IMAGE!EXTENSION=["DMP"];
04100		DEFINE MAX#TXTFIL=[31];
04200		REQUIRE "
04300	STANFORD VERSION" MESSAGE;
04400	])
04500	DEC([	DEFINE CH!SETC=['175],CH!ALT=['33];
04600		DEFINE CORE!IMAGE!EXTENSION=["SAV"];
04700		DEFINE MAX#TXTFIL=[31];
04800	NOTYMSW([REQUIRE "
04900	DEC TOPS-10 VERSION" MESSAGE;])
05000	TYMSW([	REQUIRE "
05100	TYMSHARE VERSION" MESSAGE;])
05200	])
05300	TENX([	DEFINE CH!SETC=['175],CH!ALT=['33];
05400		DEFINE CORE!IMAGE!EXTENSION=["SAV"];
05500	 T20([  DEFINE CORE!IMAGE!EXTENSION=["EXE"]; ]);
05600		DEFINE MAX#TXTFIL=[99];
05700		REQUIRE "
05800	TENX VERSION" MESSAGE;
05900	T20([ REQUIRE " for TOPS-20" MESSAGE;])
06000	])
06100	
06200	
06300	DEFINE HAND(A)=[A], NOHAND(A)=[];
06400	DEFINE FUTURE(A)=[],PAST(A)=[];
06500	DEFINE UPTO=[STEP 1 UNTIL], #=[COMMENT], CRLF=[('15 & '12)], LF=['12],TAB=['11];
06600	DEFINE SUPERCOMMENT(A)=[];
06700	DEFINE CHECK(A)=[NOW!UNSAFE A],NOCHECK(A)=[NOW!SAFE A];
06800	DEFINE MEMLOC(A,B)=[MEMORY[LOCATION(A),B]];
06900	DEFINE LEFT(A)=[((A) LSH -18)], RIGHT(A)=[((A) LAND '777777)];
07000	DEFINE	P=['17], SP=['16],
07100	    ATJRST=['254020000000],ARERR=['007000000000],FIX=['003000000000];
07200	DEFINE JRSTF=['254100000000],!JBOPC=['130],
07300	    !JBHRL=['115],HALT=[JRST 4,],!JBCST=['136];
07400	DEFINE PD!NPW=[4],PD!DSP=[5],PD!DLW=[7],PD!PPD=['11],PD!PCW=['12];
07450	external integer !jbddt, !jbsym;
07500	EXTERNAL INTEGER !SKIP!,!ERRP!,!ERRJ!,BALNK;
07600	INTEGER !RECOVERY!,#ERRP#,#SKIP#,INTERP!SKIP!;
07700	   # Here we explain the various problems with !skip!.  The problem is
07800		that !skip! is affected by/affects at least three different
07900		things: the program you are debugging as you step through it,
08000		any runtime calls made by the bail interpreter internally, and
08100		sail expressions that you type to Bail and have it interpret.
08200		In order to keep all of these things from interfering with each
08300		other, we adopt the following conventions:
08400		  as soon as Bail is entered from the user's program, !skip!
08500			is put into temp!acs['20+F+2].  Then it is restored
08600			from here when the user's program is resumed or stepped.
08700			I.e. it is saved and restored like an AC.  This protects
08800			the user's program from unintended sideeffects.  If
08900			the user explicitly asks to see or change the value or
09000			!skip!, it is this saved value he sees, by virtue of
09100			the fact that Bail has !skip! predeclared to point to
09200			temp!acs['20+F+2].
09300		  a separate saved version of !skip! is maintained for
09400			interpreted Sail expressions in the variable
09500			interp!skip!.  Before doing an interpreted procedure
09600			call, the real !skip! is set to the value of
09700			interp!skip!.  After an interpreted procedure call (or a
09800			call to SUBST, which can also set !skip!) !skip! is
09900			stored back into interp!skip!.  To allow the user to
10000			access this value, the symbol \skip\ is predeclared to
10100			point to interp!skip!.
10200		Also note that internally the symbol used for temp!acs['20+f+2]
10300			is !skip\.  !skip! is changed into that before symbol
10400			table lookup as a special-case test.;
10500	NEWTOP([ integer oldBail; ])
10600	EXTERNAL INTEGER PDLNK;
10700	EXTERNAL SAFE INTEGER ARRAY GOGTAB[0:'300];
10800	REQUIRE STANFO(["SYS:GOGTAB.DEF"]) DEC(["GOGTAB.DEF"])
10900		TENX(T20(["SAI:GOGTAB.DEF"]) NOT20(["GOGTAB.DEF"])) SOURCE!FILE;
11000	SUPERCOMMENT([
11100		# ABOVE REQUIRE IS MOSTLY A TEST OF THE NEW WAY TO DO AWAY WITH USERCON.
11200		  GOGTAB.DEF IS PRODUCED BY SCISS WHEN A NEW LIBRARY IS MADE, AND CONTAINS
11300		  DEFINITIONS OF THE USER TABLE ENTRY NAMES AND THEIR VALUES. IF THE FILE
11400		  IS NOT AROUND, TRY THESE:
11500	    DEFINE REMCHR=['12],TOPBYT=['11],UUO1=['0],BKTPRV=['34];
11600	    STANFO([DEFINE RACS=['135],BAILOC=['243];])
11700	    DEC([DEFINE RACS=['133],BAILOC=['241];])
11800	    TENX([DEFINE RACS=['133],BAILOC=['246];])
11900	]) # END SUPERCOMMENT;
12000	EXTERNAL RECORD!CLASS $CLASS(INTEGER RECRNG,HNDLER,RECSIZ;
12100	    INTEGER ARRAY TYPARR; STRING ARRAY TXTARR);
12200	
12300	SIMPLE PROCEDURE FATAL(STRING A); USERERR(0,0,A);
12400	SIMPLE PROCEDURE NONFATAL(STRING A); USERERR(0,1,A);
12500	
12600	NOTENX([
12700	DEFINE CFILE(A)="RELEASE(A)";
12800	FORWARD SIMPLE STRING PROCEDURE CATCRLF(STRING A);
12900	
13000	EXTERNAL INTEGER INIACS;
13100	STRING RUNDEV,RUNPPN;	# set from INIACS if RUN or GET;
13200	
13300	SIMPLE INTEGER PROCEDURE OPENFILE(REFERENCE STRING FILNAM; STRING MODES);
13400	BEGIN "OPENFILE"
13500	# like TENEX-SAIL, extended if errors;
13600	EXTERNAL INTEGER !SKIP!;
13700	INTEGER CHN,FLAG,R,W,E,TRIAL; LABEL BAD,TRY,TRY2; STRING DEV,FIL;
13800		PRESET!WITH
13900		"no such file ", "illegal PPN ", "protection ",	"busy ", "???";
14000		OWN SAFE STRING ARRAY REASON[0:4];
14100	IF (CHN_GETCHAN)<0 THEN GOTO BAD;
14200	QUICK!CODE SETZM TRIAL; END;
14300	TRY: DEV_"DSK";
14400	TRY2:
14500	START!CODE LABEL LOOP1,LOOP2,TEST1,TEST2,USEDFLT;
14600		SETZB	1,2;		# R,W;
14700		SETZM	E;
14800		HRRZ	3,-1(SP);	# LENGTH(MODES);
14900		MOVE	5,(SP);		# BP;
15000		JRST	TEST1;
15100	    LOOP1:ILDB	4,5;
15200		CAIN	4,"R";
15300		 MOVEI	1,2(1);
15400		cain	4,"S";   comment single buffer;
15500		 movei	1,1;
15600		CAIN	4,"W";
15700		 MOVEI	2,2(2);
15800		CAIN	4,"E";
15900		 SETOM	E;
16000	    TEST1:SOJGE	3,LOOP1;
16100		MOVEM	1,R;
16200		MOVEM	2,W;
16300	
16400		MOVEI	4,FIL;		# FIL_FILNAM;
16500		MOVE	5,-1(P);	# ADDR(FILNAM);
16600		HRRZ	1,-1(5);	# LENGTH(FILNAM);
16700		MOVEM	1,-1(4);
16800		MOVE	2,(5);		# BP;
16900		MOVEM	2,(4);
17000		JRST	TEST2;
17100	    LOOP2:ILDB	3,2;
17200		CAIE	3,":";
17300	    TEST2:SOJGE	1,LOOP2;
17400		JUMPL	1,USEDFLT;	# NO COLON, USE DEFAULT;
17500		EXCH	1,-1(4);	# 1_ORIG LEN, -1(4)_LEN OF NAME;
17600		EXCH	2,(4);		# 2_DEV BP, (4)_NAME BP;
17700		MOVEI	3,DEV;
17800		MOVEM	2,(3);		# DEVICE BP TO CORE;
17900		SUB	1,-1(4);	# LEN+1 OF DEV=ORIG LEN - LEN OF NAME;
18000		SUBI	1,1;		# CORRECT FOR COLON;
18100		MOVEM	1,-1(3);	# LENGTH TO CORE;
18200	    USEDFLT:SETZM FLAG;
18300		END;
18400	RELEASE(CHN); OPEN(CHN,DEV,'10,R,W,FLAG,FLAG,FLAG); IF FLAG THEN GOTO BAD;
18500	IF W THEN ENTER(CHN,FIL,!SKIP!) ELSE
18600	IF R THEN LOOKUP(CHN,FIL,!SKIP!);
18700	IF !SKIP! AND TRIAL=0 THEN BEGIN
18800	    # try harder; IF LENGTH(RUNDEV) THEN DEV_RUNDEV; CVFIL(FIL,TRIAL,FLAG);
18900	    IF NOT(FLAG) THEN
19000		# originally, no PPN; FILNAM_FILNAM&RUNPPN; QUICK!CODE SETOM TRIAL; END;
19100	    GOTO TRY2 END;
19200	IF !SKIP! AND NOT(E) THEN BEGIN
19300		OUTSTR("
19400	File error, "&REASON[RIGHT(!SKIP!) MIN 4]& DEV&":"&FIL& "
19500	Try again, ALT to ignore:");
19600		CLRBUF; STANFO([PTOSTR(0,DEV&":"&FIL);])
19700		FILNAM_INCHWL; IF !SKIP! NEQ CH!ALT THEN GOTO TRY END;
19800	RETURN(CHN);
19900	BAD:	CFILE(CHN); RETURN(!SKIP!_TRUE);
20000	END "OPENFILE";
20100	]);	# NOTENX;
20200	
20300		DEFINE USETOUT(CHAN,BLOCK)=[USETO(CHAN,BLOCK)],
20400			USETIN(CHAN,BLOCK)=[USETI(CHAN,BLOCK)];
20500	
20600	# SPECIAL BREAKTABLE STUFF;
20700	DEFINE DELIMS=[('00 & '11 & '12 & '13 & '14 & '15 & '40)];
20800		# NULL,TAB,LF,VT,FF,CR,SP;
20900	# Dot (period) must be last for BK!ID2. Can save space by not mentioning
21000	  lowercase because BK!ID and BK!ID2 convert to upper first ("K" mode);
21100	DEFINE LETTERS=["ABCDEFGHIJKLMNOPQRSTUVWXYZ!" & "#$\|."],
21200		DIGITS=["0123456789"], SAILID=[(DIGITS & LETTERS)],
21300		NUMBER=[(DIGITS & ".@")];
21400		# THE ASCII FOR THOSE STANFORD CHARACTERS UNDER LETTERS IS:
21500		002 (ALPHA), 003 (BETA), 007 (PI), 010 (LAMBDA),
21600		020 (SUBSET), 021 (REVERSE SUBSET), 024 (FOR ALL), 025 (THERE EXISTS)
21700		030 (UNDERSCORE), 031 (RIGHT ARROW), 032 (TILDE);
21800	DEFINE QUOTE=['042];
21900	
22000	PRESET!WITH
22100		TAB,NULL,"INS",
22200		DELIMS,NULL,"XNR",
22300		QUOTE,NULL,"INA",
22400		"01234567",NULL,"XNR",
22500		NUMBER,NULL,"XNR",
22600		".@",NULL,"INR",
22700		SAILID,NULL,"XNRK",
22800		SAILID[1 to inf-1],NULL,"XNRK",
22900			NULL,NULL,"IZ";
23000	SAFE STRING ARRAY BK!SBR[0:8,0:2];	# SETBREAK WILL BE DONE WITH THESE;
23100	PRELOAD!WITH [9]0;
23200		SAFE INTEGER ARRAY BK!TBL[0:8];		# TABLE NUMBERS STORED HERE;
23300	DEFINE BK!TAB=[BK!TBL[0]],BK!DLM=[BK!TBL[1]],BK!QUO=[BK!TBL[2]],
23400	BK!OCT=[BK!TBL[3]],BK!NUM=[BK!TBL[4]],BK!DEC=[BK!TBL[5]],BK!ID=[BK!TBL[6]],
23500	BK!ID2=[BK!TBL[7]], BK!NONE=[BK!TBL[8]];
23600	# tab,delimiters,quote,octal digits,floating decimal,
23700	    decimal digits,identifiers,ids without period, nothing (don't ignore nul);
23800	# EXTERNAL INTEGER BKTPRV;	# BREAKTABLE PRIVILEGE WORD;
23900	SIMPLE INTEGER PROCEDURE BK!PRV(BOOLEAN MODE);
24000	# USERCON(BKTPRV,MODE,TRUE);
24100	BEGIN GOGTAB[BKTPRV] SWAP MODE; RETURN(MODE) END;
24200	# SETS BREAKTABLE PRIVILEGE;
24300	
24400	DEFINE SM1LNK(I)=[MEMORY[SM1PNT+I]], T!NAME(I)=[MEMORY[C!NAME+I]],
24500	    T!BLKADR(I)=[MEMORY[C!BLKADR+I]], T!CRDIDX(I)=[MEMORY[C!CRDIDX+I]];
24600	DEFINE PAGEIT(A,B)=[T!NAME(B)];
24700	DEFINE N!CACHE=[100], BOTTOM!SLOT=[95], N!BK=[16], L!BK=[(N!BK-1)];
24800	DEFINE HRELOC(A)=[(A+HZERO)], LRELOC(A)=[(A+LZERO)];
24900	INTEGER BAIJFN,TMPJFN;	# CHANNEL NUMBERS FOR .BAI FILE AND TEXT FILES;
25000	INTEGER C!NAME,		# ADDRESS OF NAME TABLE;
25100		C!BLKADR,	# ADDRESS OF BLKADR TABLE;
25200		C!CRDIDX,	# ADDRESS OF COORDINATE INDEX TABLE;
25300		L!NAME,		# INDEX OF LAST ENTRY CURRENTLY USED IN NAME TABLE;
25400		L!BLKADR,	#					BLKADR TABLE;
25500		L!CACHE,	#					CACHE;
25600		L!CRDIDX,	#					COORDINATE INDEX;
25700		L!TXTFIL,	#					TEXTFILE TABLE;
25800		N!NAME,		# NUMBER OF ENTRIES ALLOCATED IN NAME  TABLE;
25900		N!BLKADR,	# 				BLKADR;
26000		N!CRDIDX	#				COORDINATE INDEX;
26100		;
26200	INTEGER BKLEV;		# BREAKPOINT RECURSION LEVEL;
26300	INTEGER PJPBAIL;	# CONTAINS  PUSHJ P,BAIL  AT RUNTIME;
26400	INTERNAL STRING !!QUERY;	# TO BE SET BY USER ON EXPLICIT CALL TO BAIL;
26500	INTEGER BAILOFF,NAME!POINTER;	# ANOTHER SWITCH, USETI POINTER TO NAME TABLE IN .BAI FILE;
26600	STRING ARRAY T!TXTFIL[0:MAX#TXTFIL];	# NAMES OF TEXT FILES;
26700	PRELOAD!WITH [MAX#TXTFIL+1] 0;
26800	INTEGER ARRAY STATUS[0:MAX#TXTFIL];	# FOR STATUS OF THESE FILES;
26900	PRELOAD!WITH [N!CACHE] 0;
27000	INTEGER ARRAY CACHE[0:N!CACHE-1];	# 20 MOST RECENT NAMES (5 WORDS PER);
27100	PRELOAD!WITH [256] 0;
27200	INTEGER ARRAY TARRAY[0:255];	# TEMPORARY ARRAY;
27300	PRELOAD!WITH [N!BK] 0;
27400	INTERNAL INTEGER ARRAY BK!LOC, BK!INSTR,BK!COUNT[0:L!BK]; 
27500			# BREAK LOCATIONS, SAVED INSTRUCTIONS, MULTIPLE PROCEED COUNTS;
27600	INTERNAL STRING ARRAY BK!COND,BK!ACT,BK!NAME[0:L!BK]; 
27700		# TO BE EVALUATED FOR CONDITIONAL BREAK, AUTOMATIC ACTION. ID;
27800	PRELOAD!WITH ['17+'12+1+1+1+1] 0;
27900	INTEGER ARRAY TEMP!ACS[0:'17+'12+1+1+1]; # HOLDING TANK UNTIL RECURSIVE SAIVING;
28000	PRELOAD!WITH [9] 0;
28100	INTEGER ARRAY TRAP[0:8];	# PLACE TO DO INTERCEPTIONS;
28200	STRING !STR!;			# GLOBAL ACCUMULATOR FOR PIECE-WISE OUTPUT;
28300	BOOLEAN SSF;			# SPECIAL STRING FLAG, TRUENO QUOTE-IZE;
28400	INTEGER MULDEF;			# FALSETOTALLY UNKNOWN, TRUEMULTIPLY DEFINED;
28500	INTEGER TLDEPTH;
28600	PRELOAD!WITH [16] 0;
28700	INTEGER ARRAY TLSCOPE[0:15];	# KLUGE FOR TFIND;
28800	INTEGER CRDCTR; # "GLOBAL" COUNTER OF COORDINATE NUMBERS;
28900	PRELOAD!WITH ["G"-"A"] NULL," !!GO;",["N"-"H"] NULL," OLDBAIL_FALSE;""New BAIL"";",["P"-"O"] NULL," !!GO;",
29000	    ["S"-"Q"] NULL," !!STEP;",["X"-"T"] NULL," !!GSTEP;",["Z"-"Y"+1] NULL;
29100	INTERNAL SAFE STRING ARRAY MACTAB["A":"Z"];	# MACRO TABLE;
29200	INTEGER PRGSM1;			# ptr to "main program" on .SM1 BALNK chain;
     
00100	# MEMSTRING TTYREAD FLDREAD CATCRLF CRLFCAT STRCOPY FILTIM LAST!WRITTEN COREGET COREFREE EXTND NONULL PDFIND ADDSTR ADDCHR DUMPSTR MAKPPN;
00200	
00300	SIMPLE STRING PROCEDURE MEMSTRING(INTEGER ADDR); START!CODE
00400	# MEMSTRING(ADDR) IS A LEGAL WAY TO DO MEMORY[ADDR,STRING];
00500	DEFINE T=['14];
00600		MOVE	T,ADDR;
00700		PUSH	SP,-1(T);
00800		PUSH	SP,0(T);
00900		SUB	P,['2000002];
01000		JRST	@2(P);
01100		END;
01200	
01300	simple string procedure TTYREAD(string prompt(null));
01400	TENX([ T20([
01500	
01600	begin "TTYREAD"
01700		string line;
01800		label error, fin, weird;
01900		external integer ctlosw;
02000		boolean non!null!prompt;
02100		external procedure ZSETST; external procedure ZADJST;
02200		start!code  "wait until TTY output buffer empty"
02300			movei	1,'101;
02400			DOBE;
02500		end "wait until TTY output buffer empty";
02600		comment Reset flag for old-style TENEX ^O handling;
02700		ctlosw_false;
02800		comment reset monitor bit for TOPS-20 new-style;
02900		sfmod('101,rfmod('101) land '377777777777);
03000		outstr(prompt);
03100		comment If prompt is not null, make it ASCIZ;
03200		non!null!prompt_prompt;
03300		if non!null!prompt then prompt_(prompt&0)[1 to inf-1];
03400		start!code "RDTTY"
03500			define sp='16, p='17, A=1, B=2, C=3, ORIGCNT=500;
03600			define RDTTY='104000000523;
03700			push	p,[ORIGCNT];		# max characters;
03800			pushj	p,zsetst;		# get a BP in A;
03900			hrli	B,'200000;		# bits for break on ^G, ^L, ^Z, esc, crlf, lf;
04000			hrri	B,ORIGCNT;		# again, max characters;
04100			move	C,non!null!prompt;	# Will there be a prompt?;
04200			caie	C,0;			# IF non!null!prompt;
04300			move	C,prompt;		# THEN put BP to PROMPT in C for RDTTY ^U and ^R feature;
04400			RDTTY;
04500			  JRST	error;
04600			ldb	5,A;			# get break char;
04700			soj	A,0;			# adjust byte pointer;
04800			ibp	A;			# this is actually;
04900			ibp	A;			# faster than;
05000			ibp	A;			# adjbp A,-1;
05100			move	4,A;			# save in case next byte is cr;
05200			ildb	C,A;			# last char of line, or is it?;
05300			caie	C,'15;			# is it cr?;
05400			jrst	weird;			# no;
05500			move	A,4;			# yes, reset byte ptr;
05600			movem	C,!skip!;		# save break char;
05700	fin:		push	p,[ORIGCNT];		# Adjust String Space;
05800			push	p,A;
05900			pop	sp,C;			# get rid of garbage in sp;
06000			pop	sp,C;			# ditto;
06100			pushj	p,zadjst;		# Get string on stack;
06200			setzm	ctlosw;			# Just in case;
06300			popj	p,;			# return to caller;
06400	weird:		movem	5,!skip!;		# last char is brchr;
06500			tlnn	B,'000040;		# exceeded byte count?;
06600			ibp	A;			# yes, include last char;
06700			jrst	fin;
06800		end "RDTTY";
06900	
07000	ERROR:		usererr(0,1,"? BAIL RDTTY error");
07100		return(null);
07200	end "TTYREAD";
07300	]) # T20;
07400	
07500	NOT20([
07600	begin "TTYREAD"
07700		string line;
07800		external boolean ctlosw;
07900		while true do begin
08000			ctlosw_false;
08100			outstr(prompt);
08200			line_intty;
08300			if !skip! neq ("U"-"@") then done;
08400			outstr(crlf);
08500		end;
08600		return(line);
08700	end "TTYREAD";
08800	]) # NOT20;
08900	]) # TENX;
09000	
09100	NOTENX([
09200	begin "TTYREAD"
09300		#  wait for all printing to finish, then reset ^O status of terminal;
09400			start!code "make sure prompt is seen"
09500			label tryagain, gotoit, error;
09600			movei	1,2;	#  function code for trmop. to skip if obuf not empty;
09700			calli	2,'30;	#  PJOB, get job number;
09800			calli	2,'115;	#  TRMNO., get universal index;
09900			jrst	gotoit;	#  error return, forget it;
10000			hrli	3,2;	#  put # of word in lh of ac3;
10100			hrri	3,1;	#  put addres ac1 into rh of ac3;
10200	tryagain:	calli	3,'116;	#  TRMOP., skip if output buffer not empty;
10300			jrst	gotoit;
10400			movei	4,100;	#  set up to hibernate for 100 msec;
10500			calli	4,'72;	#  hibernate for 100 msec;
10600			jrst	error;	#  error return, try sleep instead;
10700			jrst	tryagain;
10800	error:		setz	4,;	#  set up to sleep;
10900			calli	4,'31;	#  sleep for minimum time;
11000			jrst	tryagain;
11100	gotoit:		ttcall	'13,0;	# skip if user has typed at least one char (also resets ^O);
11200			jfcl;		# no op;
11300		end "make sure prompt is seen";
11400		outstr(prompt);
11500		return(inchwl);
11600	end "TTYREAD";
11700	]) # NOTENX;
11800	
11900	TENX([
12000	simple string procedure FLDREAD(integer chan,maxlength);
12100	begin "FLDREAD"
12200		comment Read up to MaxLength chars from chan.
12300			Can't use SAIL routine SINI because maxlength
12400			includes nuls.  Can't use SIN JSYS because
12500			it insists on a 7 bit bytesize which the SAIL
12600			runtimes do not allow;
12700		integer count, brchr, eof, oldprv;
12800		string s;
12900		setinput(chan,count,brchr,eof);
13000		count_maxlength;
13100		oldprv_bk!prv(true);
13200		s_input(chan,bk!none);
13300		bk!prv(oldprv);
13400		return(s);
13500	end "FLDREAD";
13600	]) # TENX;
13700	
13800	SIMPLE STRING PROCEDURE CATCRLF(STRING ARG); BEGIN
13900	NOHAND([RETURN(ARG&CRLF)]);
14000	HAND([	START!CODE EXTERNAL INTEGER CAT;
14100		PUSH	SP,[2];
14200		PUSH	SP,[CRLF];
14300		JRST	CAT;
14400		END;
14500	]);END;
14600	
14700	SIMPLE STRING PROCEDURE CRLFCAT(STRING ARG); BEGIN
14800	NOHAND([RETURN(CRLF&ARG)]);
14900	HAND([	START!CODE EXTERNAL INTEGER CAT!RV;
15000		PUSH	SP,[2];
15100		PUSH	SP,[CRLF];
15200		JRST	CAT!RV;
15300		END;
15400	]);END;
15500	
15600	SIMPLE STRING PROCEDURE STRCOPY(STRING ARG); BEGIN
15700	# COPY THE TEXT, TOO, NOT JUST THE DESCRIPTOR;
15800	NOHAND([ RETURN((ARG&".")[1 TO INF-1]); ])
15900	HAND([	START!CODE EXTERNAL INTEGER CATCHR;
16000		PUSH	P,[0+"."];
16100		PUSHJ	P,CATCHR;
16200		SOS	-1(SP);
16300			POPJ	P,;
16400		END;
16500	]);END;
16600	
16700	SIMPLE INTEGER PROCEDURE FILTIM(INTEGER JFN); BEGIN
16800	TENX([	GTFDB(JFN,TARRAY); RETURN(TARRAY['14])])
16900	NOTENX([FILEINFO(TARRAY);
17000		RETURN( NOTYMSW([ ((TARRAY[1] LAND '700000) LSH 8) LOR])
17100			TYMSW([ ((TARRAY[1] LAND '140000) LSH 9) LOR])
17200			((TARRAY[2] LAND '7777) LSH 11) LOR
17300			((TARRAY[2] LSH -12) LAND '3777)	)])
17400	END;
17500	
17600	SIMPLE INTEGER PROCEDURE LAST!WRITTEN(REFERENCE STRING FILENAME; STRING MODES);
17700	BEGIN "LAST!WRITTEN"
17800		TENX([	INTEGER JFN; JFN_GTJFN(FILENAME,1 LSH 33); IF !SKIP! THEN RETURN(0);
17900		GTFDB(JFN,TARRAY); RLJFN(JFN); RETURN(TARRAY['14])	])
18000	NOTENX([CFILE(OPENFILE(FILENAME,MODES)); RETURN(IF !SKIP! THEN 0 ELSE
18100		    FILTIM(0))])
18200	END "LAST!WRITTEN";
18300	
18400	EXTERNAL PROCEDURE CORGET;
18500	SIMPLE INTEGER PROCEDURE COREGET(INTEGER LENGTH); BEGIN "COREGET"
18600	INTEGER LOC;	LABEL FOOEY;
18700	START!CODE
18800		MOVE	3,LENGTH;	# PLACE WHERE CORGET TAKES ITS ARG;
18900		PUSHJ	P,CORGET;	# CALL THE STEWARD;
19000		 JRST	FOOEY;		# UNSUCCESSFUL RETURN;
19100		MOVEI	3,(2);		# ISOLATE ADDRESS;
19200		MOVEM	3,LOC;		# STORE ADDRESS OF BLOCK;
19300		ADD	3,LENGTH;
19400		SETZM	0,0(2);		# ZERO THE FIRST WORD FOR BLT;
19500		HRLI	2,(2);
19600		HRRI	2,1(2);
19700		BLT	2,-1(3);	# WE LIKE ZEROED BLOCKS BETTER!;
19800		END;
19900	RETURN(LOC);
20000	FOOEY:	FATAL("BAIL: No core")	END "COREGET";
20100	
20200	
20300	EXTERNAL PROCEDURE CORREL;
20400	SIMPLE PROCEDURE COREFREE(INTEGER ADDR);
20500	START!CODE "COREFREE"
20600		SKIPE	2,ADDR;		# PLACE WHERE CORREL GETS ITS ARG;
20700		PUSHJ	P,CORREL;
20800	END "COREFREE";
20900	
21000	
21100	SIMPLE STRING PROCEDURE NONULL(STRING ARG); BEGIN "NONULL"
21200	# RETURN ARG WITH ALL OCCURRANCES OF NULL BYTES REMOVED;
21300	NOHAND([
21400	INTEGER T,BRCHAR; STRING RESULT;
21500	T_BK!PRV(TRUE); RESULT_SCAN(ARG,BK!NONULL,BRCHAR); BK!PRV(T);
21600	RETURN(RESULT);
21700	]) # NOHAND;
21800	HAND([
21900	START!CODE LABEL LOOP,BOT; DEFINE T=['13],OBP=['14],NBP=['15],CT=[1];
22000		MOVE	OBP,(SP);	# OLD BYTE POINTER;
22100		MOVE	NBP,(SP);	# NEW BYTE POINTER;
22200		HRRZ	CT,-1(SP);	# CHAR COUNT;
22300		HLLZS	-1(SP);		# NEW COUNT. PRESERVE CONSTANTNESS OF STRING;
22400		JRST	BOT;		# IN CASE NULL STRING;
22500	LOOP:	ILDB	T,OBP;		# GET CHAR;
22600		JUMPE	T,BOT;		# DON'T PUT IT BACK IF IT'S A NULL;
22700		AOS	-1(SP);		# ANOTHER CHAR;
22800		IDPB	T,NBP;
22900	BOT:	SOJGE	CT,LOOP;	# CONTINUE UNTIL DONE;
23000		POPJ	P,;		# WE'RE DONE;
23100	END;
23200	]) # HAND;
23300	END "NONULL";
23400	
23500	
23600	SIMPLE INTEGER PROCEDURE PDFIND(INTEGER ENTAD);
23700	# GIVEN ENTRY ADDRESS, RETURN ADDRESS OF PROCEDURE DESCRIPTOR;
23800	NOHAND([
23900	BEGIN INTEGER I;
24000	I_PDLNK; WHILE I NEQ 0 AND MEMORY[I+1] NEQ RIGHT(ENTAD) DO I_MEMORY[I];
24100	RETURN(I+1) END;
24200	]) # NOHAND;
24300	HAND([
24400	START!CODE LABEL LOOP,BOT;
24500			MOVE	1,PDLNK;
24600		HRRZ	2,ENTAD;
24700	LOOP:	CAMN	2,1(1);
24800		 JRST	BOT;
24900		SKIPE	1,(1);
25000		 JRST	LOOP;
25100	BOT:	ADDI	1,1;
25200		SUB	P,['2000002];
25300		JRST	@2(P);
25400	END;]) # HAND;
25500	
25600	
25700	SIMPLE PROCEDURE EXTND(REFERENCE INTEGER ADDR, OLEN, INCR); BEGIN "EXTND"
25800	INTEGER TMPJFN,DUMMY;	LABEL OK; STRING T;
25900	    SIMPLE PROCEDURE GETTEMP(STRING MODE); BEGIN
26000	    TMPJFN_OPENFILE(T_"BBBBBB.TMP",MODE); IF !SKIP! THEN BEGIN BAILOFF_TRUE;
26100	    FATAL("BBBBBB.TMP problems") END END;
26200	START!CODE	EXTERNAL INTEGER CORINC;
26300		MOVE	2,ADDR;
26400		MOVE	3,INCR;
26500		PUSHJ	P,CORINC;	# ATTEMPT TO INCREASE THE CURRENT BLOCK;
26600		 SKIPA;
26700		JRST	OK;
26800	END;
26900	  GETTEMP("RWE" TENX([&"T"]) ); ARRYOUT(TMPJFN,MEMORY[ADDR],OLEN); COREFREE(ADDR);
27000	  ADDR_COREGET(OLEN+INCR); CFILE(TMPJFN);
27100	  GETTEMP("RE"); ARRYIN(TMPJFN,MEMORY[ADDR],OLEN);
27200	  NOTENX([	RENAME(TMPJFN,NULL,0,DUMMY); CFILE(TMPJFN);	])
27300	  TENX([	CLOSF(TMPJFN); DELF(TMPJFN); CFILE(TMPJFN);	])
27400	OK: OLEN_OLEN+INCR;
27500	END "EXTND";
27600	
27700	
27800	SIMPLE PROCEDURE ADDSTR(STRING A);BEGIN
27900	!STR!_!STR! & A;	END;
28000	
28100	
28200	SIMPLE PROCEDURE ADDCHR(INTEGER CHR);
28300	START!CODE	EXTERNAL INTEGER PUTCH;
28400		POP	P,1;	# RET ADDR THIS PROC;
28500		PUSHJ	P,PUTCH;# CONVERT CHR TO STRING;
28600		PUSH	P,1;	# REPLACE RET ADDR;
28700		JRST	ADDSTR;	# SOLVE SUBPROBLEM;
28800	END;
28900	
29000	
29100	SIMPLE STRING PROCEDURE DUMPSTR;BEGIN
29200	NOHAND([BEGIN STRING T; T_!STR!; !STR!_NULL; RETURN(T) END	]);
29300	HAND([	START!CODE	DEFINE T=['14];
29400		MOVEI	T,!STR!;
29500		PUSH	SP,-1(T);
29600		PUSH	SP,(T);
29700		SETZM	-1(T);
29800		SETZM	(T);
29900		POPJ	P,;
30000	END	]);	# HAND;
30100	END;
30200	
30300	SIMPLE STRING PROCEDURE MAKPPN(REFERENCE INTEGER PPN; INTEGER SFDLVL(0));
30400	BEGIN "MAKPPN"
30500	DEC([	
30600	STRING PPNSTR; INTEGER I;
30700	IF PPN=0 THEN RETURN(NULL);
30800	PPNSTR_"["&CVOS(LEFT(PPN))&","&CVOS(RIGHT(PPN));
30900	FOR I_1 UPTO SFDLVL DO IF MEMORY[LOCATION(PPN)+I] THEN
31000	  PPNSTR_PPNSTR&","&CV6STR(MEMORY[LOCATION(PPN)+I]);
31100	RETURN(PPNSTR&"]");
31200	]) # DEC;
31300	STANFO([
31400	RETURN(IF PPN=0 THEN NULL ELSE
31500		"["&CVXSTR(PPN)[1 TO 3]&","&CVXSTR(PPN)[4 TO 6]&"]")
31600	]) # STANFO;
31700	TENX([
31800	RETURN(IF PPN=0 THEN NULL ELSE MEMSTRING(PPN));
31900	]) # TENX;
32000	END "MAKPPN";
     
00100	# WRITEON PACKAGE;
00200	DEFINE TEMPB=[(1 LSH 35)],REFB=[(1 LSH 34)], QUESB=[(1 LSH 33)], BINDB=[(1 LSH 32)],
00300		PROCB=[(1 LSH 31)], ITEMB=[(1 LSH 30)], ARY2B=[(1 LSH 29)],
00400		ARRY=[('24 LSH 23)];
00500	DEFINE GETTYPE(A)=[((A) LAND (ITEMB+('77 LSH 23)))],INTEGR=[(5 LSH 23)],
00600		FLOTNG=[(4 LSH 23)],STRNG=[(3 LSH 23)],LBLTYP=[('16 LSH 23)],
00700		CTXTYP=[('13 LSH 23)],RCLTYP=[('17 LSH 23)],LSTYPE=[(7 LSH 23)],
00800		SETYPE=[(6 LSH 23)],NOTYPE=[(1 LSH 23)],ITVTYP=[('20 LSH 23)],
00900		RECTYP=[('15 LSH 23)],RNGTYP=[('22 LSH 23)];
01000	
01100	PRELOAD!WITH 0; INTEGER #$FSTR;
01200	PRELOAD!WITH 0; INTEGER #$PROU;
01300	
01400	SIMPLE PROCEDURE SWAP!FSTR; GOGTAB[$$FSTR] SWAP #$FSTR;
01500	
01600	SIMPLE PROCEDURE SWAP!PROU; GOGTAB[$$PROU] SWAP #$PROU;
01700	
01800	SIMPLE PROCEDURE $PLBL(INTEGER CHAN,LOC); BEGIN
01900	SWAP!FSTR; CPRINT(CHAN,"'"&CVOS(RIGHT(LOC))); SWAP!FSTR END;
02000	
02100	SIMPLE PROCEDURE $PARY(INTEGER CHAN,LOC); BEGIN "$PARY"
02200	INTEGER I;
02300	SWAP!FSTR; LOC_RIGHT(MEMORY[LOC])-(IF GETTYPE(LOC)=(ARRY+STRNG) THEN 1 ELSE 0);
02400	IF LOC LEQ 0 THEN CPRINT(CHAN,"Deallocated array") ELSE BEGIN
02500	    CPRINT(CHAN,"<array>["); FOR I_1 UPTO ABS(MEMORY[LOC-1] ASH -18) DO
02600	    CPRINT(CHAN," ",MEMORY[LOC-3*I-1],":",MEMORY[LOC-3*I]); CPRINT(CHAN,"]"); END;
02700	SWAP!FSTR END "$PARY";
02800	
02900	SUPERCOMMENT([	# use $PREC to get $CLASS.nnnnn for the moment;
03000	SIMPLE PROCEDURE $PRCL(INTEGER CHAN,LOC); BEGIN "$PRCL"
03100	SWAP!FSTR; CPRINT(CHAN,MEMSTRING(MEMORY[LOC+4])); SWAP!FSTR END "$PRCL";])
03200	
03300	SIMPLE PROCEDURE MYPRINT(INTEGER CHAN; STRING S); ADDSTR(S);
03400	
03500	SIMPLE STRING PROCEDURE FSTR(STRING STR);
03600	START!CODE LABEL LOOP,INNER,BOT; EXTERNAL INTEGER STRNGC;
03700	    # EXTERNAL INTEGER REMCHR,TOPBYT,GOGTAB;
03800	DEFINE BP=['14],T=[1],QUOTE=['042],USER=['15],CNT=['13],OBP=[2],F=['12];
03900		SKIPE	SSF;
04000		 JRST	BOT;		# SPECIAL STRING MODE, DONT FIDDLE;
04100		HRRZ	T,-1(SP);	# CHAR COUNT;
04200		ADDI	T,2(T);		# POTENTIALLY THIS MANY CHARS GO OUT;
04300		MOVE	USER,GOGTAB;
04400		MOVEM	F,RACS+F(USER);	# KEEP STRNGC HAPPY;
04500		ADDM	T,REMCHR(USER);
04600		SKIPL	REMCHR(USER);
04700		 PUSHJ	P,STRNGC;	# THE OUT-OF-SPACE DANCE;
04800			HRRZ	CNT,-1(SP);
04900		MOVE	BP,TOPBYT(USER);
05000		MOVE	OBP,BP;		# REMEMBER WHERE WE STARTED;
05100		EXCH	BP,(SP);
05200		MOVEI	T,QUOTE;
05300		JRST	INNER;
05400	    LOOP:ILDB	T,BP;
05500		IDPB	T,(SP);
05600		CAIN	T,QUOTE;
05700	    INNER:IDPB	T,(SP);
05800		CAIN	T,QUOTE;
05900		 AOS	-1(SP);
06000		SOJGE	CNT,LOOP;
06100		MOVEI	T,QUOTE;
06200		IDPB	T,(SP);
06300		AOS	-1(SP);
06400		EXCH	OBP,(SP);
06500		MOVEM	OBP,TOPBYT(USER);
06600	    BOT:POPJ	P,;
06700	END;
06800	
06900	SIMPLE PROCEDURE PREFIT(INTEGER CHAN,REFIT); BEGIN "PREFIT"
07000	# CPRINT(CHAN,MEMORY[REFIT,TYPE(REFIT)]);
07100	INTEGER TYPE;
07200	START!CODE
07300	EXTERNAL INTEGER $PSTR,$PREL,$PINT,$PSET,$PLST,$PITM,$PREC;
07400	LABEL JTAB,NARRY,LAB1,LAB2; DEFINE R=['13],S=['14],T=['15], L40=[0+('40 LSH 18)];
07500		MOVE	R,REFIT;
07600		LDB	T,[('270600 LSH 18)+R];	# 6 BIT TYPE;
07700		CAIGE	T,0+ARRY LSH -23;
07800		 JRST	NARRY;
07900		MOVEI	T,'11;		# RECODE ARRAYS TO '11;
08000		TLZ	R,'20+(ITEMB LSH -18);	# AND IGNORE ITEMness AND INDIRECT;
08100		JRST	LAB1;
08200	NARRY:
08300		CAIL	T,8;		# 8,9,10,11,12 ARE DATUMS OF STRANGE ITEMS;
08400		CAILE	T,12;
08500		 JRST	LAB2;
08600		MOVEI	T,'16;		# FAKE TYPE LABEL, PRINT IN OCTAL;
08700		JRST	LAB1;
08800	LAB2:	TLNE	R,0+ITEMB LSH -18;
08900		 MOVEI	T,'10;		# RECODE ITEMS TO '10;
09000	LAB1:
09100		CAIGE	T,3;
09200		 MOVEI	T,'16;		# 0,1,2 STRANGE. USE OCTAL;
09300		CAILE	T,'11;
09400		 SUBI	T,3;		# CONDENSE RANGE TO 3:'11,('15-3):('17-3);
09500		MOVEM	T,TYPE;
09600		PUSH	P,CHAN;		# WHICH CHANNEL TO USE;
09700		HLLZ	S,JTAB(T);	# NOW WORRY ABOUT ARGUMENT;
09800		LSH	S,-1;		# WHETHER DO GO DIRECT OR INDIRECT;
09900		HRRI	S,R;
10000		PUSH	P,@S;		# STACK THING TO PRINT;
10100		CAIN	T,'14;
10200		 HRRZS	(P);		# TURN RCLASS DSCR INTO PLAIN RPTR;
10300		CAIN	T,0+STRNG LSH -23;
10400		 PUSHJ	P,MEMSTRING;	# GET STRING ON CORRECT STACK;
10500		PUSHJ	P,@JTAB(T);	# FORMAT AND DISPOSE;
10600		MOVE	T,TYPE;		# CPRINT BUILTINS DON'T REMOVE CHANNEL FROM STACK;
10700		CAIE	T,'11;		# BUT $PARY;
10800		CAIN	T,'13;		# AND $PLBL;
10900		SKIPA;			# AREN'T BUILTIN, HAVE ALREADY REMOVED CHANNEL;
11000	JTAB:	 POP	P,(P);		# SO MUST DO IT HERE;
11100		SUB	P,['3000003];
11200		JRST	@3(P);
11300		0	$PSTR;	# 3;
11400		L40	$PREL;	# 4;
11500		L40	$PINT;	# 5;
11600		L40	$PSET;	# 6;
11700		L40	$PLST;	# 7;
11800		L40	$PITM;	# '10;
11900			0	$PARY;	# '11;
12000		L40	$PREC;	# '15;
12100		0	$PLBL;	# '16;
12200		0	$PREC;	# '17;
12300		END;
12400	END "PREFIT";
12500	
12600	SIMPLE PROCEDURE WR!TON(INTEGER DSCR); BEGIN "WR!TON"
12700	INTEGER FSTR$#;
12800	    SIMPLE PROCEDURE SWFSTR; GOGTAB[$$FSTR] SWAP FSTR$#;
12900	FSTR$#_RIGHT(LOCATION(FSTR)); #$PROU_LOCATION(MYPRINT);
13000	SWFSTR; SWAP!PROU; ADDSTR("   "); PREFIT(0,DSCR); SWAP!PROU; SWFSTR END "WR!TON";
     
00100	# OPERATOR CODES, REFITEM TYPE DEFINITIONS;
00200	DEFINE A(B)=[CVASC("] & [B] & [")];
00300	PRESET!WITH
00400		A(ABS),0,0,	A(AND),0,0,	A(ANY),0,0,	A(ASH),0,0,
00500		A(ASSOC),0,0,	A(CPRIN),A(T),0,A(DATUM),0,0,	A(DIV),0,0,
00600		A(EQV),0,0,	A(FALSE),0,0,	A(FOR),0,0,	A(GEQ),0,0,
00700		A(IN),0,0,	A(INF),0,0,	A(INTER),0,0,	A(LAND),0,0,
00800		A(LENGT),A(H),0,A(LEQ),0,0,	A(LNOT),0,0,	A(LOCAT),A(ION),0,
00900		A(LOR),0,0,	A(LSH),0,0,	A(MAX),0,0,	A(MIN),0,0,
01000		A(MOD),0,0,	A(NEQ),0,0,	A(NEW!R),A(ECORD),0,
01100								A(NIL),0,0,
01200		A(NOT),0,0,	A(NULL),0,0,	A(NULL!),A(RECOR),A(D),
01300								A(OR),0,0,
01400		A(PHI),0,0,	A(PRINT),0,0,	A(PROPS),0,0,	A(ROT),0,0,
01500		A(SETC),0,0,	A(SETO),0,0,	A(SWAP),0,0,	A(TO),0,0,
01600		A(TRUE),0,0,	A(UNION),0,0,	A(XOR),0,0;
01700	INTEGER ARRAY RWORD0[0:128];
01800	REDEFINE A=[NOMAC A];
01900	
02000	PRESET!WITH
02100		'120,		'004,		'142,		'101,
02200		'140,		'147,		'126,		'102,
02300		'036,		'103,		'121,		'035,
02400		'006,		'016,		'022,		'104,
02500		'144,		'034,		'105,		'145,
02600		'106,		'107,		'110,		'111,
02700		'112,		'033,		'151,		'132,
02800		'005,		'114,		'143,		'037,
02900		'131,		'150,		'127,		'115,
03000		STANFO(['176,])
03100		DEC([	'175,])
03200		TENX([	'175,])	'173,		'027,		'122,
03300		'117,		'023,		'026,	0;
03400	INTEGER ARRAY RWORD1[0:43];
03500	DEFINE N!RWORD=[43];
03600	
03700	DEFINE Q1=[LSH 27+], Q2=[LSH 18+], Q3=[LSH 9+], Q4=[];
03800	
03900	PRESET!WITH 
04000	# '000;	0,
04100	# '001;	0,
04200	# '002;	0,
04300	# '003;	0,
04400	# '004;	0,	# 220 Q1	222 Q2	002 Q3	000 Q4,	# AND;
04500	# '005;	232 Q1	230 Q2	001 Q3	000 Q4,	# NOT;
04600	# '006;	240 Q1	242 Q2	002 Q3	006 Q4,	# IN;
04700	# '007;	0,
04800	# '010;	0,
04900	# '011;	0,
05000	# '012;	0,
05100	# '013;	0,
05200	# '014;	0,
05300	# '015;	0,
05400	# '016;	300 Q1	302 Q2	000 Q3	007 Q4,	# INF;
05500	# '017;	272 Q1	449 Q2	001 Q3	000 Q4,	# PARTIAL "", EQUIVALENT TO "DATUM";
05600	# '020;	0,
05700	# '021;	0,
05800	# '022;	220 Q1	222 Q2	002 Q3	008 Q4,	# INTER;
05900	# '023;	210 Q1	212 Q2	002 Q3	008 Q4,	# UNION;
06000	# '024;	0,
06100	# '025;	0,
06200	# '026;	250 Q1	252 Q2	002 Q3	010 Q4,	# XOR;
06300	# '027;	310 Q1	312 Q2	002 Q3	000 Q4,	# SWAP;
06400	# '030;	0,
06500	# '031;	0,
06600	# '032;	0,
06700	# '033;	240 Q1	242 Q2	002 Q3	012 Q4,	# NEQ;
06800	# '034;	220 Q1	222 Q2	002 Q3	012 Q4,	# LEQ;
06900	# '035;	240 Q1	242 Q2	002 Q3	012 Q4,	# GEQ;
07000	# '036;	250 Q1	252 Q2	002 Q3	010 Q4,	# EQV;
07100	# '037;	0,	# 210 Q1	212 Q2	002 Q3	000 Q4,	# OR;
07200	# '040;	0,
07300	# '041;	0,
07400	# '042;	0,
07500	# '043;	0,
07600	# '044;	0,
07700	# '045;	260 Q1	262 Q2	002 Q3	009 Q4,	# COMPATIBLE DIVIDE;
07800	# '046;	260 Q1	262 Q2	002 Q3	003 Q4,	# CAT "&";
07900	# '047;	0,
08000	# '050;	480 Q1	000 Q2	000 Q3	000 Q4,	# LEFT PARENTHESIS "(";
08100	# '051;	000 Q1	480 Q2	000 Q3	000 Q4,	# RIGHT PARENTHESIS ")";
08200	# '052;	260 Q1	262 Q2	002 Q3	009 Q4,	# TIMES "*";
08300	# '053;	250 Q1	252 Q2	002 Q3	009 Q4,	# PLUS "+";
08400	# '054;	048 Q1	102 Q2	000 Q3	000 Q4,	# COMMA ",";
08500	# '055;	250 Q1	252 Q2	002 Q3	009 Q4,	# MINUS "-";
08600	# '056;	0,
08700	# '057;	260 Q1	262 Q2	002 Q3	002 Q4,	# DIVIDE "/";
08800	# '060;	0,
08900	# '061;	0,
09000	# '062;	0,
09100	# '063;	0,
09200	# '064;	0,
09300	# '065;	0,
09400	# '066;	0,
09500	# '067;	0,
09600	# '070;	0,
09700	# '071;	0,
09800	# '072;	448 Q1	450 Q2	002 Q3	010 Q4,	# COLON ":";
09900	# '073;	040 Q1	480 Q2	000 Q3	000 Q4,	# SEMICOLON ;
10000	# '074;	240 Q1	242 Q2	002 Q3	012 Q4,	# LESS THAN SIGN "<";
10100	# '075;	240 Q1	242 Q2	002 Q3	012 Q4,	# EQUALS "=";
10200	# '076;	240 Q1	242 Q2	002 Q3	012 Q4,	# GREATER THAN SIGN ">";
10300	# '077;	0,
10400	# '100;	0,
10500	# '101;	260 Q1	262 Q2	002 Q3	005 Q4,	# ASH;
10600	# '102;	260 Q1	262 Q2	002 Q3	001 Q4,	# DIV;
10700	# '103;	504 Q1	504 Q2	000 Q3	000 Q4,	# FALSE;
10800	# '104;	250 Q1	252 Q2	002 Q3	000 Q4,	# LAND;
10900	# '105;	272 Q1	270 Q2	001 Q3	000 Q4,	# LNOT;
11000	# '106;	250 Q1	252 Q2	002 Q3	000 Q4,	# LOR;
11100	# '107;	260 Q1	262 Q2	002 Q3	005 Q4,	# LSH;
11200	# '110;	240 Q1	242 Q2	002 Q3	009 Q4,	# MAX;
11300	# '111;	240 Q1	242 Q2	002 Q3	009 Q4,	# MIN;
11400	# '112;	260 Q1	262 Q2	002 Q3	001 Q4,	# MOD;
11500	# '113;	0,
11600	# '114;	504 Q1	504 Q2	000 Q3	000 Q4,	# NULL;
11700	# '115;	260 Q1	262 Q2	002 Q3	005 Q4,	# ROT;
11800	# '116;	0,
11900	# '117;	504 Q1	504 Q2	000 Q3	000 Q4,	# TRUE;
12000	# '120;	272 Q1	270 Q2	001 Q3	000 Q4,	# ABS;
12100	# '121;	110 Q1	108 Q2	002 Q3	001 Q4,	# FOR (SUBSTRINGER);
12200	# '122;	110 Q1	108 Q2	002 Q3	001 Q4,	# TO (SUBSTRINGER);
12300	# '123;	272 Q1	270 Q2	000 Q3	000 Q4,	# UNARY MINUS (SPECIAL);
12400	# '124;	272 Q1	270 Q2	000 Q3	000 Q4,	# ARRAY REFERENCE;
12500	# '125;	272 Q1	270 Q2	002 Q3	001 Q4,	# MEMORY;
12600	# '126;	272 Q1	449 Q2	001 Q3	000 Q4,	# DATUM;
12700	# '127;	272 Q1	270 Q2	001 Q3	000 Q4,	# PROPS;
12800	# '130;	272 Q1	270 Q2	000 Q3	000 Q4,	# PERFORM STUBSTRINGING;
12900	# '131;	504 Q1	504 Q2	000 Q3	000 Q4,	# PHI;
13000	# '132;	504 Q1	504 Q2	000 Q3	000 Q4,	# NIL;
13100	# '133;	448 Q1	000 Q2	000 Q3	000 Q4,	# LEFT BRACKET [;
13200	# '134;	0,
13300	# '135;	000 Q1	448 Q2	000 Q3	000 Q4,	# RIGHT BRACKET ];
13400	# '136;	270 Q1	272 Q2	002 Q3	009 Q4,	# UP ARROW "^";
13500	# '137;	440 Q1	050 Q2	002 Q3	004 Q4,	# GETS "_";
13600	# '140;	100 Q1	102 Q2	002 Q3	010 Q4,	# ASSOC "`";
13700	# '141;	272 Q1	270 Q2	001 Q3	000 Q4,	# RECORD SUBFIELD REFERENCE;
13800	# '142;	504 Q1	504 Q2	000 Q3	000 Q4,	# ANY;
13900	# '143;	504 Q1	504 Q2	000 Q3	000 Q4,	# NULL!RECORD;
14000	# '144;	272 Q1	270 Q2	001 Q3	000 Q4,	# LENGTH;
14100	# '145;	272 Q1	270 Q2	001 Q3	011 Q4,	# LOCATION;
14200	# '146;	100 Q1	448 Q2	000 Q3	000 Q4,	# LSTC "~~";
14300	# '147;	272 Q1	270 Q2	000 Q3	000 Q4,	# CPRINT;
14400	# '150;	272 Q1	270 Q2	000 Q3	000 Q4,	# PRINT;
14500	# '151;	272 Q1	270 Q2	001 Q3	000 Q4,	# NEW!RECORD;
14600	# '152;	0,
14700	# '153;	0,
14800	# '154;	0,
14900	# '155;	0,
15000	# '156;	0,
15100	# '157;	0,
15200	# '160;	0,
15300	# '161;	0,
15400	# '162;	0,
15500	# '163;	0,
15600	# '164;	0,
15700	# '165;	0,
15800	# '166;	0,
15900	# '167;	0,
16000	# '170;	0,
16100	# '171;	0,
16200	# '172;	0,
16300	# '173;	448 Q1	100 Q2	000 Q3	000 Q4,	# SETO "{";
16400	# '174;	0,
16500	STANFO([
16600	# '175;	0,
16700	# '176;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "~";
16800	]) # STANFO;
16900	DEC([
17000	# '175;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "~";
17100	# '176;	0,
17200	]) # DEC;
17300	TENX([
17400	# '175;	100 Q1	448 Q2	000 Q3	000 Q4,	# SETC "~";
17500	# '176;	0,
17600	]) # TENX;
17700	# '177;	000 Q1	001 Q2	000 Q3	000 Q4;	# END-OF-FILE;
17800	INTEGER ARRAY OPS1[0:'177];
17900		# CHAR CODE FOR OPERATOR, LEFT BINDING POWER, RIGHT BINDING POWER,
18000		  DEGREE (NULLARY, UNARY, BINARY), AND CONFORMITY CLASS;
18100	DEFINE OPMEMORY=['125],OPARRY=['124],OPSUBST=['130],OPCOMMA=[","],OPSUBFLD=['141],
18200		OPLSTC=['146],RBNDCOMMA=[102];
18300	DEFINE N!OPS=['200];
18400	
18500	
18600	DEFINE REFMEMORY=[(REFB+ARRY+NOTYPE)+'777777];
18700	
18800	# FOR HAND CODING, THE REFxxx CONSTRUCTS HAVE BEEN REPLACED BY SOME 
18900	  FIDDLING ON P. 14;
19000	NOHAND([
19100	DEFINE REFTRACE=[(PROCB+PDFIND(LOCATION(TRACE)))],
19200		REFBREAK=[(PROCB+PDFIND(LOCATION(BREAK)))],
19300		REFCOORD=[(PROCB+STRNG+PDFIND(LOCATION(COORD)))],
19400		REFUNTRACE=[(PROCB+PDFIND(LOCATION(UNTRACE)))],
19500		REFUNBREAK=[(PROCB+PDFIND(LOCATION(UNBREAK)))],
19600		REFSETLEX=[(PROCB+PDFIND(LOCATION(SETLEX)))],
19700		REF!!STEP=[(PROCB+PDFIND(LOCATION(!!STEP)))],
19800		REF!!GSTEP=[(PROCB+PDFIND(LOCATION(!!GSTEP)))],
19900		REF!!GOTO=[(PROCB+PDFIND(LOCATION(!!GOTO)))],
20000		REF!!ARGS=[(PROCB+STRNG+PDFIND(LOCATION(!!ARGS)))],
20100		REF!!TEXT=[(PROCB+STRNG+PDFIND(LOCATION(!!TEXT)))],
20200		REFSHOW=[(PROCB+STRNG+PDFIND(LOCATION(SHOW)))],
20300		REFHELP=[(PROCB+STRNG+PDFIND(LOCATION(HELP)))],
20400		REFTRAPS=[(PROCB+STRNG+PDFIND(LOCATION(TRAPS)))],
20500		REF!!UP=[(PROCB+PDFIND(LOCATION(!!UP)))],
20600		REFSETSCOPE=[(PROCB+PDFIND(LOCATION(SETSCOPE)))],
20700		REF!!DEFINE=[(PROCB+PDFIND(LOACTION(!!DEFINE)))],
20800		REFDDT=[(PROCB+PDFIND(LOCATION(DDT)))];
20900	]) # NOHAND;
21000	DEFINE F=[('12 LSH 18)], INDIR=[(1 LSH 22)];
21100	
21200	
21300	PRESET!WITH	0,		# BSIMPLE;
21400	ARRY+INDIR,			# BARRY;
21500			ITEMB,		# BITMV---ITEMVAR;
21600			ITEMB+  ARY2B,	# BARITM--ITEMVAR WHOSE DATUM IS AN ARRAY;
21700	ARRY+INDIR+	ITEMB,		# BITMAR--ARRAY OF ITEMVARS;
21800	ARRY+INDIR+	ITEMB+	ARY2B,	# BARITA--ARRAY OF ITEMVARS WHOSE  ARE ARRAYS;
21900				PROCB,	# BPROCED;
22000			ITEMB;		# BITEM;
22100	INTEGER ARRAY COMPLEXTYPE[0:7];
22200	
22300	PRESET!WITH 0,INTEGR,FLOTNG,STRNG,LSTYPE,SETYPE,
22400		ARRY,LBLTYP,RECTYP,RCLTYP;
22500	INTEGER ARRAY SIMPLETYPE[0:9];
22600	# BLAMDA,BINTGR,BREAL,BSTRNG,BLIST,BSET,BCNTXT,BLABEL,BRPNTR,BRCLAS;
22700	
22800	PRESET!WITH	0,	# BBILTN;
22900		F+	INDIR,	# BREF;
23000			0,	# BALLOC. ZERO FOR SETS, LISTS. ARRAYS GET  INDIR  SET
23100						BY COMPLEXTYPE;
23200		F,		# BSTAK;
23300		0,		# BEXTRN;
23400		PROCB,		# BXPROC;
23500		PROCB;		# BBLTPRC;
23600	INTEGER ARRAY ACCESSTYPE[0:6];
23700	
23800	PRESET!WITH
23900		'260000000000,	# PUSHJ;
24000		'263000000000,	# POPJ;
24100		'254020000000,	# JRST @;
24200		'254000000000,	# JRST;
24300		'320000000000,	# JUMPx;
24400		'265000000000,	# JSP;
24500		'344000000000,	# AOJA;
24600		'364000000000;	# SOJA;
24700	INTEGER ARRAY STEPINSTR[0:7];
24800	PRESET!WITH
24900		'777000000000,
25000		'777000000000,
25100		'777020000000,
25200		'777000000000,
25300		'770000000000,
25400		'777000000000,
25500		'777000000000,
25600		'777000000000;
25700	INTEGER ARRAY STEPMASK[0:7];
25800	
25900	PRESET!WITH
26000		'263000000000,	# POPJ;
26100		'254020000000,	# JRST @;
26200		'254000000000,	# JRST;
26300		'320000000000,	# JUMPx;
26400		'265000000000,	# JSP;
26500		'344000000000,	# AOJA;
26600		'364000000000;	# SOJA;
26700	INTEGER ARRAY GSTEPINSTR[0:6];
26800	PRESET!WITH
26900		'777000000000,
27000		'777020000000,
27100		'777000000000,
27200		'770000000000,
27300		'777000000000,
27400		'777000000000,
27500		'777000000000;
27600	INTEGER ARRAY GSTEPMASK[0:6];
27700	
27800	INTEGER ARRAY NAME[0:2];
27900	
28000	
28100	
28200	FORWARD PROCEDURE BREAK(STRING LOCNAME,COND(""),ACT(""); INTEGER MPC(0));
28300	FORWARD PROCEDURE TRACE(STRING PROCNAME);
28400	FORWARD PROCEDURE UNBREAK(STRING LOCNAME);
28500	FORWARD STRING PROCEDURE COORD(STRING LOCNAME);
28600	FORWARD PROCEDURE UNTRACE(STRING PROCNAME);
28700	FORWARD SIMPLE INTERNAL PROCEDURE BAIL;
28800	NOTENX([FORWARD SIMPLE INTERNAL PROCEDURE DDBAIL;])
28900	FORWARD STRING PROCEDURE HELP;
29000	FORWARD PROCEDURE DDT;
29100	FORWARD STRING PROCEDURE TRAPS;
29200	EXTERNAL RECURSIVE PROCEDURE SETLEX(INTEGER DEPTH);
29300	EXTERNAL PROCEDURE !!STEP;
29400	EXTERNAL PROCEDURE !!GOTO;
29500	EXTERNAL PROCEDURE !!GSTEP;
29600	EXTERNAL PROCEDURE !!UP(INTEGER LEVEL);
29700	EXTERNAL PROCEDURE SETSCOPE(ITEMVAR PROCITM);
29800	EXTERNAL STRING PROCEDURE !!ARGS;
29900	EXTERNAL STRING PROCEDURE !!TEXT;
30000	FORWARD STRING PROCEDURE SHOW(INTEGER FIRST,LAST(0)); 
30100	FORWARD PROCEDURE !!DEFINE(INTEGER CHAR; STRING MAC);
     
00100	# TYPEMUNGE;
00200	SIMPLE INTEGER PROCEDURE TYPEMUNGE(INTEGER D,LZERO,HZERO); BEGIN "TYPIT"
00300	# CONVERT FROM BAIL TYPES TO REFITEM DATUMS. SIMPLE PROCEDURES WILL HAVE
00400	  THE "TEMPORARY" BIT ON IN THEIR REFITEMS;
00500	NOHAND([
00600	INTEGER COMPLX,SIMPL,ACCES,LBITS,RBITS,SW;
00700		
00800	
00900	COMPLX_D LSH -18 LAND '7; SIMPL_(D LSH -21 LAND '7) LOR (D LSH -25 LAND '10);
01000	ACCES_D LSH -24 LAND '7;
01100	LBITS_COMPLEXTYPE[COMPLX] + SIMPLETYPE[SIMPL] LOR ACCESSTYPE[ACCES] LOR REFB;
01200	# SPECIAL TEST FOR PROCEDURES;
01300	IF D LAND '200000000000 THEN LBITS _ LBITS LOR PROCB;
01400	# CHECK FOR SIMPLE PROCEDURES;
01500	IF D<0 THEN LBITS_LBITS LOR (1 LSH 35); 
01600	# DISTINGUISH BETWEEN ITEMS 
01700	AND ITEMVARS.
01800	  ITEMS WILL HAVE LBITS=REFB+ITEMB, RBITS=ITEM NUMBER,
01900	  ITEMVARS WILL HAVE LBITS=REFB+ITEMB+TYPE CODE, RBITS=ADDR;
02000	IF (COMPLX=2 OR COMPLX=4) # BITMV OR BITMAR; AND SIMPL=0 THEN LBITS_LBITS + NOTYPE;
02100	RBITS_RIGHT(D);
02200	]) # NOHAND;
02300	HAND([
02400	START!CODE LABEL XHRELOC,NRELOC,JTAB,XBBILTN,XBXPROC,BOT1,UNALLOC;
02500	DEFINE COMPLX=[2],SIMPL=[3],ACCES=[4],LNK=[5];
02600		MOVE	1,D;
02700		LDB	COMPLX,['220300000001];
02800		LDB	SIMPL,['250300000001];
02900		TLNE	1,'2000;
03000		 ADDI	SIMPL,8;
03100		LDB	ACCES,['300300000001];
03200		HLL	1,SIMPLETYPE[0](SIMPL);
03300		TLO	1,0+REFB LSH -18;
03400		ADD	1,COMPLEXTYPE[0](COMPLX);
03500		IOR	1,ACCESSTYPE[0](ACCES);
03600		SKIPGE	D;
03700		 TLO	1,'400000;
03800		EXCH	2,D;
03900		TLNE	2,'200000;
04000		 TLO	1,'20000;
04100		EXCH	2,D;
04200		CAIE	COMPLX,2;
04300		CAIN	COMPLX,4;
04400		 SKIPE	SIMPL;
04500		 SKIPA;
04600		ADD	1,[NOTYPE];
04700	]) # HAND;
04800	NOHAND([
04900	# NOW CORRECT THE ADDRESS. WATCH OUT FOR ITEMS, PROCEDURES, LABELS,
05000	  AND HIGHSEG ARRAYS. ALSO PARAMETERS AND RECURSIVE LOCALS.
05100	  ALSO, IF THE ADDRESS IS ZERO, DON'T CHANGE IT.  THIS OCCURS FOR VARIABLES
05200	  WHICH ARE DECLARED BUT NEVER USED OR INTERNALED. CONSEQUENTLY THEY ARE NOT
05300	  ALLOCATED.  THIS IS A FEATURE OF SAIL;
05400	IF COMPLX NEQ 7 # BITEM; AND RBITS NEQ 0 THEN RBITS_CASE ACCES OF (
05500	  #[0]BBILTN;	IF LBITS LAND PROCB OR COMPLX=6 OR SIMPL=7 OR
05600			    ((GETTYPE(LBITS) GEQ ARRY) AND (RBITS LAND '400000))
05700			THEN HRELOC(RBITS) ELSE LRELOC(RBITS),
05800	  #[1]BREF;	RBITS LAND '377777,
05900	  #[2]BALLOC;	LRELOC(RBITS),
06000	  #[3]BSTAK;	RBITS,
06100	  #[4]BEXTRN;	RIGHT(MEMORY[HRELOC(RBITS)]),
06200	  #[5]BXPROC;	RIGHT(MEMORY[HRELOC(RBITS)]),
06300	  #[6]BBLTPRC;	HRELOC(RBITS)			);
06400	]) # NOHAND;
06500	HAND([
06600		TRNE	1,-1;		# IF ZERO ADDRESS;
06700		CAIN	COMPLX,7;	# OR ITEM;
06800		 JRST	UNALLOC;	# DON'T MANGLE;
06900		XCT	JTAB(ACCES);
07000		JRST	NRELOC;
07100	JTAB:	JRST	XBBILTN;
07200		ANDCMI	1,'400000;
07300		ADD	1,LZERO;
07400		JFCL;
07500		JRST	XBXPROC;
07600		JRST	XBXPROC;
07700		ADD	1,HZERO;
07800	XBBILTN:TLNE	1,'20000;
07900		 JRST	XHRELOC;
08000		CAIE	COMPLX,6;
08100		CAIN	SIMPL,7;
08200		 JRST	XHRELOC;
08300		HLRZ	5,1;
08400		ANDI	5,'77 LSH 5;
08500		CAIL	5,0+ARRY LSH -18;	# IF TYPE GEQ ARRY;
08600		TRNN	1,'400000;	# AND FLAG;
08700		SKIPA	5,LZERO;	# ELSE LRELOC;
08800	XHRELOC:MOVE	5,HZERO;	# THEN HRELOC;
08900		ADDI	1,(5);
09000		JRST	NRELOC;
09100	XBXPROC:ADD	1,HZERO;
09200		HRR	1,(1);		# SUBSTITUTE BITS;
09300	NRELOC:
09400	]) # HAND;
09500	NOHAND([
09600	IF ACCES=5 THEN RBITS_PDFIND(RBITS);
09700	
09800	# SHOULDN'T HAVE TO DO THIS. KLUGE TO FIX A BUG SOMEWHERE;
09900	# 7-11-76 EXTERNAL STRINGS ALSO REFER TO FIRST WORD;
10000	IF NOT (LBITS LAND PROCB) # procedure; AND
10100	     SIMPL=3 # BSTRNG; AND (ACCES=0 # BBILTN; OR ACCES=4 # BEXTRN;)
10200	     AND COMPLX=0 # BSIMPL; AND RBITS NEQ 0 THEN RBITS_RBITS+1;
10300	RETURN(LBITS LOR RBITS) 
10400	]) # NOHAND;
10500	HAND([
10600		CAIE	ACCES,5;
10700		 JRST	BOT1;
10800		PUSH	P,1;		# SAVE A COPY OF LEFT HALF BITS;
10900		PUSH	P,1;		# ENTRY ADDR;
11000		PUSHJ	P,PDFIND;
11100		HLL	1,(P);		# INSERT SAVED LEFT HALF BITS;
11200		POP	P,(P);		# ADJUST STACK;
11300		JRST	UNALLOC;
11400	BOT1:	TLNE	1,'20000;	# PROCEDURE;
11500		JRST	UNALLOC;
11600		JUMPN	COMPLX,UNALLOC;
11700		CAIE	ACCES,4;	# BEXTRN;
11800		JUMPN	ACCES,UNALLOC;
11900		CAIN	SIMPL,3;
12000		 ADDI	1,1;
12100	UNALLOC:SUB	P,['4000004];
12200		JRST	@4(P);
12300	END;]) # HAND;
12400	END "TYPIT";
     
00100	# INSERT;
00200	SIMPLE INTEGER PROCEDURE INSERT(INTEGER TYPE,FATHER,DATA; INTEGER ARRAY NAME);
00300	BEGIN "INSERT"
00400	NOHAND([
00500	INTEGER K,I;
00600	
00700	# HASH TO FIND BUCKET;
00800	K_ABS(NAME[0] MOD 31);
00900	
01000	IF L!NAME+5 GEQ N!NAME THEN EXTND(C!NAME,N!NAME,500);
01100	L!NAME_L!NAME+1;
01200	T!NAME(L!NAME)_T!NAME(K) LOR (FATHER LSH 18) LOR (TYPE LSH 34);
01300	T!NAME(K)_L!NAME;	# CHAINING;
01400	T!NAME(L!NAME+1)_DATA; FOR I_0 UPTO 2 DO T!NAME(L!NAME+2+I)_NAME[I];
01500	L!NAME_L!NAME+4;
01600	RETURN(L!NAME-4)
01700	]) # NOHAND;
01800	HAND([
01900	START!CODE LABEL ROOM; DEFINE I=[1],K=[2],T=[0],LN=[3],T2=[4];
02000		MOVE	T,L!NAME;
02100		ADDI	T,5;
02200		CAMGE	T,N!NAME;
02300		 JRST	ROOM;
02400		MOVEI	T,C!NAME;
02500		PUSH	P,T;
02600		MOVEI	T,N!NAME;
02700		PUSH	P,T;
02800		MOVEI	T,[500];
02900		PUSH	P,T;
03000		PUSHJ	P,EXTND;
03100	ROOM:	MOVE	I,@NAME;		# ABS(NAME[0]);
03200		IDIVI	I,31;
03300		MOVM	K,K;
03400		AOS	LN,L!NAME;
03500		ADD	K,C!NAME;
03600		ADD	LN,C!NAME;
03700		MOVE	T,(K);		# T!NAME(K);
03800		HRL	T,FATHER;	# LOR (FATHER LSH 18);
03900		MOVE	T2,TYPE;
04000		LSH	T2,34;
04100		IOR	T,T2;		# LOR (TYPE LSH 34);
04200		MOVEM	T,(LN);
04300		MOVEI	T,(LN);
04400		SUB	T,C!NAME;
04500		MOVEM	T,(K);		# CHAINING;
04600		MOVE	T,DATA;
04700		MOVEM	T,1(LN);
04800		HRLI	T,@NAME;	# FWA DATA;
04900		HRRI	T,2(LN);
05000		BLT	T,4(LN);	# XFER 3 WORD NAME;
05100		ADDI	LN,4;
05200		SUB	LN,C!NAME;
05300		MOVEM	LN,L!NAME;
05400		MOVEI	1,-4(LN);
05500		SUB	P,['5000005];
05600		JRST	@5(P);
05700	END;]) # HAND;
05800	END "INSERT";
     
00100	# FIND;
00200	SIMPLE INTEGER PROCEDURE FIND(INTEGER ARRAY NAME,LCHAIN; INTEGER LDEPTH,
00300				ANYNAM);
00400	BEGIN "FIND"
00500	NOHAND ([
00600	INTEGER K,I,FATHER,P!CACHE,HOMONYMN;
00700	DEFINE CURBLK=[LCHAIN[0]];
00800	
00900	# RETURN -1	 IF NAME NOT FOUND
01000		+PNTR	TO CACHE TABLE IF FOUND;
01100	# ANYNAM IS A FLAG.  FALSE MEANS MUST RETURN A VARIABLE OR A PROCEDURE.
01200	  TRUE MEANS THAT A BLOCKNAME IS ALLOWED;
01300	
01400	# CHECK CACHE FIRST;
01500	FOR I_0 STEP 5 UNTIL L!CACHE-4 DO BEGIN "SEARCH CACHE"
01600		K_-1; WHILE (K_K+1) LEQ 2 AND NAME[K]=CACHE[I+2+K] DO;
01700		IF K=3 AND RIGHT(CACHE[I])=RIGHT(LCHAIN[0]) AND
01800		    (ANYNAM OR (CACHE[I+1] LAND ('77 LSH 23 +PROCB+ITEMB)) NEQ 0)
01900		THEN BEGIN "CLIMB"
02000		IF I=0 THEN RETURN(0) ELSE FOR K_0 UPTO 4 DO
02100		  CACHE[I+K] SWAP CACHE[I+K-5]; RETURN(I-5) END"CLIMB"
02200	END "SEARCH CACHE";
02300	
02400	# COULD NOT FIND IT IN CACHE, LOOK IN REGULAR PLACE;
02500	HOMONYMN_0;
02600	K_PAGEIT(T!NAME,ABS(NAME[0] MOD 31));	# INITIAL HASH;
02700	WHILE K NEQ 0 DO BEGIN "CHAIN"
02800	    I_-1; WHILE(I_I+1)<3 AND NAME[I]=PAGEIT(T!NAME,K+2+I) DO;
02900	    IF I NEQ 3 THEN K_RIGHT(PAGEIT(T!NAME,K))	# FOLLOW DOWN CHAIN;
03000	    ELSE BEGIN "HOM"
03100		# FOUND A LIKE SPELLING;
03200		HOMONYMN_K; FATHER_LEFT(PAGEIT(T!NAME,K)) LAND '177777;
03300		I_-1; WHILE (I_I+1) LEQ LDEPTH AND LEFT(LCHAIN[I]) NEQ FATHER DO;
03400		IF I=LDEPTH+1 OR (NOT ANYNAM AND
03500			(PAGEIT(T!NAME,K+1) LAND (PROCB+ITEMB+('77 LSH 23))=0)	)
03600		    THEN K_RIGHT(PAGEIT(T!NAME,K))	# TRY AGAIN;
03700		ELSE BEGIN "GOTCHA"
03800		    # FOUND OUR MAN, SINCE INNER-MOST OCCURS FIRST IN CHAIN;
03900		    # PUT IN CACHE;
04000		    IF L!CACHE<N!CACHE-1 THEN BEGIN P!CACHE_L!CACHE+1; L!CACHE_
04100			L!CACHE+5 END ELSE P!CACHE_BOTTOM!SLOT;
04200		    FOR I_1 UPTO 4 DO CACHE[P!CACHE+I]_PAGEIT(T!NAME,K+I);
04300		    CACHE[P!CACHE]_LEFT(PAGEIT(T!NAME,K)) LSH 18 LOR RIGHT(CURBLK);
04400		    RETURN(P!CACHE)
04500		END "GOTCHA"
04600	    END "HOM"
04700	END "CHAIN";
04800	IF HOMONYMN AND ANYNAM THEN BEGIN
04900		    IF L!CACHE<N!CACHE-1 THEN BEGIN P!CACHE_L!CACHE+1; L!CACHE_
05000			L!CACHE+5 END ELSE P!CACHE_BOTTOM!SLOT;
05100		    FOR I_1 UPTO 4 DO CACHE[P!CACHE+I]_PAGEIT(T!NAME,K+I);
05200		    CACHE[P!CACHE]_LEFT(PAGEIT(T!NAME,K)) LSH 18 LOR RIGHT(CURBLK);
05300		    RETURN(P!CACHE) END;
05400	RETURN(-1)
05500	]) # NOHAND;
05600	HAND ([
05700	INTEGER RETVAL,HOMONYMN;
05800	START!CODE
05900	LABEL LOOP1,LSWAP,INC1,TEST1,LOOP2,LOOP3,BOTSLOT,RET,SUGAR,GOTCHA,LP3A;
06000	DEFINE N1=[2],N2=[3],N3=[4],I=[1],K=[5],CN=[6],FATHER=[8],LD=[9],T=[0],
06100	    PCACHE=['14],CURBLK=['15];
06200		HRLI	T,@NAME;	# ADDR OF FIRST DATA WORD IN  NAME;
06300		HRRI	T,N1;
06400		BLT	T,N3;		# GET THE NAME INTO N1,N2,N3;
06500		MOVE	I,L!CACHE;
06600		MOVEI	I,CACHE[0](I);
06700		HRRZ	CURBLK,@LCHAIN;	# RIGHT HALF OF LCHAIN[0];
06800		JRST	TEST1;
06900	LOOP1:	CAME	N1,2(I);	# FIRST 5 CHARS;
07000		 JRST	INC1;
07100		CAMN	N2,3(I);	# SECOND 5;
07200		CAME	N3,4(I);	# LAST 5;
07300		 JRST	INC1;
07400		HRRZ	T,0(I);		# BLOCK WHICH OWNS OBJECT IN CACHE;
07500		CAME	CURBLK,T;	# SAME AS CURRENT?;
07600		 JRST	INC1;		# NO;
07700		MOVE	T,1(I);		# TYPE BITS OF REFITEM DATUM;
07800		TLNN	T,'77 LSH 5 + ITEMB LSH -18 + PROCB LSH -18;
07900		SKIPE	ANYNAM;		# IF ONLY VAR OR ITEM OR PROC WILL DO;
08000		 SKIPA;			# IT'S OK;
08100		JRST	INC1;		# IT'S BAD;
08200		MOVEI	T,(I);		# POINT TO WORD 0, RELATIVE TO CACHE[0];
08300		SUBI	T,CACHE[0];
08400		MOVEM	T,RETVAL;
08500	# CLIMB;
08600		CAMN	T,L!CACHE;	# AT END ALREADY?;
08700		 JRST	RET;		# YES;
08800		MOVEI	K,5;		# SWAP 5 WORDS;
08900	LSWAP:	MOVE	T,(I);
09000		EXCH	T,5(I);
09100		MOVEM	T,(I);
09200		ADDI	I,1;
09300		SOJG	K,LSWAP;
09400		SUBI	I,CACHE[0];	# POINT TO WORD 0;
09500		MOVEM	I,RETVAL;
09600		JRST	RET;
09700	INC1:	SUBI	I,5;
09800	TEST1:	CAIL	I,CACHE[0];	# REACHED BOTTOM YET?;
09900		 JRST	LOOP1;		# NO;
10000	]) # HAND;
10100	HAND([
10200	# SEARCH NAME TABLE;
10300		SETOM	RETVAL;		# NOT FOUND;
10400		SETZM	HOMONYMN;
10500		SETZM	MULDEF;
10600		MOVE	CN,C!NAME;
10700		MOVE	T,N1;		# COMPUTE BUCKET NUMBER;
10800		IDIVI	T,31;
10900		MOVM	K,1;
11000		ADDI	K,(CN);
11100	LOOP2:	HRRZ	K,(K);		# DOWN ONE LINK IN CHAIN;
11200			JUMPE	K,SUGAR;	# LAST ONE;
11300		ADDI	K,(CN);		# GET MEMORY ADDRESS;
11400		CAME	N1,2(K);	# FIRST 5 CHARS MATCH?;
11500		 JRST	LOOP2;		# NO;
11600		CAMN	N2,3(K);
11700		CAME	N3,4(K);
11800		 JRST	LOOP2;
11900					# NEXT TWO COMMENTED OUT BY RHT;
12000		# MOVSS	HOMONYMN;	# SAVE ANYTHING THAT MIGHT BE THERE ALREADY;
12100		# HRRM	K,HOMONYMN;	# AND REMEMBER THIS ONE;
12200		LDB	FATHER,[('222000+K) LSH 18];
12300		MOVN	LD,LDEPTH;	# PREPARE FOR SEARCH ALONG LCHAIN;
12400		HRLI	LD,-1(LD);	# CONSTRUCT AOBJN POINTER IN LD;
12500		HRRI	LD,@LCHAIN;	# POINT TO LCHAIN[0];
12600	LOOP3:	HLRZ	T,(LD);
12700		CAME	FATHER,T;
12800		AOBJN	LD,LOOP3;
12900		# JUMPGE LD,LOOP2; # RHT -- CHANGES TO AVOID CONFUSION BY "SAME" OBJECTS;
13000		MOVE	T,1(K);		# TYPE BITS OF REFITEM DATUM;
13100		MOVE	FATHER,HOMONYMN;# IF 0 THEN TEST WITH AC1 WILL ALWAYS SKIP.;
13200		CAMN	T,1(FATHER);	# CURRENT REFITEM DATUM WITH PREVIOUS;
13300		JRST	LP3A;		# THEY ARE SAME, IGNORE THIS ONE;
13400		MOVSI	FATHER,(FATHER);# SAVE OLD IN LEFT HALF;
13500		HRRI	FATHER,(K);	# REMEMBER NEW;
13600		MOVEM	FATHER,HOMONYMN;# TUCK IT AWAY;
13700	LP3A:	JUMPGE	LD,LOOP2;	# IF AOBJN COUNTED OUT THEN ITERATE;
13800				   # RHT -- END OF PATCH;
13900		TLNN	T,'77 LSH 5 + ITEMB LSH -18 + PROCB LSH -18;
14000		SKIPE	ANYNAM;
14100		 SKIPA;
14200		JRST	LOOP2;
14300	GOTCHA:	MOVE	I,L!CACHE;
14400		CAIL	I,N!CACHE-5;
14500		 JRST	BOTSLOT;
14600		ADDI	I,5;
14700		MOVEM	I,L!CACHE;
14800		MOVEI	PCACHE,(I);
14900		SKIPA;
15000	BOTSLOT:SETZ	PCACHE,;
15100		MOVEM	PCACHE,RETVAL;
15200		HRLI	T,1(K);
15300		HRRI	T,CACHE[1](PCACHE);
15400		BLT	T,CACHE[4](PCACHE);
15500		HLL	CURBLK,(K);
15600		MOVEM	CURBLK,CACHE[0](PCACHE);
15700	RET:	MOVE	1,RETVAL;
15800		SUB	P,['5000005];
15900		JRST	@5(P);
16000	SUGAR:	SKIPN	K,HOMONYMN;	# IF SPELLING NOT FOUND;
16100		 JRST	RET;		# THEN GIVE UP;
16200		MOVE	T,1(K);		# TYPE BITS;
16300		TLNE	T,0+PROCB LSH -18;# IF NOT A PROCEDURE;
16400		TLNE	T,'17;		# OR IF PARAMETER;
16500		 SKIPA;			# KEEP TRYING;
16600		 JRST	GOTCHA;		# USE OUTER-MOST PROCEDURE;
16700		TLNE	K,-1;
16800		 SETOM	MULDEF;
16900		TLNN	K,-1;		# IF MULTIPLY DEFINED;
17000		TLNE	T,'17;		# OR NOT A FIXED CORE ADDRESS;
17100			 JRST	RET;		# GIVE UP;
17200		JRST	GOTCHA;		# OTHERWISE, TRY THIS;
17300		END;
17400	]) # HAND;
17500	END "FIND";
     
00100	# CVNAME PREDEC;
00200	
00300	
00400		SIMPLE PROCEDURE CVNAME(STRING STRVAL; INTEGER ARRAY NAME);BEGIN "CVNAME"
00500	NOHAND([
00600	INTEGER I; FOR I_0 UPTO 2 DO NAME[I]_CVASC(STRVAL[5*I+1 FOR 5])	]) # NOHAND;
00700	HAND([
00800	START!CODE DEFINE R=[1], L=[2], I=[3], D=[4], T=[5]; LABEL LOOP;
00900		MOVEI	R,@NAME;	# ADDRESS OF FIRST DATA WORD IN  NAME;
01000		SETZM	(R);	SETZM	1(R);	SETZM	2(R);	# CLEAR RESULT;
01100		HRLI	R,'440700;	# POINT 7, ;
01200		HRRZ	L,-1(SP);	# LENGTH OF SOURCE;
01300		MOVE	I,(SP);		# BYTE POINTER TO SOURCE;
01400		MOVEI	D,15;		# MAX LENGTH;
01500	LOOP:	ILDB	T,I;
01600		IDPB	T,R;
01700		SOSLE	D;
01800		SOJG	L,LOOP;
01900		END;			]) # HAND;
02000	END "CVNAME";
02100	
02200	
02300	SIMPLE INTEGER PROCEDURE PREDEC(STRING NM; INTEGER TYPE,FATHER,DATA); BEGIN
02400	NOHAND([
02500	CVNAME(NM,NAME); RETURN(INSERT(TYPE,FATHER,DATA,NAME))
02600	]) # NOHAND;
02700	HAND([
02800	START!CODE DEFINE T=['13];
02900		PUSH	P,NAME;	# FWA;
03000		PUSHJ	P,CVNAME;	# REMOVES NM FROM STACK UPON RETRUN;
03100		MOVE	T,NAME;	# FWA;
03200		EXCH	T,(P);	# BECOMES LAST ARG TO INSERT;
03300		PUSH	P,T;	# RETURN ADDR;
03400		JRST	INSERT;	# SICK 'EM;
03500		END;
03600	]) # HAND;
03700	END;
     
00100	# STBAIL;
00200	PROCEDURE STBAIL; BEGIN"STBAIL"
00300	INTEGER SM1PNT,BAITIM,DMPTIM,SM1TIM,N!BYTE,SM1JFN;
00400	INTEGER LZERO,HZERO,BPDALZERO,BPDAHZERO;
00500	      #	LZERO	LOW SEGMENT RELOCATION CONSTANT
00600		HZERO	HIGH SEGMENT RELOCATION CONSTANT;
00700	INTEGER CRDNO,LEVEL,DAD,D;
00800	DEFINE ID=[0], BLK=[1], SIMPRC=[2], PRC=[3];
00900	BOOLEAN ENROLL;		# WHETHER TO READ ALL .SM1 FILES;
01000	INTEGER I,L,J,ADDR1,ADDR2,BRCHAR,W;
01100	INTEGER ARRAY FILMAP[0:MAX#TXTFIL];	# TRANSLATES FROM LOCAL FILE NUMBER TO GLOBAL;
01200	STRING T,PROGNAM,BAINAM,SM1NAM;
01300	LABEL DONESTBAIL;
01400	
01500	
01600	SIMPLE INTEGER PROCEDURE HORSECART(INTEGER HTIM; STRING HORSE;
01700	    REFERENCE STRING CART); BEGIN INTEGER T; T_0;
01800	IF LENGTH(CART) AND ((T_LAST!WRITTEN(CART,"R"))>HTIM OR T=0) THEN
01900		NONFATAL(CART & " written after " & HORSE);
02000	RETURN(T); END;
02100	
02200	
02300	SIMPLE PROCEDURE AD!BLKADR(INTEGER I,J); BEGIN "AD!BLKADR"
02400	IF (L!BLKADR_L!BLKADR+2) GEQ N!BLKADR THEN EXTND(C!BLKADR,N!BLKADR,128);
02500	T!BLKADR(L!BLKADR-1)_I; T!BLKADR(L!BLKADR)_J END "AD!BLKADR";
02600	
02700	
02800	SIMPLE PROCEDURE AD!CRDIDX(INTEGER I); BEGIN "AD!CRDIDX"
02900	N!BYTE_N!BYTE+2; IF N!BYTE LAND '177 THEN RETURN;
03000	IF (L!CRDIDX_L!CRDIDX+1) GEQ N!CRDIDX THEN EXTND(C!CRDIDX,N!CRDIDX,64);
03100	T!CRDIDX(L!CRDIDX)_I END "AD!CRDIDX";
03200	
03300	
03400	SIMPLE INTEGER PROCEDURE INW; BEGIN
03500	NOHAND([RETURN(W_WORDIN(SM1JFN))])
03600	HAND([	START!CODE EXTERNAL INTEGER WORDIN;
03700		PUSH	P,SM1JFN;
03800		PUSHJ	P,WORDIN;
03900		MOVEM	1,W;
04000		POPJ	P,;
04100		END;	])
04200	END;
04300	
04400	
04500	SIMPLE PROCEDURE SYMIN;
04600	NOHAND([BEGIN TARRAY[1]_TARRAY[2]_0;
04700	    FOR I_1 UPTO L DO TARRAY[I-1]_INW END;]) # NOHAND;
04800	HAND([START!CODE LABEL LOOP;
04900	    SETZM   TARRAY[1];
05000	    SETZM   TARRAY[2];
05100	    MOVN    2,L;
05200	    HRLZI   2,(2);
05300	LOOP:PUSHJ  P,INW;
05400	    MOVEM   1,TARRAY[0](2);
05500	    AOBJN   2,LOOP;
05600	    POPJ    P,;
05700	    END;]) # HAND;
05800	
05900	
06000	SIMPLE STRING PROCEDURE FILSPC(BOOLEAN R); BEGIN "FILSPC"
06100	# IF R THEN [READ L WORDS INTO TARRAY] ELSE [FILL TARRAY FROM SM1PNT BLOCK].
06200	  GIVEN TARRAY[0:3+SFDLFL]=SIXBIT DEV,NAM,EXT,PPN, RETURN STRING OF SAME.
06300	  ON TENEX, USE L WORDS OF ASCII;
06400	STRING A;
06500	IF R THEN SYMIN
06600	ELSE BEGIN
06700	    L_RIGHT(SM1LNK(2));
06800	    NOTENX([	# SET DEFAULTS;
06900		TARRAY[0]_IF LEFT(SM1LNK(2)) THEN CVSIX("SYS") ELSE CVSIX("DSK");
07000		TARRAY[2]_CVSIX("SM1"); TARRAY[3]_0;
07100		# GET NON-DEFAULTS;	ARRBLT(TARRAY[1],SM1LNK(3),L);
07200		# XFER DEVICE TO FRONT;	IF L>3 THEN TARRAY[0]_TARRAY[L];
07300	    ]) # NOTENX;
07400	    TENX([
07500		ARRBLT(TARRAY[0],SM1LNK(3),L);
07600	    ]) # TENX;
07700	END;
07800	NOTENX([ RETURN(CV6STR(TARRAY[0]) & ":" &CVXSTR(TARRAY[1]) & "." &
07900	    (CVXSTR(TARRAY[2])[1 TO 3]) & MAKPPN(TARRAY[3],L-4));	]) # NOTENX;
08000	TENX([ A_NULL; FOR I_0 UPTO L-1 DO A_A&CVASTR(TARRAY[I]);
08100		RETURN(NONULL(A)) ]) # TENX;
08200	END "FILSPC";
08300	
08400	
08500	SIMPLE PROCEDURE EATSYM(BOOLEAN INPRC; INTEGER $RUN$); BEGIN "EATSYM"
08600	# PROCESS SYMBOLS FOR BLOCK TYPES 3 AND 4 (BAIBLK AND BAIPRC);
08700	
08800		SIMPLE PROCEDURE IND; D_TYPEMUNGE(INW,LZERO,HZERO);
08900	
09000	INW; L_W LAND '77; LEVEL_W LSH -6 LAND '77;
09100	CRDNO_LEFT(W);
09200	NOHAND([
09300	INW; IF RIGHT(W)=0 THEN W_W+LEFT(W); # Bullet-proofing for RIGHT(W)=0;
09400	]) HAND([START!CODE		# THE ABOVE IS JUST TOO INEFFICIENT;
09500		PUSHJ	P,INW;
09600		TRNN	1,-1;
09700		 HLR	1,1;
09800		MOVEM	1,W;	END;
09900	]) # HAND;
10000	D_ADDR1_HRELOC(RIGHT(W));
10100	ADDR2_HRELOC(LEFT(W)) MAX ADDR1;	# Bullet-proofing for LEFT(W)=0;
10200	
10300	IF INPRC THEN IND;
10400	
10500	SYMIN;
10600	# USE FATHER FIELD FOR LEVEL INFO UNTIL FATHER CHAIN IS BUILT;
10700	DAD_INSERT(IF INPRC THEN IF D<0 THEN SIMPRC ELSE PRC ELSE BLK,LEVEL+$RUN$,D,TARRAY);
10800	IF NOT $RUN$ THEN AD!BLKADR(DAD,ADDR2 LSH 18 LOR ADDR1);
10900	WHILE INW NEQ 0 DO BEGIN "IDENTIFIERS"
11000		L_W LAND '77; IND; SYMIN; INSERT(ID,DAD,D,TARRAY) END "IDENTIFIERS"
11100	END "EATSYM";
11200	
11300	SIMPLE PROCEDURE DOSM1(INTEGER $RUN$); BEGIN "DOSM1"
11400	# Go down the BALNK loader chain and process the files on it.  If $RUN$ is zero,
11500	  process only user files., if $RUN$ is not zero, then process predeclared runtime
11600	  files, which have a 1 in the left half of the word which tells how many words
11700	  the file name takes;
11800	SM1PNT_BALNK;
11900	WHILE SM1PNT DO BEGIN "ONE COMPILATION"
12000	LABEL EOC;
12100	
12200	IF $RUN$ AND NOT(LEFT(SM1LNK(2))) THEN GOTO EOC;
12300	IF NOT($RUN$) AND LEFT(SM1LNK(2)) THEN GOTO EOC;
12400		# Do runtimes iff correct to do so;
12500	LZERO_RIGHT(SM1LNK(1))-1; HZERO_(LEFT(SM1LNK(1))-1) LAND '377777;
12600	SM1NAM_FILSPC(FALSE);	# USE BALNK BLOCK AND FETCH FILE NAME;
12700	SM1JFN_OPENFILE(SM1NAM,"R"); SM1TIM_FILTIM(SM1JFN);
12800	IF NOT(!SKIP!) THEN BEGIN "SM1FILE"
12900	    OUTSTR(CRLFCAT(SM1NAM));
13000	    WHILE INW NEQ -1 DO CASE W OF BEGIN "CASES"
13100	    [0] ;  # The compiler seems to put in random 0's;
13200	    [1]	BEGIN "FILE INFO"
13300		STRING TEXTFILE; INTEGER FILN;	LABEL OLDCHAP;
13400		INW; L_RIGHT(W); FILN_LEFT(W);
13500		TEXTFILE_FILSPC(TRUE);	# READ WORDS AND GET FILE NAME;
13600		FOR I_0 UPTO L!TXTFIL DO IF EQU(TEXTFILE,T!TXTFIL[I]) THEN BEGIN
13700		    FILMAP[FILN]_I; GOTO OLDCHAP; END;
13800		IF L!TXTFIL=MAX#TXTFIL-1 THEN 
13900		    NONFATAL("More than "&CVS(MAX#TXTFIL-1)&" text files.
14000	Rest ignored.");
14100		FILMAP[FILN]_L!TXTFIL_(L!TXTFIL+1) MIN MAX#TXTFIL;
14200		STATUS[L!TXTFIL]_IF HORSECART(SM1TIM,SM1NAM,TEXTFILE)=0 THEN -'1000 ELSE -1;
14300		T!TXTFIL[L!TXTFIL]_TEXTFILE;
14400	OLDCHAP:OUTSTR(CRLFCAT("  " & TEXTFILE));
14500		END "FILE INFO";
14600	
14700	    [2]	BEGIN "COORDINATES"
14800		WHILE INW NEQ 0 DO BEGIN
14900		# CONVERT TO CHARACTER COUNT AND MAPPED FILE NUMBER;
15000		WORDOUT(BAIJFN,(RIGHT(W)-1)*640 + (LEFT(W) LAND '177)*5 +
15100		    (((W LSH -30)LAND 7)XOR 4)-1 LOR
15200		    (FILMAP[W LSH -25 LAND '37] LSH 24));
15300		WORDOUT(BAIJFN,W_HRELOC(INW LAND '400000777777)+
15400		    (CRDCTR LSH 18)); # USE GLOBAL COORD NUMBERS;
15500		CRDCTR_CRDCTR+1;
15600		AD!CRDIDX(W); END
15700		END "COORDINATES";
15800	
15900	    [3]	BEGIN "BLOCKS" EATSYM(FALSE,$RUN$) END "BLOCKS";
16000	
16100	    [4] BEGIN "PRC" EATSYM(TRUE,$RUN$) END "PRC"
16200	
16300	    END "CASES";
16400	    CFILE(SM1JFN);
16500	
16600	# There is some monkey business with outer blocks.  They act like procedures
16700	with no parameters, in that they put out the name twice, once for the params
16800	and once for the delcatations inwide the procedure.  The trouble is, the
16900	declarations should be treated as global in this case.  So kill the "params"
17000	block name, and set the FWA of the other one to HRELOC(0).  Also kill the
17100	outer block procedure name in the NAME table, to prevent confusion;
17200	IF NOT($RUN$) THEN BEGIN
17300	    T!NAME(RIGHT(T!BLKADR(L!BLKADR-1))+2)_0;	# KILLS THE NAME TABLE ENTRY;
17400	    L!BLKADR_L!BLKADR-2;	# THAT KILLS THE PARAM NAME BLOCK;
17500	    T!BLKADR(L!BLKADR)_T!BLKADR(L!BLKADR) LAND '777777000000 LOR HRELOC(0); END;
17600	END "SM1FILE";
17700	
17800	EOC:SM1PNT_SM1LNK(0);	# NEXT LINK;	END "ONE COMPILATION" 
17900	END "DOSM1";
18000	
     
00100	
00200	
00300	#SKIP#_!SKIP!;
00400	OLDBAIL_TRUE;
00500	INTERP!SKIP! _ 0;
00600	OUTSTR("
00700	BAIL ver. 24-Sep-79");
00800	NEWTOP([if oldbail then outstr(" ($N for new BAIL)");])
00900	
01000	IF BALNK=0 THEN BEGIN
01100	    NONFATAL("No /B switch used"); RETURN END;
01200	
01300	IF NOT PRGSM1 THEN BEGIN "NAMPRG"
01400	# Record the name of the program which was loaded first as the main program
01500	  name.  It could change when the .SM1 link is sorted by address.  In order
01600	  to find the program which was loaded first, we must go to the end of the
01700	  linked list;
01800	NOHAND([
01900	PRGSM1_BALNK; WHILE MEMORY[PRGSM1] NEQ 0 DO PRGSM1_MEMORY[PRGSM1];
02000	]) # NOHAND;
02100	HAND([START!CODE LABEL T,B;
02200		MOVE	1,BALNK;
02300	T:	SKIPN	(1);
02400		 JRST	B;
02500		MOVE	1,(1);
02600		JRST	T;
02700	B:	MOVEM	1,PRGSM1;
02800		END;
02900	]) # HAND;
03000	END "NAMPRG";
03100	
03200	SM1PNT_PRGSM1;	# need to reconstruct string, since restart zeroes all strings;
03300	NOTENX([PROGNAM_CV6STR(SM1LNK(3));])
03400	TENX([ PROGNAM_FILSPC(FALSE); ])
03500	
03600	# The loader linked list needs to be sorted by first word address of code
03700	  so that we process files in ascending order of load address.
03800	  $#$#$#$#$# THIS MEANS THAT THE LINK BLOCKS MUST BE IN THE LOWSEG #$#$#$#$#$;
03900	
04000	NOHAND([		# insertion sort of non-null linked list headed at BALNK;
04100	I_0; I SWAP MEMORY[BALNK];	# BALNK gets first element, I gets rest;
04200	WHILE I NEQ 0 DO BEGIN
04300	    J_LOCATION(BALNK); L_MEMORY[J];	# top of what's already sorted;
04400	    WHILE L NEQ 0 AND LEFT(MEMORY[I+1])>LEFT(MEMORY[L+1]) DO
04500		L_MEMORY[J_L];	# find L=first which has FWA code > FWA I;
04600	    J_MEMORY[J]_I;	# link in I, advance J to it;
04700	    I_MEMORY[I];	# CDR down stuff not yet processed;
04800	    MEMORY[J]_L;	# tack on rest of sorted list;
04900	    END;
05000	]) # NOHAND;
05100	HAND([
05200	START!CODE LABEL TOP1,TOP2,BOT1,BOT2,OUT1,OUT2;
05300	DEFINE T=[0],T1=[1],I=['13],J=['14],L=['15];
05400		MOVEI	I,0;
05500		EXCH	I,@BALNK;
05600		JRST	BOT1;
05700	TOP1:	MOVEI	J,BALNK;
05800		HRRZ	L,(J);
05900		JRST	BOT2;
06000	TOP2:	HLRZ	T,1(I);
06100		HLRZ	T1,1(L);
06200		CAIG	T,(T1);
06300		 JRST	OUT2;
06400		MOVEI	J,(L);
06500		HRRZ	L,(J);
06600	BOT2:	JUMPN	L,TOP2;
06700	OUT2:	HRRZM	I,(J);
06800		MOVEI	J,(I);
06900		HRRZ	I,(I);
07000		HRRZM	L,(J);
07100	BOT1:	JUMPN	I,TOP1;
07200	OUT1:	END;
07300	]) # HAND;
07400	
07500	# MAKE FOR NICE RENTRANCY;
07600	ARRCLR(STATUS); COREFREE(C!NAME); COREFREE(C!BLKADR); COREFREE(C!CRDIDX);
07700	BKLEV_0;
07800	
07900	# Establish special break tables;
08000	J_BK!PRV(TRUE);
08100	FOR I_0 UPTO 8 DO BEGIN 
08200	    RELBREAK(BK!TBL[I]); 
08300	    IF (BK!TBL[I]_GETBREAK) GEQ 0 THEN FATAL("Brktbl ov.");
08400	    SETBREAK(BK!TBL[I],BK!SBR[I,0],BK!SBR[I,1],BK!SBR[I,2]);
08500	END;
08600	BK!PRV(J);
08700	
08800	# Guess at where the core image originated;
08900	NOTENX([
09000	STANFO([DEFINE AC!DEV=[6],  AC!PPN=[3],AC!EXT=[1];  ])
09100	DEC([   DEFINE AC!DEV=['11],AC!PPN=[7],AC!EXT=['17];])
09200	IF LEFT(MEMORY[LOCATION(INIACS)+AC!EXT])=LEFT(CVSIX(CORE!IMAGE!EXTENSION))
09300	THEN BEGIN RUNDEV_CV6STR(MEMORY[LOCATION(INIACS)+AC!DEV]);
09400	    RUNPPN_MAKPPN(MEMORY[LOCATION(INIACS)+AC!PPN]) END;
09500	]) # NOTENX;
09600	TENX([ J_BK!PRV(TRUE); 
09700	NOT20([PROGNAM_SCAN(PROGNAM,BK!DEC,BRCHAR); BK!PRV(J); ])
09800	T20([SM1PNT _ GTJFN(PROGNAM,'41000000);
09900	     PROGNAM _ JFNS(SM1PNT,'222000000001);
10000	     RLJFN(SM1PNT);]) ])
10100	# NOW MAKE LIKE RPG -- SEE IF WE CAN USE AN EXISTING .BAI FILE;
10200	ENROLL_FALSE; SM1PNT_BALNK;
10300	IF (BAITIM_LAST!WRITTEN(BAINAM_PROGNAM & ".BAI","RE"))<
10400		(DMPTIM_LAST!WRITTEN(PROGNAM_PROGNAM & ("."&CORE!IMAGE!EXTENSION),"RE"))
10500	    OR DMPTIM=0
10600	THEN ENROLL_TRUE;
10700	WHILE SM1PNT AND NOT ENROLL DO BEGIN
10800	    SM1NAM_FILSPC(FALSE);	# USE SM1LNK AND GET FILE NAME;
10900	    SM1PNT_SM1LNK(0);	# FOLLOW DOWN LINK;
11000	    IF LAST!WRITTEN(SM1NAM,"RE") GEQ BAITIM THEN ENROLL_TRUE END;
11100	
11200	
11300	IF NOT ENROLL THEN BEGIN "NOROLL"
11400	    BAIJFN_OPENFILE(BAINAM,"R"); IF !SKIP! THEN BEGIN
11500		OUTSTR(" reconstructing .BAI file");
11600		ENROLL_TRUE END	
11700	    ELSE BEGIN
11800		OUTSTR(" using " & BAINAM);
11900		# FIRST DISK BLOCK OF .BAI FILE IS A HEADER INDEX BLOCK.
12000		WORD	0-7    UNUSED
12100			8	USETI POINTER TO BEGINNING OF T!CRDIDX
12200			9	CRDCTR,,N!CRDIDX
12300			10	USETI POINTER TO BEGINNNG OF T!BLKADR
12400			11	N!BLKADR
12500			12	USETI POINTER TO BEGINNING OF T!NAME
12600			13	N!NAME
12700			14	USETI POINTER TO TEXT FILE NAMES
12800			15	N!TXTFIL,,# OF WORDS TAKEN UP BY NAMES
12900			16-127	UNUSED;
13000		# READ THE FIRST BLOCK TO GET THE INDEX INFO;
13100		ARRYIN(BAIJFN,TARRAY[0],128);
13200		# SET UP THE VARIOUS ARRAYS;
13300		C!CRDIDX_COREGET(N!CRDIDX_RIGHT(TARRAY[9])); CRDCTR_LEFT(TARRAY[9]);L!CRDIDX_N!CRDIDX-1;
13400		    USETIN(BAIJFN,TARRAY[8]); ARRYIN(BAIJFN,T!CRDIDX(0),N!CRDIDX);
13500		C!BLKADR_COREGET(N!BLKADR_TARRAY[11]); L!BLKADR_N!BLKADR-1;
13600		    USETIN(BAIJFN,TARRAY[10]); ARRYIN(BAIJFN,T!BLKADR(0),N!BLKADR);
13700		C!NAME_COREGET(N!NAME_TARRAY[13]); L!NAME_N!NAME-1;
13800		    USETIN(BAIJFN,TARRAY[12]); ARRYIN(BAIJFN,T!NAME(0),N!NAME);
13900		L!TXTFIL_TARRAY[15] ASH -18; L_RIGHT(TARRAY[15]);
14000		    USETIN(BAIJFN,TARRAY[14]); T_NULL; FOR I_0 UPTO L DO T_T &
14100		    CVASTR(WORDIN(BAIJFN)); J_BK!PRV(TRUE);
14200		    FOR I_0 UPTO L!TXTFIL DO
14300			HORSECART(BAITIM,BAINAM,T!TXTFIL[I]_SCAN(T,BK!TAB,BRCHAR));
14400		    BK!PRV(J);
14500	
14600		# NOW WE ARE IN BUSINESS;
14700		GOTO DONESTBAIL; END END "NOROLL";
14800	
14900	# HERE TO CONSTRUCT THE .BAI FILE;
15000	BAIJFN_OPENFILE(BAINAM,"W"); IF !SKIP! THEN BEGIN BAILOFF_TRUE;
15100		OUTSTR("
15200	Bailor abandons ship.");RETURN END;
15300	
15400	# NOW GET SOME CORE FOR THE VARIABLE LENGTH TABLES;
15500	C!NAME_COREGET(N!NAME_2000);  L!NAME_32;	# FOR BUCKETS;
15600	C!BLKADR_COREGET(N!BLKADR_256);	L!BLKADR_-1;
15700	C!CRDIDX_COREGET(N!CRDIDX_64);	L!CRDIDX_-1;
15800	
15900	N!BYTE_0;CRDCTR_0;
16000	
16100	# WRITE A DUMMY FIRST BLOCK;	ARRYOUT(BAIJFN,TARRAY[0],128);
16200	
16300	L!TXTFIL_-1;
16400	DOSM1(0);	# PROCESS THOSE FILES WHICH DO NOT POINT TO PREDECLARED RUNTIMES;
     
00100	# SUPER OUTER BLOCK, FOR PREDECLARED STUFF;
00200	# FIRST THE BLOCK;
00300	L_PREDEC("$RUN$",BLK,0,0); AD!BLKADR(L,'777777000000);
00400	# NOW THE OTHER STUFF;
00500	NOHAND([
00600	PREDEC("!SKIP\"		,ID,L,REFB+INTEGR+LOCATION(TEMP!ACS['20+'12+2]));
00700	PREDEC("\SKIP\"		,ID,L,REFB+INTEGR+LOCATION(INTERP!SKIP!));
00800	PREDEC("OLDBAIL"	,ID,L,REFB+INTEGR+LOCATION(OLDBAIL));
00900	PREDEC("MEMORY"		,ID,L,REFMEMORY);
01000	PREDEC("INTEGER"	,ID,L,INTEGR+LOCATION(INTEGR));
01100	PREDEC("REAL"		,ID,L,INTEGR+LOCATION(FLOTNG));
01200	PREDEC("STRING"		,ID,L,INTEGR+LOCATION(STRNG));
01300	PREDEC("SET"		,ID,L,INTEGR+LOCATION(SETYPE));
01400	PREDEC("LIST"		,ID,L,INTEGR+LOCATION(LSTYPE));
01500	PREDEC("GOGTAB"		,ID,L,REFB+ARRY+INTEGR+LOCATION(GOGTAB));
01600	PREDEC("TRACE"		,PRC,L,REFTRACE);
01700	PREDEC("UNTRACE"	,PRC,L,REFUNTRACE);
01800	PREDEC("BREAK"		,PRC,L,REFBREAK);
01900	PREDEC("UNBREAK"	,PRC,L,REFUNBREAK);
02000	PREDEC("SETLEX"		,PRC,L,REFSETLEX);
02100	PREDEC("HELP"		,PRC,L,REFHELP);
02200	PREDEC("!!STEP"		,PRC,L,REF!!STEP);
02300	PREDEC("!!GOTO"		,PRC,L,REF!!GOTO);
02400	PREDEC("!!GSTEP"	,PRC,L,REF!!GSTEP);
02500	PREDEC("ARGS"		,PRC,L,REF!!ARGS);
02600	PREDEC("TEXT"		,PRC,L,REF!!TEXT);
02700	PREDEC("TRAPS"		,PRC,L,REFTRAPS);
02800	PREDEC("SHOW"		,PRC,L,REFSHOW);
02900	PREDEC("DDT"		,PRC,L,REFDDT);
03000	PREDEC("COORD"		,PRC,L,REFCOORD);
03100	PREDEC("!!UP"		,PRC,L,REF!!UP);
03200	PREDEC("SETSCOPE"	,PRC,L,REFSETSCOPE);
03300	PREDEC("DEFINE"		,PRC,L,REF!!DEFINE);
03400	]) # NOHAND;
03500	HAND([
03600	BEGIN
03700	DEFINE Z(B)=[CVASC("] & [B] & [")],NPD=[28];
03800	PRESET!WITH 
03900		Z(!SKIP),Z(\),0,
04000		Z(\SKIP),Z(\),0,
04100		Z(OLDBA),Z(IL),0,
04200			Z(MEMOR),Z(Y),0,
04300		Z(INTEG),Z(ER),0,
04400		Z(REAL),0,0,
04500		Z(STRIN),Z(G),0,
04600		Z(SET),0,0,
04700		Z(LIST),0,0,
04800		Z(GOGTA),Z(B),0,
04900		Z(TRACE),0,0,
05000		Z(UNTRA),Z(CE),0,
05100		Z(BREAK),0,0,
05200		Z(UNBRE),Z(AK),0,
05300		Z(SETLE),Z(X),0,
05400		Z(HELP),0,0,
05500		Z(!!STE),Z(P),0,
05600		Z(!!GOT),Z(O),0,
05700		Z(!!GST),Z(EP),0,
05800		Z(ARGS),0,0,
05900		Z(TEXT),0,0,
06000		Z(TRAPS),0,0,
06100		Z(SHOW),0,0,
06200		Z(DDT),0,0,
06300		Z(COORD),0,0,
06400		Z(!!UP),0,0,
06500		Z(SETSC),Z(OPE),0,
06600		Z(DEFIN),Z(E),0		;
06700	OWN SAFE INTEGER ARRAY PRENAM[0:3*NPD-1];
06800	START!CODE DEFINE T=['13],T2=['14];
06900	EXTERNAL INTEGER SETLEX,!!STEP,!!GSTEP,!!ARGS,!!TEXT;
07000	DEFINE	REFINT=	['200240000000],
07100		REFMEM=	['201240777777],
07200		INT=	['000240000000],
07300		INTARY=	['001440000000],
07400		PROC=	['020000000000],
07500		STRPRC=	['020140000000],
07600		INTPRC=	['020240000000];
07700	# REFB+INTEGR;
07800	# REFB+ARRY+NOTYPE;
07900	# INTEGR;
08000	# INTEGR ARRY;
08100	# PROCB;
08200	# PROCB+STRNG;
08300	# PROCB+INTEGR;
08400	LABEL LUP,REFTAB,BOT,NOTPRC;
08500		MOVEI	T,NPD-1;# NPD SYMBOLS TO BE PREDECLARED, 0 THRU NPD;
08600	LUP:	MOVEM	T,I;	# TUCK IT AWAY IN MEMORY;
08700		MOVEI	T2,PRC;	# ASSUME PROCEDURE;
08800		CAIGE	T,8;
08900		 MOVEI	T2,ID;	# WRONG ASSUMPTION;
09000		PUSH	P,T2;
09100		PUSH	P,L;
09200		PUSH	P,REFTAB(T);	# MAGIC BITS FOR THIS NAME;
09300		CAIGE	T,8;
09400		 JRST	NOTPRC;
09500		PUSHJ	P,PDFIND;	# FIND PDA FOR THIS PROC;
09600		MOVE	T,I;	# RETRIEVE DESTROYED AC;
09700		HLL	1,REFTAB(T);	# REINSERT PROCEDURE TYPE BITS;
09800		PUSH	P,1;	# STACK IT;
09900	NOTPRC:	IMULI	T,3;	# 3 WORDS PER NAME IN PRENAM ARRAY;
10000		MOVEI	T,PRENAM[0](T);
10100		PUSH	P,T;	# FWA;
10200		PUSHJ	P,INSERT;	# STICK IT IN MAGIC TABLE;
10300		MOVE	T,I;	# RESTORE DESTROYED AC;
10400		SOJGE	T,LUP;
10500		JRST	BOT;
10600	REFTAB:	REFINT	TEMP!ACS['20+'12+2];
10700		REFINT	INTERP!SKIP!;
10800		REFINT	OLDBAIL;
10900		REFMEM;
11000		INT	0,[INTEGR];
11100		INT	0,[FLOTNG];
11200		INT	0,[STRNG];
11300		INT	0,[SETYPE];
11400		INT	0,[LSTYPE];
11500		INTARY	GOGTAB;
11600		PROC	TRACE;
11700		PROC	UNTRACE;
11800		PROC	BREAK;
11900		PROC	UNBREAK;
12000		PROC	SETLEX;
12100		STRPRC	HELP;
12200		PROC	!!STEP;
12300		PROC	!!GOTO;
12400		PROC	!!GSTEP;
12500		STRPRC	!!ARGS;
12600		STRPRC	!!TEXT;
12700		STRPRC	TRAPS;
12800		STRPRC	SHOW;
12900		PROC	DDT;
13000		STRPRC	COORD;
13100		PROC	!!UP;
13200		PROC	SETSCOPE;
13300		PROC	!!DEFINE;
13400	BOT:
13500		END;
13600	END;
13700	]) # HAND;
13800	
13900	DOSM1(L);	# Process those .SM1 files for predeclared runtimes, if any;
14000	
14100	# PUT A FLAG AT THE END OF THE COORDINATES ON THE .BAI FILE;
14200	WORDOUT(BAIJFN,MAX#TXTFIL LSH 24); # ILLEGAL FILE FLAG;
14300	WORDOUT(BAIJFN,'377777777777); # ALLSTO=0, CRDNO='377777, ADDR='777777;
14400	N!BYTE_((N!BYTE+'200) LAND LNOT '177)-2;	# FORCE NEW ENTRY IN INDEX,TOO;
14500	AD!CRDIDX('377777777777);
14600	
14700	# CONSTRUCT THE FATHER CHAINS IN THE BLKADR TABLE AND NAME TABLE;
14800	NOHAND([
14900	DEFINE FWA(I)=[RIGHT(T!BLKADR(I+1))], LWA(I)=[LEFT(T!BLKADR(I+1))];
15000	DEFINE NAMPTR(I)=[RIGHT(T!BLKADR(I))], FATHERBLOCK(I)=[LEFT(T!BLKADR(I))];
15100	L_0; TARRAY[L]_L!BLKADR-1;
15200	FOR I_L!BLKADR-3 STEP -2 UNTIL 0 DO BEGIN "FBLK"
15300	    # DESCEND TO PROPER LEVEL. QUIT UPON REACHING ANY OUTER BLOCK;
15400	    WHILE LWA(I) LEQ FWA(TARRAY[L]) DO IF L NEQ 0 THEN L_L-1 ELSE BEGIN
15500		TARRAY[0]_I; CONTINUE "FBLK" END;
15600	    T!BLKADR(I)_T!BLKADR(I) LOR TARRAY[L] LSH 18;  # INSERT FATHER;
15700	    PAGEIT(T!NAME,NAMPTR(I))_PAGEIT(T!NAME,NAMPTR(I)) LAND '600000777777
15800		LOR (NAMPTR(FATHERBLOCK(I)) LSH 18);	# TAKE CARE OF NAME TABLE, TOO;
15900	    TARRAY[L_L+1]_I;	# UP A NEW LEVEL AND RECORD; END "FBLK";
16000	]) # NOHAND;
16100	HAND([
16200	START!CODE LABEL TOP2,BOT2,BOT1A;
16300	DEFINE I=['14],L=['15],T1=[1],T2=[2];
16400		MOVE	I,L!BLKADR;
16500		SUBI	I,1;
16600		ADD	I,C!BLKADR;
16700		SETO	L,;
16800	TOP2:	JUMPL	L,BOT1A;
16900	BOT2:	HLRZ	T1,1(I);		# LWA (I);
17000		MOVE	T2,TARRAY[0](L);
17100		HRRZ	T2,1(T2);		# FWA(TARRAY[L]);
17200		CAIG	T1,(T2);
17300		 SOJA	L,TOP2;
17400		MOVE	T1,TARRAY[0](L);
17500		SUB	T1,C!BLKADR;
17600		HRLM	T1,(I);		# T!BLKADR(I)_ ... LOR TARRAY[L] LSH 18;
17700		ADD	T1,C!BLKADR;	# FATHERBLOCK(I);
17800		MOVE	T1,(T1);	# NAMPTR(   );
17900		MOVE	T2,(I);		# NAMPTR(I);
18000		ADD	T2,C!NAME;
18100		DPB	T1,[('222000+T2)LSH 18];
18200	BOT1A:	MOVEM	I,TARRAY[1](L);
18300		SUBI	I,2;
18400		CAML	I,C!BLKADR;
18500		 AOJA	L,BOT2;
18600	END;
18700	]) # HAND;
18800	
18900	# REVERSE THE HASH CHAINING IN THE NAME TABLE, SO THAT THE INNERMOST 
19000	  OCCURRENCES OCCUR FIRST IN A CHAIN;
19100	NOHAND([
19200	FOR I_0 UPTO 31 DO BEGIN
19300	    INTEGER FATHER, SON;
19400	    FATHER_T!NAME(I); L_0;
19500	    WHILE FATHER NEQ 0 DO BEGIN
19600		SON_RIGHT(T!NAME(FATHER));
19700		T!NAME(FATHER)_T!NAME(FATHER) LAND '777777000000 LOR L;
19800		L_FATHER; FATHER_SON END;
19900	    T!NAME(I)_L END;
20000	]) # NOHAND;
20100	HAND([
20200	START!CODE LABEL TOP1,TOP2,BOT1;
20300	DEFINE F=['14],S=['15],L=[0],I=[2];
20400		MOVSI	I,-32;
20500		HRR	I,C!NAME;
20600	TOP1:	MOVE	F,(I);
20700		SETZ	L,;
20800		JRST	BOT1;
20900	TOP2:	ADD	F,C!NAME;	# RELOC FATHER;
21000		HRRZ	S,(F);		# SON_RIGHT(T!NAME(FATHER));
21100		HRRM	L,(F);
21200		MOVEI	L,(F);
21300		SUB	L,C!NAME;
21400		MOVEI	F,(S);
21500	BOT1:	JUMPN	F,TOP2;
21600		MOVEM	L,(I);
21700		AOBJN	I,TOP1;
21800	END;
21900	]) # HAND;
22000	
22100	# NOW WRITE THE VARIABLE LENGTH TABLES TO THE .BAI FILE;
22200	USETOUT(BAIJFN,TARRAY[8]_(N!BYTE + '577) LSH -7);	# PAST HEADER BLOCK AND COORDS;
22300	    ARRYOUT(BAIJFN,T!CRDIDX(0),RIGHT(TARRAY[9]_(CRDCTR LSH 18)+L!CRDIDX+1));
22400	USETOUT(BAIJFN,TARRAY[10]_TARRAY[8]+((L!CRDIDX+'200) LSH -7));
22500	    ARRYOUT(BAIJFN,T!BLKADR(0),TARRAY[11]_L!BLKADR+1);
22600	USETOUT(BAIJFN,TARRAY[12]_TARRAY[10]+((L!BLKADR+'200) LSH -7));
22700	    ARRYOUT(BAIJFN,T!NAME(0),TARRAY[13]_L!NAME+1);
22800	T_NULL; FOR I_0 UPTO L!TXTFIL DO T_T & T!TXTFIL[I] & TAB; L_(LENGTH(T)+4) DIV 5;
22900	    USETOUT(BAIJFN,TARRAY[14]_TARRAY[12]+((L!NAME+'200) LSH -7));
23000	    TARRAY[15]_L!TXTFIL LSH 18 LOR L;
23100	    FOR I_1 UPTO L DO WORDOUT(BAIJFN,CVASC(T[5*I-4 FOR 5]));
23200	
23300	# WRITE THE HEADER INDEX BLOCK AND CLOSE OUR GLORIOUS FILE;
23400	USETOUT(BAIJFN,1); ARRYOUT(BAIJFN,TARRAY[0],128); CFILE(BAIJFN);
23500	
23600	# NOW REOPEN IT FOR BUSINESS;
23700	BAIJFN_OPENFILE(BAINAM, "R"); # RELEASE T!NAME CORE HERE IF
23800			YOU ARE PAGING THE NAME TABLE;
23900	
24000	DONESTBAIL:
24100	NOHAND([L!CACHE_-1;]) HAND([L!CACHE_-5;])
24200	# INITIALIZE THE BREAKPOINT TRAP;
24300	PJPBAIL_'260000000000 # PUSHJ; +(P LSH 23)+LOCATION(BAIL);
24400	
24500	
24600	
24700	START!CODE DEFINE USER=['15],TEMP=['14];
24800		MOVE	USER,GOGTAB;
24900		MOVSI	TEMP,'400000;
25000		IORM	TEMP,BAILOC(USER);	# SIGN BIT IFF INITIALIZED,,LOC(BAIL);
25100		SETZM	BAILOFF;
25200	END;
25300	OUTSTR("
25400	End of BAIL initialization.
25500	");
25600	!SKIP!_#SKIP#;
25700	END "STBAIL";
     
00100	# LINED DBANG !!EQU EVALERR;
00200	DEFINE INTVAL=[1], REALVAL=[2], STRCON=[3], ID=[4], SPCHAR=[5];
00300	
00400	SIMPLE STRING PROCEDURE LINED(integer BKLEV); BEGIN "LINED"
00500	DEFINE QUOTE=['042], SEMI=['073];
00600	# RETURN A STRING WHICH ENDS IN A SEMICOLON AND IS BALANCED WITH
00700		RESPECT TO STRING QUOTES;
00800	NOHAND([
00900	STRING RESULT; INTEGER CHAR, QUOTECOUNT,#SKIP#;
01000	
01100	if not(length(!!query)) then outstr(crlfcat(cvs(bklev)&":"));
01200	QUOTECOUNT_0; RESULT_NULL; #SKIP#_!SKIP!;
01300		WHILE TRUE DO BEGIN
01400	    IF LENGTH(!!QUERY) THEN BEGIN
01500		RESULT_!!QUERY; !!QUERY_NULL; RETURN(RESULT) END
01600	    ELSE
01700		NOTENX([RESULT_RESULT & INCHWL;]) TENX([RESULT_RESULT & INTTY;])
01800	    QUOTECOUNT_0; J_LENGTH(RESULT);
01900	    FOR I_1 UPTO J DO IF RESULT[I FOR 1]=QUOTE THEN QUOTECOUNT_LNOT (QUOTECOUNT);
02000	    IF NOT QUOTECOUNT THEN BEGIN
02100		IF !SKIP!=CH!ALT OR !SKIP! GEQ '200 THEN BEGIN "MACRO EXPAND"
02200		    CHAR_(IF !SKIP!=CH!ALT THEN INCHRW ELSE !SKIP!) LAND '137;
02300		    IF "A" LEQ CHAR LEQ "Z" THEN RESULT_RESULT & MACTAB[CHAR];
02400		    !SKIP!_0 END "MACRO EXPAND";
02500		IF RESULT[INF FOR 1]='073 THEN BEGIN
02600		    !SKIP!_#SKIP#;
02700		    # SYNTACTIC SUGAR;
02800		    IF RESULT="?" THEN RETURN("HELP;")
02900		    ELSE RETURN(RESULT) END;
03000		IF !SKIP!='15 OR !SKIP!='12 THEN RESULT_CATCRLF(RESULT)
03100		   ELSE IF !SKIP!>0 THEN RESULT_RESULT&!SKIP!;
03200	END END;
03300	]) # NOHAND;
03400	HAND([
03500	EXTERNAL INTEGER CAT,CATCHR;
03600	STRING RESULT,TSTR,TSTR1; INTEGER I,J;
03700	if not(length(!!query)) then outstr(crlfcat(cvs(bklev)&":"));
03800	START!CODE LABEL LOOP1,LOOP2,CCRLF,NORAISE,SUGAR,CCRLF1,NOQ,CATR,TSEMI,TMAC;
03900	NOTENX([EXTERNAL INTEGER INCHWL;])
04000	TENX([EXTERNAL INTEGER INTTY;])
04100	EXTERNAL INTEGER INCHRW;
04200	DEFINE L=[1],T=[2],QC=[3],BP=[4];	# DO NOT CHANGE L=1;
04300		MOVEI	T,!!QUERY;
04400		HRRZ	L,-1(T);	# LENGTH OF !!QUERY;
04500		JUMPE	L,NOQ;
04600		PUSH	SP,-1(T);	# USE !!QUERY;
04700		PUSH	SP,(T);
04800		SETZM	-1(T);		# !!QUERY_NULL;
04900		POPJ	P,;
05000	
05100	NOQ:	PUSH	SP,[0];
05200		PUSH	SP,[0];	# NULL STRING;
05300	LOOP1:
05400		PUSH	P,!SKIP!;	# PRESERVE OVER CALL WHICH MUNGES IT;
05500		PUSHJ	P,NOTENX([INCHWL]) TENX([INTTY]);
05600		POP	P,T;	# PREVIOUS !SKIP!;
05700		EXCH	T,!SKIP!;
05800		MOVEM	T,#SKIP#;
05900	CATR:	PUSHJ	P,CAT;
06000		SETZ	QC,0;
06100		HRRZ	L,-1(SP);	# LENGTH OF STRING;
06200		JUMPE	L,TMAC;
06300		MOVE	BP,(SP);	# BYTE POINTER TO STRING;
06400		MOVE	T,(SP);		# BYTE POINTER;
06500		ILDB	T,T;		# FIRST CHAR;
06600		CAIN	T,"?";		# CHECK FIRST CHAR FOR HELP;
06700		 JRST	SUGAR;
06800	LOOP2:	ILDB	T,BP;
06900		CAIN	T,QUOTE;
07000		 SETCA	QC,QC;
07100		JUMPN	QC,NORAISE;	# IF IN STRING QUOTE, DON'T MUNGE;
07200		CAIN	T,"";		# CHECK FOR UNDERBAR;
07300		 MOVEI	T,"!";		# CHANGE TO BANG;
07400		DPB	T,BP;
07500		NORAISE:
07600		SOJG	L,LOOP2;
07700		JUMPN	QC,CCRLF;
07800	TMAC:	MOVE	L,#SKIP#;	# CHECK FOR MACRO;
07900		CAIE	L,CH!ALT;
08000		CAIL	L,'200;
08100		 SKIPA;			# IT'S A MACRO;
08200		JRST	TSEMI;
08300		CAIN	L,CH!ALT;
08400		 PUSHJ	P,INCHRW;	# ALTMODE STYLE, GET NEXT CHAR;
08500		ANDI	L,'137;
08600		CAIL	L,"A";
08700		CAILE	L,"Z";
08800		 JRST	TSEMI;		# NOT IN RANGE;
08900		ADDI	L,-1-2*"A"(L);	# 2*L-1, TO GET WD1 OF STRING;
09000		PUSH	SP,MACTAB["A"](L);
09100		MOVEI	L,1(L);		# 2*L, TO GET WD2;
09200		PUSH	SP,MACTAB["A"](L);
09300		SETZM	#SKIP#;
09400		JRST	CATR;		# CAT ON MACRO AND CONTINUE;
09500	TSEMI:	HRRZ	L,-1(SP);	# LENGTH SO FAR;
09600		JUMPE	L,LOOP1;
09700		CAIN	T,SEMI;
09800		 POPJ	P,;
09900	CCRLF:
10000		MOVE	T,#SKIP#;	# GET BREAK CHAR;
10100		JUMPLE	T,LOOP1;	# IF NO BREAK CHAR, JUST CONTINUE;
10200		CAIE	T,'15;
10300		CAIN	T,'12;
10400		 JRST	CCRLF1;		# IF CR OR LF, THEN PUT CRLF ON END;
10500		PUSH	P,T;		# SOME CHAR OTHER THAN CR OR LF;
10600		PUSHJ	P,CATCHR;
10700		JRST	LOOP1;
10800	CCRLF1:	PUSHJ	P,CATCRLF;
10900		JRST	LOOP1;
11000	SUGAR:	MOVEI	T,5;
11100		MOVEM	T,-1(SP);
11200		MOVE	T,["HELP;"];
11300		MOVEM	T,(SP);
11400		POPJ	P,;
11500	END;
11600	]) # HAND;
11700	END "LINED";
11800	
11900	
12000	
12100	SIMPLE STRING PROCEDURE DBANG(STRING ARG); START!CODE "DBANG"
12200	# CHANGE STANFORD UNDERBAR TO EXCLAMATION MARK;
12300	LABEL LOOP,LAB;
12400		HRRZ	1,-1(SP);	# LENGTH;
12500		SKIPN	1;
12600		 POPJ	P,;		# NULL STRING;
12700		MOVE	2,(SP);		# BYTE POINTER TO STRING;
12800	LOOP:	ILDB	3,2;		# GET CHAR;
12900		CAIN	3,"";		# CHECK FOR STANFORD UNDERBAR;
13000		 MOVEI	3,"!";		# CHANGE TO BANG;
13100	LAB:	DPB	3,2;
13200		SOJG	1,LOOP;		# UNTIL DONE;
13300		POPJ	P,;
13400	END "DBANG";
13500	
13600	
13700	SIMPLE INTEGER PROCEDURE !!EQU(STRING A,B);
13800		    EQU(DBANG(STRCOPY(A)),DBANG(STRCOPY(B)));
13900	    # SAME AS EQU EXCEPT THAT STANFORD UNDERBARS EQUAL EXCLAMATION POINTS;
14000	
14100	
14200	SIMPLE PROCEDURE EVALERR(STRING WHY,OLDARG,ARG); BEGIN
14300	    !ERRP! SWAP !RECOVERY!; OUTSTR(DUMPSTR);
14400	    NONFATAL(WHY & ":  " & OLDARG & LF & ARG);END;
14500	SIMPLE PROCEDURE EV1ERR(STRING WHY); EVALERR(WHY,NULL,NULL);
14600	
14700	NEWTOP([
14800	simple string procedure NewLined(integer BKLEV);
14900	begin "Newlined"
15000		define quote=['042], semi=['073];
15100		# Return a string to be evaluated by EVAL.
15200		  Build string out of user commands, or allow him
15300		  to pass a string to be evaluated;
15400		string line, result, prompt, word;
15500		integer c, i, j, #SKIP#;
15600		preset!with
15700	# 1;		"DDT",
15800	# 2;		"HELP",
15900	# 3;		"TEXT",
16000	# 4;		"TRAPS",
16100	# 5;		"*GO",
16200	# 6;		"ARGUMENTS",
16300	# 7;		"*CONTINUE",
16400	# 8;		"*STEP",
16500	# 9;		"*NEXT",
16600	# 10;		"BREAK",
16700	# 11;		"UNBREAK",
16800	# 12;		"TRACE",
16900	# 13;		"UNTRACE",
17000	# 14;		"SHOW",
17100	# 15;		"COORDINATE",
17200	# 16;		"*EVALUATE", define eval!case=16;
17300	# 17;		"SETLEX",
17400	# 18;		"GOTO",
17500	# 19;		"UP",
17600	# 20;		"TYPE",
17700	# 21;		"OLDBAIL",
17800	# 22;		"EXIT",
17900	# 23;		"SETSCOPE";
18000		own string array commands[1:23];
18100		#skip#_!skip!;
18200		if length(!!query) then begin
18300			result_!!query;
18400			!!query_null;
18500			return(result);
18600		end;
18700		prompt_cvs(BKLEV)&":";
18800		while true do begin "cmd loop"
18900			outstr(crlf);
19000			line_ttyread(prompt);
19100			if line="?" then line_"$RUN$.HELP;";
19150			if !skip!=ch!alt or !skip! geq '200 then begin "macro expand"
19155				integer char;
19160				char_(if !skip!=ch!alt then inchrw else !skip!) land '137;
19170				if "A" leq char leq "Z" then line_line & mactab[char];
19180				!skip!_0;
19190			end "macro expand";
19200			j_bk!prv(true);
19300			scan(line,bk!dlm,0);
19400			word_scan(line,bk!id,0);
19500			bk!prv(j);
19600			if not word and not line then continue "cmd loop";
19650			# If line began with '(' then word is null;
19700			if not word or line[inf to inf]=";" then begin
19800				line_word&line;
19900				j_eval!case
20000			end
20100			else
20200			begin "disambiguate command"
20300				j_0;
20400				for i_1 upto arrinfo(commands,2) do
20500				if equ(word,commands[i]) or (commands[i]="*" and
20600					equ(word,commands[i][2 for length(word)]))
20700				then begin
20800					j_i;
20900						done;
21000				end
21100				else
21200				if equ(word,commands[i][1 to length(word)])
21300				then begin
21400					if j>0 then begin
21500						outstr("? Ambiguous command ");
21600						outstr(word);
21700						continue "cmd loop";
21800					end;
21900					j_i;
22000				end;
22100				comment if j=0 then it was not found;
22200				if j=0 then begin
22300					outstr("? Unknown Cmd "); outstr(word);
22400					continue "cmd loop";
22500				end;
22600			end "disambiguate command";
22700			word_commands[j];
22800			if word="*" then word_word[2 to inf];
22900			done "cmd loop";
23000		end "cmd loop";
23100		case j of begin
23200	[0][1][2][3][4]	result_"$RUN$."&word;
23300	[5][7]		result_"!!GO";
23400	[6]		result_"$RUN$.ARGS";
23500	[8]		result_"!!STEP";
23600	[9]		result_"!!GSTEP";
23700	[10]		begin "BREAK"
23800				result_"$RUN$.BREAK("&quote;
23900				while line do begin
24000					c_lop(line);
24100					if c="," then done;
24200					result_result&c;
24300				end;
24400				result_result&quote;
24500				# Use obscure BAIL definition of BREAK cond.
24600				  so that BREAK occurs only if
24700				  cond is true;
24800				if c="," then result_result&(",""NOT(")&
24900				line&(")"",""!!GO""");
25000				result_result&")";
25100			end "BREAK";
25200	[11]		result_"$RUN$.UNBREAK("&quote&line&quote&")";
25300	[12][13]	result_"$RUN$."&word&"("&quote&line&quote&")";
25400	[18]		result_"!!GOTO"&"("&quote&line&quote&")";
25500	[15]		result_"$RUN$.COORD("&quote&line&quote&")";
25600	[14]		result_"$RUN$.SHOW("&(if line then cvs(intscan(line,0)) else "-1")&","&cvs(intscan(line,0))&")";
25700	[16][20]	result_line;
25800	[17]		result_"$RUN$."&word&"("&cvs(intscan(line,0))&")";
25900	[19]		result_"!!UP"&"("&cvs(intscan(line,0))&")";
26000	[21]		begin oldBail_true; result_null; end;
26100	[22]		begin call(0,"EXIT"); result_("""Back to BAIL"";");end;
26200	[23]		result_"$RUN$.SETSCOPE("&line&")"
26300		end;
26400		result_result&";"&crlf;
26500		!skip!_#skip#;
26600		return(result);
26700	end "Newlined";
26800	]) # NEWTOP
     
00100	# GET!TOKEN;
00200	SIMPLE PROCEDURE GET!TOKEN(REFERENCE STRING ARG,STRVAL; REFERENCE INTEGER CLASS,
00300		IVAL); BEGIN "GET!TOKEN"
00400	# CLASS: 0: use BK!ID for identifiers. NEQ 0: use BK!ID2;
00500	INTEGER BRCHAR,T,J,#SKIP#;		STRING A;
00600	DEFINE XDELIMS=[SCAN(ARG,BK!DLM,BRCHAR)];
00700	
00800	#SKIP#_!SKIP!;
00900	# Establish breaktable privilege and skip over initial delimiters;
01000	J_BK!PRV(TRUE); XDELIMS;
01100		
01200	# Check for string constant. String constants are returned without
01300	    surrounding  quotes, and with internal double quotes removed;
01400	# Note heavy dependence on SAIL type conversion in this "IF";
01500	IF ARG=QUOTE THEN BEGIN
01600		STRVAL_NULL;
01700		WHILE ARG=QUOTE DO BEGIN A_LOP(ARG);
01800			STRVAL_STRVAL & SCAN(ARG,BK!QUO,BRCHAR) END;
01900		IF BRCHAR NEQ QUOTE THEN
02000		    NONFATAL("String quote added")
02100		ELSE STRVAL_STRVAL[1 TO INF-1]; 	# REMOVE TERMINATING QUOTE;
02200		CLASS_STRCON; END
02300	
02400	# Check for octal;
02500	ELSE IF ARG="'" THEN BEGIN
02600		A_LOP(ARG);
02700		IVAL_CVO(SCAN(ARG,BK!OCT,BRCHAR)); CLASS_INTVAL; END
02800	
02900	# Check for integer or real;
03000	# This is a kluge because INTSCAN won't stop upon seeing a letter or 
03100		special char or delimiter.  INTSCAN insists upon finding a 
03200		number, even the "8" in "K[I]_FN(SYM8T)";
03300	ELSE IF LENGTH(A_SCAN(ARG,BK!NUM,BRCHAR)) THEN BEGIN
03400		# Found a number. Reconstitute ARG, then decide real or integer;
03500		T_LENGTH(STRVAL_ARG_A & ARG);
03600		SCAN(A,BK!DEC,BRCHAR);
03700		IF LENGTH(A) THEN BEGIN # REAL CONSTANT;
03800		    MEMLOC(IVAL,REAL)_REALSCAN(ARG,BRCHAR); CLASS_REALVAL; END
03900		ELSE BEGIN # INTEGER CONSTANT;
04000		    IVAL_INTSCAN(ARG,BRCHAR); CLASS_INTVAL; END;
04100		STRVAL_STRVAL[1 FOR T-LENGTH(ARG)] END
04200	
04300	# Check for identifier;
04400	ELSE BEGIN STRVAL_SCAN(ARG,IF CLASS=0 THEN BK!ID ELSE BK!ID2,BRCHAR); 
04500	IF STRVAL=NULL THEN BEGIN
04600		STRVAL_LOP(ARG); CLASS_SPCHAR; END
04700	ELSE BEGIN
04800		XDELIMS; CLASS_ID; STRVAL_DBANG(STRVAL); CVNAME(STRVAL,NAME) END END;
04900	
05000	# COMMON RETURN POINT;
05100	BK!PRV(J); !SKIP!_#SKIP#; RETURN END "GET!TOKEN";
     
00100	# INTARRAY, CRD!PC, FTEXT, SHOW, CRDFND, GETTEXT;
00200	SIMPLE PROCEDURE INTARRAY(INTEGER CHAN,BLOCK); BEGIN
00300	USETIN(CHAN,BLOCK); ARRYIN(CHAN,TARRAY[0],256) END;
00400	
00500	SIMPLE INTEGER PROCEDURE CRD!PC(INTEGER PC);
00600	# RETURN INDEX TO TARRAY OF COORDINATE WHICH IS FLOOR OF PC;
00700	NOHAND([
00800	BEGIN
00900	PC_RIGHT(PC);	# In case someone forgot;
01000	I_-1; DO I_I+1 UNTIL RIGHT(T!CRDIDX(I))>PC;
01100	INTARRAY(BAIJFN,I+2);
01200	I_-1; DO I_I+2 UNTIL RIGHT(TARRAY[I])>PC; RETURN(I-3) END;
01300	]) # NOHAND;
01400	HAND([
01500	BEGIN
01600	START!CODE LABEL LOOP1,LOOP2; DEFINE I=[1],T=['15];
01700		MOVE	I,C!CRDIDX;	# FWA DATA;
01800		HRRZS	PC;		# SAFETY FIRST;
01900	LOOP1:	HRRZ	T,(I);		# PC FOR COORD;
02000		CAMGE	T,PC;
02100		 AOJA	I,LOOP1;	# FIND FIRST WHICH IS GREATER;
02200		PUSH	P,BAIJFN;
02300		ADDI	I,2;		# USETI POINTER;
02400		SUB	I,C!CRDIDX;
02500		PUSH	P,I;
02600		PUSHJ	P,INTARRAY;
02700		SETO	I,;	
02800	LOOP2:	ADDI	I,2;		# NEXT COORD;
02900		HRRZ	T,TARRAY[0](I);
03000		CAMG	T,PC;		# FIND FIRST WHICH IS GREATER;
03100		 JRST	LOOP2;
03200		SUBI	I,3;		# POINT TO RIGHT PLACE;
03300		SKIPGE	I;
03400		 SETZ	I,;		# JUST IN CASE;
03500		SUB	P,['2000002];
03600		JRST	@2(P);
03700	END; END;
03800	]) # HAND;
03900	
04000	
04100	SIMPLE INTEGER PROCEDURE CRDFND(INTEGER CRDNO); BEGIN "CRDFND"
04200	# RETURN INDEX TO TARRAY WHICH POINTS TO COORDINATE INFO FOR CRDNO;
04300	IF L!CRDIDX<0 THEN EV1ERR("No coords");
04400	CRDNO_0 MAX CRDNO MIN (CRDCTR-1);	# Clip bounds. CRDCTR-1 for fake coord at end;
04500	INTARRAY(BAIJFN,(CRDNO LSH -6)+2);
04600	RETURN((CRDNO LAND '77) LSH 1) END "CRDFND";
04700	
04800	
04900	SIMPLE STRING PROCEDURE FTEXT(INTEGER CRDPNTR); BEGIN "FTEXT"
05000	# CONSTRUCT STRING CONTAINING TEXT OF COORDINATE GIVEN BY TARRAY[CRDPNTR];
05100	INTEGER ALLSTO,COORD1,NCHR;
05200	INTEGER PNTR1,PNTR2,I,FILN,OFILN;	STRING TEXT;
05300	#SKIP#_!SKIP!;
05400	# PICK UP FILE,BLOCK,WORD NUMBERS FOR CURRENT AND NEXT COORDINATE;
05500	NOHAND([
05600	PNTR1_TARRAY[CRDPNTR]; COORD1_LEFT(TARRAY[CRDPNTR+1]) LAND '377777;
05700	ALLSTO_TARRAY[CRDPNTR+1] LSH -35;
05800	FILN_PNTR1 LSH -24; PNTR1_PNTR1 LAND '77777777;
05900	PNTR2_TARRAY[CRDPNTR+2];
06000	NCHR_IF FILN=(PNTR2 LSH -24) THEN (PNTR2-PNTR1) LAND '77777777 ELSE 400;
06100	NOTENX([
06200		MEMORY[LOCATION(TEXT)-1]_NCHR; MEMORY[LOCATION(TEXT)]_
06300		    LOCATION(TARRAY[0]) + PNTR1%640%5 + (7 LSH 24) + 
06400		    ((5-(PNTR1 MOD 5))*7+1) LSH 30;
06500	]) # NOTENX;
06600	]) # NOHAND;
06700	HAND([
06800	START!CODE DEFINE T=[1],T2=[2],CP=[3],U=['14];
06900		MOVE	CP,CRDPNTR;
07000		MOVE	T,TARRAY[0](CP);
07100		LDB	T2,[('301400 LSH 18)+T];	# FILE NUMBER OF PNTR1;
07200		MOVEM	T2,FILN;
07300		TLZ	T,'777700;	# ISOLATE CHAR NUMBER;
07400		MOVEM	T,PNTR1;
07500		HLRZ	T,TARRAY[1](CP);
07600		ANDI	T,'377777;
07700		MOVEM	T,COORD1;
07800		SETZM	ALLSTO;
07900		SKIPGE	TARRAY[1](CP);
08000		 SETOM	ALLSTO;
08100		MOVE	T,TARRAY[2](CP);	# T HOLDS PNTR2;
08200		LDB	T2,[('301400 LSH 18)+T];	# FILE NUMBER OF PNTR2;
08300			SUB	T,PNTR1;	# PNTR2-PNTR1;
08400		TLZ	T,'777700;	# BOTTOM 24 BITS;
08500		CAME	T2,FILN;
08600		 MOVEI	T,400;		# DIFFERENT FILES;
08700	TENX([	MOVEM	T,NCHR;	])
08800	NOTENX([MOVEI	CP,TEXT;	# ADR OF WD2;
08900		MOVEM	T,-1(CP);	# STRING CHAR COUNT;
09000	# COMPUTE BYTE POINTER;
09100		MOVE	T,PNTR1;
09200		IDIVI	T,640;		# BLOCK OFFSET IN T, CHAR OFFSET IN T+1;
09300		ADDI	T,1;		# USETI NUMBER;
09400		MOVEM	T,PNTR1;	# SAVE USETI BLOCK NUMBER;
09500		MOVEI	T,(T+1);	# CHAR OFFSET;
09600		IDIVI	T,5;		# WORD OFFSET IN T, BYTE OFFSET IN T+1;
09700		MOVEI	U,'400;		# ADJUST LENGTH TO NO MORE THAN WE READ IN;
09800		SUBI	U,(T);		# 128+ WORDS TO NEXT BLOCK BOUNDARY;
09900		IMULI	U,5;		# CHARS;
10000		SUBI	U,(T+1);	# SOME WERE COUNTED ALREADY;
10100		CAMGE	U,-1(CP);	# L_L MIN U;
10200		 MOVEM	U,-1(CP);
10300		MOVEI	T,TARRAY[0](T);	# WORD ADDRESS;
10400		XORI	T+1,7;		# 0,1,2,3,4 BECOMES 7,6,5,4,3;
10500		IMULI	T+1,'70000;	# BYTE POINTER "P" OF 49,42,35,28,21;
10600		HRLI	T,'630700(T+1);
10700		MOVEM	T,(CP);		# BYPTE POINTER AT LAST;
10800	]) # NOTENX;
10900		END;
11000	]) # HAND;
11100	# STATUS OF FILES
11200		-'1000	NOT ACCESSIBLE (DETERMINED AT INITIALIZATION TIME)
11300		    -1	ACCESSIBLE, NOT OPEN
11400		     1	OPEN;
11500	IF FILN=MAX#TXTFIL OR STATUS[FILN]=-'1000 THEN
11600	    RETURN("% File not viewable");
11700	IF STATUS[FILN] NEQ 1 THEN BEGIN "NOPEN"	# FILE NOT OPEN;
11800	    # CLOSE PREVIOUS FILE, IF ANY;
11900	    IF TMPJFN GEQ 0 THEN CFILE(TMPJFN); STATUS[OFILN]_-1;
12000	    # OPEN NEW FILE ON TMPJFN;
12100	    TMPJFN_OPENFILE(T!TXTFIL[FILN],"RE"); IF !SKIP! THEN BEGIN
12200		!SKIP!_#SKIP#; RETURN("% File not viewable") END ELSE
12300		STATUS[FILN]_1 END "NOPEN";
12400	# POSITION AND READ TEXT FILE;
12500	OFILN_FILN; NOTENX([ INTARRAY(TMPJFN,PNTR1); ])
12600	TENX([ SCHPTR(TMPJFN,PNTR1); 
12700		TEXT_FLDREAD(TMPJFN,NCHR);  ])
12800	text_nonull(text);
12900	TEXT_"#" & CVS(COORD1) & (IF ALLSTO THEN " " ELSE "+") & TAB & TEXT;
13000	!SKIP!_#SKIP#; RETURN(TEXT)
13100	END "FTEXT";
13200	
13300	
13400	string procedure SHOW(integer first(-1),last(0));
13500	begin "SHOW"
13600		comment Type out text for coordinate(s) given;
13700		own integer current;
13800		string s;
13900		if first=-1 then begin "next few lines"
14000			first_current;
14100			last_first+10;
14200		end "next few lines"
14300		else if last<first then last_last+first;
14400		last_last min (CRDCTR-1); # Clip upper bound;
14500		# Must do this because result is returned as a string;
14600		ADDSTR(crlf);
14700		for current_first step 1 until last do begin
14800			s_FTEXT(CRDFND(current));
14900			while s='15 or s='12 do s_s[2 to inf];
15000			ADDSTR(s);
15100			if s[inf to inf] neq '12 then ADDSTR(crlf);
15200		end;
15300		ssf_true;
15400		return(DUMPSTR)
15500	end "SHOW";
15600	
15700	
15800	SIMPLE STRING PROCEDURE GETTEXT(INTEGER PC); BEGIN "GETTEXT"
15900	INTEGER T;
16000	START!CODE HRRZS PC; END;	# PC_RIGHT(PC);
16100	# TRY TO DO A FAVOR FOR BREAKS OF RECURSIVE PROCEDURES.  THE ENTRY POINT
16200	  IS AFTER ALL THE CODE, SO THE ADDRESS IS NOT PARTICULARLY MEANINGFUL;
16300	IF (MEMORY[PC] LAND '777777400000)='551517400000	# HRRZI F,-n(P);
16400	    AND LEFT(T_MEMORY[PC+1])='254000			# JRST;
16500	    AND RIGHT(T)<PC					# FWA<ENTRY;
16600	  THEN PC_RIGHT(T);
16700	T_CRD!PC(PC);
16800	IF ABS(PC-RIGHT(TARRAY[T+1]))>'400 THEN
16900		RETURN("'" & CVOS(PC) &TAB& "% File not viewable");
17000	RETURN(FTEXT(T)) END "GETTEXT";
     
00100	# N!PARAMS DEFINE HELP;
00200	
00300	SIMPLE INTEGER PROCEDURE N!PARAMS(INTEGER REFIT);
00400	NOHAND([
00500	BEGIN"N!PARAMS"
00600	DEFINE PD(A)=[MEMORY[PDA+A]];
00700	INTEGER PDA;
00800	
00900	PDA_RIGHT(REFIT); RETURN(RIGHT(PD(PD!NPW))-1 + (LEFT(PD(PD!NPW)) LSH -1))
01000	END "N!PARAMS";
01100	]) # NOHAND;
01200	HAND([
01300	START!CODE
01400		HRRZ	2,REFIT;
01500		HRRZ	1,PD!NPW(2);
01600		SUBI	1,1;
01700		HLRZ	2,PD!NPW(2);
01800		LSH	2,-1;
01900		ADDI	1,(2);
02000		SUB	P,['2000002];
02100		JRST	@2(P);
02200	END;]) # HAND;
02300	
02400	
02500	PROCEDURE !!DEFINE(INTEGER CHAR; STRING MAC); BEGIN "DEFINE"
02600	CHAR_CHAR LAND '137; # CONVERT TO UPPER CASE;
02700	IF "A" LEQ CHAR LEQ "Z" THEN MACTAB[CHAR]_MAC END "DEFINE";
02800	
02900	
03000	STRING PROCEDURE HELP; 
03100	BEGIN "HELP"
03200		SSF_TRUE; 
03300		NEWTOP([if oldBail then ])
03400		RETURN("
03500		loc ::= procedure | block | label | # coordinate | ' octalnumber
03600	expression;
03700	procedure!call;
03800	BREAK(""loc"",""condition""(null),""action""(null),count(0));
03900	UNBREAK(""loc"");
04000	TRACE(""procedure"");		UNTRACE(""procedure"");
04100	SHOW(coord,coord(0));		DEFINE(char,""string"");
04200	SETLEX(level);			!!UP(level);
04300	COORD(""loc"");			!!GOTO(""loc"");
04400	ARGS;		DDT;		HELP;		TEXT;		TRAPS;
04500	!!GO;		!!STEP;		!!GSTEP;	?
04600	") 
04700	NEWTOP([
04800	else RETURN("
04900	BAIL Cmds that Type Information:
05000		variable;		;type value of variable
05100		expr;			;type result of a SAIL expression
05200		TEXT			;current text and scope in pgm
05300		ARGUMENTS		;args of the current procedure
05400		TRAPS			;BREAKS and TRACES in effect
05500		SHOW coord1,coord2	;source code from coord1 to coord2
05600		COORDINATE loc		;coordinate (stmnt #) of loc
05700	BAIL Cmds for Tracing/Pausing:
05800		TRACE procedure		;trace call/return of procedure
05900		UNTRACE procedure	;turn off trace of procedure
06000		BREAK loc [,condition]	;BREAK pgm at loc if condition
06100		UNBREAK loc		;turn off BREAK at loc
06200		CONTINUE		;continue program from a BREAK
06300		STEP			;xct nxt stmt in program
06400		NEXT			;xct nxt stmt or procedure call
06500	Miscellaneous:	HELP or ?	;type this message
06600			SETLEX level	;set lexical scope to level
06700			DDT		;invoke DDT debugger
06800			OLDBAIL		;get old-style BAIL top level
06900			EXIT		;exit to operating system
07000	loc ::= procedure | block | label | # coordinate | ' octalnumber
07100	Wizards only:	GOTO loc	UP level	PROCESS process!item");
07200	]) # NEWTOP; ;
07300	end "HELP";
     
00100	# CVINTEGR, CVREAL, CVSTRNG;
00200	
00300	INTEGER ARRAY EV1TEMP[1:2];	STRING ARRAY EV1STRTEMP[1:2];
00400	
00500	SIMPLE INTEGER PROCEDURE CVINTEGR(INTEGER REFIT,T); BEGIN "CVINTEGR"
00600	# CONVERT THE DATUM OF THE REFITEM TO INTEGER, USING TEMP CELL NUMBER T.
00700	  RETURN THE REFITEM OF THE RESULT;
00800	INTEGER TYP,LOC;
00900	
01000	IF (TYP_GETTYPE(REFIT))=INTEGR OR REFIT=-1 THEN RETURN(REFIT);
01100	# THE CHECK FOR REFIT=-1 IS TO ACCOMODATE THE  MEMORY  CONSTRUCT;
01200	LOC_RIGHT(REFIT);
01300	IF TYP=FLOTNG THEN MEMLOC(EV1TEMP[T],INTEGER)_MEMORY[LOC,REAL]
01400	ELSE IF TYP=STRNG THEN EV1TEMP[T]_MEMSTRING(LOC)
01500	ELSE EV1ERR("Can't convert to integer");
01600	RETURN(INTEGR+LOCATION(EV1TEMP[T]))
01700	
01800	END "CVINTEGR";
01900	
02000	
02100	SIMPLE INTEGER PROCEDURE CVREAL(INTEGER REFIT,T); BEGIN"CVREAL"
02200	# CONVERT REFIT DATUM TO REAL USING TEMP CELL T. RETURN REFITEM OF RESULT.;
02300	INTEGER TYP;
02400	
02500	IF (TYP_GETTYPE(REFIT))=FLOTNG THEN RETURN(REFIT);
02600	IF TYP=STRNG THEN BEGIN
02700	    REFIT_CVINTEGR(REFIT,T); TYP_INTEGR END;
02800	IF TYP=INTEGR THEN MEMLOC(EV1TEMP[T],REAL)_MEMORY[REFIT,INTEGER]
02900	ELSE EV1ERR("Can't convert to real");
03000	RETURN(FLOTNG+LOCATION(EV1TEMP[T]))
03100	
03200	END "CVREAL";
03300		
03400	
03500	SIMPLE INTEGER PROCEDURE CVSTRNG(INTEGER REFIT,T); BEGIN "CVSTRNG"
03600	# CONVERT THE DATUM OF THE REFIT TO STRING AND RETURN THE REFITEM OF THE RESULT;
03700	INTEGER TYP;
03800	
03900	IF (TYP_GETTYPE(REFIT))=STRNG THEN RETURN(REFIT);
04000	IF TYP=FLOTNG THEN BEGIN
04100	    REFIT_CVINTEGR(REFIT,T); TYP_INTEGR END;
04200	IF TYP=INTEGR THEN EV1STRTEMP[T]_MEMORY[REFIT,INTEGER]
04300	ELSE EV1ERR("Can't convert to string");
04400	RETURN(STRNG+RIGHT(LOCATION(EV1STRTEMP[T])))
04500	
04600	END "CVSTRNG";
     
00100	# INCOR;
00200	SIMPLE INTEGER PROCEDURE INCOR(INTEGER PCACHE;INTEGER ARRAY DCHAIN; INTEGER 
00300		DDEPTH,DISPLVL); BEGIN "INCOR"
00400	# RETURN REFITEM DATUM WHICH HAS ABSOLUTE CORE ADDRESS OF THE OBJECT IN CACHE;
00500	DEFINE SIMPRC=[2];
00600	NOHAND([
00700	INTEGER IND,FATHER,REFIT,PPDA,T,ADDR,PTYPE,FREG;
00800	
00900	IF ((REFIT_CACHE[PCACHE+1]) LAND ('17 LSH 18))=0 THEN # FIXED CORE LOCATION;
01000	    RETURN(REFIT);
01100	]) # NOHAND;
01200	HAND([
01300	START!CODE LABEL ONSTACK,ON1T,UPPROC,LMSCP,SIMP,SERRCK,DONSIMP,TYCK,NSTR,PARAM,NSRP,
01400		NSTR2,RET,BAD1,BAD2,RET1,BADRET;
01500	DEFINE DL=['14],DD=['15],DCH=[2],REFIT=[1],T3=[3],T4=[4],PPDA=[5],FREG=[6],
01600		FATHER=[7],PTYPE=[8];
01700	EXTERNAL INTEGER OUTSTR,INCHWL;
01800		SKIPL	REFIT,PCACHE;
01900		CAILE	REFIT,N!CACHE;
02000		 ARERR	1,["CACHE"];
02100		MOVE	REFIT,CACHE[1](REFIT);	# REFITEM;
02200		TLZN	REFIT,'17;
02300		 JRST	RET;
02400	]) # HAND;
02500	
02600	# WE NOW KNOW THAT THE OBJECT IS ON THE STACK AND IS EITHER A PARAMETER TO 
02700	  A PROCEDURE OR A LOCAL TO A RECURSIVE PROCEDURE.;
02800	NOHAND([
02900	IND_REFIT LAND(1 LSH 22); ADDR_RIGHT(REFIT); REFIT_REFIT LAND '777760000000;
03000	
03100	# FOLLOW UP THE FATHER CHAIN IN THE NAME TABLE UNTIL COMING TO A PROCEDURE;
03200	FATHER_LEFT(CACHE[PCACHE]) LAND '177777;
03300	WHILE NOT(PAGEIT(T!NAME,FATHER+1) LAND PROCB) DO
03400		FATHER_LEFT(PAGEIT(T!NAME,FATHER)) LAND '177777;
03500	# FETCH PDA FOR THE PROCEDURE;
03600	PPDA_RIGHT(PAGEIT(T!NAME,FATHER+1)); PTYPE_LEFT(PAGEIT(T!NAME,FATHER)) LSH -16;
03700	]) # NOHAND;
03800	HAND([
03900	ONSTACK:MOVE	FATHER,PCACHE;
04000		ADDI	FATHER,CACHE[0];
04100	ON1T:	LDB	FATHER,[('222000+FATHER)LSH 18];
04200		ADD	FATHER,C!NAME;
04300		MOVE	PPDA,1(FATHER);
04400		TLNN	PPDA,0+PROCB LSH -18;
04500		 JRST	ON1T;
04600		LDB	PTYPE,[('420200+FATHER)LSH 18];
04700	]) # HAND;
04800	# IF PROCEDURE IS NON-simple,search from DISPLVL to DDEPTH to find FREG setting
04900	  which matches PDA;
05000	NOHAND([
05100	IF PTYPE NEQ SIMPRC THEN BEGIN
05200	    # go up DCHAIN until finding a non-simple procedure;
05300	    WHILE DCHAIN[DISPLVL,0]<0 AND DISPLVL<DDEPTH DO DISPLVL_DISPLVL+1;
05400	    IF DCHAIN[DISPLVL,0]<0 THEN
05500		EVALERR("BAIL error searching for procedure parameter",
05600		    CVASC(CACHE[PCACHE+2])&CVASC(CACHE[PCACHE+3])&CVASC(CACHE[PCACHE+4]),
05700		    NULL);
05800	    FREG_DCHAIN[DISPLVL,0];
05900	    # SEARCH BACK THROUGH THE STACK (ALONG THE STATIC LINKS) TO FIND THE MSCP;
06000	    WHILE LEFT(T_MEMORY[FREG+1]) NEQ PPDA DO FREG_RIGHT(T); END
06100	# if procedure is simple, search from DISPLVL to DDEPTH for match of PUSHJ on entry addr;
06200	ELSE BEGIN
06300	    FOR DISPLVL_DISPLVL UPTO DDEPTH DO BEGIN
06400		# Look for simple procedure activation and compare against
06500		    addr that was PUSHJ'ed to;
06600		IF DCHAIN[DISPLVL,0]<0 AND RIGHT(MEMORY[PPDA])=RIGHT(
06700		    MEMORY[DCHAIN[DISPLVL+1,1]]) THEN DONE;
06800		IF DISPLVL=DDEPTH THEN
06900		    EVALERR("BAIL error searching for simple procedure parameter",
07000			CVASC(CACHE[PCACHE+2])&CVASC(CACHE(PCACHE[PCACHE+3])&CVASC(CACHE[PCACHE+4]),
07100			NULL);
07200		END;
07300	    # DCHAIN[DISPLVL,0] is now negative of P register at entry to proc. Simulate F reg;
07400	    FREG_1-DCHAIN[DISPLVL,0]; END;
07500	]) # NOHAND;
07600	HAND([
07700		MOVE	DL,DISPLVL;
07800		CAIN	PTYPE,SIMPRC;
07900		 JRST	SIMP;
08000	# GO UP DCHAIN UNTIL NON-SIMPLE;
08100	UPPROC:	MOVEI	DCH,@DCHAIN;		# FWA DATA;
08200		ADDI	DCH,(DL);
08300		ADDI	DCH,(DL);
08400		SKIPGE	(DCH);
08500		CAML	DL,DDEPTH;
08600		SKIPA;
08700		AOJA	DL,UPPROC;
08800		SKIPGE	FREG,(DCH);
08900		 JRST	BAD1;
09000		SKIPA;
09100	LMSCP:	HRRZ	FREG,1(FREG);
09200		JUMPE	FREG,BAD1;	# ANOTHER BUG TRAP;
09300		HLRZ	T3,1(FREG);
09400		CAIN	T3,(PPDA);
09500		JRST	TYCK;	# FOUND THE RIGHT ONE;
09600		CAIE	FREG,-1;# VALUE PUT ON STACK BY SAILOR;
09700		 JRST	LMSCP;	# HAVEN'T GONE OFF END YET;
09800		JRST	BAD1;	# TOO BAD;
09900	SIMP:	MOVEI	DCH,@DCHAIN;
10000		ADDI	DCH,(DL);
10100		ADDI	DCH,(DL);
10200		SKIPL	(DCH);
10300		 JRST	SERRCK;
10400		HRRZ	T3,(PPDA);
10500		HRRZ	T4,@3(DCH);
10600			CAIN	T4,(T3);
10700		 JRST	DONSIMP;
10800	SERRCK:	AOJ	DL,;
10900		CAMG	DL,DDEPTH;
11000		 JRST	SIMP;
11100		JRST	BAD2;
11200	DONSIMP:MOVEI	FREG,1;
11300		SUB	FREG,(DCH);
11400	]) # HAND;
11500	
11600	# FIND OUT WHETHER THIS IS A PARAM OR A LOCAL.  LOCALS ARE FLAGGED WITH
11700		'400000 IN ADDR;
11800	NOHAND([
11900	IF ADDR LAND '400000 THEN BEGIN "LOCAL"
12000	    ADDR_ADDR-'400000;
12100	     # STRINGS CAUSE HAIR.  REFERENCE STRINGS ARE ON THE P-STACK, HENCE THE
12200		ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR IS IN A WORD 
12300		WHICH IS FOUND USING DISPLACEMENTS [POSITIVE FOR LOCALS, NEGATIVE
12400		FOR PARAMS] ON THE F REGISTER.  LOCAL AND VALUE STRINGS ARE ON THE
12500		SP-STACK, HENCE THE ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR
12600		IS COMPUTED USING DISPLACEMENTS FROM THE OLD SP-REGISTER.  THE OLD
12700		SP-REGISTER IS HANDILY SAVED AS THE LAST WORD OF THE 3-WORD MSCP.;
12800	    IF GETTYPE(REFIT)=STRNG THEN	# RECURSIVE STRING LOCAL;
12900		RETURN(REFIT+RIGHT(MEMORY[FREG+2])+ADDR+1)
13000	    ELSE	# RECURSIVE NON-STRING LOCAL;
13100		RETURN(REFIT+FREG+ADDR) END "LOCAL"
13200	ELSE BEGIN "PARAM"
13300	    IF IND AND GETTYPE(REFIT)<ARRY THEN	# SIMPLE REFERENCE PARAM;
13400		RETURN((REFIT LAND '777740000000)+RIGHT(MEMORY[FREG-ADDR-1]))
13500	    ELSE	# VALUE PARAM OR ARRAY;
13600		IF GETTYPE(REFIT)=STRNG THEN BEGIN
13700		    # check for simple procedure;
13800		    IF PTYPE=SIMPRC AND DISPLVL NEQ 0 THEN BEGIN OUTSTR("
13900			BAIL warning: attempt to access value string parameter of simple
14000			procedure which is not at top of stack"); INCHWL; END;
14100		RETURN(REFIT+RIGHT(MEMORY[FREG+2])-ADDR+1) END
14200		ELSE RETURN(REFIT+FREG-ADDR-1) END "PARAM"
14300	]) # NOHAND;
14400	HAND([
14500	TYCK:	TRZN	REFIT,'400000;
14600		 JRST	PARAM;
14700		TLZ	REFIT,'37;
14800		LDB	T3,['270600000000+REFIT];
14900		TLNN	REFIT,0+ITEMB LSH -18;	# STRING ITEM(var) IS NOT A STRING;
15000		CAIE	T3,0+STRNG LSH -23;
15100		 JRST	NSTR;
15200		HRRZ	T3,2(FREG);
15300		ADDI	REFIT,1(T3);
15400		JRST	RET;
15500	NSTR:	ADDI	REFIT,(FREG);
15600		JRST	RET;
15700	PARAM:	LDB	T3,['270600000000+REFIT];
15800		CAIGE	T3,0+ARRY LSH -23;
15900		TLZN	REFIT,'20;
16000		 JRST	NSRP;		# NOT SIMPLE REF PARAM;
16100		SUBI	FREG,1(REFIT);	# -ADDR-1;
16200		HRR	REFIT,(FREG);
16300		JRST	RET;
16400	NSRP:	CAIE	T3,0+STRNG LSH -23;
16500		 JRST	NSTR2;
16600		CAIN	PTYPE,SIMPRC;
16700		SKIPN	DL;
16800		 JRST	RET1;
16900		MOVEI	T3,["
17000	Warning: value string parameter,
17100	simple procedure not at top of stack"];
17200		PUSH	SP,-1(T3);
17300		PUSH	SP,(T3);
17400		PUSHJ	P,OUTSTR;
17500	RET1:	HRRZ	T3,2(FREG);
17600		SUBI	T3,-1(REFIT);		# -ADDR+1;
17700		HRRI	REFIT,(T3);
17800		JRST	RET;
17900	NSTR2:	SUBI	FREG,1(REFIT);
18000		HRRI	REFIT,(FREG);
18100	RET:	SUB	P,['5000005];
18200		JRST	@5(P);
18300	BAD1:
18400	BAD2:		# IF WE NEED TO, WE CAN ALWAYS BREAK THE JRSTs TO HERE;
18500		MOVEI	T3,["
18600	BAIL error, procedure parameter"];
18700		PUSH	SP,-1(T3);
18800		PUSH	SP,(T3);	# GENERAL MESSAGE;
18900		MOVE	T3,PCACHE;	# NOW FOR THE CULPRIT;
19000		ADDI	T3,CACHE[2];
19100		HRLI	T3,'440700;	# FABRICATE A BYTE POINTER;
19200		PUSH	SP,[15];
19300		PUSH	SP,T3;
19400		PUSH	SP,[0];
19500		PUSH	SP,[0];		# EVALERR TAKES 3 STRINGS;
19600		JRST	EVALERR;
19700	END;]) # HAND;
19800	END "INCOR";
     
00100	# GETLSCOPE, PRLSCOPE;
00200	
00300	SIMPLE PROCEDURE GETLSCOPE(INTEGER ARRAY LCHAIN; REFERENCE INTEGER LDEPTH;INTEGER PC);
00400	BEGIN "GETLSCOPE"
00500	NOHAND([
00600	INTEGER I,U,L,T;	LABEL EXACT;
00700	DEFINE LWA(I)=[LEFT(T!BLKADR(I+1))], FWA(I)=[RIGHT(T!BLKADR(I+1))];
00800	# CONSTRUCT LEXICAL SCOPE CHAIN, MOST RECENT FIRST;
00900	
01000	PC_RIGHT(PC);
01100	L_0; U_(L!BLKADR+1) ASH -1;
01200	WHILE U GEQ L DO BEGIN
01300	    I_(L+U) ASH -1;
01400	    IF (T_LWA(I LSH 1))=1+PC THEN GOTO EXACT;
01500	    IF T>PC THEN U_I-1 ELSE L_I+1 END;
01600	IF LWA((I_L) LSH 1) LEQ PC THEN I_L+1;
01700	EXACT:	I_I LSH 1;
01800	# GO UP FATHER CHAIN UNTIL PC IS GEQ FWA;
01900	WHILE PC<FWA(I) DO I_LEFT(T!BLKADR(I));
02000	
02100	LDEPTH_-1; DO BEGIN "UP"
02200	    LCHAIN[LDEPTH_LDEPTH+1]_RIGHT(T!BLKADR(I)) LSH 18 LOR FWA(I);
02300	    I_LEFT(T!BLKADR(I));	# FATHER (IN T!BLKADR) OF THIS BLOCK;
02400	END "UP" UNTIL I=0;
02500	]) # NOHAND;
02600	HAND([
02700	START!CODE LABEL TOP1,TOP2,TEST2,TOP3;
02800	DEFINE I=[1],LCH=[2],LWA=[3],FWA=[3],T=[0];
02900		SETO	I,;
03000		ADD	I,C!BLKADR;	# RELOCATE;
03100		HRRZS	PC;
03200	TOP1:	ADDI	I,2;
03300		HLRZ	LWA,(I);
03400		CAMG	LWA,PC;
03500		 JRST	TOP1;
03600		SUBI	I,1;		# I NOW POINTS AT WORD ZEROES;
03700		JRST	TEST2;
03800	TOP2:	HLRZ	I,(I);
03900		ADD	I,C!BLKADR;
04000	TEST2:	HRRZ	FWA,1(I);
04100		CAMLE	FWA,PC;
04200		 JRST	TOP2;
04300		MOVEI	LCH,@LCHAIN;	# FWA DATA;
04400		SUBI	LCH,1;
04500		SKIPA;
04600	TOP3:	ADD	I,C!BLKADR;
04700		HRLZ	T,(I);
04800		HRR	T,1(I);
04900		ADDI	LCH,1;
05000		MOVEM	T,(LCH);
05100		HLRZ	I,(I);
05200		JUMPN	I,TOP3;
05300		SUBI	LCH,@LCHAIN;
05400		MOVEM	LCH,LDEPTH;
05500		MOVEI	FWA,@LCHAIN;	# FWA DATA;
05600		CAMLE	LCH,-3(FWA);	# BOUNDS CHECK;
05700		 ARERR	1,["LCHAIN"];
05800	END;]) # HAND;
05900	END "GETLSCOPE";
06000	
06100	
06200	SIMPLE PROCEDURE PRLSCOPE(INTEGER ARRAY LCHAIN; INTEGER LDEPTH);BEGIN "PRLSCOPE"
06300	INTEGER I,T,j;
06400	ADDSTR("
06500	Lexical Scope (top down):
06600	");
06700	FOR I_LDEPTH STEP -1 UNTIL 0 DO begin
06800		for j_2 upto ldepth-i do addstr(" ");
06900		ADDSTR(NONULL(CVASTR(PAGEIT(T!NAME,2+(T_LEFT(LCHAIN[I])))) &
07000		CVASTR(PAGEIT(T!NAME,T+3)) & CATCRLF(CVASTR(PAGEIT(T!NAME,T+4))) ));
07100	end;
07200	END "PRLSCOPE";
     
00100	# GETDSCOPE,PRDSCOPE;
00200	SIMPLE PROCEDURE GETDSCOPE(INTEGER FR,PR,PC;REFERENCE INTEGER DDEPTH;
00300			INTEGER ARRAY DCHAIN); BEGIN "DSCOPE"
00400	# DYNAMIC SCOPE UNWINDER ROUTINE.  FILLS ARRAY DCHAIN [*,0] WITH THE
00500	  F (OR P) REGISTER VECTOR CORRESPONDING TO THE DYNAMIC ACTIVATIONS, AND
00600	  DCHAIN [*,1] WITH THE CORRESPONDING PC, WITH THE MOST RECENT ACTIVATION
00700	  FIRST.  THE ENTRIES [*,0] ARE THE F REGISTER VALUES FOR NON-SIMPLE
00800	  PROCEDURES, AND THE NEGATIVE OF THE P REGISTER FOR SIMPLE PROCEDURES.
00900	 I.E., DCHAIN[0,0] = VALUE OF F REGISTER FOR THE ROUTINE BEGIN BROKEN
01000		     [0,1] = PC AT INTERRUPTION
01100		     [1,0] = F REGISTER OF PARENT
01200		     [1,1] = RETURN ADDRESS -1;
01300	NOHAND([
01400	INTEGER I,K,T,PDA;
01500	
01600	DDEPTH_-1; DCHAIN[0,1]_PC;
01700	# '777777 IS THE VALUE PUT ON THE BOTTOM OF THE STACK BY SAILOR;
01800	WHILE (FR_RIGHT(FR)) NEQ '777777 DO BEGIN
01900	    K_FR+RIGHT(MEMORY[(PDA_LEFT(MEMORY[FR+1]))+PD!DSP])+1;
02000		# 1+RIGHT(P) AFTER PROLOG;
02100	    FOR I_RIGHT(PR) STEP -1 UNTIL K DO BEGIN
02200		# SIMPLE PROCEDURE HAS BEEN CALLED, OR WE ARE IN THE MIDDLE OF
02300		  STACKING SOME ARGUMENTS.  PICK UP THE WORD ON THE STACK AND SEE
02400		  IF IT IS A REASONABLE RETURN ADDRESS.  THE INDIRECT AND
02500		  INDEX FIELDS MUST BE ZERO.  THE OPCODE AND ADDRESS FIELDS
02600		  MUST BE NON-ZERO.;
02700		T_MEMORY[I]; IF (T LAND '37000000)=0 AND (T LAND '777000000000)
02800		NEQ 0 AND (T LAND '777777) NEQ 0 THEN BEGIN
02900		    # THERE MUST BE A PUSHJ AT RIGHT(T)-1;
03000		    IF LEFT(MEMORY[T_RIGHT(T)-1])=LEFT(PUSHJ+(P LSH 23)) THEN BEGIN
03100			# SIMPLE PROCEDURE CALLED AT MEMORY[RIGHT(T)-1];
03200			DCHAIN[DDEPTH_DDEPTH+1,0]_-I;	# NEGATIVE OF P AT ENTRY;
03300			DCHAIN[DDEPTH+1,1]_T;		# PC OF CALL (IN PARENT);
03400			PR_I-1;	# PESSIMISTIC ESTIMATE; END
03500		    END
03600		END;
03700	    # NON-SIMPLE PROCEDURE CALLED;
03800	    DCHAIN[DDEPTH_DDEPTH+1,0]_FR;	# F REGISTER OF ROUTINE;
03900	    DCHAIN[DDEPTH+1,1]_RIGHT(MEMORY[FR-1])-1;	# PC OF CALL (IN PARENT);
04000	    PR_FR-2-(RIGHT(MEMORY[PDA+PD!NPW])-1);	# SUBTRACT P-STACK PARAMS;
04100	    FR_MEMORY[FR];
04200	    END;
04300	]) # NOHAND;
04400	HAND([
04500	START!CODE LABEL TOP1,TEST2,OUT2,TEST1,BOT1;
04600	DEFINE I=[1],K=[2],QFR=[3],QPR=[4],PDA=[5],T=[6],T2=[7],DCH=['10];
04700		MOVEI	QFR,FR;
04800		MOVE	QPR,PR;
04900		MOVEI	DCH,@DCHAIN;	# FWA DATA;
05000		MOVE	T,PC;
05100		MOVEM	T,1(DCH);
05200		SUBI	DCH,2;		# ADJUST INITIAL VALUE;
05300		JRST	TEST1;
05400	TOP1:	HLRZ	PDA,1(QFR);
05500		HRRZ	K,PD!DSP(PDA);	# P STACK DISPLACEMENT;
05600		ADDI	K,1(QFR);	# 1+RIGHT(P) AFTER PROLOG;
05700		HRRZI	I,(QPR);
05800	TEST2:	CAIGE	I,(K);
05900		 JRST	OUT2;
06000		MOVE	T,(I);
06100		TLNN	T,'37;		# CHECK INDIR, INDEX;
06200		TLNN	T,'777000;	# CHECK OP CODE;
06300		 SOJA	I,TEST2;
06400		TRNN	T,-1;		# CHECK ADDR;
06500		 SOJA	I,TEST2;
06600		MOVEI	T,-1(T);
06700		HLRZ	T2,(T);		# GET LEFT HALF OF INSTR AT -1(T);
06800		CAIE	T2,'260740;	# PUSHJ P,;
06900		 SOJA	I,TEST2;
07000		ADDI	DCH,2;
07100		MOVNM	I,(DCH);
07200		MOVEM	T,3(DCH);
07300		MOVEI	QPR,-1(I);
07400		SOJA	I,TEST2;
07500	OUT2:	ADDI	DCH,2;
07600		MOVEM	QFR,(DCH);
07700		HRRZ	T,-1(QFR);
07800		SUBI	T,1;
07900		MOVEM	T,3(DCH);
08000		MOVEI	QPR,-2(QFR);
08100		MOVE	T2,PD!NPW(PDA);
08200		SUBI	QPR,-1(T2);	# -# OF ARITH PARAMS;
08300	TEST1:	HRRZ	QFR,(QFR);
08400		JUMPE	QFR,BOT1;	# IN CASE WE RUN OUT (PROCESSES, FOR EXAMPLE);
08500		CAIE	QFR,-1;
08600		 JRST	TOP1;
08700	BOT1:	SUBI	DCH,@DCHAIN;	# CURRENT ADDR MINUS FWA;
08800		LSH	DCH,-1;
08900		MOVEM	DCH,DDEPTH;
09000		MOVEI	T,@DCHAIN;	# FWA DATA;
09100		CAMLE	DCH,-3(T);	# BOUNDS CHECK;
09200		 ARERR	1,["DCHAIN"];
09300	END;]) # HAND;
09400	END "DSCOPE";
09500	
09600	SIMPLE PROCEDURE PRDSCOPE(INTEGER ARRAY DCHAIN; INTEGER DDEPTH); BEGIN "PRDSCOPE"
09700	INTEGER I;
09800	ADDSTR("
09900	Dynamic Scope (most recent first)
10000		level	routine		text
10100	");
10200	FOR I_0 UPTO DDEPTH DO BEGIN
10300	    addstr(cvs(i)&tab);
10400	    ADDSTR(IF DCHAIN[I,0]<0 THEN ".simple."
10500		ELSE MEMSTRING(2+LEFT(MEMORY[DCHAIN[I,0]+1])));
10600	    ADDSTR(CATCRLF(TAB & GETTEXT(DCHAIN[I,1]))) END;
10700	
10800	END "PRDSCOPE";
     
00100	# TFIND,BREAK1,SWAP!BREAKS,PLANT!BREAKS,UNPLANT!BREAKS,LOC!PC,BREAK,COORD,TRAPS;
00200	
00300	SIMPLE INTEGER PROCEDURE TFIND(STRING LOCNAME; BOOLEAN ANYNAM;
00400		REFERENCE INTEGER CRDADDR); BEGIN "TFIND"
00500	# Special find routine for TRACE, BREAK, etc, since one frequently wants to
00600	  specify names which are not in the current algol scope.
00700	
00800	  The format of LOCNAME is
00900		[LOCNAME]:=[SAILID] or [BLOCKNAME].[LOCNAME]
01000	
01100	  The search for LOCNAME proceeds as follows.  The block table [T!BLKADR]
01200	  is searched from the end to the beginning [breadth first].  If just
01300	  [SAILID] appears, then [SAILID] must be a block or procedure name, and
01400	  the search is for a match on the name.  If more than just [SAILID]
01500	  appears, then the search is for a match on the [BLOCKNAME].
01600	  If more than oneE [BLOCKNAME] appears, the search
01700	  is continued for each succeeding [BLOCKNAME] at the point where the
01800	  previous search ended.  This is continued until the last [BLOCKNAME] is
01900	  located.  Then the ancestry of the last [BLOCKNAME] is consructed,,
02000	  and FIND is asked to locate [SAILID].
02100	
02200	  This is very flexible and powerful.  The complete history of [SAILID]
02300	  need not be specified in LOCNAME.  Indeed, the sequence of [BLOCKNAME]s
02400	  need not be a treelike path at all.
02500	;
02600	
02700	INTEGER CLASS,PNTR,I,CRDNO;	STRING STRVAL;
02800	
02900	PNTR_L!BLKADR+1;
03000	WHILE LENGTH(LOCNAME) DO BEGIN
03100	    GET!TOKEN(LOCNAME,STRVAL,CLASS_-1,CRDADDR_0);
03200	    IF CRDADDR THEN RETURN(-2);	# ABSOLUTE LOCATION;
03300	    IF LENGTH(STRVAL)=0 THEN EVALERR("Bad location",STRVAL,LOCNAME);
03400	    IF LENGTH(LOCNAME) THEN BEGIN "BLKNAM" LABEL NEXBLK;
03500		WHILE (PNTR_PNTR-2) GEQ 0 DO BEGIN "HUNT"
03600		    FOR I_0 UPTO 2 DO IF PAGEIT(T!NAME,RIGHT(T!BLKADR(PNTR))+2+I) NEQ
03700			NAME[I] THEN CONTINUE "HUNT";
03800		    I_LOP(LOCNAME); # GET RID OF DELIM;
03900		    GOTO NEXBLK END "HUNT"; NEXBLK: END "BLKNAM"
04000	    ELSE BEGIN "SAILID"
04100		IF L!BLKADR+1 NEQ PNTR THEN GETLSCOPE(TLSCOPE,TLDEPTH,RIGHT(T!BLKADR(PNTR+1)));
04200		IF (I_FIND(NAME,TLSCOPE,TLDEPTH,ANYNAM))GEQ 0 THEN RETURN(I);
04300		I_LOP(STRVAL);
04400		IF I="#" THEN # COORDINATE SPECIFICATION;
04500		    CRDADDR_RIGHT(TARRAY[CRDFND(INTSCAN(STRVAL,I))+1]);
04600		RETURN(-1)
04700		END "SAILID"
04800	END
04900	END "TFIND";
05000	
05100	
05200	BOOLEAN BREAKPOINTS!PLANTED;
05300	
05400	SIMPLE PROCEDURE SWAP!BREAKS; BEGIN "SWAPBR"
05500	NOHAND([
05600	INTEGER I; FOR I_0 UPTO L!BK DO IF BK!LOC[I] NEQ 0 THEN
05700	    MEMORY[BK!LOC[I]] SWAP BK!INSTR[I];BREAKPOINTS!PLANTED_NOT BREAKPOINTS!PLANTED;
05800	]) # NOHAND;
05900	HAND([
06000	START!CODE LABEL LOOP,BOT; DEFINE I=['14],T=[0];
06100		MOVSI	I,-N!BK;
06200	LOOP:	SKIPN	BK!LOC[0](I);
06300		 JRST	BOT;
06400		MOVE	T,BK!INSTR[0](I);
06500		EXCH	T,@BK!LOC[0](I);
06600		MOVEM	T,BK!INSTR[0](I);
06700	BOT:	AOBJN	I,LOOP;
06800		SETCMM	BREAKPOINTS!PLANTED;
06900	END;
07000	]) # HAND;
07100	END "SWAPBR";
07200	
07300	SIMPLE PROCEDURE PLANT!BREAKS;
07400	    IF NOT BREAKPOINTS!PLANTED THEN SWAP!BREAKS;
07500	
07600	SIMPLE PROCEDURE UNPLANT!BREAKS;
07700	    IF BREAKPOINTS!PLANTED THEN SWAP!BREAKS;
07800	
07900	
08000	
08100	SIMPLE PROCEDURE BREAK1(INTEGER LOC; STRING NAME,COND,ACT; INTEGER MPC,NEWINSTR);
08200	BEGIN "BREAK1"
08300	# INSERT A BREAKPOINT AT MEMORY[LOC], OVERWRITING ANY OLD BREAKPOINT
08400	  Left half of LOC has bit(s) which may flag temporary breakpoints.
08500	  Indirect through LOC should work;
08600	NOHAND ([
08700	INTEGER I; EXTERNAL PROCEDURE !UINIT;
08800	# DO NOT BREAK THE CALL ON !UINIT (WHICH IS THE FIRST INSTRUCTION IN THE OUTER BLOCK);
08900	IF RIGHT(MEMORY[LOC])=LOCATION(!UINIT) THEN LOC_LOC+1;
09000	UNPLANT!BREAKS;
09100	# SEARCH FOR DUPLICATE OR FOR EMPTY SLOT;
09200	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;
09300	IF I=N!BK THEN EV1ERR("Brkpt ov.")
09400	ELSE BEGIN
09500		BK!LOC[I]_LOC; BK!INSTR[I]_NEWINSTR;
09600		BK!COND[I]_COND; BK!ACT[I]_ACT; BK!COUNT[I]_MPC; BK!NAME[I]_NAME END
09700	]) # NOHAND;
09800	HAND ([
09900	LABEL BAD;
10000	START!CODE
10100	DEFINE I=['14],T=['13],KEY=['15],R=[1]; LABEL LOOP,LOOP2,FOUND;
10200	EXTERNAL INTEGER !UINIT;
10300		HRRZ	I,@LOC;
10400		CAIN	I,!UINIT;
10500		 AOS	LOC;
10600		PUSHJ	P,UNPLANT!BREAKS;
10700		MOVSI	I,-N!BK;
10800		HRRZ	R,LOC;
10900	LOOP:	HRRZ	KEY,BK!LOC[0](I);
11000		CAIE	KEY,(R);
11100		AOBJN	I,LOOP;
11200		JUMPL	I,FOUND;	# WRITE OVER AN OLD BREAKPOINT;
11300		MOVSI	I,-N!BK;	# ELSE SEARCH FOR AN EMPTY SLOT;
11400	LOOP2:	SKIPE	BK!LOC[0](I);
11500		AOBJN	I,LOOP2;
11600		JUMPGE	I,BAD;		# NONE LEFT;
11700	FOUND:	MOVE	T,LOC;
11800		MOVEM	T,BK!LOC[0](I);
11900		MOVE	T,NEWINSTR;
12000		MOVEM	T,BK!INSTR[0](I);
12100		MOVE	T,MPC;
12200		MOVEM	T,BK!COUNT[0](I);
12300		LSH	I,1;
12400		HRROI	T,(SP);
12500		MOVEI	R,BK!ACT[0](I);
12600		POP	T,(R);
12700		POP	T,-1(R);
12800		MOVEI	R,BK!COND[0](I);
12900		POP	T,(R);
13000		POP	T,-1(R);
13100		MOVEI	R,BK!NAME[0](I);
13200		POP	T,(R);
13300		POP	T,-1(R);
13400	END; RETURN;
13500	BAD:	EV1ERR("Brkpt ov.");
13600	]) # HAND;
13700	END "BREAK1";
13800	
13900	
14000	SIMPLE INTEGER PROCEDURE LOC!PC(STRING LOCNAME; INTEGER ANYNAM(TRUE));
14100	BEGIN "LOC!PC"
14200		# returns the PC associated with the place named in locname.
14300		  if anynam is false then locname must be a procedure and the
14400		  procedure descriptor address is returned;
14500		INTEGER PNTR,REFIT,T,CRDADDR;
14600		PNTR_TFIND(LOCNAME,ANYNAM,CRDADDR);
14700		IF PNTR=-1 AND CRDADDR=0 
14800		THEN EVALERR("Unknown " & (IF ANYNAM THEN "location" ELSE "procedure"),LOCNAME,NULL);
14900		IF PNTR<0 THEN REFIT_CRDADDR  # COORDINATE OR OCTAL LOCATION;
15000		ELSE 
15100		IF (T_GETTYPE((REFIT_CACHE[PNTR+1]))) NEQ 0 AND
15200				    NOT(REFIT LAND PROCB) AND T NEQ LBLTYP
15300		THEN EVALERR("Need block, label, coordinate, or procedure",LOCNAME,NULL)
15400		ELSE 
15500		IF ANYNAM AND (REFIT LAND PROCB) THEN BEGIN "break proc"
15600	# We want to break a procedure.  There was (is?) some confusion about
15700	where to put the break.  For a simple procedure (one with TEMPB on in
15800	its  refitem)  the  break  belongs  on  the JFCL 0 which the compiler
15900	inserted  for  this  purpose  at  user  request.   For  a  non-simple
16000	procedure  the  break  belongs  on the HRRZI F,-n(P) which sets the F
16100	register.  In  the  case of a non-recursive procedure (or a recursive
16200	procedure  with  no parameters) the location of the HRRZI is given by
16300	the  pcnt  at  MKSEMT  in the procedure descriptor.  In the case of a
16400	recursive  procedure  with  parameters, a search must be made for the
16500	HRRZI, because the code which puts the locals on the stack and zeroes
16600	them  is  of undetermined length.  All this barf is made necessary in
16700	the  first  place  because  the  first instruction inside a procedure
16800	might  be  a  WHILE  loop,  and we want to break only on entry to the
16900	procedure, not everytime around the loop;
17000		    # PCNT AT MKSEMT;
17100		    PNTR_LEFT(MEMORY[RIGHT(REFIT)+PD!PPD]);    
17200		    # MAKE SURE THE INSTR WE LOOK FOR WILL BE THERE;
17300		    UNPLANT!BREAKS;	
17400		    # '255 LSH 27 = JFCL; 
17500		    IF REFIT LAND TEMPB AND MEMORY[PNTR_PNTR-1]='255 LSH 27 
17600		    THEN REFIT_PNTR
17700		    ELSE WHILE LEFT(MEMORY[PNTR]) NEQ '551517 # HRRZI F,(P);
17800		    DO PNTR_PNTR+1; REFIT_PNTR 
17900		END "break proc";
18000		# RETURN FULL REFITEM FOR PROC;
18100		RETURN(IF ANYNAM THEN RIGHT(REFIT) ELSE REFIT);	
18200	END "LOC!PC";
18300	
18400	procedure BREAK(string locname;string cond(""),act("");integer mpc(0));
18500	begin "BREAK"
18600		# insert breakpoint at beginning of thing specified in locname.;
18700		BREAK1(LOC!PC(locname),locname,cond,act,mpc,pjpbail)
18800	end "BREAK";
18900	
19000	string procedure COORD(string locname);
19100	begin "COORD"
19200		# returns the coordinate number of the place named by locname.
19300		  if locname has form 'nnnn, then nnnn will be treated as an 
19400		  octal number;
19500		ssf_true;
19600		RETURN(	if not length(locname) then null
19700			else
19800			"#"&cvs((TARRAY[1+CRD!PC(IF LOCNAME="'" 
19900					THEN CVO(LOCNAME[2 TO INF]) 
20000					ELSE LOC!PC(LOCNAME))] LSH -18) 
20100				LAND '377777));
20200	end "COORD";
20300	
20400	STRING PROCEDURE TRAPS; BEGIN INTEGER I;
20500	addstr(crlf);
20600	FOR I_0 UPTO N!BK-1 DO
20700	    IF LENGTH(BK!NAME[I]) THEN ADDSTR(CATCRLF(BK!NAME[I] & TAB & BK!COND[I] & TAB
20800		& BK!ACT[I] & TAB & (IF BK!COUNT[I]>0 THEN CVS(BK!COUNT[I]) ELSE NULL)))
20900	    ELSE IF BK!LOC[I] THEN ADDSTR(CATCRLF((0+"'")&CVOS(BK!LOC[I])));
21000	ssf_true;
21100	RETURN(DUMPSTR) END;
     
00100	# PRARGS, TRACER, TRACE;
00200	
00300	SIMPLE PROCEDURE PRARGS(INTEGER REFIT,PPNTR,SPPNTR); BEGIN "PRARGS"
00400	# PRINT ARGUMENTS, GIVEN PROC DESCR AND STACK POINTERS;
00500	INTEGER PARAMPNTR,NP;
00600	START!CODE LABEL LOOP,NSTRV,BOT,OUT1,NARR,ARR; DEFINE T=['14],T2=['15];
00700		PUSH	P,REFIT;
00800		PUSHJ	P,N!PARAMS;
00900		JUMPLE	1,OUT1;
01000		MOVEM	1,NP;
01100		HRRZ	2,PPNTR;	# TOS;	
01200		MOVE	1,REFIT;
01300		HRRZ	3,PD!NPW(1);	# #ARITH PARAMS+1;
01400		SUBI	2,-1(3);
01500		MOVEM	2,PPNTR;	# BEGINNING OF PSTACK PARAMS;
01600		HRRZ	2,SPPNTR;
01700		HLRZ	3,PD!NPW(1);	# 2*#STRING PARAMS;
01800		SUBI	2,-2(3);
01900		MOVEM	2,SPPNTR;	# BEGINNING OF SPSTACK PARAMS;
02000		HRRZ	3,PD!DLW(1);	# POINTER TO PARAM INFO;
02100		MOVEM	3,PARAMPNTR;
02200	LOOP:	MOVE	T,@PARAMPNTR;
02300		AOS	PARAMPNTR;
02400		LDB	T2,[('271000 LSH 18)+T];	# 8 BITS WIDE TO GET ITEMB, TOO;
02500		CAIN	T2,0+STRNG LSH -23;
02600		TLNE	T,0+REFB LSH -18;
02700		 JRST	NSTRV;
02800		HRR	T,SPPNTR;
02900		AOS	SPPNTR;
03000		AOS	SPPNTR;
03100		JRST	BOT;
03200	NSTRV:	HRR	T,PPNTR;
03300		AOS	PPNTR;
03400		TLNE	T,0+ARY2B LSH -18;
03500		 JRST	ARR;			#  ARRAY ITEMVAR ARRAY is an array;
03600		TLNN	T,0+ITEMB LSH -18;	# BUT PLAIN ITEMVAR IS NOT;
03700		CAIGE	T2,0+ARRY LSH -23;
03800		 JRST	NARR;
03900	ARR:	TLO	T,'20;
04000		JRST	BOT;
04100	NARR:	TLNE	T,0+REFB LSH -18;	# CHECK FOR REFERENCE PARAMS;
04200		 HRR	T,(T);
04300	BOT:	PUSH	P,T;
04400		PUSHJ	P,WR!TON;
04500		SOSLE	NP;
04600		 JRST	LOOP;
04700	OUT1:END;
04800	END "PRARGS";
04900	
05000	SIMPLE PROCEDURE TRACER;
05100	BEGIN "TRACER"
05200	# CALLED BY AN INSERTED PUSHJ FROM ENTRY ADDRESS OF ROUTINE BEING TRACED.
05300	WHAT TO DO:
05400	1.  PICK UP TOP WORD OF STACK AND GET THE REFITEM FROM THE MULTIPLE PROCEED	
05500		COUNT OF THE CORRESPONDING BREAK ENTRY.
05600	2.  USE THE PDA INFO TO PRINT THE PROCEDURE NAME AND PARAMETERS.
05700	3.  MASSAGE THE P STACK SO THAT THE TRACED PROCEDURE RETURNS TO TRACER.
05800	4.  XCT THE DISPLACED INSTRUCTION.
05900	5.  JUMP TO ENTRY ADDRESS+1.
06000	6.  UPON RETURN FROM TRACED PROCEDURE, PRINT THE NAME (AND RESULT, IF ANY).
06100	7.  RESTORE P STACK TO ITS PROPER STATE.
06200	8.  RETURN.
06300	
06400	THE P-STACK GETS TWO EXTRA WORDS IN STEP 3.  THE FIRST ONE IS THE ORIGINAL RETURN ADDRESS,
06500	THE SECOND IS THE REFITEM FOR THE TRACED PROCEDURE, TO ALLOW PRINTING THE NAME AND RESULT;
06600	
06700	INTEGER REFIT,REFITA,I,BL,PPNTR,SPPNTR,PARAMPNTR,TRLEV,NP,ENTAD,T;
06800	DEFINE SPACES=["          "];
06900	
07000	# STACK LOOKS LIKE
07100			(P)/	RETURN TO ENTRY+1
07200			-1(P)/	RETURN TO CALLING PROC
07300			-2(P)/	PARAM n
07400			.
07500			.
07600			.
07700			-n-3(P)/	PARAM 1;
07800	START!CODE
07900		POP	P,0;		# REMOVE RETURN TO ENTRY+1;
08000		SUBI	0,1;		# ENTRY ADDRESS;
08100		MOVEM	0,ENTAD;
08200			AOS	TRLEV;		# DEPTH OF TRACE;
08300		END;
08400	NOHAND([
08500	FOR BL_0 UPTO L!BK DO IF BK!LOC[BL]=RIGHT(ENTAD) THEN DONE;
08600	REFIT_BK!COUNT[BL];
08700	]) # NOHAND;
08800	HAND([START!CODE
08900	DEFINE KEY=[0],I=['14]; LABEL LOOP,GOOD;
09000		HRRZ	KEY,ENTAD;
09100		MOVSI	I,-N!BK;
09200	LOOP:	CAME	KEY,BK!LOC[0](I);
09300		AOBJN	I,LOOP;
09400		JUMPL	I,GOOD;
09500		PUSH	SP,[10];
09600		PUSH	SP,["TRACE sunk"];
09700		PUSHJ	P,FATAL;	# TRACER CALLED BUT TRACE LOCATION NOT IN TABLE;
09800	GOOD:	MOVE	KEY,BK!COUNT[0](I);
09900		MOVEM	KEY,REFIT;
10000		HRRZM	I,BL;
10100	END;]) # HAND;
10200	OUTSTR(CRLFCAT(SPACES[1 FOR TRLEV]&"Entering "&MEMSTRING(REFIT+2)));
10300	START!CODE	EXTERNAL INTEGER OUTSTR;
10400		PUSH	P,REFIT;
10500		MOVEI	'14,-1(P);
10600		PUSH	P,'14;
10700		MOVEI	'14,(SP);
10800		PUSH	P,'14;
10900		PUSHJ	P,PRARGS;
11000		PUSHJ	P,DUMPSTR;
11100		PUSHJ	P,OUTSTR;
11200	END;
11300	
11400	# MASSAGE THE STACK;
11500	
11600	START!CODE	LABEL TR!RET,TRRETW;
11700		MOVE	1,REFIT;
11800		HRRZ	2,PD!NPW(1);	# #ARITH PARAMS+1;
11900		HRRZ	3,P;
12000		SUBI	3,-1(2);	# AC3 POINTS AT FIRST PARAM;
12100		HRLI	4,(3);
12200		HRRI	4,TARRAY[0];
12300		BLT	4,TARRAY[0](2);	# UNSTACK;
12400		PUSH	P,0;		# SPACE FILLER;
12500		MOVE	0,-1(P);	# RETURN TO CALLING PROC;
12600		MOVEM	0,(3);		# PLANT IT;
12700		MOVEM	1,1(3);		# PLANT REFIT;
12800		HRLI	4,TARRAY[0];
12900		HRRI	4,2(3);
13000		BLT	4,(P);		# STACK;
13100		MOVE	4,BL;
13200		PUSH	P,TRRETW;	# PUT RETURN ON STACK;
13300		XCT	BK!INSTR[0](4);	# THIS IS EITHER A  PUSH P,F  OR A  JFCL;
13400		MOVE	2,ENTAD;
13500		JRST	1(2);		# CALL THE TRACED PROC;
13600	TRRETW:	CAM	TR!RET;		# TYPICAL PUSHJ WORD;
13700	TR!RET:	POP	P,REFIT;
13800		MOVEM	1,REFITA;
13900		END;
14000	OUTSTR(CRLFCAT(SPACES[1 FOR TRLEV]&"Exiting "&MEMSTRING(REFIT+2)));
14100	IF (T_GETTYPE(REFIT)) NEQ 0 THEN BEGIN "RESULT"
14200	    OUTCHR("="); IF T=STRNG THEN begin
14300			# Even this patch does not do quotes right;
14400			outchr('42);
14500			START!CODE
14600				PUSH	SP,-1(SP);
14700				PUSH	SP,-1(SP);
14800				PUSHJ	P,OUTSTR;
14900			END;
15000			outchr('42);
15100	    end
15200	    ELSE BEGIN WR!TON(T LOR LOCATION(REFITA)); OUTSTR(DUMPSTR) END END "RESULT";
15300	OUTSTR(CRLF);
15400	START!CODE
15500		MOVE	1,REFITA;
15600		SOS	TRLEV;
15700		POPJ	P,0;		# FINALLY!;
15800		END;
15900	END "TRACER";
16000	
16100	
16200	PROCEDURE TRACE(STRING PROCNAME);
16300	BEGIN"TRACE"
16400	# BREAK ENTRY AND EXIT OF PROCEDURE;
16500		INTEGER REFIT;	 DEFINE PUSHJ=['260000000000];
16600	BREAK1(MEMORY[REFIT_LOC!PC(PROCNAME,FALSE)],PROCNAME,"","",REFIT,PUSHJ+(P LSH 23)+
16700	    LOCATION(TRACER));
16800	END "TRACE";
     
00100	# UNBREAK1,UNBREAK,UNTRACE,CLRTBK,STEPPING;
00200	
00300	SIMPLE PROCEDURE UNBREAK1(INTEGER LOC); BEGIN "UNBREAK1"
00400	# REMOVE BREAKPOINT AT MEMORY[LOC];
00500	NOHAND([
00600	INTEGER I;
00700	UNPLANT!BREAKS;
00800	# SEARCH FOR THE BREAKPOINT;
00900	FOR I_0 UPTO N!BK DO IF I=N!BK OR RIGHT(BK!LOC[I])=RIGHT(LOC) THEN DONE;
01000	IF I=N!BK THEN EVALERR("UNBREAK1. Not currently broken",
01100	    CVOS(LOC),NULL);
01200	BK!INSTR[I]_0; BK!LOC[I]_0; BK!NAME[I]_NULL
01300	]) # NOHAND;
01400	HAND([
01500		LABEL BAD;
01600	START!CODE	DEFINE I=['14],T=['13],KEY=['15]; LABEL LOOP;
01700		PUSHJ	P,UNPLANT!BREAKS;
01800		MOVSI	I,-N!BK;
01900		HRRZ	KEY,LOC;
02000	LOOP:	HRRZ	T,BK!LOC[0](I);
02100		CAIE	T,(KEY);
02200		AOBJN	I,LOOP;
02300		JUMPGE	I,BAD;
02400		SETZM	BK!INSTR[0](I);
02500		SETZM	BK!LOC[0](I);
02600		ADDI	I,-1(I);	# 2*I-1;
02700		SETZM	BK!NAME[0](I);	# TURNS IT INTO A STRING OF LENGTH 0, HENCE NULL;
02800	END; RETURN;
02900	BAD:	EVALERR("UNBREAK1. Not currently broken",CVOS(LOC),NULL)
03000	]) # HAND;
03100	END "UNBREAK1";
03200	
03300	
03400	PROCEDURE UNBREAK(STRING LOCNAME);
03500	UNBREAK1(LOC!PC(LOCNAME));
03600	
03700	
03800	PROCEDURE UNTRACE(STRING PROCNAME);
03900	# SIGNIFY "PROC ONLY", WHICH GETS PROCEDURE DESCRIPTOR ADDR FROM LOC!PC.
04000	  THEN PICK UP ENTRY ADDR FROM PROCEDURE DESCRIPTOR;
04100	UNBREAK1(MEMORY[LOC!PC(PROCNAME,FALSE)]);
04200	
04300	
04400	SIMPLE PROCEDURE CLRTBK(INTEGER LOC); BEGIN "CLRTBK"
04500	# (CLEAR GROUP OF TEMPORARY BREAKPOINTS)
04600	  SEARCH THE BREAKPOINT TABLE FOR THE LOCATION.  IF NOT FOUND, EXIT.
04700	  IF LOCATION IS ONE OF A SET OF TEMPORARY BREAK POINTS, CLEAR THE WHOLE SET.
04800	  CLRTBK IS ALWAYS CALLED WITH THE BREAK-POINT INSTRUCTIONS IN.
04900	  MUST BE START!CODE BECAUSE AC'S MUST BE SAVED;
05000	START!CODE LABEL LOOP1,LOOP2,RET,BOT2; DEFINE I=['14],J=['15],KEY=['13];
05100		MOVSI	I,-N!BK;
05200		HRRZ	KEY,LOC;
05300	LOOP1:	HRRZ	J,BK!LOC[0](I);
05400		CAIE	J,(KEY);
05500		AOBJN	I,LOOP1;
05600		JUMPGE	I,RET;
05700		HLRZ	J,BK!LOC[0](I);
05800		JUMPE	J,RET;
05900		MOVSI	I,-N!BK;
06000	LOOP2:	HLRZ	KEY,BK!LOC[0](I);
06100		CAIE	KEY,(J);
06200		 JRST	BOT2;
06300		MOVE	KEY,BK!INSTR[0](I);
06400		MOVEM	KEY,@BK!LOC[0](I);
06500		SETZM	BK!INSTR[0](I);
06600		SETZM	BK!LOC[0](I);
06700	BOT2:	AOBJN	I,LOOP2;
06800	RET:	END;
06900	END "CLRTBK";
07000	
07100	SIMPLE PROCEDURE STEP!POPJ; START!CODE
07200	# CALLED BY PUSHJ; DEFINE I=['14]; LABEL DOT1;
07300		SOS	(P);		# POINT TO BREAK THAT GOT US HERE;
07400		PUSHJ	P,CLRTBK;	# CLEAR TEMP BREAKS, REMOVE EXTRA RETURN WORD;
07500		JSP	I,DOT1;		# CURRENT FLAGS;
07600	DOT1:	TLO	I,'20;		# "JRST MODE" BREAK;
07700		HLLM	I,(P);		# SUBSTITUTE FLAGS;
07800		JRST	BAIL;		# POPS STACK AS RETURN WORD, GETS INTO BAILOR;
07900	END;
08000	
08100	SIMPLE PROCEDURE STEP!ATJRST; START!CODE
08200	# CALLED BY JSP '14,STEP!ATJRST;
08300	DEFINE KEY=['14],I=['13],J=['15]; LABEL LOOP;
08400		MOVEI	KEY,-1(KEY);	# ADDR OF JSP;
08500		MOVSI	I,-N!BK;
08600	LOOP:	HRRZ	J,BK!LOC[0](I);
08700		CAIE	J,(KEY);
08800		AOBJN	I,LOOP;
08900		MOVEI	I,@BK!INSTR[0](I);	# THE EFFECTIVE ADDRESS;
09000		TLO	I,'20;		# JRST MODE BREAK;
09100		PUSH	P,I;		# A COPY FOR BAIL TO POP;
09200		PUSH	P,KEY;		# LOCATION OF JSP '14,;
09300		PUSHJ	P,CLRTBK;	
09400		JRST	BAIL;
09500	END;
09600	
09700	SIMPLE PROCEDURE STEPIT(INTEGER PC; INTEGER ARRAY INSTR,MASK); BEGIN "STEPIT"
09800	DEFINE PUSHJ=['260000000000],POPJ=['263000000000],PUSH=['261000000000],
09900	       JSP14=['265600000000];
10000	NOHAND([
10100		SIMPLE PROCEDURE BREAK2(INTEGER LOC);
10200		BREAK1(RIGHT(LOC)+(1 LSH 23),"","","",0,PJPBAIL);
10300	INTEGER I,L,U,U2,J,T;
10400	U2_ARRINFO(INSTR,2);	# UPPER BOUND FOR FIRST DIMENSION;
10500	# SEARCH COORDINATE INDEX AND THEN COORDINATE TABLE TO FIND PC OF CURRENT
10600	  STATEMENT AND NEXT;
10700	I_CRD!PC(PC);
10800	L_RIGHT(TARRAY[I+1]); U_RIGHT(TARRAY[I+3]);	# PC OF CURRENT, NEXT STATEMENT;
10900	IF U='777777 THEN U_L+'200;
11000	UNPLANT!BREAKS;
11100	FOR I_L UPTO U DO BEGIN
11200	    FOR J_0 UPTO U2 DO BEGIN
11300		IF ((T_MEMORY[I]) XOR INSTR[J]) LAND MASK[J]=0 THEN BEGIN
11400		    IF INSTR[J]=POPJ 
11500		    THEN BREAK1((1 LSH 23)+I,"","","",0,PUSHJ+(P LSH 23)+LOCATION(STEP!POPJ)
11600		    ELSE IF INSTR[J]=ATJRST
11700		    THEN BREAK1((1 LSH 23)+I,"","","",0,('265 LSH 27)+('14 LSH 23)+
11800			    LOCATION(STEP!ATJRST))
11900		    ELSE IF INSTR[J]=PUSHJ
12000		    THEN BEGIN # DON'T BREAK LOCATIONS IN SEGMENT OR CALLS ON BAIL;
12100			IF RIGHT(T)<NOTENX('400000) TENX('640000) 
12200			    AND RIGHT(T) NEQ LOCATION(BAIL)
12300				THEN BEGIN
12400				IF LEFT(MEMORY[T]) NEQ '255000	# JFCL (/4B simple proc.);
12500				THEN WHILE LEFT(MEMORY[T]) NEQ '551517 DO T_T+1;
12600					# find HRRZI RF,-n(P) which sets environment;
12700				BREAK2(T) END END
12800		    ELSE BREAK2(T);
12900		    DONE END;
13000	    END END;
13100	BREAK2(U);
13200	]) # NOHAND;
13300	HAND([
13400	INTEGER L,U,U2,J;
13500	START!CODE LABEL STPBBRK,STPBRK,TOP2,LAB1,LAB2,INC2,INC1,CHK1,SP0LUP,HRRZL,LAB3,LAB4;
13600	DEFINE A=[1],B=[2],I=[3],INS=[4];
13700		MOVE	A,INSTR;
13800		MOVE	A,-3(A);	# UPPER BOUND FOR FIRST DIM;
13900		MOVEM	A,U2;
14000		PUSH	P,PC;
14100		PUSHJ	P,CRD!PC;
14200		HRRZ	I,TARRAY[1](1);
14300		MOVEM	I,L;		# PC CURRENT STMT;
14400			HRRZ	B,TARRAY[3](1);
14500		MOVEM	B,U;		# PC NEXT STMT;
14600		MOVEI	A,'200(I);
14700		CAIN	B,-1;
14800		MOVEM	A,U;
14900		PUSHJ	P,UNPLANT!BREAKS;
15000		JRST	CHK1;
15100	STPBBRK:MOVE	A,PJPBAIL;
15200	STPBRK:	HRLI	B,'40;
15300		PUSH	P,B;		# B=WHERE;
15400		MOVEI	B,6;	# 6 ZEROES ON SP;
15500	SP0LUP:	PUSH	SP,[0];
15600		SOJG	B,SP0LUP;
15700		PUSH	P,[0];
15800		PUSH	P,A;		# A=WHAT INSTR TO USE;
15900		PUSHJ	P,BREAK1;
16000		POPJ	P,;
16100	TOP2:	MOVE	INS,INSTR;	# FWA INSTR ARRAY;
16200		ADDI	INS,(A);	# ADD J;
16300		MOVE	B,MASK;	# FWA MASK ARRAY;
16400		ADDI	B,(A);	# ADD J;
16500		MOVE	A,(INS);
16600		XOR	A,(I);
16700		AND	A,(B);
16800		JUMPN	A,INC2;	# INSTR NOT ONE WE WANT;
16900		HLRZ	INS,(INS);	# OPCODE IN RIGHT HALF;
17000		MOVE	A,PJPBAIL;	# GET PUSHJ P, IN TOP HALF OF A;
17100		HRRI	A,STEP!POPJ;
17200		MOVEI	B,(I);		# ADDR TO BREAK;
17300		CAIE	INS,0+ATJRST LSH -18;
17400		 JRST	LAB3;
17500		MOVSI	A,0+JSP14 LSH -18;
17600		HRRI	A,STEP!ATJRST;
17700		JRST	LAB4;
17750	]) # HAND;  HAND([
17800	LAB3:	CAIE	INS,0+POPJ LSH -18;
17900		 JRST	LAB1;
18000	LAB4:	PUSHJ	P,STPBRK;
18100		JRST	INC1;
18200	LAB1:	HRRZ	B,(I);		# DEALING WITH PUSHJ, AOJA, SOJA, JUMPx, JRST;
18300		CAIE	INS,0+PUSHJ LSH -18;
18400		 JRST	LAB2;
18500		CAIGE	B,NOTENX('400000) TENX('640000);	# NOW PUSHJ ONLY;
18600		CAIN	B,BAIL;
18700		 JRST	INC1;
18800					# B CONTAINS ENTRY ADDR. FIND THE JFCL OR HRRZI;
18900	HRRZL:	HLRZ	A,(B);		# OPCODE HALF;
19000		CAIE	A,'255000;	# JFCL;
19100		CAIN	A,'551517;	# HRRZI F,(P);
19200		 JRST	LAB2;		# FOUND THE ONE WE WANT;
19300		AOJA	B,HRRZL;	# KEEP LOOKING;
19400	LAB2:	PUSHJ	P,STPBBRK;
19500		JRST	INC1;		# ONCE WE'VE BROKEN IT, DON'T TRY TO BREAK IT AGAIN;
19600	INC2:	AOS	A,J;
19700		CAMG	A,U2;
19800		 JRST	TOP2;
19900	INC1:	AOS	I,L;
20000	CHK1:	SETOB	A,J;
20100		CAMG	I,U;
20200		 JRST	INC2;
20300		MOVE	B,U;
20400		PUSHJ	P,STPBBRK;
20500		END;
20600	]) # HAND;
20700	END "STEPIT";
     
00100	# BAILOR,!!TEXT,!!ARGS,EVAL,PSH,OPPSH,SETLEX,X1TEMP,X1TEMP,NEWTEMP,NEWSTRTEMP;
00200	INTERNAL RECURSIVE PROCEDURE BAILOR; BEGIN "BAILOR"
00300	INTEGER ARRAY SAVED!ACS[0:'17+'12+1+1+1];
00400	INTEGER PC,FLAGS,I,T,DISPLVL;
00500	INTEGER LDEPTH,DDEPTH,CURBRK;	# LEXICAL DEPTH, DYNAMIC DEPTH,CURRENT
00600					BREAKPOINT NUMBER;
00700	INTEGER ARRAY LCHAIN[0:15];	# MOST RECENT FIRST;
00800	INTEGER ARRAY DCHAIN[0:63,0:1];	# MOST RECENT FIRST;
00900	LABEL BRECOV;			# RECOVERY POINT FOR BAIL ERRORS;
01000	LABEL RET;			# !!GO COMES HERE IMMEDIATELY;
01100	DEFINE F=['12];
01200	
01300	
01400	INTERNAL STRING PROCEDURE !!TEXT; BEGIN PRLSCOPE(LCHAIN,LDEPTH);
01500	PRDSCOPE(DCHAIN,DDEPTH); ADDSTR("
01600	AT SETLEX("&CVS(DISPLVL)&");"); SSF_TRUE; RETURN(DUMPSTR) END;
01700	
01800	
01900	INTERNAL STRING PROCEDURE !!ARGS; BEGIN
02000	INTEGER T,PDA;
02100	IF (T_DCHAIN[DISPLVL,0])>0 THEN # NON-SIMPLE PROCEDURE;
02200	    PRARGS(LEFT(MEMORY[T+1]),T-1,MEMORY[T+2])	# APPLAUD THE POWER OF DISPLAYS!!!;
02300		#	PDA	RIGHT(P)	SP;
02400	ELSE BEGIN
02500	    IF DDEPTH NEQ 0 THEN OUTSTR("
02600	Warning: String parameters to simple procedure may be incorrect.
02700	");
02800	    IF (PDA_PDFIND(MEMORY[MEMORY[-T]-1]))=1 THEN OUTSTR("
02900	Can't find procedure descriptor.  Use actual names.
03000	")
03100	    ELSE PRARGS(PDA,-T,SAVED!ACS[SP]) END;
03200	SSF_TRUE; RETURN(DUMPSTR) END;
03300	
03400	
03500	# EVAL, PSH, OPPSH, SETLEX, X1TEMP, EVAL1;
03600	RECURSIVE INTEGER PROCEDURE EVAL(STRING ARG);
03700	BEGIN"EVAL"
03800	EXTERNAL PROCEDURE CAT;
03900	STRING STRVAL,OLDARG;
04000	INTEGER CLASS,IVAL,REFIT,PNTR,OP;
04100	LABEL OPCHAR;
04200	INTEGER ARRAY TEMPVAL[0:31]; STRING ARRAY TSTRVAL[0:31];
04300	INTEGER ARRAY RBIND,STACK,OPSTACK[0:31];
04400	INTEGER N!TEMPVAL,N!TSTRVAL,TOS,TOOPS,T;
04500	BOOLEAN BINARYMINUSFLAG;
04600	
04700	SIMPLE PROCEDURE PSH(INTEGER ARG); STACK[TOS_TOS+1]_ARG;
04800	
04900	SIMPLE PROCEDURE OPPSH(INTEGER ARG,RBND); BEGIN
05000	    OPSTACK[TOOPS_TOOPS+1]_ARG; RBIND[TOOPS]_RBND END;
05100	
05200	INTEGER PROCEDURE NEWTEMP(INTEGER I);
05300	    RETURN(LOCATION(TEMPVAL[N!TEMPVAL_N!TEMPVAL+1]_I));
05400	
05500		INTEGER PROCEDURE NEWSTRTEMP(STRING I);
05600	    RETURN(RIGHT(LOCATION(TSTRVAL[N!TSTRVAL_N!TSTRVAL+1]_I)));
05700	
05800	PROCEDURE EV1ERR(STRING WHY); EVALERR(WHY,OLDARG,ARG);
05900	
06000	INTERNAL RECURSIVE PROCEDURE SETLEX(INTEGER DEPTH); BEGIN "SETLEX"
06100	# MOVE LEXICAL SCOPE UP AND DOWN THE DYNAMIC SCOPE CHAIN;
06200	DISPLVL_DEPTH_0 MAX DEPTH MIN DDEPTH;	# Clip bounds;
06300	GETLSCOPE(LCHAIN,LDEPTH,DCHAIN[DEPTH,1]); PRLSCOPE(LCHAIN,LDEPTH);
06400	END "SETLEX";
06500	
06600	PROCEDURE X1TEMP(INTEGER REFIT);BEGIN
06700	REFIT_RIGHT(REFIT);	# ISOLATE ADDRESS PORTION;
06800	IF N!TEMPVAL GEQ 0 AND REFIT GEQ LOCATION(TEMPVAL[0]) AND
06900	    REFIT LEQ LOCATION(TEMPVAL[N!TEMPVAL]) THEN N!TEMPVAL_N!TEMPVAL-1
07000	ELSE IF N!TSTRVAL GEQ 0 AND REFIT GEQ RIGHT(LOCATION(TSTRVAL[0])) AND
07100	    REFIT LEQ RIGHT(LOCATION(TSTRVAL[N!TSTRVAL])) THEN N!TSTRVAL_N!TSTRVAL-1; END;
07200	
     
00100	# EVAL1;
00200	RECURSIVE INTEGER PROCEDURE EVAL1; BEGIN "EVAL1"
00300	
00400	# EVALUATE OPERATOR ON TOP OF STACK AND ADJUST STACK;
00500	
00600	DEFINE PRINT=[WR!TON];	
00700	DEFINE CONFORM(A)=[(OPS1[A] LAND '777)],DEGREE(A)=[(OPS1[A] LSH -9 LAND '777)];
00800	INTEGER OP,ARG1,ARG2,TYP1,TYP2,MODE,TYP,I,DEG,RSLTTYP,LEAPFLAG;
00900	INTEGER TEMP; STRING TEMPSTR;
01000	
01100	
01200	IF ABS(OP_STACK[TOS]) LEQ N!OPS THEN BEGIN "PRIMITIVE"
01300	LABEL $INF,$COMMA,$COLON,$SEMI,$LEN,
01400		$ARRYREF,$MEMRY,$DATUM,$PROPS,$SUBST,$GETS,$SWAP,
01500		$SUBFLD,$SETC,$LSTC,$AR,$ASSIGNRESULTS;
01600	LABEL $CPRINT,$PRINT,$NEWREC;
01700	
01800	    SIMPLE PROCEDURE TYPERR; EV1ERR("Type mismatch, " & OP);
01900	
02000	    SIMPLE PROCEDURE LEAP!TYPE!CHECK; BEGIN "LPTYCK"
02100		IF (LEAPFLAG_(ARG1 LOR ARG2) LAND ITEMB) THEN BEGIN	# ONE IS AN ITEM;
02200		    MODE_0;					# ITEMS COMPARE LIKE INTEGERS;
02300		    IF (ARG1 LAND ARG2 LAND ITEMB)=0		# BOTH MUST BE ITEMS;
02400			OR ((ARG1 XOR ARG2) LSH -(18+5+6)) NEQ 0	# SECOND ORDER TYPES MUST AGREE;
02500			OR (TYP1 NEQ TYP2)
02600			    AND  TYP1 NEQ (ITEMB+NOTYPE)
02700		    THEN TYPERR END
02800		ELSE IF TYP1=TYP2 AND (TYP1=SETYPE OR TYP1=LSTYPE)
02900		    THEN BEGIN MODE_2; LEAPFLAG_TRUE END END "LPTYCK";
03000	
03100	    SIMPLE PROCEDURE MAKE!BOTH!STRING;
03200		BEGIN RSLTTYP_STRNG; MODE_0;
03300		ARG1_CVSTRNG(ARG1,1); ARG2_CVSTRNG(ARG2,2) END;
03400	
03500	    SIMPLE PROCEDURE MAKE!BOTH!REAL;
03600		BEGIN RSLTTYP_FLOTNG; MODE_1;
03700			ARG1_CVREAL(ARG1,1); ARG2_CVREAL(ARG2,2) END;
03800	
03900	    SIMPLE PROCEDURE MAKE!BOTH!INTEGER;
04000		BEGIN RSLTTYP_INTEGR; MODE_0;
04100		ARG1_CVINTEGR(ARG1,1); ARG2_CVINTEGR(ARG2,2) END;
04200		
04300	    SIMPLE PROCEDURE MAX!DOMAIN;
04400		# FLOTNG > INTEGR > STRNG, AND MUST GET AT LEAST AN INTEGR;
04500		IF TYP1=FLOTNG OR TYP2=FLOTNG THEN MAKE!BOTH!REAL
04600		ELSE MAKE!BOTH!INTEGER;
04700	
04800	    DEG_DEGREE(OP); IF TOS-DEG<0 THEN EV1ERR("Syntax error");
04900	    # HANDLE TEMPORARY LOCATIONS ASSIGNED BY EVAL;
05000	    IF DEG GEQ 2 THEN X1TEMP(ARG1_STACK[TOS-2]);
05100	    IF DEG GEQ 1 THEN X1TEMP(ARG2_STACK[TOS-1]);
05200	
05300	    # CONFORM THE OPERANDS TO THE OPERATOR. DEFAULT TO INTEGER;
05400	    TYP1_GETTYPE(ARG1); TYP2_GETTYPE(ARG2);
05500	    MODE_0; RSLTTYP_INTEGR;
05600	    CASE CONFORM(OP) OF BEGIN "CONFORM"
05700	    [0] "OPERATOR UNTYPED. RETURN TYPE OF FIRST ARG"
05800		RSLTTYP_GETTYPE(STACK[TOS-DEG]);
05900	    [1]	MAKE!BOTH!INTEGER;
06000	    [2] MAKE!BOTH!REAL;
06100	    [3] "CAT &" IF TYP1=LSTYPE AND TYP2=LSTYPE THEN BEGIN MODE_1; RSLTTYP_LSTYPE END
06200		ELSE MAKE!BOTH!STRING;
06300	    [4] "SECOND GETS TYPE OF FIRST" BEGIN
06400		LEAP!TYPE!CHECK; IF NOT LEAPFLAG THEN BEGIN
06500		    IF (RSLTTYP_TYP1) NEQ TYP2 THEN BEGIN
06600			IF (TYP_RSLTTYP LSH -23)<3 OR TYP>5 THEN TYPERR
06700			ELSE CASE TYP OF BEGIN
06800			    [3] MAKE!BOTH!STRING;
06900			    [4] MAKE!BOTH!REAL;
07000			    [5] MAKE!BOTH!INTEGER
07100		END END END END;
07200	    [5] "SECOND GETS INTEGER; FOR LSH, ASH, ROT"
07300		BEGIN RSLTTYP_TYP1; ARG2_CVINTEGR(ARG2,2) END;
07400	    [6]	"MEMBERSHIP"
07500		IF NOT(ARG1 LAND ITEMB) OR (TYP2 NEQ SETYPE) THEN TYPERR;
07600	    [7]	"INF" ;
07700	    [8]	"SET"  BEGIN MODE_3; RSLTTYP_SETYPE END;
07800	    [9]	MAX!DOMAIN;
07900	   [10]	"ASSOCIATIVE POSSIBILITY"
08000		IF (ARG1 LAND ARG2 LAND ITEMB)	# BOTH ITEMS;
08100		THEN BEGIN MODE_1; RSLTTYP_SETYPE END	# DERIVED!SET_ITEM OP ITEM;
08200		ELSE IF OP="`"
08300		     THEN TYPERR	# ASSOC OF NON-ITEMS;
08400		     ELSE RSLTTYP_TYP1;		# BIT OPERATOR XOR, EQV;
08500	   [11] ;		# LOCATION;
08600	   [12] "RELATION" BEGIN
08700		LEAP!TYPE!CHECK; # TO SET MODE TO 2 FOR SET OR LIST;
08800		IF NOT(LEAPFLAG) OR (TYP1 NEQ TYP2)
08900		THEN BEGIN # TAKE MAX ALGEBRAIC DOMAIN BUT KEEP RESULT BOOLEAN;
09000		    IF TYP1=TYP2=RECTYP AND (OP="=" OR OP="") THEN ELSE MAX!DOMAIN;
09100		    MODE_0; RSLTTYP_INTEGR
09200		END END
09300	    END "CONFORM";
09400	
     
00100	# INTERPRETATION OF OPERATORS;
00200	START!CODE	# JUMP TABLE FOR OPERATORS;
00300		LABEL $NOT,$AND,$OR;
00400		LABEL $EQ,$NEQ,$LEQ,$LESS;
00500		LABEL $JEQ,$JNEQ,$JLEQ,$JLESS;
00600		LABEL $LPEQ,$LPNEQ,$LPLEQ,$LPLES;
00700		LABEL $REVOP1,$REVOP2;
00800		LABEL $PLUS,$MINUS,$MUL,$CDIV,$EXP,$EXPI,$EXPR;
00900		LABEL $MIN,$MAX,$MOD,$LOC;
01000		LABEL $CAT,$LPCAT,$JCAT,$JSUBST,$SUBST,$LPSUBST,$STRNG;
01100		LABEL $ASSOC,$LPEQV,$LPXOR,$IN,$UNION,$INTER,$LPMINUS,
01200		    LPSET,LPREL,LPDRV,LPRL2,LPDO1;
01300		LABEL $XOR,$EQV;
01400		LABEL $FOR,$TO;
01500		LABEL $FALSE,$TRUE,$NULL,$PHI,$NIL,$ANY,$NLREC;
01600		LABEL BADOP,ZERO,ONES,DONE,JTAB,$UMINUS,ZCONST,SCONST,ONES$,ZERO$;
01700		EXTERNAL INTEGER LEAP,SUBST,CAT,POW,FLOGS;
01800		DEFINE A=[1],B=[2],M=[3],T=[4];
01900		PROTECT!ACS A,B,M,T;
02000	
02100		MOVE	A,@ARG1;	# FIRST OPERAND;
02200		MOVE	B,@ARG2;	# SECOND OPERAND;
02300		MOVE	M,MODE;		# SOME OPS: 0=INTEGER, 1=REAL, 2=BOOL_(SET,SET), 3=SET_(SET,SET);
02400		MOVE	T,OP;
02500		XCT	JTAB(T);
02600	DONE:	MOVEM	A,TEMP;
02700	BADOP:	JRST	$ASSIGNRESULTS;
02800	ZERO:	TDZA	A,A;
02900	ONES:	SETO	A,;
03000		JRST	DONE;
03100	JTAB:
03200	$JNEQ:	JRST	$NEQ;	# '000;
03300		JRST	$NEQ;	# '001;
03400		JRST	$LPNEQ;	# '002;
03500		JRST	BADOP;	# '003;
03600		JRST	$AND;	# "";
03700		JRST	$NOT;	# "";
03800		JRST	$IN;	# "";
03900	$JEQ:	JRST	$EQ;	# '007;
04000		JRST	$EQ;	# '010;
04100		JRST	$LPEQ;	# '011;
04200	$JLEQ:	JRST	$LEQ;	# '012;
04300		JRST	$LEQ;	# '013;
04400		JRST	$LPLEQ;	# '014;
04500		JRST	BADOP;	# '015;
04600		JRST	$INF;	# "";
04700		JRST	$DATUM;	# "";
04800		JRST	BADOP;	# '020;
04900		JRST	BADOP;	# '021;
05000		JRST	$INTER;	# "";
05100		JRST	$UNION;	# "";
05200		JRST	BADOP;	# '024;
05300		JRST	BADOP;	# '025;
05400		XCT	$XOR(M);# "";
05500		JRST	$SWAP;	# "";
05600	$JLESS:	JRST	$LESS;	# '030;
05700		JRST	$LESS;	# '031;
05800		JRST	$LPLES;	# '032;
05900		JRST @	$JNEQ(M);	# "";
06000		JRST @	$JLEQ(M);	# "";
06100		JRST	$REVOP1;	# "";
06200		XCT	$EQV(M);# "";
06300		JRST	$OR;	# "";
06400	$MAX:	CAMGE	A,B;	# '040;
06500		MOVE	A,B;	# "!";
06600		JRST	DONE;	# quote;
06700	$XOR:	XOR	A,B;	# "#";
06800		JRST	$LPXOR;	# "$";
06900		XCT	$CDIV(M);	# "%";
07000		JRST @	$JCAT(M);# "&";
07100	$MIN:	CAMLE	A,B;	# "'";
07200		MOVE	A,B;	# "(";
07300		JRST	DONE;	# ")";
07400		XCT	$MUL(M);	# "*";
07500		XCT	$PLUS(M);	# "+";
07600		JRST	$COMMA;	# ",";
07700		XCT	$MINUS(M);	# "-";
07800		JRST	BADOP;	# ".";
07900		FDVR	A,B;	# "/";
08000	$AND:	JUMPE	A,ZERO;	# "0";
08100		JUMPE	B,ZERO;	# "1";
08200		JRST	ONES;	# "2";
08300	$NOT:	JUMPE	B,ONES;	# "3";
08400		JRST	ZERO;	# "4";
08500	$NEQ:	CAMN	A,B;	# "5";
08600		JRST	ZERO;	# "6";
08700		JRST	ONES;	# "7";
08800	$EXP:	JRST	$EXPI;	# "8";
08900		JRST	$EXPR;	# "9";
09000		JRST	$COLON;	# ":";
09100		JRST	$SEMI;	# '073;
09200		JRST @	$JLESS(M);	# "<";
09300		JRST @	$JEQ(M);	# "=";
09400		JRST	$REVOP2;	# ">";
09500	$EQV:	EQV	A,B;	# "?";
09600			JRST	$LPEQV;	# "@";
09700		ASH	A,(B);	# '101;
09800		IDIV	A,B;	# DIV;
09900		JRST	$FALSE;	# '103;
10000		AND	A,B;	# LAND;
10100		SETCM	A,B;	# LNOT;
10200		IOR	A,B;	# LOR;
10300		LSH	A,(B);	# ' 107;
10400		JRST	$MAX;	# '110;
10500		JRST	$MIN;	# '111;
10600		JRST	$MOD;	# '112;
10700		JRST	BADOP;	# '113;
10800		JRST	$NULL;	# '114;
10900		ROT	A,(B);	# '115;
11000		JRST	BADOP;	# '116;
11100		JRST	$TRUE;	# '117;
11200		MOVM	A,B;	# ABS;
11300		JRST	$FOR;	# (SUBSTRINGER);
11400		JRST	$TO;	# (SUBSTRINGER);
11500		JRST	$UMINUS;# UNARY MINUS;
11600		JRST	$ARRYREF;	# '124;
11700		JRST	$MEMRY;	# '125;
11800		JRST	$DATUM;	# '126;
11900		JRST	$PROPS;	# '127;
12000		JRST @	$JSUBST(M);	# PERFORM SUBSTRINGING OR SUBSLITING;
12100		JRST	$PHI;	# '131;
12200		JRST	$NIL;	# '132;
12300		JRST	BADOP;	# LBRACKET;
12400		JRST	BADOP;	# BACKSLASH;
12500		JRST	BADOP;	# RBRACKET;
12600		XCT	$EXP(M);	# UP ARROW;
12700		JRST	$GETS;	# ASSIGN;
12800		JRST	$ASSOC;	# ASSOC;
12900		JRST	$SUBFLD;	# '141;
13000		JRST	$ANY;	# '142;
13100		JRST	$NLREC;	# '143;
13200		JRST	$LEN;	# '144;
13300		JRST	$LOC;	# '145;
13400		JRST	$LSTC;	# '146;
13500		JRST	$CPRINT;# '147;
13600		JRST	$PRINT;	# '150;
13700		JRST	$NEWREC;# '151;
13800	$MUL:	IMUL	A,B;	# '152;
13900		FMPR	A,B;	# '153;
14000	$PLUS:	ADD	A,B;	# '154;
14100		FADR	A,B;	# '155;
14200	$CDIV:	IDIV	A,B;	# '156;
14300		FDVR	A,B;	# '157;
14400	$LESS:	CAML	A,B;	# '160;
14500		JRST	ZERO;	# '161;
14600		JRST	ONES;	# '162;
14700	$EQ:	CAME	A,B;	# '163;
14800		JRST	ZERO;	# '164;
14900			JRST	ONES;	# '165;
15000	$REVOP2:SUBI	T,1;	# '166;	# CONVERT ">" TO "<";
15100	$REVOP1:SUBI	T,1;	# '167;	# CONVERT "" TO "";
15200		EXCH	A,B;	# '170;
15300		XCT	JTAB(T);# '171;
15400	$LEQ:	CAMLE	A,B;	# '172;
15500		JRST	ZERO;	# '173;
15600		JRST	ONES;	# '174;
15700	STANFO([JRST	BADOP;	# ALT;
15800		JRST	$SETC;	# '176;	])
15900	DEC([	JRST	$SETC;	# '175;
16000		JRST	BADOP;	# '176;	])
16100	TENX([	JRST	$SETC;	# '175;
16200		JRST	BADOP;	# '176;	])
16300		JRST	DONE;	# BS, END-OF-FILE;
16400	# END OF 0:'177 JTAB;
16500	
16600	$OR:	JUMPN	A,ONES;
16700		JUMPN	B,ONES;
16800		JRST	ZERO;
16900	$MINUS:	SUB	A,B;
17000		FSBR	A,B;
17100		JRST	BADOP;
17200		JRST	$LPMINUS;
17300	$JCAT:	JRST	$CAT;
17400		JRST	$LPCAT;
17500	$JSUBST:JRST	$SUBST;
17600		JRST	$LPSUBST;
     
00100	
00200	$MOD:	IDIV	A,B;
00300		MOVE	A,A+1;
00400		JRST	DONE;
00500	$EXPR:	PUSH	P,B;	# EXPONENT;
00600		PUSH	P,A;	# BASE;
00700		PUSHJ	P,FLOGS;
00800		JRST	DONE;
00900	$EXPI:	PUSH	P,B;
01000		PUSH	P,A;
01100		PUSHJ	P,POW;
01200		FIX	1,1;
01300		JRST	DONE;
01400	
01500	$LOC:	HRRZ	A,ARG2;
01600		JRST	DONE;
01700	
01800	SUPERCOMMENT([
01900	$FOR:	"FOR (SUBSTRINGER)" BEGIN	# CONVERT INDICES TO "TO";
02000		    TEMP_MEMORY[ARG1]+MEMORY[ARG2]-1;	# COMPUTE END CHAR NUMBER;
02100		    TEMPVAL[N!TEMPVAL_N!TEMPVAL+1]_MEMORY[ARG1]; # BEGINNING CHAR #;
02200		    RSLTTYP_RNGTYP;
02300		    DEG_2; GOTO $AR END;
02400	$TO:	"TO (SUBSTRINGER)" BEGIN DEG_2;
02500		    TEMP_MEMORY[ARG2];	# END CHAR #;
02600		    TEMPVAL[N!TEMPVAL_N!TEMPVAL+1]_MEMORY[ARG1]; # BEGINNING CHAR #;
02700		    RSLTTYP_RNGTYP; GOTO $AR END;
02800	]) # SUPERCOMMENT;
02900	$FOR:	ADD	B,A;
03000		SUBI	B,1;
03100	$TO:	MOVEM	B,TEMP;		# END CHAR #;
03200		PUSH	P,A;		# BEGINNING CHAR #;
03300		PUSHJ	P,NEWTEMP;
03400		MOVEI	A,2;
03500		MOVEM	A,DEG;
03600		MOVSI	A,0+RNGTYP LSH -18;
03700		MOVEM	A,RSLTTYP;
03800		JRST	$AR;
03900	
04000	$CAT:	PUSH	P,ARG1;
04100		PUSHJ	P,MEMSTRING;
04200		PUSH	P,ARG2;
04300		PUSHJ	P,MEMSTRING;
04400		PUSHJ	P,CAT;
04500	$STRNG:	HRROI	T,ACCESS(TEMPSTR);
04600		POP	SP,(T);
04700		POP	SP,-1(T);
04800		MOVSI	T,0+STRNG LSH -18;
04900		MOVEM	T,RSLTTYP;
05000		JRST	$AR;
05100	
05200	SUPERCOMMENT([
05300	$SUBST:	"PERFORM SUBSTRINGING" BEGIN
05400		    EXTERNAL STRING PROCEDURE SUBST(STRING ARG; INTEGER ENDCHAR, STARTCHAR);
05500		    TEMPSTR_SUBST(MEMSTRING(OPSTACK[TOOPS]),MEMORY[STACK[TOS-1]],
05600			MEMORY[STACK[TOS-1]-1]);
05700		    X1TEMP(STACK[TOS-1]);
05800		    DEG_2; RSLTTYP_STRNG; GOTO $AR
05900		   END;
06000	]) # SUPERCOMMENT;
06100	$SUBST:	MOVE	B,ACCESS(STACK[TOS-1]);
06200		PUSH	P,(B);		# END CHAR;
06300		PUSH	P,-1(B);	# START CHAR;
06400		PUSH	P,ACCESS(OPSTACK[TOOPS]);	# ADDR OF STRING;
06500		PUSH	P,B;
06600		PUSHJ	P,X1TEMP;
06700		PUSHJ	P,MEMSTRING;	# GET STRING ON SP;
06800		PUSHJ	P,SUBST;
06900		MOVE	T,!SKIP!;
07000		MOVEM	T,INTERP!SKIP!;
07100		MOVEI	T,2;
07200		MOVEM	T,DEG;
07300		JRST	$STRNG;
07400	
07500	SUPERCOMMENT([
07600	$UMINUS:BEGIN # CONVERT -X TO (0-X);
07700		STACK[TOS]_STACK[TOS-1];	# COPY X;
07800		STACK[TOS-1]_REFZERO;		# ZERO;
07900		STACK[TOS_TOS+1]_"-";		# BINARY MINUS;
08000		EVAL1;				# RECURSE;
08100		GOTO $AR END;
08200	]) # SUPERCOMMENT;
08300	$UMINUS:MOVEI	B,ACCESS(STACK[TOS]);
08400		MOVE	T,-1(B);
08500		MOVEM	T,(B);		# STACK[TOS]_STACK[TOS-1];
08600		MOVSI	T,0+INTEGR LSH -18;
08700		HRRI	T,ZERO$;
08800		MOVEM	T,-1(B);	# STACK[TOS-1]_REFZERO;
08900		MOVEI	T,"-";
09000		MOVEM	T,1(B);		# STACK[TOS+1]_binary minus;
09100		AOS	ACCESS(TOS);
09200		PUSHJ	P,EVAL1;
09300		JRST	$AR;
09400	
09500	ONES$:	-1;
09600		0;
09700	ZERO$:	0;
09800	
09900	$TRUE:	MOVEI	A,ONES$;
10000		HRLI	A,0+INTEGR LSH -18;
10100		JRST	SCONST;
10200	$FALSE:	MOVSI	A,0+INTEGR LSH -18;
10300		JRST	ZCONST;
10400	$NULL:	MOVSI	A,0+STRNG LSH -18;
10500		JRST	ZCONST;
10600	$ANY:	MOVSI	A,0+(ITEMB+NOTYPE) LSH -18;
10700		JRST	ZCONST;
10800	$NLREC:	MOVSI	A,0+RECTYP LSH -18;
10900		JRST	ZCONST;
11000	$PHI:	MOVSI	A,0+SETYPE LSH -18;
11100		JRST	ZCONST;
11200	$NIL:	MOVSI	A,0+LSTYPE LSH -18;
11300	ZCONST:	HRRI	A,ZERO$;
11400	SCONST:	MOVEM	A,ACCESS(STACK[TOS]);
11500		SETZM	ACCESS(CLASS);		# SYMBOLIC CONSTANTS ARE NOT SPCHARs;
11600		JRST	$AR;
11700	
11800	$LPLES:	MOVEI	5,'65;
11900		JRST	LPREL;
12000	$LPEQ:	MOVEI	5,'67;
12100		JRST	LPREL;
12200	$LPNEQ:	MOVEI	5,'70;
12300		JRST	LPREL;
12400	$LPLEQ:	MOVEI	5,'71;
12500	LPREL:	HRLI	5,'110;
12600	LPRL2:	PUSH	P,A;
12700		PUSH	P,B;
12800		PUSHJ	P,LEAP;
12900		JUMPN	1,ONES;
13000		JRST	ZERO;
13100	
13200	$UNION:	MOVEI	5,'56;
13300		JRST	LPSET;
13400	$INTER:	MOVEI	5,'57;
13500		JRST	LPSET;
13600	$LPMINUS:MOVEI	5,'60;
13700	LPSET:	HRLI	5,'110;
13800		JRST	LPDRV;
13900	
14000	$LPXOR:	MOVE	5,[('2 LSH 18)+'40];
14100		JRST	LPDRV;
14200	$ASSOC:	MOVE	5,[('20 LSH 18)+'41];
14300		JRST	LPDRV;
14400	$LPEQV:	MOVE	5,[('200 LSH 18)+'42];
14500	LPDRV:	PUSH	P,A;
14600		PUSH	P,B;
14700	LPDO1:	PUSHJ	P,LEAP;
14800		HRROI	'14,TEMP;
14900		MOVE	5,[('110 LSH 18)+'61];
15000		PUSHJ	P,LEAP;
15100		JRST	$AR;
15200	
15300	$IN:	MOVE	5,[('10 LSH 18)+'63];
15400		JRST	LPRL2;
15500	
15600	$LPCAT:	MOVE	5,[('110 LSH 18)+'121];
15700		JRST	LPDRV;
15800	$LPSUBST:MOVE	B,ACCESS(STACK[TOS-1]);
15900		PUSH	P,@ACCESS(OPSTACK[TOOPS]);
16000		PUSH	P,-1(B);		# START EL;
16100		PUSH	P,(B);		# END EL;
16200		MOVE	5,[('100 LSH 18)+'125];
16300		JRST	LPDO1;
16400	
16500	END;
16600	
16700	$INF:	BEGIN
16800		    # SPECIAL OPERATOR MEANING LENGTH OF STRING, SET, LIST;
16900		CLASS_0;	# SYMBOLIC CONSTANTS ARE NOT SPCAHRS. CAUSES
17000					PROBLEMS WITH UNARY MINUS;
17100		FOR I_TOOPS STEP -1 UNTIL 0 DO
17200		    IF (TYP1_GETTYPE(OP_OPSTACK[I])) NEQ 0 THEN DONE;
17300		STACK[TOS]_INTEGR+NEWTEMP(IF TYP1=STRNG THEN LENGTH(MEMSTRING(OP))
17400		    ELSE LENGTH(MEMORY[OP,SET])); GOTO $AR END;
17500	$LEN:	BEGIN TEMP_IF TYP2=STRNG THEN LENGTH(MEMSTRING(ARG2))
17600		ELSE LENGTH(MEMORY[ARG2,SET]); RSLTTYP_INTEGR; GOTO $AR END;
17700	$COLON:	EV1ERR("No contexts in BAIL");
17800	$SEMI:	BEGIN IF TOOPS GEQ 0 THEN EV1ERR("Syntax error");
17900		FOR I_0 UPTO TOS-1 DO PRINT(STACK[I]); OUTSTR(DUMPSTR);
18000		N!TSTRVAL_N!TEMPVAL_TOS_-1; GOTO $AR END;
18100	$SETC:	BEGIN
18200		# STACK HAS	[CODE FOR SETC]
18300				[DESCR FOR LAST ITEMVAR]
18400					:
18500				[DESCR FOR FIRST ITEMVAR]
18600				[-1];
18700		MEMLOC(TEMP,SET)_PHI; FOR I_TOS-1 STEP -1 UNTIL 0 DO BEGIN
18800		    IF STACK[I]=-1 THEN DONE;
18900		    PUT MEMORY[STACK[I],ITEMVAR] IN MEMLOC(TEMP,SET) END;
19000		RSLTTYP_SETYPE; DEG_TOS-I; GOTO $AR END;
19100	$LSTC:	BEGIN
19200		MEMLOC(TEMP,LIST)_NIL; FOR I_TOS-1 STEP -1 UNTIL 0 DO BEGIN
19300		    IF STACK[I]=-1 THEN DONE;
19400		    PUT MEMORY[STACK[I],ITEMVAR] IN MEMLOC(TEMP,LIST) BEFORE 1 END;
19500		RSLTTYP_LSTYPE; DEG_TOS-I; GOTO $AR END;
19600	
19700	$PROPS:	"PROPS()" START!CODE
19800		    EXTERNAL INTEGER PROPS;
19900			MOVE	3,@ARG2;
20000			LDB	0,PROPS;
20100			MOVEM	0,TEMP;
20200			JRST	$AR;
20300			END;
     
00100	$COMMA:	BEGIN
00200		    INTEGER FPNTR;
00300		    # REMOVE OPCOMMA FROM TOP OF STACK;
00400		    TOS_TOS-1;
00500		    # ARE WE PARSING PARAMETER LIST TO A PROCEDURE?;
00600		    IF TOOPS>0 AND (FPNTR_RBIND[TOOPS-1])<0 THEN
00700		    BEGIN
00800		    NOHAND([
00900		    INTEGER ACTREF,FRMREF,ACTTYP,FRMTYP;
01000			# WE ARE PARSING THE PARAMETER LIST OF A PROCEDURE.
01100			PERFORM TYPE COERCION.  ALSO ASSIGN VALUE PARAMETERS TO 
01200			TEMPORARIES, TO PREVENT MISHAPS SUCH AS
01300				EXTERNAL PROCEDURE A(INTEGER VALUE P,Q).,
01400				A(I_3,I_4);
01500			FRMTYP_GETTYPE(FRMREF_MEMORY[ABS FPNTR]);
01600			ACTTYP_GETTYPE(ACTREF_STACK[TOS]);
01700			IF FRMTYP NEQ ACTTYP THEN BEGIN # COERCION NECESSARY;
01800			    IF (FRMTYP=NOTYPE) OR (FRMTYP=NOTYPE+ITEMB) OR (FRMTYP=NOTYPE+ARRY)
01900			    THEN STACK[TOS]_STACK[TOS] LAND LNOT('77 LSH 23) LOR FRMTYP
02000			    ELSE BEGIN
02100			    # MAKE SURE WE ASSIGN A TEMP;
02200			    ACTREF_ACTREF LAND (LNOT REFB);
02300			    IF FRMTYP<STRNG OR FRMTYP>INTEGR THEN
02400				EV1ERR("Can't coerce types")
02500			    ELSE CASE FRMTYP LSH -23 OF BEGIN
02600			    [3] ACTREF_CVSTRNG(ACTREF,1);
02700			    [4] ACTREF_CVREAL(ACTREF,1);
02800			    [5] ACTREF_CVINTEGR(ACTREF,1) END; END; END;
02900			IF NOT (ACTREF LAND REFB) THEN BEGIN # ASSIGN TEMP;
03000			    X1TEMP(ACTREF); # GET RID OF OLD;
03100			    RSLTTYP_FRMTYP; # RESULT IS SAME TYPE AS FORMAL;
03200			    IF FRMTYP=STRNG THEN TEMPSTR_MEMSTRING(ACTREF)
03300			    ELSE TEMP_MEMORY[ACTREF];
03400			    # RESULT ASSIGNMENT TAKE CARE OF ALLOCATING THE TEMP;
03500			    # BUT REMEMBER THAT WE ALREADY ADJUSTED TOS;
03600			    TOS_TOS+1;
03700			    DEG_1; END;
03800			# SET UP POINTER TO NEXT PARAMETER REFITEM;
03900			RBIND[TOOPS-1]_RBIND[TOOPS-1]-1;
04000			END ]) # NOHAND;
04100		    HAND([
04200		    INTEGER !FRMTYP;
04300		    START!CODE LABEL COERCE,BAD,CHKTMP,OUT1,FIXTYP,NSTR;
04400		    DEFINE ACTREF=[1],FRMREF=[2],ACTTYP=[3],FRMTYP=[4],!STACK=[5],T=[6];
04500			MOVEI	!STACK,ACCESS(STACK[TOS]);
04600			MOVM	T,FPNTR;
04700			MOVE	FRMREF,(T);
04800			LDB	FRMTYP,[('271000 LSH 18)+FRMREF]; # 8 BITS INCLUDES ITEMB;
04900			MOVEM	FRMTYP,!FRMTYP;
05000			MOVE	ACTREF,(!STACK);
05100			LDB	ACTTYP,[('271000 LSH 18)+ACTREF]; # 8 BITS INCLUDES ITEMB;
05200			CAIN	FRMTYP,(ACTTYP);
05300			 JRST	CHKTMP;
05400			CAIE	FRMTYP,0+NOTYPE LSH -23;
05500			CAIN	FRMTYP,0+(NOTYPE+ITEMB) LSH -23;
05600			 JRST	FIXTYP;
05700			CAIN	FRMTYP,0+(NOTYPE+ARRY) LSH -23;
05800			 JRST	FIXTYP;
05900			CAIL	FRMTYP,0+STRNG LSH -23;
06000			CAILE	FRMTYP,0+INTEGR LSH -23;
06100			 JRST	BAD;
06200			TLZ	ACTREF,0+REFB LSH -18;
06300			PUSH	P,ACTREF;
06400			MOVEI	T,1;
06500		COERCE:	PUSH	P,T;
06600			PUSHJ	P,@COERCE(FRMTYP);
06700			JRST	CHKTMP;
06800			PUSHJ	P,CVSTRNG;
06900			PUSHJ	P,CVREAL;
07000			PUSHJ	P,CVINTEGR;
07100		BAD:	PUSH	SP,[18];
07200			PUSH	SP,["Can't coerce types"];
07300			PUSHJ	P,EV1ERR;
07400		FIXTYP:	DPB	FRMTYP,[('271000+!STACK)LSH 18]; # 8 BITS INCLUDES ITEMB;
07500		CHKTMP:	TLNE	ACTREF,0+REFB LSH -18;
07600			 JRST	OUT1;
07700			MOVE	FRMTYP,!FRMTYP;
07800			LSH	FRMTYP,23;
07900			MOVEM	FRMTYP,RSLTTYP;
08000			MOVE	T,(ACTREF);
08100			MOVEM	T,TEMP;
08200			CAME	FRMTYP,[0+STRNG];
08300			 JRST	NSTR;
08400			PUSH	P,ACTREF;
08500			PUSHJ	P,MEMSTRING;
08600			MOVEI	T,ACCESS(TEMPSTR);
08700			POP	SP,(T);
08800			POP	SP,-1(T);
08900		NSTR:	MOVEI	T,ACCESS(TOS);
09000			AOS	(T);
09100			MOVEI	T,1;
09200			MOVEM	T,DEG;
09300		OUT1:	MOVEI	T,ACCESS(RBIND[TOOPS]);
09400			SOS	-1(T);
09500		END END ]) # HAND;
09600	
09700		ELSE BEGIN # NOT AN ARG LIST. JUST ASSIGN TEMPORARY;
09800		    IF ARG1 LAND REFB THEN BEGIN
09900			RSLTTYP_TYP1;
10000			IF TYP1=STRNG THEN TEMPSTR_MEMSTRING(ARG1)
10100			ELSE TEMP_MEMORY[ARG1]; DEG_1 END END;
10200		GOTO $AR; END;
     
00100	$ARRYREF:BEGIN
00200		    # THE STACK LOOKS LIKE
00300			[OPCODE FOR ARRAY REFERENCE]
00400			[REFIT FOR LAST SUBSCRIPT]
00500			.
00600			.
00700			[REFIT FOR FIRST SUBSCRIPT]
00800			-1
00900		      THE TOP WORD OF THE OPSTACK IS THE REFIT FOR THE ARRAY;
01000	
01100		    # TO SAVE STACK SPACE AT RUNTIME;
01200		    DEFINE REFIT=[ARG1],ADDR=[ARG2],NDIMS=[DEG],RNGFLG=[MODE],
01300			STRARRFLG=[TYP],SUBSBASE=[OP];
01400		    RECURSIVE PROCEDURE RNGPRNT(INTEGER SBPK,ADDRM3K,T); BEGIN "RNGPRNT"
01500			# SBPK=LOCATION(STACK[SUBSBASE+index])
01600			  ADDRM3K=ADDRESS-3*index
01700			  T=OFFSET;
01800		    NOHAND([
01900			INTEGER I,U;
02000			IF GETTYPE(MEMORY[SBPK])=RNGTYP THEN BEGIN RNGFLG_TRUE;
02100			    U_MEMORY[SBPK]; I_MEMORY[SBPK-1] END
02200			ELSE U_I_MEMORY[CVINTEGR(MEMORY[SBPK],1)];
02300			UB_MEMORY[ADDRM3K]; LB_MEMORY[ADDRM3K-1];
02400			T_T+(I-1)*(1-STRARRFLG)*MEMORY[ADDRM3K+1];
02500			FOR I_I UPTO U DO BEGIN
02600			    IF I<MEMORY[ADDRM3K-1] OR I>MEMORY[ADDRM3K] THEN
02700				EV1ERR("Subscripting error.  index  value   min   max
02800				"&CVS(SBPK-LOCATION(STACK[SUBSBASE]))&TAB&CVS(I)&TAB
02900				&CVS(LB)&TAB&CVS(UB));
03000			    T_T+(1-STRARRFLG)*MEMORY[ADDRM3K+1];
03100			    IF MEMORY[SBPK+1]=OPARRY THEN BEGIN
03200				STACK[SUBSBASE]_STACK[SUBSBASE]LAND '777777000000
03300				   LOR RIGHT(T);
03400				IF RNGFLG THEN PRINT(STACK[SUBSBASE]) END
03500			    ELSE RNGPRNT(SBPK+1,ADDRM3K-3,T) END
03600		    ]) # NOHAND;
03700		    HAND([
03800		    INTEGER I,U;
03900		    START!CODE LABEL NRNG,JOIN1,FORTOP,FORINC,FORCHK,BAD,NLDIM,BADCAT;
04000		    EXTERNAL INTEGER CVS,CAT,CATCHR;
04100		    DEFINE T1=[1],T2=[2],T3=[3],!STACK=[4],SBREF=[5];
04200		    PROTECT!ACS T1,T2,T3,!STACK,SBREF;
04300			MOVE	!STACK,SBPK;	# LOC OF SUBSCRIPT REFIT;
04400			MOVE	SBREF,(!STACK);	# REFIT FOR SUBSCRIPT;
04500			LDB	T1,[('270600 LSH 18)+SBREF];
04600			CAIE	T1,0+RNGTYP LSH -23;
04700			 JRST	NRNG;
04800			SETOM	ACCESS(RNGFLG);
04900			MOVE	T2,-1(SBREF);	# LOW LIMIT OF RANGE;
05000			MOVE	T3,(SBREF);	# HIGH LIMIT;
05100			JRST	JOIN1;
05200		    NRNG:PUSH	P,SBREF;
05300			PUSH	P,[1];
05400			PUSHJ	P,CVINTEGR;
05500			MOVE	T2,(1);
05600			MOVE	T3,(1);
05700		    JOIN1:MOVEM	T3,U;
05800			MOVE	T1,T2;		# L;
05900			SUBI	T1,1;
06000			MOVE	T3,ADDRM3K;
06100			IMUL	T1,1(T3);
06200			SKIPE	ACCESS(STRARRFLG);
06300			 ADD	T1,T1;		# CURSE YOU, STRING ARRAYS;
06400			ADDM	T1,T;
06500			JRST	FORCHK;
06600		    FORTOP:MOVE	T3,ADDRM3K;
06700			CAML	T2,-1(T3);	# LB/UB CHECK;
06800			CAMLE	T2,(T3);
06900			 JRST	BAD;
07000			MOVE	T2,1(T3);
07100			SKIPE	ACCESS(STRARRFLG);
07200			 ADD	T2,T2;		# DOUBLE FOR STRING ARRAYS;
07300			ADDB	T2,T;		# INCREMENT OFFSET;
07400			MOVE	T3,SBPK;	# CHECK FOR LAST DIMENSION;
07500			MOVE	T3,1(T3);
07600			CAIE	T3,OPARRY;
07700			 JRST	NLDIM;		# NOT LAST DIMENSION;
07800			MOVEI	!STACK,ACCESS(STACK[SUBSBASE]);
07900			HRRM	T2,(!STACK);
08000			SKIPN	ACCESS(RNGFLG);
08100			 JRST	FORINC;
08200			PUSH	P,(!STACK);
08300			PUSHJ	P,WR!TON;
08400			JRST	FORINC;
08500		    BADCAT:PUSHJ P,CVS;
08600			PUSHJ	P,CAT;
08700			PUSH	P,[TAB];
08800			PUSHJ	P,CATCHR;
08900			JRST	(T1);
09000		    BAD:PUSH	SP,[52];
09100			PUSH	SP,[
09200	"Subscripting error.   index    value	min    max
09300				"];
09400			MOVE	T1,SBPK;
09500			SUBI	T1,ACCESS(STACK[SUBSBASE]);
09600			PUSH	P,T1;
09700			JSP	T1,BADCAT;
09800			PUSH	P,T2;
09900			JSP	T1,BADCAT;
10000			PUSH	P,-1(T3);
10100			JSP	T1,BADCAT;
10200			PUSH	P,(T3);
10300			JSP	T1,BADCAT;
10400			PUSHJ	P,EV1ERR;
10500		    NLDIM:MOVE	T1,SBPK;
10600			MOVE	T2,ADDRM3K;
10700			MOVE	T3,T;
10800			ADDI	T1,1;
10900			PUSH	P,T1;
11000			SUBI	T2,3;
11100			PUSH	P,T2;
11200			PUSH	P,T3;
11300			PUSHJ	P,RNGPRNT;
11400		    FORINC:AOS	T2,I;
11500		    FORCHK:MOVEM T2,I;
11600			CAMG	T2,U;
11700			 JRST	FORTOP;
11800			END;
11900		    ]) # HAND;
12000		    END "RNGPRNT";
12100			
12200		    REFIT_OPSTACK[TOOPS];
12300		    STRARRFLG_IF GETTYPE(REFIT)=STRNG+ARRY THEN -1 ELSE 0;
12400		    # THE ADDRESS IN REFIT IS THE ADDRESS OF THE [AN] ALLOCATION CELL;
12500		    ADDR_RIGHT(MEMORY[REFIT]);	# ADDR POINTS TO FIRST DATA WORD;
12600		    IF NOT ADDR THEN EV1ERR("Deallocated array");
12700		    # FIND BEGINNING OF DIMENSIONS;
12800		    I_TOS; DO I_I-1 UNTIL STACK[I]=-1; SUBSBASE_I;
12900		    # MAKE A REFIT WITH THE RIGHT ADDR AND THE ARRAY BIT OFF;
13000		    STACK[SUBSBASE]_(REFIT-ARRY) LAND '777740000000;
13100		    ADDR_ADDR+STRARRFLG; NDIMS_ABS(MEMORY[ADDR-1] ASH -18);
13200		    IF TOS-SUBSBASE-1 NEQ NDIMS THEN
13300			EV1ERR("# of subscripts is "&CVS(NDIMS));
13400	
13500		    RNGPRNT(LOCATION(STACK[SUBSBASE+1]),ADDR-3,MEMORY[ADDR-3*NDIMS-2]);
13600		    FOR I_SUBSBASE UPTO TOS DO X1TEMP(STACK[I]);
13700		    TOS_SUBSBASE+RNGFLG; DEG_0;
13800		GOTO $AR; END;
     
00100	# $MEMRY,$DATUM,$SWAP,$GETS,$SUBFLD,$AR,$APPLY,$CPRINT,$PRINT,$NEWREC;
00200	$MEMRY:	"MEMORY[]" BEGIN
00300		    # THE "ARGUMENTS" (EITHER ONE OR TWO) HAVE BEEN CONVERTED TO INTEGER
00400		    BY FUDGING ON THE DEGREE AND CONFOMITY CLASS.  IF THERE IS ONE ARG,
00500		    THEN ARG1=-1 AND ARG2=[REFIT FOR ADDRESS].  IF THERE ARE TWO ARGUMENTS,
00600		    THEN ARG1=[REFIT FOR ADDRESS] AND ARG2=[REFIT FOR TYPE BITS].  BEFORE
00700		    WE FALL THROUGH WE MUST SET DEG_0 AND FIX UP THE STACK;
00800	
00900		    IF ARG1=-1 THEN STACK[TOS_TOS-2]_REFB+INTEGR+
01000			(IF (I_RIGHT(MEMORY[ARG2]))<'20 THEN LOCATION(SAVED!ACS[I]) ELSE I)
01100		    ELSE STACK[TOS_TOS-3]_REFB+(MEMORY[ARG2] LAND (-1 LSH 23))+
01200			(IF (I_RIGHT(MEMORY[ARG1]))<'20 THEN LOCATION(SAVED!ACS[I]) ELSE I);
01300		    DEG_0; GOTO $AR END;
01400	$DATUM:	"DATUM()" START!CODE
01500		    EXTERNAL INTEGER DATM,INFTB;
01600			MOVE	3,@ARG2;	# ITEM NUMBER;
01700			LDB	0,INFTB;	# ITEM TYPE BITS;
01800			MOVEI	1,@DATM;	# AC1_ADDR OF DATUM, UNLESS DATUM IS STRING;
01900			CAIN	0,0+STRNG LSH -23;# IS DATUM A STRING?;
02000			 HRRZ	1,(1);		# YES, FETCH ADDR OF WORD2;
02100			MOVEM	1,ARG1;		# LOCATION OF THIS OBJECT;
02200			MOVE	2,0;		# COPY;
02300			LSH	0,23;		# SHIFT OVER INTO PLACE;
02400			CAIL	2,0+ARRY LSH -23;# IS DATUM AN ARRAY?;
02500			 TLO	0,'20;		# YES, TURN ON INDIRECT BIT;
02600			TLO	0,0+REFB LSH -18;# WE HAVE A REFERENCE, NOT A VALUE;
02700			MOVEM	0,RSLTTYP;
02800			JRST	$AR;
02900			END;
03000	$SWAP:	BEGIN IF NOT(ARG1 LAND ARG2 LAND REFB) THEN EV1ERR("Invalid assignment");
03100		RSLTTYP_ARG1 LAND '777777000000;
03200		MEMORY[ARG1] SWAP MEMORY[ARG2]; GOTO $AR END;
03300	$GETS:	"GETS _" BEGIN
03400	DEFINE DOINT(OP)=[TEMP_MEMORY[ARG1] OP MEMORY[ARG2]];
03500		    IF NOT(ARG1 LAND REFB) THEN EV1ERR("Invalid assignment");
03600		    RSLTTYP_ARG1 LAND '777777000000;
03700		    IF RSLTTYP=REFB+STRNG THEN START!CODE
03800			MOVE	1,ARG2;		# WORD 2 OR SOURCE;
03900			MOVE	2,ARG1;		# WORD 2 OF DEST.;
04000			MOVE	0,(1);
04100			MOVEM	0,(2);
04200			MOVE	0,-1(1);
04300			MOVEM	0,-1(2);
04400			END
04500		    ELSE DOINT([_]); GOTO $AR END;
04600	$SUBFLD:BEGIN
04700			# STACK LOOKS LIKE
04800			[OP CODE FOR SUBFIELDING]
04900			[REFITEM FOR RECORD LPOINTER] (ARG2 HAS ADDR OF RECORD POINTER)
05000			[-1]
05100			[SUBFIELD # (NEG. FOR STRINGS)]
05200			THE TOP OF OPSTACK IS A REFITEM FOR THE CLASS;
05300		    RECORD!POINTER(ANY!CLASS) RPCLASS;
05400		    INTEGER CLASS,SUBFIELD;
05500		    MEMLOC(RPCLASS,INTEGER)_CLASS_OPSTACK[TOOPS]; SUBFIELD_STACK[TOS-3];
05600		    IF MEMORY[ARG2]=0 THEN EV1ERR("Subfield of null record");
05700		    IF RIGHT(MEMORY[MEMORY[ARG2]]) NEQ RIGHT(CLASS) THEN
05800			EV1ERR("Class-pointer mismatch");
05900		    # COMPUTE ADDRESS OF DATA;
06000		    ARG1_RIGHT(MEMORY[ARG2])+ABS(SUBFIELD); IF SUBFIELD<0 THEN ARG1_
06100			RIGHT(MEMORY[ARG1]);
06200		    RSLTTYP_REFB+$CLASS:TYPARR[RPCLASS][ABS(SUBFIELD)];
06300			COMMENT MEMORY[MEMORY[CLASS+4]+ABS(SUBFIELD)];
06400		    DEG_3; GOTO $AR END;
06500	
06600	$PRINT:	BEGIN STACK[TOS_TOS+1]_0;	# Convert to CPRINT(-1, ... );
06700		ARRTRAN(TARRAY,STACK); ARRBLT(STACK[1],TARRAY[0],TOS);
06800		STACK[0]_INTEGR+LOCATION(-1);	END;
06900	$CPRINT:BEGIN
07000		STACK[0]_CVINTEGR(STACK[0],1);
07100		FOR I_1 UPTO TOS-1 DO PREFIT(MEMORY[STACK[0]],STACK[I]);
07200		TOS_-1;		# CLEAR STACK;
07300		GOTO $AR END;
07400	
07500		$NEWREC:BEGIN
07600		EXTERNAL INTEGER PROCEDURE $RECFN(INTEGER OP,R); # Type hacking;
07700		IF GETTYPE(TEMP_STACK[TOS-1]) NEQ RCLTYP THEN EV1ERR("Invalid class name");
07800		TEMP_$RECFN(1,RIGHT(TEMP)); RSLTTYP_RECTYP END;
07900	
08000	
08100	$AR: $ASSIGNRESULTS:
08200		# REMEMBER THE CASE  PROC(I_3)  WHERE I IS A REFERENCE PARAM;
08300	    IF DEG>0 THEN STACK[TOS_TOS-DEG]_RSLTTYP+
08400		(IF RSLTTYP LAND REFB THEN RIGHT(ARG1)
08500		ELSE (IF RSLTTYP=STRNG THEN NEWSTRTEMP(TEMPSTR)
08600			ELSE NEWTEMP(TEMP)));
08700	
08800	SSF_FALSE;
08900	END "PRIMITIVE"
09000	
09100	
09200	ELSE BEGIN "PROC"
09300	    EXTERNAL PROCEDURE APPLY(REFERENCE STRING TEMPSTR;
09400		REFERENCE INTEGER TEMP; INTEGER PDA,ARGLIS);
09500	    # SEARCH BACK THROUGH STACK TO MARKER,
09600		IN ORDER TO DETERMINE NUMBER OF PARAMS;
09700		    I_TOS; DO I_I-1 UNTIL STACK[I]=-1;
09800	    # CHECK NUMBER OF PARAMETERS. DEFAULTABLE PARAMS HAVE SIGN BIT ON;
09900	    FOR ARG2_TOS-I UPTO (DEG_N!PARAMS(OP)) DO
10000		IF MEMORY[MEMORY[OP+PD!DLW]+ARG2-1]>0 THEN
10100		    EV1ERR(MEMSTRING(OP+2)&" takes "&CVS(DEG)&" arguments");
10200	    # DO IT;
10300	    STACK[TOS]_0;
10400	    PLANT!BREAKS;
10500	    # SEARCH FOR CORRECT STATIC LINK;
10600	    START!CODE	LABEL LUP,FOUND,BAD,OK;
10700	    DEFINE F=['12],T1=['13],T2=['14],T3=['15];
10800		HRRZ	1,OP;		# PROC DESCR ADDR;
10900		SETZ	T2,;		# DEFAULT CONTEXT IS NULL;
11000		HRRZ	T1,PD!PPD(1);	# PARENT'S PDA;
11100		JUMPE	T1,FOUND;	# "PROCEDURE" IS REALLY OUTER BLOCK;
11200		HRRZ	T2,PD!PPD(T1);	# GRANDFATHER PDA;
11300		JUMPE	T2,FOUND;	# PROC IS AT TOP LEVEL OF SOME OUTER BLOCK;
11400		MOVEI	T2,F;		# NOT OUTER, MUST LOOK FOR PARENT;
11500	    LUP:HRRZ	T2,(T2);	# UP DYNAMIC LINK;
11600		JUMPE	T2,BAD;		# F CHAIN RAN OUT;
11700		CAIN	T2,-1;
11800		 JRST	BAD;
11900		HLRZ	T3,1(T2);	# PDA FROM STACK;
12000		CAIE	T1,(T3);	# THE ONE WE WANT?;
12100		 JRST	LUP;
12200	    FOUND:HRLI	1,(T2);		# CONTEXT,,PDA;
12300		MOVEM	1,ARG2;
12400		JRST	OK;
12500	    BAD:MOVEI	T1,["Proper context does not exist"];
12600		PUSH	SP,-1(T1);
12700		PUSH	SP,(T1);
12800		PUSHJ	P,EV1ERR;
12900	    OK:	END;
13000	    !SKIP! _ INTERP!SKIP!;
13100	    APPLY(TEMPSTR,TEMP,ARG2,LOCATION(STACK[I]));
13200	    INTERP!SKIP! _ !SKIP!;
13300	    # REMOVE PARAMS FROM TEMPORARY CELLS;
13400	    FOR DEG_I+1 UPTO TOS-1 DO X1TEMP(STACK[DEG]);
13500	    # IF TYPED PROCEDURE, RETURN VALUE;
13600	    IF (TYP_GETTYPE(OP)) NEQ 0 THEN STACK[TOS_I]_TYP+
13700		(IF TYP=STRNG THEN NEWSTRTEMP(TEMPSTR)
13800		ELSE NEWTEMP(TEMP))
13900	    ELSE TOS_I-1;
14000	END"PROC";
14100	    
14200	END "EVAL1";
14300	
     
00100	# PARSER;
00200	PROCEDURE LOPARG; OLDARG_OLDARG & LOP(ARG);
00300	
00400	OLDARG_NULL; ARG_ARG&'177;	# PUT ON "END-OF-FILE";
00500	N!TSTRVAL_N!TEMPVAL_TOS_TOOPS_-1;
00600	
00700	WHILE LENGTH(ARG) DO BEGIN "PARSE"
00800	GET!TOKEN(ARG,STRVAL,CLASS_0,IVAL); OLDARG_OLDARG & STRVAL;
00900	CASE CLASS OF BEGIN "CASES"
01000	    [INTVAL] PSH(NEWTEMP(IVAL)+INTEGR);
01100	    [REALVAL] PSH(NEWTEMP(IVAL)+FLOTNG);
01200	    [STRCON] PSH(NEWSTRTEMP(STRVAL)+STRNG);
01300	    [ID] BEGIN "ID"
01400		LABEL NOTRW;
01500		# CHECK IF THE ID IS EQUIVALENT TO A SPECIAL CHAR;
01600		START!CODE LABEL LOOP,INCR,FOUND;	DEFINE A=[1],K0=[2],K1=[3],K2=[4];
01700			MOVE	K0,NAME[0];
01800			MOVE	K1,NAME[1];
01900			MOVE	K2,NAME[2];
02000			MOVSI	A,-N!RWORD;
02100		LOOP:	CAMN	K0,RWORD0[0](A);
02200			CAME	K1,RWORD0[1](A);
02300			 JRST	INCR;
02400			CAMN	K2,RWORD0[2](A);
02500			 JRST	FOUND;
02600		INCR:	ADDI	A,2;
02700			AOBJN	A,LOOP;
02800			JRST	NOTRW;
02900		FOUND:	HLRE	A,A;
03000			MOVE	A,RWORD1[N!RWORD](A);
03100			MOVEM	A,OP;
03200			END;
03300		STRVAL_OP; CLASS_SPCHAR; GOTO OPCHAR;
03400		NOTRW:
03500		# CHECK FOR EVAL SPECIALS;
03600		IF EQU(STRVAL,"!SKIP!") THEN STRVAL _ "!SKIP\";
03700		IF EQU(STRVAL,"!!GO") THEN GOTO RET
03800		ELSE BEGIN
03900		    # SEARCH SYMBOL TABLE;
04000		    TLDEPTH_LDEPTH; ARRTRAN(TLSCOPE,LCHAIN);	# FOR TFIND KLUGE;
04100		    IF (PNTR_TFIND(STRVAL,FALSE,IVAL))<0
04200		    THEN BEGIN MEMLOC(REFIT,ITEMVAR)_CVSI(STRVAL,PNTR);
04300			IF PNTR THEN EV1ERR(IF MULDEF THEN "Mul. def. ID" ELSE "Unknown ID");
04400			REFIT_ITEMB+RIGHT(REFIT) END
04500		    ELSE IF RIGHT(CACHE[PNTR+1]) THEN
04600			REFIT_INCOR(PNTR,DCHAIN,DDEPTH,DISPLVL) ELSE
04700			EV1ERR("Unallocated variable") END;
04800		# CHECK FOR ITEMS;
04900		IF (REFIT LAND ITEMB) AND (REFIT LAND ('77 LSH 23))=0 THEN
05000		    PSH(REFB+ITEMB + (TYPEIT(MEMLOC(REFIT_RIGHT(REFIT),ITEMVAR)) LSH 23) +
05100			NEWTEMP(REFIT))
05200		# CHECK FOR PROCEDURE;
05300		ELSE IF REFIT LAND PROCB THEN BEGIN "PROCED"
05400		    IF RIGHT(REFIT)<'140 THEN EV1ERR("Procedure descriptor missing");
05500		    # MARK STACK FOR CHECKING NUMBER OF PARAMS;
05600		    PSH(-1);
05700		    IF N!PARAMS(REFIT)>0 AND ARG="(" THEN BEGIN "WITH PARAMS"
05800			# REMOVE THE "(" AND PLACE PROCEDURE NAME ON OPSTACK;
05900			LOPARG;
06000			OPPSH(REFIT,-(RIGHT(MEMORY[REFIT+PD!DLW])));
06100			# ALSO STICK IN AN EXTRA COMMA.  THEN THERE WILL BE AS MANY
06200			COMMAS AS ARGUMENTS, AND TYPE CHECKING AND COERCION WORKS BETTER;
06300			OPPSH(OPCOMMA,RBNDCOMMA);
06400			# REMEMBER THAT WE HAVE SEEN A SPECIAL CHARACTER, SO THAT UNARY
06500			  MINUS WORKS IN  PROC(-1,-1);
06600			CLASS_SPCHAR;
06700			END "WITH PARAMS"
06800		    ELSE BEGIN PSH(REFIT); EVAL1 END END "PROCED"
06900		# CHECK FOR RECORD CLASS NAME;
07000		ELSE IF GETTYPE(REFIT)=RCLTYP THEN BEGIN
07100			RECORD!POINTER(ANY!CLASS) RPREFIT;
07200			SIMPLE INTEGER PROCEDURE FNDSBFLD(RECORD!POINTER($CLASS)C;
07300			    STRING NAM); BEGIN INTEGER I;
07400			FOR I_1 UPTO $CLASS:RECSIZ[C] DO
07500			    IF !!EQU($CLASS:TXTARR[C][I],NAM) THEN RETURN(I);
07600			RETURN(-1) END;
07700		    IF ARG NEQ ":" THEN PSH(REFIT) # Probably a call to NEW!RECORD;
07800		    ELSE BEGIN LOPARG; # Remove colon;
07900			# LOOK FOR SUBFIELD NAME;
08000			MEMLOC(RPREFIT,INTEGER)_REFIT;	# KLUGEY TYPE COERCION;
08100			GET!TOKEN(ARG,STRVAL,CLASS_0,IVAL); OLDARG_OLDARG&STRVAL;
08200			IF CLASS NEQ ID OR (0>IVAL_FNDSBFLD(RPREFIT,STRVAL))
08300			    THEN EV1ERR("No such subfield");
08400			IF GETTYPE($CLASS:TYPARR[RPREFIT][IVAL])=STRNG THEN IVAL_-IVAL;
08500			PSH(IVAL); PSH(REFIT) END END
08600		ELSE PSH(REFIT)
08700		END "ID";
08800	
08900	    [SPCHAR] OPCHAR: BEGIN "SPCHAR"
09000		# FIND WHICH OPERATOR IT IS AND ITS LEFT AND RIGHT BINDING POWER;
09100		DEFINE LBND=[(OPS1[OP] LSH -27)], RBND=[(OPS1[OP] LSH -18 LAND '777)];
09200		OP_STRVAL; IF OP="-" AND NOT BINARYMINUSFLAG THEN OP_'123;
09300		IF OPS1[OP]=0 THEN EV1ERR("Invalid operator");
09400		# EVALUATE OPERATORS OF HIGHER PRECEDENCE WHICH OCCUR TO THE LEFT;
09500		WHILE TOOPS NEQ -1 AND RBIND[TOOPS]>LBND DO BEGIN
09600		    PSH(OPSTACK[TOOPS]); EVAL1; TOOPS_TOOPS-1 END;
09700		# CHECK FOR  "[" OR ")" OR "]" AND PROCEDURES, ARRAYS, STRINGS;
09800		IF OP=")" THEN BEGIN
09900		    IF TOOPS<0 THEN EV1ERR("Too many )");
10000		    IF (REFIT_OPSTACK[TOOPS])="(" # OP NUMBER OF LEFT PAREN "(";
10100			THEN TOOPS_TOOPS-1
10200		    ELSE IF REFIT LAND PROCB THEN BEGIN "PROCS"
10300			PSH(REFIT); EVAL1; TOOPS_TOOPS-1 END "PROCS" END
10400		ELSE IF OP="]" THEN BEGIN
10500		    IF TOOPS<0 THEN EV1ERR("Misplaced ]");
10600		    PSH(IF (T_GETTYPE((REFIT_OPSTACK[TOOPS]))) GEQ ARRY THEN
10700			    (IF REFIT=REFMEMORY THEN OPMEMORY ELSE OPARRY)
10800			ELSE IF T=STRNG OR T=LSTYPE THEN OPSUBST
10900			ELSE IF T=RCLTYP THEN OPSUBFLD
11000			ELSE 0);
11100		    EVAL1; TOOPS_TOOPS-1;
11200		    END
11300		ELSE IF OP="[" THEN BEGIN
11400		    IF TOS<0 THEN EV1ERR("Misplaced [");
11500		    IF (T_GETTYPE((REFIT_STACK[TOS]))) GEQ ARRY OR T=STRNG OR T=RCLTYP
11600			OR T=LSTYPE THEN BEGIN OPPSH(REFIT,0); STACK[TOS]_-1 END
11700		    ELSE EV1ERR("Misplaced [");
11800		    END
11900		ELSE IF OP=";" THEN BEGIN PSH(OP); EVAL1 END
12000		ELSE IF OP="{" THEN BEGIN
12100		    IF ARG="{" THEN LOPARG;
12200		    OPPSH("{",0); PSH(-1) END
12300		ELSE IF OP=CH!SETC THEN BEGIN
12400		    IF ARG=CH!SETC THEN BEGIN OP_OPLSTC; LOPARG END;
12500		    IF TOOPS<0 OR OPSTACK[TOOPS] NEQ "{" THEN EV1ERR("Bad set or list");
12600		    PSH(OP); EVAL1; TOOPS_TOOPS-1 END
12700		ELSE OPPSH(OP,RBND)
12800		END "SPCHAR"
12900	END "CASES";
13000	BINARYMINUSFLAG_IF CLASS NEQ SPCHAR OR OP=")" OR OP="]" THEN TRUE
13100	    ELSE FALSE
13200	END "PARSE";
13300	RETURN(STACK[0])
13400	END "EVAL";
     
00100	# SETSCOPE !!STEP !!GSTEP !!GOTO CLNRET !!UP Q!BRECOV P!BRECOV;
00200	
00300	INTEGER NXTINSTR,PCSHADOW;
00400	
00500	INTERNAL PROCEDURE SETSCOPE(ITEMVAR PROCITM); BEGIN "SETSCOPE"
00600	DEFINE PCW=['23],ACF=['15],ACP=['22],STATUS=['30];
00700	INTEGER PB;
00800	IF TYPEIT(PROCITM) NEQ '11 THEN EV1ERR("Not a process item");
00900	START!CODE EXTERNAL INTEGER DATM;
01000		MOVE	3,PROCITM;	# PB_DATUM(PROCITM);
01100		MOVE	5,@DATM;	# PROCITM must be untyped to work at runtime;
01200		MOVEM	5,PB;		# but compiler gives message UNTYPED ITEMVAR;
01300	END;
01400	IF (PB LAND '1000000) OR MEMORY[PB+STATUS]=2 THEN
01500	    EV1ERR("Terminated");
01600	GETLSCOPE(LCHAIN,LDEPTH,MEMORY[PB+PCW]);
01700	GETDSCOPE(MEMORY[PB+ACF],MEMORY[PB+ACP],MEMORY[PB+PCW],DDEPTH,DCHAIN);
01800	END "SETSCOPE";
01900	
02000	INTERNAL PROCEDURE !!STEP; BEGIN STEPIT(PC,STEPINSTR,STEPMASK);
02100	    GOTO RET END;
02200	
02300	INTERNAL PROCEDURE !!GSTEP; BEGIN STEPIT(PC,GSTEPINSTR,GSTEPMASK);
02400	    GOTO RET END;
02500	
02600	INTERNAL PROCEDURE !!GOTO(STRING WHERE); BEGIN
02700	    PC_LOC!PC(WHERE); FLAGS_FLAGS LOR ('20 LSH 18); # JRST MODE; GOTO RET END;
02800	
02900	PROCEDURE Q!BRECOV; GOTO BRECOV;
03000	
03100	SIMPLE PROCEDURE CLNRET; BEGIN "CLNRET"
03200	PLANT!BREAKS;
03300	IF CURBRK=N!BK AND NOT(FLAGS LAND '20)
03400	    THEN NXTINSTR_MEMORY[PC_PC+1];	# EXPLICIT USER CALL;
03500	ARRTRAN(TEMP!ACS,SAVED!ACS);	# RESTORE ACS;
03600	START!CODE LABEL LUP1,SIM1,SIMI2,SIM2,SIMDON;
03700	DEFINE T1=['13],T2=['14],T3=['15];
03800		SOS	BKLEV;
03900		MOVE	T1,PCSHADOW;
04000		MOVEM	T1,-1(F);	# CORRECT THE FAKE RETURN ADDR;
04100		MOVS	T1,FLAGS;
04200		TLZ	T1,'37;
04300		HRRI	T1,TRAP[1];
04400		MOVEM	T1,TRAP[0];	# JRSTF @[FLAGS,,TRAP[1]] RESUMES;
04500		HRRZ	T2,PC;
04600		TLO	T2,'254000;	# JRST;
04700		MOVSI	T3,-6;
04800	LUP1:	MOVEM	T2,TRAP[1](T3);	# JRST PC+i IN TRAP[i+1];
04900		ADDI	T2,1;
05000		AOBJN	T3,LUP1;
05100		HRRI	T1,-5(T2);	# FLAGS,,PC+1;
05200		MOVEM	T1,TRAP[7];	# RETURN WORD TO BE PUSHED;
05300		MOVE	T2,NXTINSTR;
05400		MOVEM	T2,TRAP[1];	# DONE FOR USUSAL CASE, NOW CHECK SUBROUTINE CALLS;
05500		MOVE	T3,T2;		# COPY OF NEXT INSTR;
05600	
05700		LDB	T1,[('331100 LSH 18)+T2];	# 9 BIT OPCODE;
05800		CAIE	T1,'260;	# PUSHJ;
05900		 JRST	SIM1;
06000		TLZ	T3,'000037;	# CLEAR INDEX AND INDIR;
06100		TLO	T3,'261000;	# TURN INTO PUSH;
06200		HRRI	T3,TRAP[7];
06300		MOVEM	T3,TRAP[1];	# FIRST HALF: PUSH RETURN WORD;
06400		TLZ	T2,'777740;	# LEAVE INDEX AND INDIR;
06500		TLO	T2,'254000;	# TURN INTO JRST;
06600		MOVEM	T2,TRAP[2];	# SECOND HALF: JUMP TO DESTINATION;
06700	SIM1:	CAIE	T1,'264;	# JSR;
06800		 JRST	SIM2;
06900		TLZ	T2,'777740;	# LEAVE ONLY INDIRECT AND INDEX;
07000		TLO	T2,'202040;	# MOVEM 1,;
07100		MOVEM	T2,TRAP[1];	# SAVE AC1 IN JSR DESTINATION;
07200		MOVE	T3,SIMI2;
07300		MOVEM	T3,TRAP[2];	# GET ACTUAL RETURN WORD IN AC1;
07400		TLC	T2,'052000;	# TURN MOVEM INTO EXCH;
07500		MOVEM	T2,TRAP[3];	# PLANT RETURN WORD, RETRIEVE AC1;
07600		TLO	T2,'254000;	# TURN EXCH INTO JRST;
07700		HRRI	T2,1(T2);	# AND INCREMENT ADDR;
07800		MOVEM	T2,TRAP[4];
07900	SIMI2:	MOVE	1,TRAP[7];	# A LITERAL;
08000	SIM2:	CAIE	T1,'265;	# JSP;
08100		 JRST	SIMDON;
08200		TLZ	T3,'777037;	# LEAVE ONLY AC;
08300		TLO	T3,'200000;	# MOVE;
08400		HRRI	T3,TRAP[7];
08500		MOVEM	T3,TRAP[1];	# PLACE RETURN WORD IN AC;
08600		TLZ	T2,'777740;	# LEAVE INDEX AND INDIR;
08700		TLO	T2,'254000;	# JRST;
08800		MOVEM	T2,TRAP[2];
08900	SIMDON:	END;
09000	END "CLNRET";
09100	CLEANUP CLNRET;
09200	
09300	
09400	INTERNAL PROCEDURE !!UP(INTEGER LEVEL); BEGIN "!!UP"
09500	# PEEL BACK TO LEVEL (CF SETLEX);
09600	OWN INTEGER BACKF,PC;
09700	LEVEL_0 MAX LEVEL MIN DDEPTH;	# Clip bounds;
09800	WHILE (BACKF_DCHAIN[LEVEL,0])<0 DO LEVEL_LEVEL+1;	# AVOID GOING TO SIMPLE LEVEL;
09900	PC_DCHAIN[LEVEL,1]+1;
10000	START!CODE DEFINE LPSA=['13];
10100	LABEL LUP,DUN,DUN1; EXTERNAL INTEGER STKUWD;
10200	LUP:	HRRZ	LPSA,BACKF;	# DESIRED DESTINATION;
10300		CAIN	LPSA,(F);	# VS. CURRENT;
10400		 JRST	DUN;
10500		HRRZ	LPSA,(F);	# UP DYNAMIC LINK;
10600		HLRO	LPSA,1(LPSA);	# LEVEL 777777,,PDA -- THUS NO DEALLOCATION AT DEST;
10700		HRLM	F,BACKF;	# REMEMBER F BEFORE STKUWD;
10800		PUSHJ	P,STKUWD;	# ATTEMPT IT;
10900		HLRZ	LPSA,BACKF;	# OLD F;
11000		CAIE	LPSA,(F);	# VS. CURRENT;
11100		 JRST	LUP;		# MADE IT;
11200		HRRZ	LPSA,(F);	# DIDN'T MAKE IT, MUST FORCE IT;
11300		HLRZ	LPSA,1(LPSA);	# LEVEL 0,,PDA -- THUS EVERYTHING DEALLOCATED;
11400		PUSHJ	P,STKUWD;	# DEALLOCATE;
11500		HRRZ	F,(F);		# FORCE BACK;
11600		JRST	LUP;
11700	DUN:				# RESTORE ACS IF F REGISTER MATCHES;
11800		HRRZ	LPSA,TEMP!ACS[F];
11900		CAIE	LPSA,(F);
12000		 JRST	DUN1;		# DON'T KNOW WHAT'S GOING ON HERE;
12100		MOVSI	'17,TEMP!ACS[0];
12200		BLT	'17,'17;
12300	DUN1:	PUSH	P,PC;
12400		JRST	BAIL;
12500		END;
12600	END "!!UP";
12700	
12800	
12900	SIMPLE INTEGER PROCEDURE P!BRECOV(INTEGER LOC; STRING MSG,RSP); BEGIN
13000	LABEL PRUNE;
13100	!ERRJ!_LOCATION(PRUNE); RETURN("C"+(2 LSH 18)); # CONTINUE, INHIBIT Called from;
13200	PRUNE: !ERRP! SWAP !RECOVERY!;
13300	START!CODE LABEL LUP; DEFINE T2=['14],T1=['13],T3=['15];
13400		MOVEI	T2,Q!BRECOV;		# ENTRY ADDR;
13500		PUSH	P,T2;
13600		PUSHJ	P,PDFIND;		# AC1_PDA;
13700		HRRZ	T3,PD!PPD(1);		# PARENT'S PDA;
13800		MOVEI	T2,(F);
13900	LUP:	HRRZ	T2,(T2);		# UP DYNAMIC LINK;
14000		HLRZ	T1,1(T2);		# PDA FROM STACK;
14100		CAIE	T1,(T3);
14200		 JRST	LUP;
14300		PUSH	P,F;			# NEW DYNAMIC LINK;
14400		HRLI	T2,(1);
14500		PUSH	P,T2;			# PDA,,STATIC LINK;
14600		PUSH	P,SP;
14700		HLRZ	T2,PD!PPD(1);
14800		JRST	(T2);			# PCNT AT MKSEMT;
14900		END;
15000	END;
15100	
15200	
15300	ARRTRAN(SAVED!ACS,TEMP!ACS);	# RECURSIVE SAVE;
15400	# There are three modes of calling: explicit user call via PUSHJ P,BAIL,
15500	  call from a BAIL-planted breakpoint via PUSHJ P,BAIL with a displaced
15600	  instruction, and "JRST MODE" in which a fake return word is put on the
15700	  stack and then JRST BAIL.  In the case of JRST, the '20 bit is on
15800	  (otherwise illegal as a flag bit);
15900	IF (FLAGS_LEFT(TRAP[0])) LAND '20
16000	THEN BEGIN PC_RIGHT(TRAP[0]); CURBRK_N!BK END
16100	ELSE BEGIN
16200	    PC_RIGHT(TRAP[0])-1;
16300	    NOHAND([
16400	    CURBRK_-1; WHILE (CURBRK_CURBRK+1)<N!BK AND RIGHT(BK!LOC[CURBRK])
16500		NEQ PC DO;
16600	    ]) # NOHAND;
16700	    HAND([
16800	    START!CODE LABEL LOOP;
16900	    DEFINE KEY=[0],I=['14];
17000		MOVSI	I,-N!BK;
17100	    LOOP:HRRZ	KEY,BK!LOC[0](I);
17200		CAME	KEY,PC;
17300		AOBJN	I,LOOP;
17400		HRRZM	I,CURBRK;
17500	    END;]) # HAND;
17600	END;
17700	START!CODE DEFINE T=['14];
17800		AOS	BKLEV;		# RECURSION LEVEL;
17900		MOVE	T,PC;		# Make it look like BAILOR was called from;
18000		MOVEI	T,1(T);		#  PC  rather than BAIL+16, but remember return;
18100		HLL	T,-1(F);	# word so that CLNRET can put it back together;
18200		EXCH	T,-1(F);
18300		MOVEM	T,PCSHADOW;
18400	END;
18500	CLRTBK(PC);	# CLEAR TEMPORARY BREAKPOINTS;
18600	UNPLANT!BREAKS;
18700	NXTINSTR_MEMORY[PC];
18800	
18900	DISPLVL_0;
19000	!RECOVERY!_LOCATION(P!BRECOV);	# GOTO BRECOV IF BAIL ERRORS OCCUR;
19100	GETLSCOPE(LCHAIN,LDEPTH,PC);
19200	IF (CURBRK=N!BK) THEN 	# EXPLICIT USER CALL;
19300	    GETDSCOPE(SAVED!ACS[F],SAVED!ACS[P],PC,DDEPTH,DCHAIN)
19400	ELSE BEGIN	# BAIL-PLANTED BREAKPOINT;
19500	    IF LEFT(NXTINSTR)='551517 THEN
19600		# '551517 IS THE LEFT HALF OF  HRRZI F,(P).  IF THE BROKEN INSTR
19700		  IS THIS, ASSUME THAT WE HAVE BROKEN A NON-SIMPLE PROCEDURE AND THAT
19800		  THE INSTR IS THE ONE THAT SETS THE F REGISTER.  IN ORDER TO MAKE
19900		  PARAMETER ACCESSING CONSISTENT WITH BREAKS INSIDE THE PROCEDURE,
20000		  SET UP SAVED!ACS AS IF THE HRRZI HAD BEEN EXECUTED;
20100		SAVED!ACS[F]_RIGHT(SAVED!ACS[P])+
20200		    (RIGHT(NXTINSTR) LSH 18 ASH -18);
20300	    GETDSCOPE(SAVED!ACS[F],SAVED!ACS[P],PC,DDEPTH,DCHAIN);
20400	    IF LENGTH(BK!COND[CURBRK]) AND MEMORY[EVAL(BK!COND[CURBRK])]
20500		AND (BK!COUNT[CURBRK]_BK!COUNT[CURBRK]-1)<0 AND
20600		LENGTH(BK!ACT[CURBRK]) THEN EVAL(BK!ACT[CURBRK]) END;
20700	
20800	# TELL USER HOW HE GOT HERE, BUT KEEP QUIET IF USER STUFFED REQUEST INTO !!QUERY;
20900	IF NOT(LENGTH(!!QUERY)) THEN
21000	OUTSTR(CRLFCAT(
21100	    (IF CURBRK=N!BK OR NOT LENGTH(BK!NAME[CURBRK]) THEN GETTEXT(PC)
21200	    ELSE BK!NAME[CURBRK])	));
21300	
21400	BRECOV:
21500	while true do begin "read BAIL command"
21600		NEWTOP([if not oldBail then eval(Newlined(BKLEV))
21700		else])
21800		EVAL(LINED(BKLEV));
21900		end "read BAIL command";
22000	
22100	"BREAK RETURN"
22200	RET:	# ALL THE WORK IS DONE IN THE CLEANUP;
22300	
22400	RETURN
22500	END "BAILOR";
22600	
     
00100	# BAIL,UBINIT,DDBAIL,B!;
00200	SIMPLE INTERNAL PROCEDURE BAIL; START!CODE "BAIL"
00300	DEFINE TEMP=['14],USER=['15],F=['12];
00400		POP	P,TRAP[0];
00500		MOVEM	'17,TEMP!ACS['17];
00600		MOVEI	'17,TEMP!ACS[0];
00700		BLT	'17,TEMP!ACS['16];
00800		MOVE	'17,TEMP!ACS['17];
00900		MOVE	USER,GOGTAB;	# DAMN RUNTIMES AREN'T REENTRANT, MUST SAVE THEIR;
01000		HRRI	TEMP,TEMP!ACS['20];	# SAVED ACS;
01100		HRLI	TEMP,RACS(USER);
01200		BLT	TEMP,TEMP!ACS['20+F];
01300		MOVE	TEMP,!SKIP!;
01400		MOVEM	TEMP,TEMP!ACS['20+F+2]; # AND SAVE !SKIP!;
01500		MOVE	TEMP,UUO1(USER);	# AND THIS FUNNY RETURN LOCATION;
01600		MOVEM	TEMP,TEMP!ACS['20+F+1];
01700		SKIPL	BAILOC(USER);	# SIGN BIT SET IFF INITIALIZED;
01800		 PUSHJ	P,STBAIL;
01900		SKIPE	BALNK;		# IN CASE BAIL LOADED BUT NO /B COMPILATIONS;
02000		 PUSHJ	P,BAILOR;
02100		MOVE	USER,GOGTAB;
02200		MOVE	TEMP,TEMP!ACS['20+F+2];
02300		MOVEM	TEMP,!SKIP!;
02400		MOVE	TEMP,TEMP!ACS['20+F+1];
02500		MOVEM	TEMP,UUO1(USER);
02600		HRRI	TEMP,RACS(USER);
02700		HRLI	TEMP,TEMP!ACS['20];
02800		BLT	TEMP,RACS+F(USER);
02900		HRLZI	'17,TEMP!ACS[0];
03000		BLT	'17,'17;
03100		JRSTF	@TRAP[0];
03200	END "BAIL";
03300	
03400	
03500		
03600	SIMPLE INTERNAL PROCEDURE DDBAIL; START!CODE
03700	# Break the next location to be executed, except try to diagnose procedure
03800	  returns which rely on positive stack displacements.  Use a "JRST MODE" break
03900	  to avoid problems in case the location is in an upper segment.
04000	
04100	  For TENEX, this procedure is entered only via ctrl-B pseudo interrupt, since
04200	  TENEX always manages to find DDT somehow.  For non-TENEX, you get here
04300	  when BAIL is your DDT and you say "DDT" to the monitor or "D" to the SAIL
04400	  error handler.  The assumption is that !JBOPC contains the PC.  Thus you
04500	  should not say "D" to the SAIL error handler, because the PC will be lost.;
04600	
04700	LABEL BOT,LOOP,BOT1,BOT2,SIMSTK,STKCHK,SIMXCT;
04800	NOTENX([
04900		MOVEM	1,TEMP!ACS[1];
05000		MOVEM	2,TEMP!ACS[2];
05100		MOVE	2,!JBOPC;
05200	]) # NOTENX;
05300	TENX([		EXTERNAL INTEGER PS3ACS;	# ACS AT INTERRUPT;
05400		MOVEI	1,'400000;	# CURRENT FORK;
05500		RIR;			# READ INTERRUPT REGISTER?;
05600			MOVSS	2;		# CHNTAB,,LEVTAB;
05700		MOVE	2,@2(2);	# PC FOR LEVEL 2;
05800		MOVEI	1,PS3ACS;	# GET REAL P AND SP FOR A WHILE;
05900		EXCH	P,P(1);
06000		EXCH	SP,SP(1);
06100	]) # TENX;
06200			# IF LAST INSTR EXECUTED KILLED THE STACK,
06300			  THEN MUST ALLOW THE STACK KILL TO FINISH, SINCE
06400			  4 INSTR COULD BE INVOLVED (MOVE F,(F)	  SUB SP,[m,,m]
06500			  SUB P,[n,,n]	JRST @k(P)	) AND WE DONT WANT
06600			  TO BE IN THE MIDDLE;
06700	STKCHK:	HLRZ	1,-1(2);	# OPCODE HALF OF LAST INSTR;
06800		CAIE	1,'274740;	# SUB P,;
06900		CAIN	1,'274700;	# SUB SP,;
07000		 JRST	SIMSTK;		# BLETCH, STACK HAS BEEN WIPED;
07100		CAIE	1,'105740;	# ADJSP P,;
07200		CAIN	1,'105700;	# ADJSP SP,;
07300		 JRST	SIMSTK;		# BLETCH, STACK HAS BEEN WIPED;
07400		CAIE	1,'200512;	# MOVE F,(F);
07500		 JRST	BOT;		# WAS OK, NO WORRY;
07600	SIMSTK:	HLRZ	1,(2);		# GET OPCODE HALF OF NEXT INSTR;
07700		CAIE	1,'105740;	# ADJSP P,;
07800		CAIN	1,'105700;	# ADJSP SP,;
07900		 JRST	SIMXCT;
08000		CAIE	1,'274740;	# SUB P,;
08100		CAIN	1,'274700;	# SUB SP,;
08200		 SKIPA;			# MUST SIMULATE THIS ONE;
08300		JRST	BOT1;		# DONE INTERPRETING;
08400	SIMXCT:	XCT	(2);		# DO THE SUBTRACT;
08500		AOJA	2,SIMSTK;	# KEEP ON SIMULATING UNTIL NO MORE BAD ONES;
08600	BOT1:	CAIE	1,'263740;	# POPJ P,;
08700		 JRST	BOT2;
08800		HRR	2,(P);		# MUST SIMULATE THIS ONE, TOO;
08900		SUB	P,['1000001];
09000	BOT2:	CAIN	1,'254037;	# JRST @(P);
09100		 HRRI	2,@(2);		# AND THIS ONE;
09200		MOVEM	2,!JBOPC;	# LEAVE GOOD TRACKS;
09300	BOT:	TLO	2,'20;		# JRST MODE;
09400		PUSH	P,2;		# CREATED RETURN WORD;
09500	NOTENX([MOVE	1,TEMP!ACS[1];
09600		MOVE	2,TEMP!ACS[2];
09700		JRST	BAIL;
09800	]) # NOTENX;
09900	TENX([	MOVEI	1,'400000;	# ALL THIS BALONEY AGAIN;
10000		RIR;
10100		MOVS	1,2;
10200		MOVE	2,!JBOPC;
10300		HRRI	2,BAIL;		# THIS IS HOW WE GET INTO BAIL;
10400		MOVEM	2,@2(1);
10500		MOVEI	1,PS3ACS;
10600		EXCH	P,P(1);		# RESTORE ACS;
10700		EXCH	SP,SP(1);
10800	]) # TENX;
10900		END;
11000	
11100	FORWARD INTERNAL SIMPLE PROCEDURE B!;
11200	
11300	SIMPLE PROCEDURE UBINIT; BEGIN # TRY TO LIVE WITH RESETS AND SAVED CORE IMAGES;
11400	# USERCON(BAILOC,#SKIP#_LOCATION(BAIL),TRUE);	# INFORM ERROR HANDLER WE ARE HERE;
11500	GOGTAB[BAILOC]_LOCATION(BAIL);
11600	C!NAME_C!BLKADR_C!CRDIDX_0;	BAIJFN_TMPJFN_-1;
11700	NOTENX([			# SET !JBDDT IF NOT ALREADY SET;
11800			DEFINE SETDDT=['047000000002];
11900	    START!CODE
12000		MOVEI	1,DDBAIL;
12100		SKIPN	!JBDDT;
12200		 SETZM	!JBSYM;		# WE REALLY DONT HAVE SYMBOLS;
12300		SKIPE	2,!JBDDT;
12400		CAIN	2,B!;		# IF (.JBDDT)=B., THEN RESET IT ANYWAY;
12500		 SETDDT	1,0;
12600		END;
12700	]) # NOTENX;
12800	TENX([
12900		PSIMAP(34,DDBAIL,0,3);	# USE CHANNEL 34, GOTO DDBAIL, , LEVEL 3;
13000		ENABLE(34); ATI(34,"B"-'100);	# <ctrl>B !!!!!!!!;
13100	]) # TENX;
13200	END;
13300	REQUIRE UBINIT INITIALIZATION [0];
13400	
13500	INTERNAL SIMPLE PROCEDURE B!;
13600	BEGIN
13700	COMMENT
13800		The location B! (B. in DDT or RAID) is meant to be
13900	a universal entry to BAIL from DDT.  By typing B.$G, we get
14000	to BAIL.  Upon exit from BAIL, we return to DDT.
14100		The main problem is that if the core image is
14200	not initialized by the SAILOR call, then we must initialize it.
14300		
14400	Non-TENEX sites: When loaded, .JBDDT (location '74) will be set to LOCATION(B.)
14500	by some external means.  This is so that GET followed by DD works.  Attempt to
14600	!!GO from this first entry will start the program.
14700	;
14800	INTEGER SAVE13,OJOBSA;
14900	EXTERNAL INTEGER !JBSA,SAILOR;
15000	LABEL DOINIT,GO,B!DDT;
15100	DEFINE !  = [COMMENT];
15200	DEFINE P=['17],SP=['16],RF=['12];
15300	    START!CODE
15400		MOVEM '13,SAVE13;
15500		MOVE '13,!JBSA;
15600		MOVEM '13,OJOBSA;	! SAVE IT;
15700		MOVS '13,('13);		! GET THE CONTENTS OF THE STARTING
15800					ADDRESS;
15900		SKIPE SAILOR;		# ANOTHER CONDITION WHICH FORCES INITIALIZATION;
16000		CAIN '13,'334000;	! IS IT THE ORIGINAL STARTING ADDRESS?;
16100		  JRST DOINIT;		! GO THRU SAIL INITIALIZATION;
16200	GO:	MOVE '13,SAVE13;
16300		ADD P,['12000012];	! ADD A FEW LOCATIONS TO THE P STACK;
16400		PUSHJ P,BAIL;		! CALL BAIL;
16500		SUB P,['12000012];	
16600	B!DDT:
16700		HRRZ	'13,!JBDDT;
16800		SKIPE	'13;		# IF !JBDDT=0 THEN WE ARE AT FUNNY TENEX;
16900		CAIN	'13,B!;		# IF !JBDDT=B. THEN USER TYPED  GET  THEN  DDT;
17000		HRRZ	'13,!JBSA;	# IN EITHER CASE, START PROGRAM;
17100		JRST	('13);
17200	
17300	DOINIT:	JSR SAILOR;		! INITIALIZE;
17400		HRLOI 	RF,1;		! SET UP RF;
17500		PUSH	P,RF;
17600		HRRZ	'13,OJOBSA;	# OLD STARTING ADDRESS;
17700		PUSH	P,@4('13);	# PDA,,0 FOR OUTER BLOCK;
17800		PUSH	P,SP;
17900		HRRI	RF,-2(P);
18000		HRRZ 	'13,OJOBSA;	! GET THE OLD STARTING ADDRESS;
18100		ADDI 	'13,3;		! ADD 3;
18200		HRLI 	'13,'310000;	! PUT A "CAM" ON THE LEFT ;
18300		MOVEM 	'13,SAILOR;	! CONVINCE IT THAT THIS IS 
18400					THE USER'S STARTING ADDRESS;
18500		MOVE 	'13,SAVE13;	! GET BACK 13;
18600		PUSHJ	P,BAIL;					! CALL SDDT;
18700		SUB	P,['3000003];	! ADJUST P STACK, FOR PUSHING DONE ABOVE;
18800		JRST	B!DDT;		! RETURN TO DDT (PRESUMABLY);
18900	END;  ! OF START!CODE;
19000	END;
19100	
19200	NOTENX([
19300	PROCEDURE DDT; START!CODE LABEL DUMB,DONE;
19400	DEC([	LABEL	FNDDDT;	])
19500	STANFO([ LABEL	PRAID;	])
19600	EXTERNAL INTEGER OUTSTR;
19700	DEC([
19800		HRRZ	1,!JBCST;	# "SDDT" PUTS DDT START ADDR HERE;
19900		JUMPN	1,FNDDDT;
20000	]) # DEC;
20100		HRRZ	1,!JBDDT;	# PICK UP ADDRESS;
20200		CAIN	1,DDBAIL;
20300		 JRST	DUMB;
20400	DEC([
20500	FNDDDT:
20600		PUSH	SP,[29];
20700		PUSH	SP,["
20800	DDT  (POPJ 17,$X to return)"];
20900		PUSHJ	P,OUTSTR;
21000	]) # DEC;
21100		STANFO([
21200		MOVEI	2,["
21300	DDT  (P or POPJ 17,$X to return)"];
21400		PUSH	SP,-1(2);
21500		PUSH	SP,(2);
21600		PUSHJ	P,OUTSTR;
21700		MOVE	2,-1('12);	# RETURN WD FOR THIS PROCEDURE, FLAGS IN LH;
21800		HRRI	2,PRAID;	# FAKE RETURN ADDR;
21900		MOVEM	2,!JBOPC;	# SO <CTRL>P WORKS FROM RAID;
22000	]) # STANFO;
22100		PUSHJ	P,(1);
22200		JRST	DONE;
22300	STANFO([
22400	PRAID:	POPJ	P,;		# A "LITERAL";
22500	]) # STANFO;
22600	DUMB:	PUSH	SP,[18];
22700		PUSH	SP,["
22800	BAIL is your DDT"];
22900		PUSHJ	P,OUTSTR;
23000	DONE:	END;
23100	]) # NOTENX;
23200	
23300	TENX([
23400	PROCEDURE DDT;
23500	COMMENT
23600		Call from SAIL to go to DDT on a TENEX system.
23700	Tries several ways.;
23800	BEGIN
24000	DEFINE	DDTORG=['770000],
24100		DDTPAGE=['770];
24200	
24300	SIMPLE PROCEDURE GO1(INTEGER ADDR);
24400	BEGIN
24500	OUTSTR("
24600	DDT  POPJ 17,$x to return
24700	");
24800	START!CODE PUSHJ P,@ADDR; END;
24900	END;
25000	
25100	
25200	SIMPLE BOOLEAN PROCEDURE PAGE!EXISTS(INTEGER PAGE);
25300	START!CODE
25400		MOVE	1,PAGE;
25500		HRLI	1,'400000;
25600		RPACS;
25700		TLNE	2,'010000;
25800		  SKIPA	1,[-1];
25900		SETZ	1,;
26000	END;
26100		  
26200	
26300	IF !JBDDT AND RIGHT(!JBDDT) NEQ LOCATION(DDBAIL)
26400	THEN GO1(!JBDDT LAND '777777)
26500	ELSE
26600	   BEGIN
26700		IF PAGE!EXISTS(DDTPAGE) AND MEMORY[DDTORG]='254000000000+DDTORG+2 THEN
26800		GO1(DDTORG+2) ELSE
26900		    BEGIN
27000			INTEGER JFN;
27100	NOT20([
27200			JFN _ GTJFN("<SAIL>UDDT.SAV",'100000000000);
27300			IF JFN=-1 THEN JFN _ GTJFN("<SUBSYS>UDDT.SAV",'100000000000);
27400	     ])
27500	T20([
27600			JFN _ GTJFN("SYS:UDDT.EXE",'100000000000);
27700	     ])
27800			IF JFN=-1 THEN NONFATAL("CANNOT GO TO DDT") ELSE
27900			    BEGIN
28000				START!CODE
28100					PUSH	P,JFN;
28200					PUSHJ	P,CVJFN;
28300					HRLI	1,'400000;
28400					GET;
28500				END;
28600				COMMENT MOVE UP SYMBOL TABLE POINTER;
28700				MEMORY[MEMORY[DDTORG+1]]_!JBSYM;
28800				GO1(DDTORG+2);
28900			   END;
29000		    END;
29100	    END;
29200	END;
29300	
29400	
29500	END;
29600	]) # TENX;
29700	
29800	
29900	
30000	END "BILGE"