Trailing-Edge
-
PDP-10 Archives
-
decuslib20-01
-
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(""e;
23900 while line do begin
24000 c_lop(line);
24100 if c="," then done;
24200 result_result&c;
24300 end;
24400 result_result"e;
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(""e&line"e&")";
25300 [12][13] result_"$RUN$."&word&"(""e&line"e&")";
25400 [18] result_"!!GOTO"&"(""e&line"e&")";
25500 [15] result_"$RUN$.COORD(""e&line"e&")";
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"