perm filename BAIL.SAI[TNX,AIL] blob
sn#123324 filedate 1974-10-09 generic text, type T, neo UTF8
BEGIN "BILGE"
REQUIRE 64 STRING!PDL; COMMENT STANDARD IS 40;
REQUIRE "<><>" DELIMITERS;
LET DEFINE=REDEFINE;
DEFINE TENXSW=<TRUE>, TENX(A)=<IFC TENXSW THENC A ENDC>,
NOTENX(A)=<IFC NOT TENXSW THENC A ENDC>;
DEFINE UPTO=<STEP 1 UNTIL>, #=<COMMENT>, CRLF=<('15 & '12)>, LF=<'12>,TAB=<'11>;
DEFINE SUPERCOMMENT(A)=<>;
DEFINE MEMLOC(A,B)=<MEMORY[LOCATION(A),B]>;
DEFINE LEFT(A)=<((A) LSH -18)>, RIGHT(A)=<((A) LAND '777777)>;
DEFINE JRST=<'254000000000>, XCT=<'256000000000>, JSR=<'264000000000>,
JFCL=<'255000000000>,PUSHJ=<'260000000000>,P=<'17>, SP=<'16>;
DEFINE PD!NPW=<4>,PD!DSP=<5>,PD!DLW=<7>,PD!PPD=<'11>,PD!PCW=<'12>;
EXTERNAL INTEGER !SKIP!,!ERRP!,!ERRJ!;
DEFINE FATAL(A)=<USERERR(0,0,A)>, NONFATAL(A)=<USERERR(0,1,A)>;
# GENERALIZED PRINT ROUTINE DECLARATIONS;
EXTERNAL PROCEDURE WR!TON(INTEGER REFIT); EXTERNAL INTEGER WR!LEN,WR!ACT;
EXTERNAL STRING WR!S1,WR!S2,WR!S3,WR!S4;
SIMPLE PROCEDURE INIT!WR; BEGIN "INITWR"
WR!LEN←75; WR!ACT←3; WR!S2←" "; # 3 SPACES SEPARATE EXPRESSIONS;
WR!S3←" "; # TWO SPACES BETWEEN ARRAY ELEMENTS; WR!S4←", "; # BETWEEN
ITEMS IN A SET OR LIST; END "INITWR";
REQUIRE INIT!WR INITIALIZATION;
NOTENX(<REQUIRE "<REISER>OPENFI.SAI" SOURCE!FILE;>)
REQUIRE "<REISER>WRITON.REL" LOAD!MODULE;
DEFINE ERROREXIT(LAB)=<
PROCEDURE GOTO>&<LAB>&<; GOTO >&<LAB;
SIMPLE INTEGER PROCEDURE ERR>&<LAB>&<(INTEGER LOC;STRING MSG,RSP);
BEGIN "ERR>&<LAB>&<" LABEL PRUNE; EXTERNAL INTEGER !ERRJ!;
!ERRJ!←LOCATION(PRUNE);
RETURN(IF LENGTH(RSP) NEQ 0 THEN RSP ELSE "C");
PRUNE: GOTO>&<LAB>&<
END "ERR>&<LAB>&<";
>;
DEFINE ERRSET(A,LAB)=<
QUICK!CODE
MOVE '13,ERRPDP; # STACK POINTER FOR RECURSIVE ERRSETS;
PUSH '13,!ERRP!; # SAVE PREVIOUS ERRP;
MOVEM '13,ERRPDP; # SAVE PDP;
MOVEI '13,ACCESS(ERR>&<LAB>&<); # LOCATION OF ERROR PROCEDURE;
MOVEM '13,!ERRP!; # PLANT IT;
END;
A; # REGULAR SAIL STUFF;
QUICK!CODE
MOVE '13,ERRPDP;
POP '13,!ERRP!;
MOVEM '13,ERRPDP;
END;
>;
INTEGER ERRPDP; INTEGER ARRAY ERRSTK[1:16];
SIMPLE PROCEDURE INI000; ERRPDP←(-16 LSH 18) LOR (LOCATION(ERRSTK[1])-1);
REQUIRE INI000 INITIALIZATION;
DEFINE SM1LNK(I)=<MEMORY[SM1PNT+I]>, T!NAME(I)=<MEMORY[C!NAME+I]>,
T!BLKADR(I)=<MEMORY[C!BLKADR+I]>, T!CRDIDX(I)=<MEMORY[C!CRDIDX+I]>;
DEFINE PAGEIT(A,B)=<T!NAME(B)>;
DEFINE N!CACHE=<100>, BOTTOM!SLOT=<95>, N!BK=<16>, L!BK=<(N!BK-1)>;
DEFINE HRELOC(A)=<(A-'400000+HZERO)>, LRELOC(A)=<(A+LZERO)>;
INTEGER BAIJFN,TMPJFN; # CHANNEL NUMBERS FOR .BAI FILE AND TEXT FILES;
INTEGER C!NAME, # ADDRESS OF NAME TABLE;
C!BLKADR, # ADDRESS OF BLKADR TABLE;
C!CRDIDX, # ADDRESS OF COORDINATE INDEX TABLE;
L!NAME, # INDEX OF LAST ENTRY CURRENTLY USED IN NAME TABLE;
L!BLKADR, # BLKADR TABLE;
L!CACHE, # CACHE;
L!CRDIDX, # COORDINATE INDEX;
L!TXTFIL, # TEXT FILE TABLE;
N!NAME, # NUMBER OF ENTRIES ALLOCATED IN NAME TABLE;
N!BLKADR, # BLKADR;
N!CRDIDX # COORDINATE INDEX;
;
INTEGER BKLEV; # BREAKPOINT RECURSION LEVEL;
INTERNAL STRING QUERY; # TO BE SET BY USER ON EXPLICIT CALL TO BAIL;
INTEGER BAILOFF,NAME!POINTER; # ANOTHER SWITCH, USETI POINTER TO NAME TABLE IN .BAI FILE;
STRING ARRAY T!TXTFIL[0:32]; # NAMES OF TEXT FILES;
INTEGER ARRAY STATUS[0:32]; # FOR STATUS OF THESE FILES;
INTEGER ARRAY CACHE[0:N!CACHE-1]; # 20 MOST RECENT NAMES (5 WORDS PER);
INTEGER ARRAY TARRAY[0:127]; # TEMPORARY ARRAY;
INTEGER ARRAY BK!LOC, BK!INSTR,BK!COUNT[0:L!BK];
# BREAK LOCATIONS, SAVED INSTRUCTIONS, MULTIPLE PROCEED COUNTS;
STRING ARRAY BK!COND,BK!ACT[0:L!BK];
# TO BE EVALUATED FOR CONDITIONAL BREAK, AUTOMATIC ACTION;
INTEGER ARRAY TEMP!ACS[0:'17]; # HOLDING TANK UNTIL RECURSIVE SAIVING;
INTEGER ARRAY TRAP[0:8]; # PLACE TO DO INTERCEPTIONS;
INTEGER ARRAY FSTACK[0:31]; # RETURN ADDRESSES IN DYNAMIC SCOPE;
DEFINE A(B)=<CVASC("> & <B> & <")>;
PRESET!WITH
A(ABS), '120,
A(AND), '004,
A(ASH), '101,
A(ASSOC), '140,
A(DIV), '102,
A(EQV), '036,
A(FALSE), '103,
A(FOR), '121,
A(GEQ), '035,
A(IN), '006,
A(INF), '016,
A(INTER), '022,
A(LAND), '104,
A(LEQ), '034,
A(LNOT), '105,
A(LOR), '106,
A(LSH), '107,
A(MAX), '110,
A(MIN), '111,
A(MOD), '112,
A(NEQ), '033,
A(NOT), '005,
A(NULL), '114,
A(OR), '037,
A(ROT), '115,
A(SETC), '176,
A(SETO), '173,
A(SWAP), '027,
A(TO), '122,
A(TRUE), '117,
A(UNION), '023,
A(XOR), '026 ;
INTEGER ARRAY RWORD[0:31,0:1];
DEFINE Q1=<LSH 27+>, Q2=<LSH 18+>, Q3=<LSH 9+>, Q4=<>;
PRESET!WITH
'004, 220 Q1 222 Q2 002 Q3 000 Q4, # AND;
'005, 232 Q1 230 Q2 001 Q3 000 Q4, # NOT;
'006, 240 Q1 242 Q2 002 Q3 006 Q4, # IN;
'016, 300 Q1 302 Q2 000 Q3 007 Q4, # INF;
'022, 220 Q1 222 Q2 002 Q3 008 Q4, # INTER;
'023, 210 Q1 212 Q2 002 Q3 008 Q4, # UNION;
'026, 250 Q1 252 Q2 002 Q3 000 Q4, # XOR;
'027, 310 Q1 312 Q2 002 Q3 000 Q4, # SWAP;
'033, 240 Q1 242 Q2 002 Q3 004 Q4, # NEQ;
'034, 220 Q1 222 Q2 002 Q3 004 Q4, # LEQ;
'035, 240 Q1 242 Q2 002 Q3 004 Q4, # GEQ;
'036, 250 Q1 252 Q2 002 Q3 000 Q4, # EQV;
'037, 210 Q1 212 Q2 002 Q3 000 Q4, # OR;
'045, 260 Q1 262 Q2 002 Q3 009 Q4, # COMPATIBLE DIVIDE;
'046, 260 Q1 262 Q2 002 Q3 003 Q4, # CAT "&";
'050, 448 Q1 000 Q2 000 Q3 000 Q4, # LEFT PARENTHESIS "(";
'051, 000 Q1 448 Q2 000 Q3 000 Q4, # RIGHT PARENTHESIS ")";
'052, 260 Q1 262 Q2 002 Q3 009 Q4, # TIMES "*";
'053, 250 Q1 252 Q2 002 Q3 009 Q4, # PLUS "+";
'054, 100 Q1 102 Q2 000 Q3 000 Q4, # COMMA ",";
'055, 250 Q1 252 Q2 002 Q3 009 Q4, # MINUS "-";
'057, 260 Q1 262 Q2 002 Q3 002 Q4, # DIVIDE "/";
'072, 448 Q1 450 Q2 002 Q3 010 Q4, # COLON ":";
'073, 040 Q1 448 Q2 000 Q3 000 Q4, # SEMICOLON ;
'074, 240 Q1 242 Q2 002 Q3 004 Q4, # LESS THAN SIGN "<";
'075, 240 Q1 242 Q2 002 Q3 004 Q4, # EQUALS "=";
'076, 240 Q1 242 Q2 002 Q3 004 Q4, # GREATER THAN SIGN ">";
'101, 260 Q1 262 Q2 002 Q3 005 Q4, # ASH;
'102, 260 Q1 262 Q2 002 Q3 001 Q4, # DIV;
'103, 504 Q1 504 Q2 000 Q3 000 Q4, # FALSE;
'104, 250 Q1 252 Q2 002 Q3 000 Q4, # LAND;
'105, 302 Q1 300 Q2 001 Q3 000 Q4, # LNOT;
'106, 250 Q1 252 Q2 002 Q3 000 Q4, # LOR;
'107, 260 Q1 262 Q2 002 Q3 005 Q4, # LSH;
'110, 240 Q1 242 Q2 002 Q3 009 Q4, # MAX;
'111, 240 Q1 242 Q2 002 Q3 009 Q4, # MIN;
'112, 260 Q1 262 Q2 002 Q3 001 Q4, # MOD;
'114, 504 Q1 504 Q2 000 Q3 000 Q4, # NULL;
'115, 260 Q1 262 Q2 002 Q3 005 Q4, # ROT;
'117, 504 Q1 504 Q2 000 Q3 000 Q4, # TRUE;
'120, 272 Q1 270 Q2 001 Q3 000 Q4, # ABS;
'121, 100 Q1 100 Q2 002 Q3 001 Q4, # FOR (SUBSTRINGER);
'122, 100 Q1 100 Q2 002 Q3 001 Q4, # TO (SUBSTRINGER);
'123, 272 Q1 270 Q2 000 Q3 000 Q4, # UNARY MINUS (SPECIAL);
'133, 448 Q1 000 Q2 000 Q3 000 Q4, # LEFT BRACKET [;
'135, 000 Q1 448 Q2 000 Q3 000 Q4, # RIGHT BRACKET ];
'136, 270 Q1 272 Q2 002 Q3 009 Q4, # UP ARROW "↑";
'137, 448 Q1 050 Q2 002 Q3 004 Q4, # GETS "←";
'140, 100 Q1 102 Q2 002 Q3 000 Q4, # ASSOC "`";
'173, 448 Q1 100 Q2 000 Q3 000 Q4, # SETO "{";
'176, 100 Q1 448 Q2 000 Q3 000 Q4; # SETC "⎇";
INTEGER ARRAY OPS[0:50,0:1];
# CHAR CODE FOR OPERATOR, LEFT BINDING POWER, RIGHT BINDING POWER,
DEGREE (NULLARY, UNARY, BINARY), AND CONFORMITY CLASS;
DEFINE N!OPS=<50>;
REDEFINE A=<NOMAC A>;
DEFINE REFB=<(1 LSH 34)>, QUESB=<(1 LSH 33)>, BINDB=<(1 LSH 32)>,
PROCB=<(1 LSH 31)>, ITEMB=<(1 LSH 30)>, ARY2B=<(1 LSH 29)>,
ARRY=<(13 LSH 23)>;
PRESET!WITH 0, # BSIMPLE;
ARRY, # BARRY;
ITEMB, # BITMV;
ITEMB+ ARY2B, # BARITM;
ARRY+ ITEMB, # BITMAR;
ARRY+ ITEMB+ ARY2B, # BARITA;
PROCB, # BPROCED;
ITEMB; # BITEM;
INTEGER ARRAY COMPLEXTYPE[0:7];
DEFINE GETTYPE(A)=<((A) LAND ('77 LSH 23))>,INTEGR=<(5 LSH 23)>,
FLOTNG=<(4 LSH 23)>,STRNG=<(3 LSH 23)>;
PRESET!WITH 0,INTEGR,FLOTNG,STRNG,7 LSH 23,6 LSH 23,
ARRY,14 LSH 23;
INTEGER ARRAY SIMPLETYPE[0:7];
# BLAMDA,BINTGR,BREAL,BSTRNG,BLIST,BSET,BCNTXT,BLABEL;
DEFINE F=<('12 LSH 18)>, INDIR=<(1 LSH 22)>;
PRESET!WITH 0, # BBILTN;
F+ INDIR, # BREF;
INDIR, # BALLOC;
F; # BSTAK;
INTEGER ARRAY ACCESSTYPE[0:3];
PRESET!WITH 0; INTEGER ARRAY PATCH[0:'77];
FORWARD INTERNAL RECURSIVE PROCEDURE BAILOR;
SIMPLE PROCEDURE BAIL; START!CODE "BAIL"
DEFINE JRSTF=<'254100000000>,!JBDDT=<'74>,!JBOPC=<'130>;
LABEL NOTDDT;
POP P,TRAP[0];
MOVEM '17,TEMP!ACS['17];
MOVEI '17,TEMP!ACS[0];
BLT '17,TEMP!ACS['16];
MOVE '17,TEMP!ACS['17];
HRRZ 1,TRAP[0]; # RETURN PC;
NOTENX(<HRRZ 2,!JBDDT; # FWA DDT;
CAMGE 1,2;
JRST NOTDDT;
HLRZ 2,!JBDDT; # LENGTH OF DDT;
ADD 2,!JBDDT;
HRRZS 2; # LWA+1 OF DDT;
CAML 1,2;
JRST NOTDDT;>)
TENX(< CAIGE 1,'770000; # FIRST ADDR IN DDT PAGES;
JRST NOTDDT;>)
MOVE 1,!JBOPC; # ENTRY FROM DDT;
MOVEM 1,TRAP[0];
NOTDDT:
PUSHJ P,BAILOR;
HRLZI '17,TEMP!ACS[0];
BLT '17,'17;
JRSTF @TRAP[8];
END "BAIL";
SIMPLE INTEGER PROCEDURE LAST!WRITTEN(STRING FILENAME); BEGIN "LAST!WRITTEN"
TENX(< INTEGER JFN; JFN←OPENFILE(FILENAME,"RE"); IF !SKIP! THEN RETURN(0);
GTFDB(JFN,TARRAY); CLOSF(JFN); RETURN(TARRAY['14])>)
NOTENX(<INTEGER CHN,FLAG; CHN←GETCHAN; IF CHN=-1 THEN RETURN(0);
OPEN(CHN,"DSK",0,1,0,FLAG,FLAG,FLAG); IF FLAG THEN RETURN(0);
LOOKUP(CHN,FILENAME,FLAG); CLOSE(CHN); RELEASE(CHN);
IF FLAG THEN RETURN(0); FILEINFO(TARRAY); RETURN(TARRAY[3])>)
END "LAST!WRITTEN";
SIMPLE INTEGER PROCEDURE TYPEMUNGE(INTEGER D,LZERO,HZERO); BEGIN "TYPIT"
# CONVERT FROM BAIL TYPES TO REFITEM DATUMS;
INTEGER COMPLX,SIMPL,ACCES,LBITS,RBITS;
COMPLX←D LSH -18 LAND '7; SIMPL←D LSH -21 LAND '7; ACCES←D LSH -24 LAND '3;
LBITS←COMPLEXTYPE[COMPLX]+SIMPLETYPE[SIMPL]+ACCESSTYPE[ACCES]+REFB;
RBITS←RIGHT(D);
# NOW CORRECT THE ADDRESS. WATCH OUT FOR ITEMS, PROCEDURES, LABELS,
AND HIGHSEG ARRAYS. ALSO PARAMETERS AND RECURSIVE LOCALS;
IF COMPLX NEQ 7 # BITEM; THEN
IF (COMPLX=6) # BPROCED; OR (SIMPL=7) # BLABEL; OR
((ACCES=0) # BBILTN; AND (LBITS LAND ARRY) AND (RBITS LAND '400000))
THEN RBITS←HRELOC(RBITS)
ELSE IF ACCES=3 OR ACCES=1 THEN RBITS←RBITS LAND '377777
ELSE RBITS←LRELOC(RBITS);
RETURN(LBITS+RBITS) END "TYPIT";
EXTERNAL PROCEDURE CORGET;
SIMPLE INTEGER PROCEDURE COREGET(INTEGER LENGTH); BEGIN "COREGET"
INTEGER LOC;
START!CODE
MOVE 3,LENGTH; # PLACE WHERE CORGET TAKES ITS ARG;
PUSHJ P,CORGET; # CALL THE STEWARD;
SETZ 2,0; # UNSUCCESSFUL RETURN;
MOVEM 2,LOC; # SUCCESSFUL RETURN;
END;
IF LOC NEQ 0 THEN RETURN(LOC);
FATAL(<"NO CORE AVAILABLE FOR BAIL">) END "COREGET";
EXTERNAL PROCEDURE CORREL;
SIMPLE PROCEDURE COREFREE(INTEGER ADDR);
START!CODE "COREFREE"
MOVE 2,ADDR; # PLACE WHERE CORREL GETS ITS ARG;
PUSHJ P,CORREL;
END "COREFREE";
SIMPLE PROCEDURE EXTEND(REFERENCE INTEGER ADDR, OLEN, INCR); BEGIN "EXTEND"
INTEGER TMPJFN;
TMPJFN←OPENFILE("BBBBBB.TMP","RWE"); IF !SKIP! THEN BEGIN BAILOFF←TRUE;
USERERR(0,0,"CANNOT ACCESS BBBBBB.TMP. RESTART (WITHOUT BAIL)") END;
ARRYOUT(TMPJFN,MEMORY[ADDR],OLEN); COREFREE(ADDR);
ADDR←COREGET(OLEN←OLEN+INCR); CFILE(TMPJFN); TMPJFN←OPENFILE("BBBBBB.TMP","RE");
IF !SKIP! THEN BEGIN BAILOFF←TRUE; USERERR(0,0,"
CANNOT ACCESS BBBBBB.TMP. RESTART (WITHOUT BAIL)") END;
ARRYIN(TMPJFN,MEMORY[ADDR],OLEN);
CFILE(TMPJFN) END "EXTEND";
SIMPLE INTEGER PROCEDURE INSERT(INTEGER ARRAY NAME; INTEGER TYPE,FATHER,DATA);
BEGIN "INSERT"
INTEGER K,I;
# HASH TO FIND BUCKET;
K←ABS(NAME[0] MOD 31);
IF L!NAME+5 GEQ N!NAME THEN EXTEND(C!NAME,N!NAME,500);
L!NAME←L!NAME+1;
T!NAME(L!NAME)←T!NAME(K) LOR (FATHER LSH 18) LOR (TYPE LSH 34);
T!NAME(K)←L!NAME; # CHAINING;
T!NAME(L!NAME+1)←DATA; FOR I←0 UPTO 2 DO T!NAME(L!NAME+2+I)←NAME[I];
L!NAME←L!NAME+4;
RETURN(L!NAME-4) END "INSERT";
SIMPLE INTEGER PROCEDURE FIND(INTEGER ARRAY NAME,ACTIVE!BLOCKS; INTEGER LEXD,
ANYNAM);
BEGIN "FIND"
INTEGER K,I,FATHER,P!CACHE;
DEFINE CURBLK=<ACTIVE!BLOCKS[0]>;
# RETURN -1 IF NAME NOT FOUND
+PNTR TO CACHE TABLE IF FOUND;
# ANYNAM IS A FLAG. FALSE MEANS MUST RETURN A VARIABLE OR A PROCEDURE.
TRUE MEANS THAT A BLOCKNAME IS ALLOWED;
# CHECK CACHE FIRST;
FOR I←1 STEP 5 UNTIL L!CACHE DO BEGIN "SEARCH CACHE"
K←-1; WHILE (K←K+1) LEQ 2 AND NAME[K]=CACHE[I+2+K] DO;
IF K=3 AND RIGHT(CACHE[I])=RIGHT(ACTIVE!BLOCKS[0]) AND
(ANYNAM OR GETTYPE(CACHE[I+1]) NEQ 0)
THEN BEGIN "CLIMB"
IF I=1 THEN RETURN(1) ELSE FOR K←0 UPTO 4 DO
CACHE[I+K] SWAP CACHE[I+K-5]; RETURN(I-5) END"CLIMB"
END "SEARCH CACHE";
# COULD NOT FIND IT IN CACHE, LOOK IN REGULAR PLACE;
K←PAGEIT(T!NAME,ABS(NAME[0] MOD 31)); # INITIAL HASH;
WHILE K NEQ 0 DO BEGIN "CHAIN"
I←-1; WHILE(I←I+1)<3 AND NAME[I]=PAGEIT(T!NAME,K+2+I) DO;
IF I NEQ 3 THEN K←RIGHT(PAGEIT(T!NAME,K)) # FOLLOW DOWN CHAIN;
ELSE BEGIN "HOM"
# FOUND A LIKE SPELLING;
FATHER←LEFT(PAGEIT(T!NAME,K)) LAND '177777;
I←-1; WHILE (I←I+1) LEQ LEXD AND LEFT(ACTIVE!BLOCKS[I]) NEQ FATHER DO;
IF I=LEXD+1 OR (NOT ANYNAM AND GETTYPE(PAGEIT(T!NAME,K+1))=0)
THEN K←RIGHT(PAGEIT(T!NAME,K)) # TRY AGAIN;
ELSE BEGIN "GOTCHA"
# FOUND OUR MAN, SINCE INNER-MOST OCCURS FIRST IN CHAIN;
# PUT IN CACHE;
IF L!CACHE<N!CACHE THEN BEGIN P!CACHE←L!CACHE+1; L!CACHE←
L!CACHE+5 END ELSE P!CACHE←BOTTOM!SLOT;
FOR I←1 UPTO 4 DO CACHE[P!CACHE+I]←PAGEIT(T!NAME,K+I);
CACHE[P!CACHE]←LEFT(PAGEIT(T!NAME,K)) LSH 18 LOR RIGHT(CURBLK);
RETURN(P!CACHE)
END "GOTCHA"
END "HOM"
END "CHAIN";
RETURN(-1)
END "FIND";
PROCEDURE BAILINITIALIZATION; BEGIN"STBAIL"
INTERNAL BOOLEAN INIBAI; # TRUE IF BAIL HAS BEEN INITIALIZED;
EXTERNAL INTEGER BALNK; # LOADER LINK FOR NAMES OF .SM1 FILES;
INTEGER SM1PNT,FILTIM,N!BYTE;
BOOLEAN ENROLL; # WHETHER TO READ ALL .SM1 FILES;
INTEGER I,L,J,ADDR1,ADDR2,BRCHAR;
STRING T,PROGNAM;
IF INIBAI OR BAILOFF THEN RETURN; # IN CASE WE HAVE BEEN HERE BEFORE;
# THE LOADER LINKED LIST IS LINKED BACKWARDS (I.E., THE .REL FILE WHICH IS
LOADED FIRST IS LAST ON THE LIST). IT IS ESSENTIAL TO PROCESS THE FILES
IN THE ORDER IN WHICH THEY ARE LOADED, SO THE LIST MUST BE REVERSED.
$#$#$#$#$# THIS MEANS THAT THE LINK BLOCKS MUST BE IN THE LOWSEG #$#$#$#$#$;
IF MEMORY[BALNK] NEQ 0 AND MEMORY[BALNK]<BALNK THEN BEGIN
# DON'T REVERSE IT IF IT DOES NOT NEED TO BE REVERSED;
L←J←0; I←BALNK; WHILE I NEQ 0 DO BEGIN
J←I; I←MEMORY[I]; MEMORY[J]←L; L←J END;
BALNK←J; END;
# NOW MAKE LIKE RPG -- SEE IF WE CAN USE AN EXISTING .BAI FILE;
ENROLL←FALSE; SM1PNT←BALNK;
NOTENX(<PROGNAM←CVXSTR(SM1LNK(3));>)
TENX(<PROGNAM←CVSTR(SM1LNK(3));>)
FILTIM←LAST!WRITTEN(PROGNAM & ".BAI");
WHILE SM1PNT AND NOT ENROLL DO BEGIN
STRING SM1NAM;
TENX(<L←SM1LNK(2); SM1NAM←NULL; FOR I←1 UPTO L DO
SM1NAM←SM1NAM & CVSTR(SM1LNK(2+I));>)
NOTENX(<SM1NAM←CVXSTR(SM1LNK(3)) & ".SM1";>)
SM1PNT←SM1LNK(0); # FOLLOW DOWN LINK;
IF LAST!WRITTEN(SM1NAM) GEQ FILTIM THEN ENROLL←TRUE END;
IF NOT ENROLL THEN BEGIN "NOROLL"
BAIJFN←OPENFILE(PROGNAM & ".BAI","RE"); IF !SKIP! THEN BEGIN
NONFATAL("CANNOT OPEN EXISTING .BAI FILE; WILL RECONSTRUCT IT.");
ENROLL←TRUE END
ELSE BEGIN
# FIRST DISK BLOCK OF .BAI FILE IS A HEADER INDEX BLOCK.
WORD 0-7 UNUSED
8 USETI POINTER TO BEGINNING OF T!CRDIDX
9 N!CRDIDX
10 USETI POINTER TO BEGINNNG OF T!BLKADR
11 N!BLKADR
12 USETI POINTER TO BEGINNING OF T!NAME
13 N!NAME
14 USETI POINTER TO TEXT FILE NAMES
15 N!TXTFIL,,# OF WORDS TAKEN UP BY NAMES
16-127 UNUSED;
# READ THE FIRST BLOCK TO GET THE INDEX INFO;
ARRYIN(BAIJFN,TARRAY[0],128);
# SET UP THE VARIOUS ARRAYS;
C!CRDIDX←COREGET(N!CRDIDX←TARRAY[9]); L!CRDIDX←N!CRDIDX-1;
USETI(BAIJFN,TARRAY[8]); ARRYIN(BAIJFN,T!CRDIDX(0),N!CRDIDX);
C!BLKADR←COREGET(N!BLKADR←TARRAY[11]); L!BLKADR←N!BLKADR-1;
USETI(BAIJFN,TARRAY[10]); ARRYIN(BAIJFN,T!BLKADR(0),N!BLKADR);
C!NAME←COREGET(N!NAME←TARRAY[13]); L!NAME←N!NAME-1;
USETI(BAIJFN,TARRAY[12]); ARRYIN(BAIJFN,T!NAME(0),N!NAME);
L!TXTFIL←LEFT(TARRAY[15]); L←RIGHT(TARRAY[15]);
USETI(BAIJFN,TARRAY[14]); T←NULL; FOR I←0 UPTO L DO T←T &
CVSTR(WORDIN(BAIJFN)); SETBREAK(18,TAB,NULL,"INS");
FOR I←0 UPTO L!TXTFIL-1 DO T!TXTFIL[I]←SCAN(T,18,BRCHAR);
# NOW WE ARE IN BUSINESS;
BAILOFF←FALSE; RETURN END END "NOROLL";
# HERE TO CONSTRUCT THE .BAI FILE;
OUTSTR("
BAIL INITIALIZATION..."); BAIJFN←OPENFILE(PROGNAM & ".BAI","WE"); IF !SKIP!
THEN BEGIN BAILOFF←TRUE;
NONFATAL("DEVICE ERROR OR NOT AVAILABLE FOR .BAI FILE;
BAILOR ABANDONS SHIP.");RETURN END;
# NOW GET SOME CORE FOR THE VARIABLE LENGTH TABLES;
C!NAME←COREGET(N!NAME←2000); L!NAME←32; # FOR BUCKETS;
C!BLKADR←COREGET(N!BLKADR←256); L!BLKADR←-1;
C!CRDIDX←COREGET(N!CRDIDX←64); L!CRDIDX←-1;
SM1PNT←BALNK; N!BYTE←0;
# WRITE A DUMMY FIRST BLOCK; ARRYOUT(BAIJFN,TARRAY[0],128);
WHILE SM1PNT DO BEGIN "ONE COMPILATION"
INTEGER LZERO,HZERO,FZERO,SM1JFN,W,MAXFILN;
# LZERO LOW SEGMENT RELOCATION CONSTANT
HZERO HIGH SEGMENT RELOCATION CONSTANT
FZERO FILE NUMBER RELOCATION CONSTANT
SM1JFN CHANNEL NUMBER FOR .SM1 FILE
W WORK VARIABLE
MAXFILN MAXIMUM TEXT FILE NUMBER SEEN THIS COMPILATION;
STRING SM1NAM; # FILE NAME OF .SM1 FILE;
MAXFILN←0;
LZERO←RIGHT(SM1LNK(1))-1; HZERO←LEFT(SM1LNK(1));
TENX(<L←SM1LNK(2); SM1NAM←NULL; FOR I←1 UPTO L DO
SM1NAM←SM1NAM & CVSTR(SM1LNK(2+I));>)
NOTENX(<SM1NAM←CVXSTR(SM1LNK(3)) & ".SM1";>)
SM1JFN←OPENFILE(SM1NAM,"RE"); IF !SKIP! THEN NONFATAL(
"CANNOT ACCESS SYMBOL FILE " & SM1NAM) ELSE BEGIN "SM1FILE"
OUTSTR(CRLF & SM1NAM);
WHILE (W←WORDIN(SM1JFN)) NEQ -1 DO CASE W OF BEGIN "CASES"
[1] BEGIN "FILE INFO"
STRING TEXTFILE; INTEGER L,FILN;
W←WORDIN(SM1JFN); L←RIGHT(W); FILN←LEFT(W); MAXFILN←FILN MAX MAXFILN;
FILN←FILN+FZERO; IF MAXFILN=31 THEN NONFATAL(<"MORE THAN 30 TEXT FILES.
TEXT FROM REMAINING FILES CANNOT BE DISPLAYED.">);
TENX(<TEXTFILE←NULL; FOR I←1 UPTO L DO
TEXTFILE←TEXTFILE & CVSTR(WORDIN(SM1JFN));>)
NOTENX(<TEXTFILE←CVXSTR(WORDIN(SM1JFN)) & "." &
(CVXSTR(WORDIN(SM1JFN))[1 TO 3]);>)
TMPJFN←OPENFILE(TEXTFILE,"RE"); IF !SKIP! THEN BEGIN NONFATAL(
"CANNOT ACCESS TEXT FILE " & TEXTFILE); STATUS[31 MIN FILN]←-'1000 END
ELSE BEGIN STATUS[31 MIN FILN]←-1; CFILE(TMPJFN);
OUTSTR(CRLF & " " & TEXTFILE); T!TXTFIL[31 MIN FILN]←TEXTFILE END
END "FILE INFO";
[2] BEGIN "COORDINATES"
WHILE (W←WORDIN(SM1JFN)) NEQ 0 DO BEGIN
I←W LSH -25 LAND '37; W←(W LAND '770177777777) LOR
((31 MIN (FZERO+I)) LSH 25);
WORDOUT(BAIJFN,W); W←WORDIN(SM1JFN);
IF NOT(N!BYTE LAND '177) THEN BEGIN
IF (L!CRDIDX←L!CRDIDX+1) GEQ N!CRDIDX THEN EXTEND(C!CRDIDX,N!CRDIDX,64);
T!CRDIDX(L!CRDIDX)←HRELOC(W) END;
WORDOUT(BAIJFN,HRELOC(W));
N!BYTE←N!BYTE + 2 END
END "COORDINATES";
[3] BEGIN "BLOCKS"
INTEGER COORD,LEVEL,DAD,D,T; INTEGER ARRAY NAME[0:2];
DEFINE ID=<0>, BLK=<1>;
W←WORDIN(SM1JFN); L←W LAND '77; LEVEL←W LSH -6 LAND '77;
T←RIGHT(W) LSH -17;
COORD←LEFT(W); D←ADDR1←HRELOC(RIGHT(W←WORDIN(SM1JFN)));
ADDR2←HRELOC(LEFT(W));
IF T=1 THEN BEGIN
# PROCEDURE BLOCK;
D←TYPEMUNGE(W,LZERO,HZERO); # D IS A REFITEM FOR THE PROC;
ADDR2←RIGHT(MEMORY[RIGHT(D)+'12]); # JRST EXIT LOC; END;
FOR I←0 UPTO 2 DO NAME[I]←0;
FOR I←0 UPTO (L-1 MIN 2) DO NAME[I]←WORDIN(SM1JFN);
FOR I←4 UPTO L DO WORDIN(SM1JFN);
# USE FATHER FIELD FOR LEVEL INFO UNTIL FATHER CHAIN IS BUILT;
DAD←INSERT(NAME,T+BLK,LEVEL,D);
# USE FWA CODE FOR BLOCKS, ENTRY POINT FOR SIMPLE PROCEDURES, AND
PCNT AT PRDEC FOR NON-SIMPLE PROCEDURES. SO WE ONLY NEED
TO CORRECT IN THE CASE OF NON-SIMPLE PROCEDURES, FOR WHICH
THE ADDR1 THAT WE HAVE IS THE PDA;
IF T=1 THEN ADDR1←LEFT(MEMORY[ADDR1+'12]);
# KLUGE FOR OUTER BLOCK FOLLOWS;
IF (L!BLKADR←L!BLKADR+2) GEQ N!BLKADR THEN EXTEND(C!BLKADR,N!BLKADR,128);
T!BLKADR(L!BLKADR-1)←DAD; T!BLKADR(L!BLKADR)←ADDR2 LSH 18 LOR ADDR1;
WHILE (W←WORDIN(SM1JFN)) NEQ 0 DO BEGIN "IDENTIFIERS"
L←W LAND '77; D←WORDIN(SM1JFN);
FOR I←0 UPTO 2 DO NAME[I]←0;
D←TYPEMUNGE(D,LZERO,HZERO);
FOR I←0 UPTO (L-1 MIN 2) DO NAME[I]←WORDIN(SM1JFN);
FOR I←4 UPTO L DO WORDIN(SM1JFN);
INSERT(NAME,ID,DAD,D) END "IDENTIFIERS"
END "BLOCKS"
END "CASES";
CFILE(SM1JFN); END "SM1FILE";
SM1PNT←SM1LNK(0); # NEXT LINK;
L!TXTFIL←FZERO←FZERO+MAXFILN+1
END "ONE COMPILATION";
# THE ADDRESSES IN T!BLKADR FOR OUTERMOST BLOCKS ARE SCREWED UP. I THINK AT
THIS STAGE THAT FWA IS ZERO. SO GO THROUGH THE LIST AND CHANGE THE PAIR
TO THE BOUNDS OF THE BLOCKS WHICH IT ENCLOSES;
ADDR1←'777777; ADDR2←0;
FOR I←1 STEP 2 UNTIL L!BLKADR DO
IF RIGHT(T!BLKADR(I))=0 THEN BEGIN
T!BLKADR(I)←(ADDR2+4) LSH 18 LOR (ADDR1-'10); ADDR1←'777777; ADDR2←0 END
ELSE BEGIN ADDR1←ADDR1 MIN RIGHT(T!BLKADR(I));
ADDR2←ADDR2 MAX LEFT(T!BLKADR(I)) END;
# RUN THROUGH BLKADR TO CONSTRUCT THE FATHER CHAINS IN THE NAME TABLE;
# THE FATHER FIELD CONTAINS THE LEVEL INFO AT THE START OF THIS OPERATION,
AND AT THE END IT CONTAINS THE FATHER CHAINS;
BEGIN INTEGER FATHER,SON,J;
FOR I←L!BLKADR-1 STEP -2 UNTIL 0 DO BEGIN
TARRAY[L←LEFT(PAGEIT(T!NAME,(SON←T!BLKADR(I)))) LAND '77]←
T!BLKADR(I) LSH 18;
IF L NEQ 0 THEN PAGEIT(T!NAME,SON)←PAGEIT(T!NAME,SON)
LAND '600000777777 LOR TARRAY[L-1] END;
# CONSTRUCT THE FATHER CHAINS IN THE BLKADR TABLE;
DEFINE FWA(I)=<RIGHT(T!BLKADR(I+1))>, LWA(I)=<LEFT(T!BLKADR(I+1))>;
L←0; TARRAY[L]←N!BLKADR-1;
FOR I←L!BLKADR-3 STEP -2 UNTIL 0 DO BEGIN "FBLK"
# DESCEND TO PROPER LEVEL. QUIT UPON REACHING ANY OUTER BLOCK;
WHILE LWA(I)<FWA(TARRAY[L]) DO IF L NEQ 0 THEN L←L-1 ELSE BEGIN
TARRAY[0]←I; CONTINUE "FBLK" END;
T!BLKADR(I)←T!BLKADR(I) LOR TARRAY[L] LSH 18; # INSERT FATHER;
TARRAY[L←L+1]←I; # UP A NEW LEVEL AND RECORD; END "FBLK";
# REVERSE THE HASH CHAINING IN THE NAME TABLE, SO THAT THE INNERMOST
OCCURRENCES OCCUR FIRST IN A CHAIN;
FOR I←0 UPTO 31 DO BEGIN
FATHER←T!NAME(I); L←0;
WHILE FATHER NEQ 0 DO BEGIN
SON←RIGHT(T!NAME(FATHER));
T!NAME(FATHER)←T!NAME(FATHER) LAND '777777000000 LOR L;
L←FATHER; FATHER←SON END;
T!NAME(I)←L END;
END;
# NOW WRITE THE VARIABLE LENGTH TABLES TO THE .BAI FILE;
USETO(BAIJFN,TARRAY[8]←(N!BYTE + '577) LSH -7); # PAST HEADER BLOCK AND COORDS;
ARRYOUT(BAIJFN,T!CRDIDX(0),TARRAY[9]←L!CRDIDX+1);
USETO(BAIJFN,TARRAY[10]←TARRAY[8]+((L!CRDIDX+'200) LSH -7));
ARRYOUT(BAIJFN,T!BLKADR(0),TARRAY[11]←L!BLKADR+1);
USETO(BAIJFN,TARRAY[12]←TARRAY[10]+((L!BLKADR+'200) LSH -7));
ARRYOUT(BAIJFN,T!NAME(0),TARRAY[13]←L!NAME+1);
T←NULL; FOR I←0 UPTO L!TXTFIL DO T←T & T!TXTFIL[I] & TAB; L←(LENGTH(T)+4) DIV 5;
USETO(BAIJFN,TARRAY[14]←TARRAY[12]+((L!NAME+'200) LSH -7));
TARRAY[15]←L!TXTFIL LSH 18 LOR L;
FOR I←1 UPTO L DO WORDOUT(BAIJFN,CVASC(T[5*I-4 FOR 5]));
# WRITE THE HEADER INDEX BLOCK AND CLOSE OUR GLORIOUS FILE;
USETO(BAIJFN,1); ARRYOUT(BAIJFN,TARRAY[0],128); CFILE(BAIJFN);
# NOW REOPEN IT FOR BUSINESS;
BAIJFN←OPENFILE(PROGNAM & ".BAI", "R"); # RELEASE T!NAME CORE HERE IF
YOU ARE PAGING THE NAME TABLE;
L!CACHE←-1;
# INITIALIZE THE BREAKPOINT TRAP;
TRAP[1]←JRST+LOCATION(BAIL);
INIBAI←TRUE; BAILOFF←FALSE; OUTSTR("
END OF BAIL INITIALIZATION.")
END "STBAIL";
SIMPLE STRING PROCEDURE LINED; BEGIN "LINED"
# RETURN A STRING WHICH ENDS IN A SEMICOLON AND IS BALANCED WITH
RESPECT TO STRING QUOTES;
STRING RESULT; INTEGER CHAR, QUOTECOUNT,I,J;
DEFINE QUOTE=<'042>,CTRLA=<("A"-'100)>,CTRLR=<("R"-'100)>,CTRLX=<("X"-'100)>;
SUPERCOMMENT "$%" ($
QUOTECOUNT←0; RESULT←NULL;
WHILE TRUE DO BEGIN
WHILE (CHAR←INCHRW) NEQ ";" DO BEGIN
IF CHAR=CTRLA THEN BEGIN
OUTCHR("\"); WHILE CHAR=CTRLA DO BEGIN
CHAR←RESULT[INF TO INF]; OUTCHR(CHAR);
RESULT←RESULT[1 TO INF-1]; CHAR←INCHRW END;
OUTCHR("\") END;
IF CHAR=CTRLR THEN OUTSTR(CRLF&RESULT)
ELSE IF CHAR=CTRLX THEN BEGIN RESULT←NULL; OUTSTR(CRLF) END
ELSE RESULT←RESULT & CHAR
END;
# HIT A SEMICOLON. SEE IF BALANCED QUOTES;
RESULT←RESULT&";";
FOR I←1 UPTO LENGTH(RESULT) DO IF RESULT[I TO I]=QUOTE THEN
QUOTECOUNT←1-QUOTECOUNT;
IF QUOTECOUNT=0 THEN RETURN(RESULT)
END
%) # END OF SUPERCOMMENT;
QUOTECOUNT←0; RESULT←NULL;
WHILE TRUE DO BEGIN
RESULT←RESULT & INCHWL; QUOTECOUNT←0; J←LENGTH(RESULT);
FOR I←1 UPTO J DO IF RESULT[I FOR 1]=QUOTE THEN QUOTECOUNT←LNOT (QUOTECOUNT);
IF NOT QUOTECOUNT THEN RETURN(RESULT) END;
END"LINED";
SIMPLE STRING PROCEDURE DRAISE(STRING ARG); START!CODE "DRAISE"
# DESTRUCTIVELY CONVERTS TO UPPER CASE BY TURNING OFF THE '40 BIT;
# ALSO CHANGE EXCLAMATION MARK TO UNDERBAR, SINCE THE COMPILER DOES;
LABEL LOOP;
HRRZ 1,-1(SP); # LENGTH;
SKIPN 1;
POPJ P,; # NULL STRING;
MOVE 2,(SP); # BYTE POINTER TO STRING;
LOOP: ILDB 3,2; # GET CHAR;
CAIN 3,'041; # CHECK FOR BANG;
MOVEI 3,'030; # WAS A BANG. NOW AN UNDERBAR;
ANDI 3,'137; # UP IT;
DPB 3,2; # PUT CHAR;
SOJG 1,LOOP; # UNTIL DONE;
POPJ P,;
END "DRAISE";
DEFINE INTVAL=<1>, REALVAL=<2>, STRCON=<3>, ID=<4>, SPCHAR=<5>;
PROCEDURE GET!TOKEN(REFERENCE STRING ARG,STRVAL; REFERENCE INTEGER CLASS,
IVAL); BEGIN "GET!TOKEN"
INTEGER BRCHAR; STRING A;
DEFINE DELIMS=<('00 & '11 & '12 & '13 & '14 & '15 & '40)>;
# NULL,TAB,LF,VT,FF,CR,SP;
DEFINE LETTERS=<"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz!" & '30>,
DIGITS=<"0123456789">, SAILID=<(LETTERS & DIGITS)>,
NUMBER=<(DIGITS & ".@")>;
DEFINE QUOTE=<'042>;
SIMPLE PROCEDURE XDELIMS;BEGIN
SETBREAK(18,DELIMS,NULL,"XNR"); SCAN(ARG,18,BRCHAR) END;
# SKIP OVER INITIAL DELIMITERS;
XDELIMS;
# CHECK FOR STRING CONSTANT. STRING CONSTANTS ARE RETURNED WITHOUT
SURROUNDING QUOTES, AND WITH INTERNAL DOUBLE QUOTES REMOVED;
# NOTE HEAVY DEPENDENCE ON SAIL TYPE CONVERSION IN THIS "IF";
IF ARG=QUOTE THEN BEGIN
SETBREAK(18,QUOTE,NULL,"INA"); STRVAL←NULL;
WHILE ARG=QUOTE DO BEGIN A←LOP(ARG);
STRVAL←STRVAL & SCAN(ARG,18,BRCHAR) END;
IF BRCHAR NEQ QUOTE THEN
NONFATAL("INSERTING MISSING STRING QUOTE")
ELSE STRVAL←STRVAL[1 TO INF-1]; # REMOVE TERMINATING QUOTE;
CLASS←STRCON; RETURN END;
# CHECK FOR OCTAL CONSTANT;
IF ARG="'" THEN BEGIN
SETBREAK(18,"01234567",NULL,"XNR"); A←LOP(ARG);
IVAL←CVO(SCAN(ARG,18,BRCHAR)); CLASS←INTVAL; RETURN END;
# CHECK FOR INTEGER OR REAL CONSTANT;
# THIS IS A KLUGE BECAUSE INTSCAN WON'T STOP UPON SEEING A LETTER OR
SPECIAL CHAR OR DELIMITER. INTSCAN INSISTS UPON FINDING A
NUMBER, EVEN THE "8" IN "K[I]←FN(SYM8T)";
SETBREAK(18,NUMBER,NULL,"XNR"); STRVAL←SCAN(ARG,18,BRCHAR);
IF LENGTH(STRVAL) THEN BEGIN
# FOUND A NUMBER. NOW DIFFERENTIATE BETWEEN REALS AND INTEGERS;
SETBREAK(18,".@",NULL,"INR"); A←STRVAL; SCAN(A,18,BRCHAR);
IF LENGTH(A) THEN BEGIN
# REAL CONSTANT; A←STRVAL; MEMLOC(IVAL,REAL)←REALSCAN(A,BRCHAR);
CLASS←REALVAL; RETURN END
ELSE BEGIN
# INTEGER CONSTANT; A←STRVAL; IVAL←INTSCAN(A,BRCHAR);
CLASS←INTVAL; RETURN END END;
# CHECK FOR IDENTIFIER;
SETBREAK(18,SAILID,NULL,"XNR"); STRVAL←SCAN(ARG,18,BRCHAR);
IF STRVAL=NULL THEN BEGIN
STRVAL←LOP(ARG); CLASS←SPCHAR; RETURN END
ELSE BEGIN
XDELIMS; CLASS←ID; STRVAL←DRAISE(STRVAL); RETURN END
END "GET!TOKEN";
STRING PROCEDURE GETTEXT(INTEGER PC); BEGIN "GETTEXT"
STRING TEXT;
INTEGER I,T,FILN,ADDR,COORD,ALLSTO,BP,WORD,BLOCK,OFILN;
# CHECK INDEX FOR WHICH BLOCK OF .BAI FILE HAS THE POINTER;
I←0; WHILE I<N!CRDIDX AND PC GEQ RIGHT(T!CRDIDX(I+1)) DO I←I+1;
# GET THE BLOCK THAT HAS THE POINTER;
USETI(BAIJFN,I+2); ARRYIN(BAIJFN,TARRAY[0],128);
# LOOK FOR THE RIGHT POINTER;
I←1; WHILE I<127 AND PC GEQ RIGHT(TARRAY[I+2]) DO I←I+2;
# I NOW POINTS AT THE SECOND WORD OF THE POINTER;
ADDR←RIGHT(T←TARRAY[I]); COORD←LEFT(T) LAND '377777; ALLSTO←T LSH -35;
BP←(T←TARRAY[I-1]) LSH -30; FILN←T LSH -25 LAND '37; WORD←T LSH -18 LAND '177;
BLOCK←RIGHT(T);
# STATUS OF FILES
-'1000 NOT ACCESSIBLE (DETERMINED AT INITIALIZATION TIME)
-1 ACCESSIBLE, NOT OPEN
1 OPEN;
IF FILN=31 OR STATUS[FILN]=-'1000 THEN
RETURN("%%% FILE NOT VIEWABLE. PC='"&CVOS(PC));
IF STATUS[FILN] NEQ 1 THEN BEGIN "NOPEN" # FILE NOT OPEN;
# CLOSE PREVIOUS FILE, IF ANY;
IF OFILN NEQ 0 THEN BEGIN CFILE(TMPJFN); STATUS[OFILN]←-1 END;
# OPEN NEW FILE ON TMPJFN;
TMPJFN←OPENFILE(T!TXTFIL[FILN],"RE"); IF !SKIP! THEN
RETURN("%%% FILE NOT VIEWABLE. PC='"&CVOS(PC)) ELSE
STATUS[FILN]←1 END "NOPEN";
# POSITION AND READ TEXT FILE;
OFILN←FILN; USETI(TMPJFN,BLOCK); ARRYIN(TMPJFN,TARRAY[0],128);
# CONSTRUCT TEXT STRING;
TEXT←NULL; T←(WORD+14) MIN 127; FOR I←WORD UPTO T DO BEGIN
# CHECK FOR PECULIARITIES OF TEXT EDITORS;
IF TARRAY[I]=0 THEN T←I ELSE TEXT←TEXT&CVSTR(TARRAY[I]) END;
IF (T←WORD+14-I)>0 THEN BEGIN "TWOBL"
# TEXT DIVIDED BETWEEN TWO DISK BLOCKS;
ARRYIN(TMPJFN,TARRAY[0],128); # CONTINUE WHERE WE LEFT OFF;
FOR I←0 UPTO T DO BEGIN
# SAME CHECKS FOR EDITORS;
IF TARRAY[I]=0 THEN T←I
ELSE TEXT←TEXT&CVSTR(TARRAY[I]) END END "TWOBL";
# CORRECT FOR TEXT BEGINNING IN MIDDLE OF WORD;
RETURN(TEXT[((44-BP) LSH -3) TO INF])
# GIVES 1,2,3,4,5 FOR BYTEPOINTER "P" OF '44,'35,'26,'17,'10;
END "GETTEXT";
SIMPLE PROCEDURE CVNAME(STRING STRVAL; INTEGER ARRAY NAME);BEGIN "CVNAME"
INTEGER I; FOR I←0 UPTO 2 DO NAME[I]←CVASC(STRVAL[5*I+1 FOR 5])
END "CVNAME";
SIMPLE INTEGER PROCEDURE BINSEARCH(INTEGER KEY; INTEGER ARRAY TABLE); BEGIN "BINSRCH"
# TABLE IS TWO DIMENSIONAL OF THE FORM [0:N,0:1]. THE KEYS ARE ALONG THE
FIRST DIMENSION [*,0] AND THE DATA ARE IN THE SECOND DIMENSION [*,1].
RETURN THE INDEX OF THE KEY IF IT IS IN THE TABLE, AND RETURN -1 IF NOT FOUND;
INTEGER L,I,U;
L←ARRINFO(TABLE,1); # LOWER BOUND FOR FIRST DIMENSION;
U←ARRINFO(TABLE,2); # UPPER BOUND FOR FIRST DIMENSION;
WHILE U GEQ L DO BEGIN
I←(L+U) ASH -1;
IF TABLE[I,0]=KEY THEN RETURN(I);
IF TABLE[I,0]>KEY THEN U←I-1 ELSE L←I+1;
END;
# UNSUCCESSFUL SEARCH; RETURN(-1)
END "BINSRCH";
INTEGER PROCEDURE SEARCH!RW(STRING STRVAL); BEGIN
# RETURN CHARACTER EQUIVALENT OF RESERVED WORD.
RETURN -1 IF NOT IN TABLE;
INTEGER ARRAY NAME[0:2]; INTEGER K;
CVNAME(STRVAL,NAME); IF NAME[1] NEQ 0 THEN RETURN(-1);
IF (K←BINSEARCH(NAME[0],RWORD))=-1 THEN RETURN(-1);
RETURN(RWORD[K,1]);
END;
SIMPLE INTEGER PROCEDURE N!PARAMS(INTEGER REFIT);BEGIN"N!PARAMS"
DEFINE PD(A)=<MEMORY[PDA+A]>;
INTEGER PDA;
PDA←RIGHT(REFIT); RETURN(RIGHT(PD(4))-1 + (LEFT(PD(4)) LSH -1))
END "N!PARAMS";
SIMPLE PROCEDURE SEARCH!OP(INTEGER CHAR; REFERENCE INTEGER OP,LBND,RBND;
INTEGER BINARYMINUSFLAG);
BEGIN "SEARCH!OP"
IF CHAR='055 AND NOT BINARYMINUSFLAG THEN CHAR←'123; # UNARY MINUS;
IF(OP←BINSEARCH(CHAR,OPS))=-1 THEN RETURN;
LBND←OPS[OP,1] LSH -27; RBND←OPS[OP,1] LSH -18 LAND '777; RETURN
END "SEARCH!OP";
DEFINE ARRY=<(16 LSH 23)>; # BIT TO MASK A REFITEM DATUM;
INTEGER ARRAY EV1TEMP[1:2]; STRING ARRAY EV1STRTEMP[1:2];
SIMPLE INTEGER PROCEDURE CVINTEGR(INTEGER REFIT,T); BEGIN "CVINTEGR"
# CONVERT THE DATUM OF THE REFITEM TO INTEGER, USING TEMP CELL NUMBER T.
RETURN THE REFITEM OF THE RESULT;
INTEGER TYP,LOC;
IF (TYP←GETTYPE(REFIT))=INTEGR THEN RETURN(REFIT);
LOC←RIGHT(REFIT);
IF TYP=FLOTNG THEN MEMLOC(EV1TEMP[T],INTEGER)←MEMORY[LOC,REAL]
ELSE IF TYP=STRNG THEN BEGIN
IF RIGHT(MEMORY[LOC-1])=0 THEN "NULL STRING" EV1TEMP[T]←0
ELSE START!CODE
PROTECT!ACS 1;
MOVE 2,LOC; # BYTE POINTER;
LDB 1,2;
MOVEM 1,ACCESS(EV1TEMP[T]); # STORE;
END;
END
ELSE BEGIN
NONFATAL(<"CANNOT CONVERT TO INTEGER; SETTING RESULT TO ZERO.">);
EV1TEMP[T]←0 END;
RETURN(INTEGR+LOCATION(EV1TEMP[T]))
END "CVINTEGR";
SIMPLE INTEGER PROCEDURE CVREAL(INTEGER REFIT,T); BEGIN"CVREAL"
# CONVERT REFIT DATUM TO REAL USING TEMP CELL T. RETURN REFITEM OF RESULT.;
INTEGER TYP;
IF (TYP←GETTYPE(REFIT))=FLOTNG THEN RETURN(REFIT);
IF TYP=STRNG THEN BEGIN
REFIT←CVINTEGR(REFIT,T); TYP←INTEGR END;
IF TYP=INTEGR THEN MEMLOC(EV1TEMP[T],REAL)←MEMORY[RIGHT(REFIT),INTEGER]
ELSE BEGIN
NONFATAL(<"CANNOT CONVERT TO REAL; SETTING RESULT TO ZERO">);
EV1TEMP[T]←0 END;
RETURN(FLOTNG+LOCATION(EV1TEMP[T]))
END "CVREAL";
SIMPLE INTEGER PROCEDURE CVSTRNG(INTEGER REFIT,T); BEGIN "CVSTRNG"
# CONVERT THE DATUM OF THE REFIT TO STRING AND RETURN THE REFITEM OF THE RESULT;
INTEGER TYP;
IF (TYP←GETTYPE(REFIT))=STRNG THEN RETURN(REFIT);
IF TYP=FLOTNG THEN BEGIN
REFIT←CVINTEGR(REFIT,T); TYP←INTEGR END;
IF TYP=INTEGR THEN EV1STRTEMP[T]←MEMORY[RIGHT(REFIT),INTEGER]
ELSE BEGIN
NONFATAL(<"CANNOT CONVERT TO STRING; SETTING RESULT TO NULL.">);
EV1STRTEMP[T]←NULL END;
RETURN(STRNG+LOCATION(EV1STRTEMP[T]))
END "CVSTRNG";
SIMPLE INTEGER PROCEDURE INCOR(INTEGER PCACHE,FREG); BEGIN "INCOR"
# RETURN REFITEM DATUM WHICH HAS ABSOLUTE CORE ADDRESS OF THE OBJECT IN CACHE;
INTEGER IND,FATHER,REFIT,PPDA,T,ADDR;
IF ((REFIT←CACHE[PCACHE+1]) LAND ('17 LSH 18))=0 THEN RETURN(REFIT);
# WE NOW KNOW THAT THE OBJECT IS ON THE STACK AND IS EITHER A PARAMETER TO
A PROCEDURE OR A LOCAL TO A RECURSIVE PROCEDURE.;
IND←REFIT LAND(1 LSH 22); ADDR←RIGHT(REFIT); REFIT←REFIT LAND '777740000000;
# FOLLOW UP THE FATHER CHAIN IN THE NAME TABLE UNTIL COMING TO A PROCEDURE;
FATHER←LEFT(CACHE[PCACHE]) LAND '177777;
WHILE NOT(PAGEIT(T!NAME,FATHER+1) LAND PROCB) DO
FATHER←LEFT(PAGEIT(T!NAME,FATHER)) LAND '177777;
# FETCH PDA FOR THE PROCEDURE;
PPDA←RIGHT(PAGEIT(T!NAME,FATHER+1));
# SEARCH BACK THROUGH THE STACK (ALONG THE STATIC LINKS) TO FIND THE MSCP;
WHILE LEFT(T←MEMORY[FREG+1]) NEQ PPDA DO FREG←RIGHT(T);
# FIND OUT WHETHER THIS IS A PARAM OR A LOCAL. LOCALS ARE FLAGGED WITH
'400000 IN ADDR;
IF ADDR LAND '400000 THEN BEGIN "LOCAL"
ADDR←ADDR-'400000;
# STRINGS CAUSE HAIR. REFERENCE STRINGS ARE ON THE P-STACK, HENCE THE
ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR IS IN A WORD
WHICH IS FOUND USING DISPLACEMENTS [POSITIVE FOR LOCALS, NEGATIVE
FOR PARAMS] ON THE F REGISTER. LOCAL AND VALUE STRINGS ARE ON THE
SP-STACK, HENCE THE ADDRESS OF THE SECOND WORD OF THE STRING DESCRIPTOR
IS COMPUTED USING DISPLACEMENTS FROM THE OLD SP-REGISTER. THE OLD
SP-REGISTER IS HANDILY SAVED AS THE LAST WORD OF THE 3-WORD MSCP.;
IF GETTYPE(REFIT)=STRNG THEN # RECURSIVE STRING LOCAL;
RETURN(REFIT+RIGHT(MEMORY[FREG+2])+ADDR+ADDR)
ELSE # RECURSIVE NON-STRING LOCAL;
RETURN(REFIT+FREG+ADDR) END "LOCAL"
ELSE BEGIN "PARAM"
IF IND THEN # REFERENCE PARAM;
RETURN(REFIT+RIGHT(MEMORY[FREG-ADDR-1]))
ELSE # VALUE PARAM;
IF GETTYPE(REFIT)=STRNG THEN RETURN(REFIT+RIGHT(MEMORY[FREG+2])-ADDR-ADDR+2)
ELSE RETURN(REFIT+FREG-ADDR-1) END "PARAM"
END "INCOR";
SIMPLE PROCEDURE EVALERR(STRING WHY,OLDARG,ARG);
NONFATAL(<WHY & OLDARG & LF & ARG>);
FORWARD PROCEDURE ANCESTRY(INTEGER ARRAY ACTIVE!BLOCKS; REFERENCE INTEGER LEXD,
PC,CURBLK);
INTEGER PROCEDURE TFIND(STRING LOCNAME; BOOLEAN ANYNAM); BEGIN "TFIND"
# SPECIAL FIND ROUTINE FOR TRACE, BREAK, ETC, SINCE ONE FREQUENTLY WANTS TO
SPECIFY NAMES WHICH ARE NOT IN THE CURRENT ALGOL SCOPE.
THE FORMAT OF LOCNAME IS
<LOCNAME>:=<SAILID> or <BLOCKNAME> <DELIM> <LOCNAME>
THE SEARCH FOR LOCNAME PROCEEDS AS FOLLOWS. THE BLOCK TABLE [T!BLKADR]
IS SEARCHED FROM THE END TO THE BEGINNING [BREADTH FIRST]. IF JUST
<SAILID> APPEARS, THEN <SAILID> MUST BE A BLOCK OR PROCEDURE NAME, AND
THE SEARCH IS FOR A MATCH ON THE NAME. IF MORE THAN JUST <SAILID>
APPEARS, THEN THE SEARCH IS FOR A MATCH ON THE <BLOCKNAME> PORTION OF
<BLOCKNAME> <DELIM>. IF MORE THAN ONE <BLOCKNAME> APPEARS, THE SEARCH
IS CONTINUED FOR EACH SUCCEEDING <BLOCKNAME> AT THE POINT WHERE THE
PREVIOUS SEARCH ENDED. THIS IS CONTINUED UNTIL THE LAST <BLOCKNAME> IS
LOCATED. THEN THE ANCESTRY OF THE LAST <BLOCKNAME> IS CONSTRUCTED,
AND FIND IS ASKED TO LOCATE <SAILID>.
THIS IS VERY FLEXIBLE AND POWERFUL. THE COMPLETE HISTORY OF <SAILID>
NEED NOT BE SPECIFIED IN LOCNAME. INDEED, THE SEQUENCE OF <BLOCKNAME>S
NEED NOT BE A TREELIKE PATH AT ALL.
;
INTEGER CLASS,IVAL,PNTR,I,LEXD,CURBLK,PC; STRING STRVAL;
INTEGER ARRAY NAME[0:2],ACTIVE!BLOCKS[0:15];
PNTR←L!BLKADR-1;
WHILE LENGTH(LOCNAME) DO BEGIN
GET!TOKEN(LOCNAME,STRVAL,CLASS,IVAL);
IF CLASS NEQ ID THEN EVALERR("INCORRECT LOCATION SPECIFICATION",STRVAL,LOCNAME);
CVNAME(STRVAL,NAME);
IF LENGTH(LOCNAME) THEN BEGIN "BLKNAM" LABEL NEXNAM;
WHILE (PNTR←PNTR-2) GEQ 0 DO BEGIN "HUNT" LABEL NEXPNTR;
FOR I←0 UPTO 2 DO IF PAGEIT(T!NAME,RIGHT(T!BLKADR(PNTR))+2+I) NEQ
NAME[I] THEN GOTO NEXPNTR;
GOTO NEXNAM;
NEXPNTR: END "HUNT";
NEXNAM: STRVAL←LOP(LOCNAME); # GET RID OF DELIM; END "BLKNAM"
ELSE BEGIN "SAILID"
ANCESTRY(ACTIVE!BLOCKS,LEXD,PC←RIGHT(T!BLKADR(PNTR+1)),CURBLK);
RETURN(FIND(NAME,ACTIVE!BLOCKS,LEXD,ANYNAM)) END "SAILID"
END
END "TFIND";
RECURSIVE PROCEDURE BREAK1(INTEGER LOC; STRING COND,ACT; INTEGER MPC,NEWINSTR);
BEGIN "BREAK1"
# INSERT A BREAKPOINT AT MEMORY[LOC], OVERWRITING ANY OLD BREAKPOINT;
INTEGER I;
# SEARCH FOR DUPLICATE OR FOR EMPTY SLOT;
FOR I←0 UPTO N!BK DO IF I=N!BK OR BK!LOC[I]=0 OR BK!LOC[I]=LOC THEN DONE;
IF I=N!BK THEN EVALERR("BREAKTABLE OVERFLOW. ",CVOS(LOC),NULL)
ELSE BEGIN
IF BK!LOC[I] NEQ LOC THEN BEGIN # NEW LOCATION BROKEN;
BK!LOC[I]←LOC; BK!INSTR[I]←MEMORY[LOC];
MEMORY[LOC]←NEWINSTR END;
BK!COND[I]←COND; BK!ACT[I]←ACT; BK!COUNT[I]←MPC END
END "BREAK1";
RECURSIVE PROCEDURE BREAK(STRING LOCNAME,COND,ACT; INTEGER MPC);
BEGIN "BREAK"
# INSERT BREAKPOINT AT BEGINNING OF THING SPECIFIED IN LOCNAME;
INTEGER PNTR,REFIT,T;
# ENABLE THE SEARCH FOR ANY NAME THAT MATCHES (THE INNERMOST ONE);
PNTR←TFIND(LOCNAME,TRUE);
IF PNTR=-1 THEN EVALERR("UNKNOWN LOCATION: ",LOCNAME,NULL)
ELSE IF (T←GETTYPE((REFIT←CACHE[PNTR+1]))) NEQ 0 AND
NOT(REFIT LAND PROCB) AND T NEQ (14 LSH 23)
THEN EVALERR("NEED A BLOCK, LABEL, OR PROCEDURE: ",LOCNAME,NULL)
ELSE BEGIN
IF REFIT LAND PROCB THEN REFIT←LEFT(MEMORY[RIGHT(REFIT)+PD!PPD]);
# ABOVE GETS PCNT AT MKSEMT IN CASE WE ARE BREAKING A PROCEDURE;
BREAK1(RIGHT(REFIT),COND,ACT,MPC,PUSHJ+(P LSH 23)+LOCATION(BAIL)) END;
END "BREAK";
SIMPLE PROCEDURE TRACER;
BEGIN "TRACER"
# CALLED BY AN INSERTED PUSHJ FROM ENTRY ADDRESS OF ROUTINE BEING TRACED.
WHAT TO DO:
1. PICK UP TOP WORD OF STACK AND GET THE REFITEM FROM THE MULTIPLE PROCEED
COUNT OF THE CORRESPONDING BREAK ENTRY.
2. USE THE PDA INFO TO PRINT THE PROCEDURE NAME AND PARAMETERS.
3. MASSAGE THE P STACK SO THAT THE TRACED PROCEDURE RETURNS TO TRACER.
4. XCT THE DISPLACED INSTRUCTION.
5. JUMP TO ENTRY ADDRESS+1.
6. UPON RETURN FROM TRACED PROCEDURE, PRINT THE NAME (AND RESULT, IF ANY).
7. RESTORE P STACK TO ITS PROPER STATE.
8. RETURN.
THE P-STACK GETS TWO EXTRA WORDS IN STEP 3. THE FIRST ONE IS THE ORIGINAL RETURN ADDRESS,
THE SECOND IS THE REFITEM FOR THE TRACED PROCEDURE, TO ALLOW PRINTING THE NAME AND RESULT;
INTEGER REFIT,REFITA,I,BL,PPNTR,SPPNTR,PARAMPNTR,TRLEV,NP,ENTAD,T;
DEFINE SPACES=<" ">;
# STACK LOOKS LIKE
(P)/ RETURN TO ENTRY+1
-1(P)/ RETURN TO CALLING PROC
-2(P)/ PARAM n
.
.
.
-n-3(P)/ PARAM 1;
START!CODE
POP P,0; # REMOVE RETURN TO ENTRY+1;
SUBI 0,1; # ENTRY ADDRESS;
MOVEM 0,ENTAD;
AOS TRLEV; # DEPTH OF TRACE;
END;
FOR BL←0 UPTO L!BK-1 DO IF BK!LOC[BL]=RIGHT(ENTAD) THEN DONE;
REFIT←BK!COUNT[BL];
OUTSTR(SPACES[1 FOR TRLEV]&"ENTERING ");
START!CODE
MOVE 1,REFIT;
PUSH SP,1(1);
PUSH SP,2(1);
PUSHJ P,OUTSTR; # PRINT PROC NAME;
END;
IF (NP←N!PARAMS(REFIT))>0 THEN BEGIN "PPARAMS"
START!CODE
HRRZ 2,P; # TOS;
MOVE 1,REFIT;
HRRZ 3,PD!NPW(1); # #ARITH PARAMS+1;
SUBI 3,1;
SUB 2,3;
MOVEM 2,PPNTR; # BEGINNING OF PSTACK PARAMS;
HRRZ 2,SP;
HLRZ 3,PD!NPW(1); # 2*#STRING PARAMS;
SUBI 3,2;
SUB 2,3;
MOVEM 2,SPPNTR; # BEGINNING OF SPSTACK PARAMS;
HRRZ 3,PD!DLW(1); # POINTER TO PARAM INFO;
MOVEM 3,PARAMPNTR;
END;
OUTSTR("("); FOR I←1 UPTO NP DO BEGIN "ONEP"
REFITA←MEMORY[PARAMPNTR]; PARAMPNTR←PARAMPNTR+1;
IF GETTYPE(REFITA)=STRNG AND NOT(REFITA LAND REFB) THEN BEGIN
# VALUE STRING; REFITA←REFITA+SPPNTR; SPPNTR←SPPNTR+2 END
ELSE BEGIN # OTHER; REFITA←REFITA+PPNTR; PPNTR←PPNTR+1 END;
WR!TON(REFITA) END "ONEP";
OUTSTR(")"&CRLF) END "PPARAMS";
# MASSAGE THE STACK;
START!CODE LABEL TR!RET,TRRETW;
MOVE 1,REFIT;
HRRZ 2,PD!NPW(1); # #ARITH PARAMS+1;
SUBI 2,1;
HRRZ 3,P;
SUB 3,2; # AC3 POINTS AT FIRST PARAM;
HRL 4,3;
HRRI 4,TARRAY[0];
BLT 4,TARRAY[0](2); # UNSTACK;
POP P,0; # RETURN TO CALLING PROC;
MOVEM 0,(3); # PLANT IT;
MOVEM 1,1(3); # PLANT REFIT;
PUSH P,0;
PUSH P,0; # SPACE FILLERS;
HRLI 4,TARRAY[0];
HRRI 4,2(3);
BLT 4,(P); # STACK;
MOVE 4,BL;
SKIPA ; # ONLY WAY TO ENTER "DATA" INTO START CODE;
TRRETW: CAM TR!RET; # TYPICAL PUSHJ WORD;
PUSH P,TRRETW; # PUT RETURN ON STACK;
XCT BK!INSTR[0](4); # THIS IS EITHER A PUSH P,F OR A JFCL;
MOVE 2,ENTAD;
JRST 1(2); # CALL THE TRACED PROC;
TR!RET: POP P,REFIT;
MOVEM 1,REFITA;
END;
OUTSTR(SPACES[1 FOR TRLEV]&"EXITING ");
START!CODE
MOVE 1,REFIT;
PUSH SP,1(1);
PUSH SP,2(1);
PUSHJ P,OUTSTR; # PRINT NAME;
END;
IF (T←GETTYPE(REFIT)) NEQ 0 THEN BEGIN "RESULT"
OUTSTR("="); IF T=STRNG THEN
START!CODE
PUSH SP,-2(SP);
PUSH SP,-2(SP);
PUSHJ P,OUTSTR;
END
ELSE WR!TON(T LOR LOCATION(REFITA)) END "RESULT";
OUTSTR(CRLF);
START!CODE
MOVE 1,REFITA;
SOS TRLEV;
POPJ P,0; # FINALLY!;
END;
END "TRACER";
RECURSIVE PROCEDURE TRACE(STRING PROCNAME);
BEGIN"TRACE"
# BREAK ENTRY AND EXIT OF PROCEDURE;
INTEGER PNTR,REFIT;
# ONLY PROCEDURE NAME WILL DO;
PNTR←TFIND(PROCNAME,FALSE);
IF PNTR=-1 OR NOT((REFIT←CACHE[PNTR+1]) LAND PROCB) THEN
EVALERR("UNKNOWN PROCEDURE: ",PROCNAME,NULL)
ELSE BEGIN
# SAVE REFIT IN MULTIPLE PROCEED COUNT;
BREAK1(MEMORY[RIGHT(REFIT)],NULL,NULL,REFIT,PUSHJ+(P LSH 23)+LOCATION(TRACER));
# AT ENTRY ADDRESS;
END;
END "TRACE";
RECURSIVE PROCEDURE UNBREAK1(INTEGER LOC); BEGIN "UNBREAK1"
# REMOVE BREAKPOINT AT MEMORY[LOC];
INTEGER I;
# SEARCH FOR THE BREAKPOINT;
FOR I←0 UPTO N!BK DO IF I=N!BK OR BK!LOC[I]=LOC THEN DONE;
IF I=N!BK THEN EVALERR("UNBREAK1. LOCATION NOT CURRENTLY BROKEN: ",
CVOS(LOC),NULL)
ELSE BEGIN MEMORY[LOC]←BK!INSTR[I]; BK!LOC[I]←0 END
END "UNBREAK1";
RECURSIVE PROCEDURE UNBREAK(STRING LOCNAME);
BEGIN "UNBREAK"
# REMOVE BREAKPOINT AT SYMBOLIC LOCATION LOCNAME;
INTEGER PNTR,REFIT;
# ANYNAM WILL DO;
PNTR←TFIND(LOCNAME,TRUE);
IF PNTR=-1 THEN EVALERR("UNKNOWN LOCATION: ",LOCNAME,NULL)
ELSE BEGIN
REFIT←CACHE[PNTR+1];
IF REFIT LAND PROCB THEN REFIT←LEFT(MEMORY[RIGHT(REFIT)+PD!PPD]);
# ABOVE GETS PCNT AT MKSEMT IN CASE WE ARE UNBREAKING A PROC;
UNBREAK1(RIGHT(REFIT)) END
END "UNBREAK";
RECURSIVE PROCEDURE UNTRACE(STRING PROCNAME);
BEGIN "UNTRACE"
# REMOVE BREAKPOINT AROUND PROCEDURE;
INTEGER PNTR,REFIT;
# ONLY PROCEDURE NAMES HERE;
PNTR←TFIND(PROCNAME,FALSE);
IF PNTR=-1 OR NOT((REFIT←CACHE[PNTR+1]) LAND PROCB) THEN
EVALERR("UNKNOWN PROCEDURE: ",PROCNAME,NULL)
ELSE BEGIN
UNBREAK1(MEMORY[RIGHT(REFIT)]); # ENTRY ADDR;
END;
END "UNTRACE";
INTEGER PROCEDURE ADD(INTEGER X,Y); BEGIN "ADD"
OUTSTR("
HI! GLAD YOU STOPPED BY."); RETURN(X+Y) END "ADD";
RECURSIVE INTEGER PROCEDURE EVAL(STRING ARG; INTEGER ARRAY ACTIVE!BLOCKS;
REFERENCE INTEGER LEXD,BKRET,FREG);
BEGIN"EVAL"
EXTERNAL PROCEDURE CAT;
STRING STRVAL,OLDARG; STRING A;
INTEGER CLASS,IVAL,RW,REFIT,PNTR,LBND,RBND,OP;
LABEL OPCHAR; INTEGER ARRAY NAME[0:2];
INTEGER ARRAY TEMPVAL[0:15]; STRING ARRAY TSTRVAL[0:15];
INTEGER ARRAY RBIND,STACK,OPSTACK[0:15];
INTEGER N!TEMPVAL,N!TSTRVAL,TOS,TOOPS;
BOOLEAN BINARYMINUSFLAG;
# THESE DEFINES ATTEMPT TO GET THE PDA ADDRESSES FOR THE BREAKPOINT
ROUTINES. THE OFFSETS DEPEND ON THE FACT THAT THE
ROUTINES ARE RECURSIVE AND HAVE EXACTLY SO MANY LOCALS. THESE OFFSETS
MUST BE CHECKED EACH TIME THE BREAKPOINT ROUTINES ARE RECOMPILED;
DEFINE TEMPB=<(1 LSH 35)>,REFTRACE=<(PROCB+LOCATION(TRACE)+'10)>,
REFBREAK=<(PROCB+LOCATION(BREAK)+'11)>,
REFUNTRACE=<(PROCB+LOCATION(UNTRACE)+'10)>,
REFUNBREAK=<(PROCB+LOCATION(UNBREAK)+'10)>;
SIMPLE PROCEDURE PSH(INTEGER ARG); STACK[TOS←TOS+1]←ARG;
SIMPLE PROCEDURE OPPSH(INTEGER ARG,RBND); BEGIN
OPSTACK[TOOPS←TOOPS+1]←ARG; RBIND[TOOPS]←RBND END;
PROCEDURE X1TEMP(INTEGER LOC);
IF N!TEMPVAL GEQ 0 AND LOC GEQ LOCATION(TEMPVAL[0]) AND
LOC LEQ LOCATION(TEMPVAL[N!TEMPVAL]) THEN N!TEMPVAL←N!TEMPVAL-1
ELSE IF N!TSTRVAL GEQ 0 AND LOC GEQ LOCATION(TSTRVAL[0]) AND
LOC LEQ RIGHT(LOCATION(TSTRVAL[N!TSTRVAL])) THEN N!TSTRVAL←N!TSTRVAL-1;
INTEGER VALZERO,VALTRUE;
STRING VALNULL;
RECURSIVE PROCEDURE EVAL1; BEGIN "EVAL1"
# EVALUATE OPERATOR ON TOP OF STACK AND ADJUST STACK;
DEFINE REFTRUE=<(INTEGR+LOCATION(VALTRUE))>,
REFZERO=<(INTEGR+LOCATION(VALZERO))>,
REFNULL=<(STRNG+RIGHT(LOCATION(VALNULL)))>;
DEFINE PRINT(A)=<WR!TON(A)>;
DEFINE CATENATE=<14>, CONFORM(A)=<(OPS[A,1] LAND '777)>,
DEGREE(A)=<(OPS[A,1] LSH -9 LAND '777)>;
INTEGER OP,ARG1,ARG2,LOC1,LOC2,MODE,TYP,I,DEG,RSLTTYP,RSLTLOC;
INTEGER TEMP; STRING TEMPSTR;
IF ABS(OP←STACK[TOS]) LEQ N!OPS THEN BEGIN "PRIMITIVE"
DEG←DEGREE(OP);
# HANDLE TEMPORARY LOCATIONS ASSIGNED BY EVAL;
IF DEG GEQ 2 THEN BEGIN ARG1←STACK[TOS-2]; X1TEMP(RIGHT(ARG1)) END;
IF DEG GEQ 1 THEN BEGIN ARG2←STACK[TOS-1]; X1TEMP(RIGHT(ARG2)) END;
# CONFORM THE OPERANDS TO THE OPERATOR;
CASE CONFORM(OP) OF BEGIN "CONFORM"
[0] "OPERATOR UNTYPED. RETURN TYPE OF FIRST ARG"
RSLTTYP←GETTYPE(STACK[TOS-DEG]);
[1] "BOTH INTEGERS" BEGIN RSLTTYP←INTEGR;
MODE←0; ARG1←CVINTEGR(ARG1,1); ARG2←CVINTEGR(ARG2,2) END;
[2] "BOTH REAL" BEGIN RSLTTYP←FLOTNG;
MODE←1; ARG1←CVREAL(ARG1,1); ARG2←CVREAL(ARG2,2) END;
[3] "BOTH STRINGS" BEGIN RSLTTYP←STRNG;
ARG1←CVSTRNG(ARG1,1); ARG2←CVSTRNG(ARG2,2) END;
[4] "SECOND GETS TYPE OF FIRST" BEGIN
TYP←(RSLTTYP←GETTYPE(ARG1)) LSH -23; IF TYP<3 OR TYP>5 THEN BEGIN
NONFATAL(<"CANNOT CONVERT SECOND ARG TO TYPE OF FIRST.">);
ARG2←TYP LSH 23 + LOCATION(EV1TEMP[2]←0) END
ELSE CASE TYP OF BEGIN
[3] ARG2←CVSTRNG(ARG2,2);
[4] BEGIN ARG2←CVREAL(ARG2,2); MODE←1 END;
[5] BEGIN ARG2←CVINTEGR(ARG2,2); MODE←0 END
END END;
[5] "SECOND GETS INTEGER; FOR LSH, ASH, ROT, ROTC"
BEGIN RSLTTYP←GETTYPE(ARG1); ARG2←CVINTEGR(ARG2,2) END;
[6] "MEMBERSHIP" ;
[7] "INF" ;
[8] "SET" ;
[9] "MAXIMUM DOMAIN. INT←(INT,INT), ALL OTHERS TO REAL."
BEGIN RSLTTYP←INTEGR; IF GETTYPE(ARG1) NEQ INTEGR OR
GETTYPE(ARG2) NEQ INTEGR THEN BEGIN
RSLTTYP←FLOTNG; ARG1←CVREAL(ARG1,1); ARG2←CVREAL(ARG2,2) END
END
END "CONFORM";
LOC1←RIGHT(ARG1); LOC2←RIGHT(ARG2);
DEFINE
DOINT(OP)=<TEMP←MEMORY[LOC1] OP MEMORY[LOC2]>,
DOREAL(OP)=<MEMLOC(TEMP,REAL)←MEMORY[LOC1,REAL] OP MEMORY[LOC2,REAL]>,
DOMODE(OP)=<BEGIN IF MODE=0 THEN DOINT(OP) ELSE
DOREAL(OP) END>,
DO1(OP)=<TEMP←OP MEMORY[LOC2]>;
CASE OP OF BEGIN "OPERATE"
DOINT(AND);
DO1(NOT);
NONFATAL(<"NO LEAP IN BAIL">); # IN (MEMBERSHIP);
BEGIN "INF"
# SPECIAL OPERATOR MEANING LENGTH OF STRING, SET, LIST;
# STRINGS ONLY FOR NOW;
TYP←GETTYPE(OPSTACK[TOOPS]); IF TYP NEQ STRNG THEN BEGIN
NONFATAL(<"SPECIAL INFINITY OP IS ONLY FOR STRINGS; WILL USE 0.">);
TEMP←0 END
ELSE BEGIN TEMP←RIGHT(MEMORY[RIGHT(OPSTACK[TOOPS])-1]);
TEMP←INTEGR+LOCATION(TEMPVAL[N!TEMPVAL]) END
END "INF";
NONFATAL(<"NO LEAP IN BAIL">); # INTERSECTION;
NONFATAL(<"NO LEAP IN BAIL">); # UNION;
DOINT(XOR);
"SWAP" MEMORY[LOC1] SWAP MEMORY[LOC2];
DOMODE(NEQ);
DOMODE(LEQ);
DOMODE(GEQ);
DOINT(EQV); # BIT EQUIVALENCE;
DOINT(OR);
DOMODE(<%>); # COMPATIBLE DIVIDE;
"CAT" START!CODE
MOVE 1,LOC1; # POINTER TO WD 2;
PUSH SP,-1(1); # FIRST WORD OF DESCRIPTOR;
PUSH SP,(1); # SECOND WORD OF DESCRIPTOR
MOVE 1,LOC2;
PUSH SP,-1(1);
PUSH SP,(1);
PUSHJ P,CAT;
MOVEI 1,ACCESS(TEMPSTR); # ADDRESS OF 2ND WORD OF RESULT;
POP SP,(1);
POP SP,-1(1);
END;
"LPAR" ;
"RPAR" ;
DOMODE(<*>);
DOMODE(<+>);
"COMMA" TOS←TOS-1;
DOMODE(<->);
DOREAL(</>);
"COLON" NONFATAL(<"NO CONTEXTS OR RECORDS IN BAIL">);
"SEMICOLON" BEGIN FOR I←0 UPTO TOS-1 DO PRINT(STACK[I]); TOS←-1 END;
DOMODE "$%" ($<%);
DOMODE(<=>);
DOMODE "$%" ($>%);
DOINT(ASH);
DOINT(DIV);
"FALSE" STACK[TOS]←REFZERO;
DOINT(LAND);
DO1(LNOT);
DOINT(LOR);
DOINT(LSH);
DOMODE(MAX);
DOMODE(MIN);
DOINT(MOD);
"NULL" STACK[TOS]←REFNULL;
DOINT(ROT);
"TRUE" STACK[TOS]←REFTRUE;
DO1(ABS);
"FOR (SUBSTRINGER)" BEGIN # CONVERT TO "TO";
STACK[TOS]←STACK[TOS-2]; # STACK NOW LOOKS LIKE
TOS/ DSCR FOR BEGINNING CHAR
TOS-1/DSCR FOR NUMBER OF CHARS
TOS-2/DSCR FOR BEGINNING CHAR;
STACK[TOS←TOS+1]←18; # CODE FOR PLUS;
EVAL1; # RECURSE;
END;
"TO (SUBSTRINGER)" ; # NOTE THAT WE HAVE CONVERTED THE
CHARACTER INDICES TO INTEGER;
"UNARY MINUS" BEGIN # CONVERT -X TO (0-X);
STACK[TOS]←STACK[TOS-1]; # COPY X;
STACK[TOS-1]←REFZERO; # ZERO;
STACK[TOS←TOS+1]←20; # BINARY MINUS;
EVAL1; # RECURSE;
END;
"LBRACKET [" ;
"RBRACKET ]" ;
DOMODE(<↑>); # UP ARROW (EXPONENTIATION);
DOINT(<←>);
NONFATAL(<"NO LEAP IN BAIL">); # ASSOC;
NONFATAL(<"NO LEAP IN BAIL">); # SETO;
NONFATAL(<"NO LEAP IN BAIL">); # SETC;
END "OPERATE";
# ASSIGN RESULTS;
IF DEG>0 THEN BEGIN
IF OP=CATENATE THEN
RSLTLOC←RIGHT(LOCATION(TSTRVAL[N!TSTRVAL←N!TSTRVAL+1]←TEMPSTR))
ELSE RSLTLOC←LOCATION(TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←TEMP);
STACK[TOS←TOS-DEG]←RSLTTYP+RSLTLOC END;
END "PRIMITIVE"
ELSE BEGIN "PROC"
INTEGER I,K,TYP;
EXTERNAL PROCEDURE APPLY(REFERENCE STRING TEMPSTR;
REFERENCE INTEGER TEMP; INTEGER PDA,ARGLIS);
# SEARCH BACK THROUGH STACK TO MARKER,
IN ORDER TO DETERMINE NUMBER OF PARAMS;
I←TOS-1; WHILE STACK[I] NEQ -1 DO I←I-1;
# DO IT;
STACK[TOS]←0;
APPLY(TEMPSTR,TEMP,(-1 LSH 18)+RIGHT(OP),LOCATION(STACK[I]));
# REMOVE PARAMS FROM TEMPORARY CELLS;
FOR K←I+1 UPTO TOS-1 DO X1TEMP(STACK[K]);
# IF TYPED PROCEDURE, RETURN VALUE;
IF (TYP←GETTYPE(OP)) NEQ 0 THEN IF TYP=STRNG THEN
STACK[TOS←I]←TYP+RIGHT(LOCATION(TSTRVAL[N!TSTRVAL←N!TSTRVAL+1]←TEMPSTR))
ELSE
STACK[TOS←I]←TYP+LOCATION(TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←TEMP)
ELSE TOS←I-1;
END"PROC";
END "EVAL1";
OLDARG←NULL;
# REINITIALIZE THE CONSTANTS IN CASE THEY GOT CLOBBERED;
VALTRUE←TRUE; VALZERO←0; VALNULL←NULL;
N!TSTRVAL←N!TEMPVAL←TOS←TOOPS←-1;
WHILE LENGTH(ARG) DO BEGIN "PARSE"
GET!TOKEN(ARG,STRVAL,CLASS,IVAL); OLDARG←OLDARG & STRVAL;
CASE CLASS OF BEGIN "CASES"
[INTVAL] PSH(INTEGR+LOCATION(TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←IVAL));
[REALVAL] PSH(FLOTNG+LOCATION(TEMPVAL[N!TEMPVAL←N!TEMPVAL+1]←IVAL));
[STRCON] PSH(STRNG+RIGHT(LOCATION(TSTRVAL[N!TSTRVAL←N!TSTRVAL+1]←STRVAL)));
[ID] BEGIN "ID"
# CHECK IF THE ID IS EQUIVALENT TO A SPECIAL CHAR;
RW←SEARCH!RW(STRVAL); IF RW>0 THEN BEGIN
STRVAL←RW; CLASS←SPCHAR; GOTO OPCHAR END;
# CHECK FOR EVAL SPECIALS;
IF EQU(STRVAL,'30 & '30 & "GO") THEN BEGIN BKRET←TRUE; RETURN(0) END
ELSE IF EQU(STRVAL,"TRACE") THEN REFIT←REFTRACE
ELSE IF EQU(STRVAL,"BREAK") THEN REFIT←REFBREAK
ELSE IF EQU(STRVAL,"UNTRACE") THEN REFIT←REFUNTRACE
ELSE IF EQU(STRVAL,"UNBREAK") THEN REFIT←REFUNBREAK
ELSE BEGIN
# SEARCH SYMBOL TABLE;
CVNAME(STRVAL,NAME); IF (PNTR←FIND(NAME,ACTIVE!BLOCKS,LEXD,FALSE))<0
THEN BEGIN EVALERR("UNKNOWN ID: ",OLDARG,ARG);
RETURN(0) END;
REFIT←INCOR(PNTR,RIGHT(FREG)) END;
# CHECK FOR PROCEDURE WITH PARAMS, ARRAY WITH SUBSCRIPTS, OR
STRING WITH SUBSTRING;
IF REFIT LAND PROCB THEN BEGIN "PROCED"
# MARK STACK FOR CHECKING NUMBER OF PARAMS;
PSH(-1);
IF N!PARAMS(REFIT)>0 THEN BEGIN "WITH PARAMS"
IF ARG NEQ "(" THEN BEGIN EVALERR("MISSING PARAMETER LIST: ",
OLDARG,ARG); TOS←TOS-1;
RETURN(0) END;
# REMOVE THE "(" AND PLACE PROCEDURE NAME ON OPSTACK;
A←LOP(ARG); OPPSH(REFIT,0) END "WITH PARAMS"
ELSE BEGIN PSH(REFIT); EVAL1 END END "PROCED"
ELSE PSH(REFIT)
END "ID";
[SPCHAR] OPCHAR: BEGIN "SPCHAR"
# FIND WHICH OPERATOR IT IS AND ITS LEFT AND RIGHT BINDING POWER;
SEARCH!OP(STRVAL,OP,LBND,RBND,BINARYMINUSFLAG);
# EVALUATE OPERATORS OF HIGHER PRECEDENCE WHICH OCCUR TO THE LEFT;
WHILE TOOPS NEQ -1 AND RBIND[TOOPS]>LBND DO BEGIN
PSH(OPSTACK[TOOPS]); EVAL1; TOOPS←TOOPS-1 END;
# CHECK FOR "[" OR ")" OR "]" AND PROCEDURES, ARRAYS, STRINGS;
IVAL←STRVAL;
IF IVAL=")" THEN BEGIN
IF TOOPS<0 THEN BEGIN EVALERR("TOO MANY RIGHT PARENTHESES: ",
OLDARG,ARG); RETURN(0) END
ELSE IF OPSTACK[TOOPS]=15 # OP NUMBER OF LEFT PAREN "(";
THEN TOOPS←TOOPS-1
ELSE IF (REFIT←OPSTACK[TOOPS]) LAND PROCB THEN BEGIN "PROCS"
PSH(REFIT); EVAL1; TOOPS←TOOPS-1 END "PROCS" END
ELSE IF IVAL="]" THEN BEGIN
IF TOOPS<0 THEN BEGIN EVALERR("MISPLACED ]: ",OLDARG,ARG);
RETURN(0) END
ELSE IF (REFIT←OPSTACK[TOOPS]) LAND ARRY THEN BEGIN "SUBSCRIPT"
# THE ADDRESS IN REFIT IS A POINTER TO A WORD WHICH
CONTAINS THE ADDRESS OF THE FIRST DATA WORD;
INTEGER I,U,L,OFFSET,ADDR,SUBSBASE,NDIMS,INDX;
# FIND BEGINNING OF DIMENSIONS; I←TOS; WHILE STACK[I] NEQ -1
DO I←I-1; SUBSBASE←I;
# PROCESS THE INDICES; ADDR←RIGHT(MEMORY[RIGHT(REFIT)]);
PSH(0); NDIMS←ABS(MEMORY[ADDR-1] ASH -18); OFFSET←0;
FOR I←1 UPTO NDIMS DO BEGIN
IF STACK[SUBSBASE+I]=0 THEN BEGIN
EVALERR("INSUFFICIENT NUMBER OF DIMENSIONS SPECIFIED."
&" CORRECT NUMBER IS "&CVS(NDIMS),OLDARG,ARG);
RETURN(0) END;
INDX←MEMORY[RIGHT(CVINTEGR(STACK[SUBSBASE+I],1))];
U←MEMORY[ADDR-3*I]; L←MEMORY[ADDR-3*I-1];
IF INDX<L OR INDX>U THEN BEGIN EVALERR(
"INDEX OUT OF RANGE FOR DIMENSION "&CVS(I)&"."
&"VALUE IS "&CVS(INDX)&", LOWER BOUND="&CVS(L)&
", UPPER BOUND="&CVS(U),OLDARG,ARG); RETURN(0) END;
OFFSET←OFFSET+MEMORY[ADDR-3*I+1]*INDX END;
# MAKE A REFIT WITH THE RIGHT ADDR AND THE ARRAY BIT OFF;
STACK[SUBSBASE]←(REFIT-(13 LSH 23)) LAND '777777000000
LOR (OFFSET+MEMORY[ADDR-3*NDIMS-2]);
FOR I←SUBSBASE+1 UPTO TOS DO X1TEMP(RIGHT(STACK[I]));
TOOPS←TOOPS-1; TOS←SUBSBASE END "SUBSCRIPT"
ELSE IF GETTYPE(<REFIT←OPSTACK[TOOPS]>)=STRNG THEN BEGIN "SUBSTRING"
EXTERNAL PROCEDURE SUBST;
PSH(OPSTACK[TOOPS]); PSH(STRNG+LOCATION(SUBST)); TOOPS←TOOPS-1
END "SUBSTRING"
END
ELSE IF IVAL="[" THEN BEGIN
IF (REFIT←STACK[TOS]) LAND ARRY OR GETTYPE(REFIT)=STRNG THEN BEGIN
OPPSH(REFIT,0); STACK[TOS]←-1 END
ELSE BEGIN EVALERR("MISPLACED [: ",OLDARG,ARG); RETURN(0) END
END
ELSE IF IVAL=";" THEN BEGIN PSH(OP); EVAL1 END
ELSE OPPSH(OP,RBND)
END "SPCHAR"
END "CASES";
BINARYMINUSFLAG←IF CLASS NEQ SPCHAR OR IVAL=")" OR IVAL="]" THEN TRUE
ELSE FALSE
END "PARSE";
RETURN(STACK[0])
END "EVAL";
PROCEDURE DSCOPE(INTEGER FR,PR); BEGIN "DSCOPE"
# DYNAMIC SCOPE UNWINDER ROUTINE. FILLS ARRAY FSTACK WITH THE VALUES OF
THE F REGISTER CORRESPONDING TO THE VARIOUS DYNAMIC ACTIVATIONS, MOST
RECENT FIRST. IN THE CASE OF SIMPLE PROCEDURES, THE ENTRY IS THE
NEGATIVE OF THE CORRESPONDING P REGISTER.;
INTEGER I,K,T,NFS; STRING PROCNAME;
# '777777 IS THE VALUE PUT ON THE BOTTOM OF THE STACK BY SAILOR;
WHILE FR NEQ '777777 DO BEGIN
K←FR+RIGHT(MEMORY[LEFT(MEMORY[FR+1])+PD!DSP])+1;
# 1+RIGHT(P) AFTER PROLOG;
FOR I←FR STEP -1 UNTIL K DO BEGIN
# SIMPLE PROCEDURE HAS BEEN CALLED, OR WE ARE IN THE MIDDLE OF
STACKING SOME ARGUMENTS. PICK UP THE WORD ON THE STACK AND SEE
IF IT IS A REASONABLE RETURN ADDRESS. THE ACCUMULATOR, INDIRECT,
AND INDEX FIELDS MUST BE ZERO. THE OPCODE AND ADDRESS FIELDS
MUST BE NON-ZERO.;
T←MEMORY[I]; IF (T LAND '777000000)=0 AND (T LAND '777000000000)
NEQ 0 AND (T LAND '777777) NEQ 0 THEN BEGIN
# THERE MUST BE A PUSHJ AT RIGHT(T)-1;
IF LEFT(MEMORY[T←RIGHT(T)-1])=LEFT(PUSHJ+(P LSH 23)) THEN BEGIN
# SIMPLE PROCEDURE CALLED AT MEMORY[T];
FSTACK[NFS←NFS+1]←-I; # NEGATIVE OF P AT ENTRY; END
END
END;
# NON-SIMPLE PROCEDURE CALLED;
FSTACK[NFS←NFS+1]←FR; FR←MEMORY[FR] END;
# NOW PRINT THIS OUT FOR THE USER;
OUTSTR("
DYNAMIC SCOPE, MOST RECENT FIRST:
callee retn addr text of call
");
FOR I←0 UPTO NFS DO
IF FSTACK[I]<0 THEN OUTSTR(".simple." & " '" &
CVOS(T←RIGHT(MEMORY[-FSTACK[I]])) & TAB & GETTEXT(T) & CRLF)
ELSE BEGIN
INTEGER PDA;
# GET NAME OF THIS PROCEDURE;
PDA←LEFT(MEMORY[1+FSTACK[I]]);
START!CODE
MOVE 1,PDA;
HRROI 2,2(1);
POP 2,PROCNAME; # TRANSFER WORD 2;
MOVEI 1,PROCNAME;
POP 2,-1(1); # TRANSFER WORD 1;
END;
OUTSTR(PROCNAME & " '" & CVOS(T←RIGHT(MEMORY[-1+FSTACK[I]])) &
TAB & GETTEXT(T) & CRLF);
END;
END "DSCOPE";
PROCEDURE ANCESTRY(INTEGER ARRAY ACTIVE!BLOCKS; REFERENCE INTEGER LEXD,PC,CURBLK);
BEGIN "ANCESTRY"
INTEGER I,U,L,T; LABEL EXACT;
DEFINE LWA(I)=<LEFT(T!BLKADR(I+1))>, FWA(I)=<RIGHT(T!BLKADR(I+1))>;
# CONSTRUCT LIST OF ACTIVE BLOCKS, MOST RECENT FIRST;
OUTSTR("
LEXICAL SCOPE, TOP DOWN:
");
L←0; U←(L!BLKADR+1) ASH -1;
WHILE U GEQ L DO BEGIN
I←(L+U) ASH -1;
IF (T←LWA(I LSH 1))=PC THEN GOTO EXACT;
IF T>PC THEN U←I-1 ELSE L←I+1 END;
IF LWA((I←L) LSH 1)<PC THEN I←L+1;
EXACT: I←I LSH 1;
# GO UP FATHER CHAIN UNTIL PC IS GEQ FWA;
WHILE PC<FWA(I) DO I←LEFT(T!BLKADR(I));
LEXD←-1; DO BEGIN "UP"
ACTIVE!BLOCKS[LEXD←LEXD+1]←RIGHT(T!BLKADR(I)) LSH 18 LOR FWA(I);
I←LEFT(T!BLKADR(I)); # FATHER (IN T!BLKADR) OF THIS BLOCK;
END "UP" UNTIL I=0;
# PRINT IT OUT FOR ALL THE WORLD TO SEE;
FOR I←LEXD STEP -1 UNTIL 0 DO
OUTSTR(CVSTR(PAGEIT(T!NAME,2+(T←LEFT(ACTIVE!BLOCKS[I])))) & CVSTR(PAGEIT(
T!NAME,T+3)) & CVSTR(PAGEIT(T!NAME,T+4)) & CRLF);
END "ANCESTRY";
INTERNAL RECURSIVE PROCEDURE BAILOR; BEGIN "BAILOR"
INTEGER ARRAY SAVED!ACS[0:'17];
INTEGER PC,FLAGS,I,#SKIP#;
BOOLEAN BKRET; # REQUEST FOR RETURN FROM BREAKPOINT PACKAGE;
INTEGER LEXD,CURBLK,CURBRK; # LEXICAL DEPTH OF CURRENT POINT IN
PROGRAM, =ACTIVE!BLOCKS[0], CURRENT BREAKPOINT NUMBER;
INTEGER ARRAY ACTIVE!BLOCKS[0:15]; # MOST RECENT FIRST;
DEFINE F=<'12>;
#SKIP#←!SKIP!; # FOR PRESERVING STATE OF THE WORLD;
BKLEV←BKLEV+1; # RECURSION LEVEL IN BREAKPOINT;
BKRET←FALSE;
ARRBLT(SAVED!ACS[0],TEMP!ACS[0],'20); # RECURSIVE SAVE;
PC←RIGHT(TRAP[0])-1; FLAGS←LEFT(TRAP[0]);
CURBRK←-1; WHILE (CURBRK←CURBRK+1)<L!BK AND BK!LOC[CURBRK]
NEQ PC DO;
ANCESTRY(ACTIVE!BLOCKS,LEXD,PC,CURBLK);
IF CURBRK=L!BK THEN BEGIN # EXPLICIT USER CALL;
IF LENGTH(QUERY) NEQ 0 THEN EVAL(QUERY,ACTIVE!BLOCKS,LEXD,BKRET,SAVED!ACS[F]) END
ELSE BEGIN # BAIL-PLANTED BREAKPOINT;
IF LEFT(BK!INSTR[CURBRK])='551517 THEN
# '551517 IS THE LEFT HALF OF HRRZI F,(P). IF THE BROKEN INSTR
IS THIS, ASSUME THAT WE HAVE BROKEN A NON-SIMPLE PROCEDURE AND THAT
THE INSTR IS THE ONE THAT SETS THE F REGISTER. IN ORDER TO MAKE
PARAMETER ACCESSING CONSISTENT WITH BREAKS INSIDE THE PROCEDURE,
SET UP SAVED!ACS AS IF THE HRRZI HAD BEEN EXECUTED;
SAVED!ACS[F]←RIGHT(SAVED!ACS[P])+
(RIGHT(BK!INSTR[CURBRK]) LSH 18 ASH -18);
IF LENGTH(BK!COND[CURBRK]) NEQ 0 AND MEMORY[RIGHT(EVAL(BK!COND[CURBRK],
ACTIVE!BLOCKS,LEXD,BKRET,SAVED!ACS[F]))] AND
(BK!COUNT[CURBRK]←BK!COUNT[CURBRK]-1)<0 AND
LENGTH(BK!ACT[CURBRK]) NEQ 0 THEN
EVAL(BK!ACT[CURBRK],ACTIVE!BLOCKS,LEXD,BKRET,SAVED!ACS[F]) END;
WHILE NOT BKRET DO BEGIN OUTSTR(CRLF & CVS(BKLEV)&":");
EVAL(LINED,ACTIVE!BLOCKS,LEXD,BKRET,SAVED!ACS[F])END;
"BREAK RETURN"
BKRET←FALSE;
ARRBLT(TEMP!ACS[0],SAVED!ACS[0],'20); # RESTORE ACS;
TRAP[8]←FLAGS LSH 18 LOR LOCATION(TRAP[2]); # RESTORE FLAGS;
!SKIP!←#SKIP#; BKLEV←BKLEV-1;
IF CURBRK=L!BK THEN BEGIN
TRAP[8]←FLAGS LSH 18 LOR (PC+1); TRAP[2]←JFCL END
ELSE BEGIN
TRAP[2]←XCT+LOCATION(BK!INSTR[CURBRK]); # BROKEN INSTRUCTION;
FOR I←3 UPTO 7 DO TRAP[I]←JRST+BK!LOC[CURBRK]+I-2; # FOR SKIPS; END;
RETURN
END "BAILOR";
BAILINITIALIZATION;
BAIL;
END "BILGE"