Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0068/entree.imc
There are 2 other files named entree.imc in the archive. Click here to see a list.
TWOSEG;
#THIS IS ENTREE, THE CODE TREE MAKING ROUTINE FOR THE IMP COMPILERS.
THE CODE TREE IS KEPT IN FREE STORAGE ARRAY CT, AND CONSISTS OF TWO (OR
SOMETIMES THREE) WORD NODES:
WORD 1: BITS 35-18 INDEX OF ALTERNATE NODE (DOWN POINTER)
BITS 17-0 INDEX OF SUCCESSOR NODE (RIGHT POINTER)
WORD 2: BITS 35-33 TYPE: 2=THIS NODE IS TO BE MATCHED WITH KTH ITEM OF
THE PATTERN. K IS LOW 18 BITS OF THIS WORD.
3=MATCH WITH IDENTIFIER ID (DIR INDEX OF ID IS
LOW 18 BITS). IF BIT 18 IS A 1, ID IS THE
INDEX OF A ONE WORD CONSTANT WHOSE VALUE IS IN
THE THIRD WORD OF THIS NODE, AND AN ATTEMPT
SHOULD ALSO BE MADE TO MATCH BY VALUE.
1=MATCH WITH A STACK ITEM OF INDICATED TYPE:
TYPE 1 NODE HAS A SECOND WORD AS FOLLOWS:
(NR BITS) 3 2 111 111 5 5 7 8
TTT XI WSV CRN PP QQ KKK LLL
TTT = TYPE
X = 1 IF FLOATING POINT MAY MATCH (NOT CHECKED FOR N)
I = 1 IF INTEGER MAY MATCH (NOT CHECKED FOR N)
(IMP11: IF X=I=0, ONLY BYTE MAY MATCH)
W = 1 IF ONLY EXPRESSIONS GENERATING EXACTLY 1 WORD OF CODE MAY MATCH
(IMP11: ONLY EXPRESSIONS WITHOUT SIDE-EFFECTS MAY MATCH)
S = 1 IF ANY SUBSCRIPTED VARIABLE MAY MATCH.
V = 1 IF ANY SIMPLE VARIABLE MAY MATCH.
C = 1 IF SOME CONSTANT MIGHT MATCH (MODIFIED BY KKK LLL)
R = 1 IF SOME REGISTER MIGHT MATCH (MODIFIED BY PPP QQQ)
N = 1 IF ANY RAW IDENTIFIER MAY MATCH.
IF A REGISTER IS CALLED FOR IT MUST BE ONE OF THE REGISTERS NUMBERED
PP THROUGH QQ (RANGE 0-37B). IF A CONSTANT IS CALLED FOR,
IT MUST BE ZERO EXCEPT FOR THE KKK BITS STARTING LLL BITS FROM THE
RIGHT END OF THE WORD (RANGE 00-177B). IF LLL HAS THE 200B BIT SET,
THEN THE CONSTANT MUST BE ALL ONES EXCEPT FOR THE KKK BIITS STARTING
(LLL AND 177B) BITS FROM THE RIGHT OF THE WORD.
IF WSVCRN=00, THEN THE NODE MATCHES PRODUCTIONS, AND THE NODE IDENTIFIER
IS IN THE RIGHTMOST 18 BITS OF THE WORD. IF BIT 19=0, THEN THE NODE
MATCHES ONLY THE PRODUCTION NUMBER WHICH IS THE IDENTIFIER. BIT 18 IS
0 IF THIS IS A REAL PRODUCTION AND 1 IF IT IS A CLASS OF VAL/ PROD'NS.
IF BIT 19 IS 1, THEN THIS IS A TERMINAL NODE AND MATCHP (IN DOSEM) IS
CALLED TO DETERMINE IF THERE HAS BEEN A MATCH AND TO FETCH THE SEMANTICS.
THE ROUTINES WHICH BUILD AND SEARCH THE CODE TREE ARE:
MATCH(TN,SN) - CHECKS IF TREE NODE TN IS MATCHED BY A STACK ENTRY BEGINNING
AT FREE STORAGE ADDRESS SN. RETURNS 0 IF NO MATCH, -1 IF A MATCH, AND
THE SEMANTICS NUMBER IF A MATCH WAS MADE AT A TERMINAL NODE (I.E., WHEN
A COMPLETE PATH HAS BEEN FOUND).
ENTREE(S,CS,SR,PN) - S IS THE POINTER TO A FREE STORAGE ARRAY CONTAINING PARSER
OUTPUT TO BE ENTERED IN THE CODE TREE. THE ENTRIES ARE EITHER NEGATIVE DIR
INDICES OR POSITIVE SEMANTICS INDICES. CS IS THE NUMBER OF THE PRODUCTION
BEING PROCESSED (I.E., PARSER OUTPUT). SR IS THE SEMANTIC ROUTINE TO BE
INVOKED BY THIS INSTANCE OF THE SEMANTICS. PN IS THE PRODUCTION NUMBER TO
BE INSERTED IN THE CODE GENERATION TREE (DIFFERS FROM CS IF A CASE IS
BEING DEFINED).
THE VALUE RETURNED BY ENTREE IS A FREE STORAGE ARRAY CONTAINING THE DIR
INDICES OF THE IDENTIFIER CORRESPONDING TO EACH TERMINAL SYMBOL IN S (OR 0
FOR A CONSTANT. THE ARRAY IS TERMINATED BY A NEGATIVE
ENTRY. ENTREE WILL ALTER THE ARRAY S.
THE PARSER OUTPUT IS GENERATED BY PARSING AN INSTANCE OF THE PRODUCTION
BEING PROCESSED. IT CONTAINS IDENTIFIERS OF THE FOLLOWING FORMS:
REGNNKK NN,KK DECIMAL DIGITS - WILL MATCH A REGISTER
BETWEEN NN AND KK.
REGNN SAME AS REGNNNN
REG MATCHES ANY REGISTER.
CONMMKK MATCHES A CONSTANT IN MM BITS SHIFTED KK BITS LEFT.
CONMM SAME AS CONMM00
CON MATCHES ANY CONSTANT
CNG USED SAME AS CON, BUT FOR NEGATIVE CONSTANTS.
VAR MATCHES ANY CONSTANT OR SIMPLE VARIABLE
MEM MATCHES ANY SUBSCRIPTED VARIABLE.
FLT ONLY FLOATING POINT MAY MATCH
IGR ONLY FIXED POINT MAY MATCH
BYT (IMP11) ONLY ATYPE BYTE WILL MATCH
NAM MATCHES A RAW IDENTIFIER.
WRD (IMP10) ONLY 1 WORD OF CODE MAY MATCH.
NSE (IMP11) ONLY NO-SIDE-EFFECTS MAY MATCH.
AN IDENTIFIER WITHOUT MODIFIERS MAY MATCH ANY OF THE ABOVE.
THE PROPERTIES FLT AND IGR ARE ORTHOGONAL TO THE OTHERS.
THE PROPERTY WRD IS ORTHOGONAL TO THE OTHERS.
A REGISTER MATCHES THE SPECIFICATIONS ONLY WHEN IT IS FORCED, WHEN
EVENTUALLY ALLOCATED, TO FALL WITHIN THE SPECIFIED LIMITS.
AN IDENTIFIER WHICH MAY MATCH MORE THAN ONE OF THE ABOVE MAY BE MADE
BY CATENATING THE APPROPRIATE IDENTIFIERS - E.G.,CON18REG0115.
IN ADDITION, ANY IDENTIFIER NOT CONTAINING THE CHARACTER 0 MAY
APPEAR. IF AN IDENTIFIER APPEARS MORE THAN ONCE, SUBSEQUENT OCCURRENCES
WILL BE REQUIRED TO MATCH THE FIRST OCCURRENCE EXACTLY (I.E., SAME
EXPRESSION). MODIFIERS ARE NOT ALLOWED ON THE SUBSEQUENT OCCURRENCES
EXCEPT THAT IF THE IDENTIFIER IS TO MATCH A 'NAM' THE MODIFIER NAM
>>MUST<< APPEAR ON EVERY OCCURENCE OF IT.
TO INDICATE AN IDENTIFIER WHICH MATCHES ONE OR MORE OF THE CASES ABOVE,
FOLLOW THE IDENTIFIER BY 0 AND THE APPROPRIATE CASES. EXAMPLE:
Q0REG0115 _ Q + CON18
INDICATES SOMETHING OF THE FORM Q_Q+C WHERE Q IS A REGISTER BETWEEN 1
AND 15, AND C IS AN 18-BIT CONSTANT.
THE PARSE OUTPUT PROVIDED WILL, OF COURSE, BE A COMPLETE PARSE FROM RAW
IDENTIFIERS TO STATEMENT LIST. THE PARSE IS TRUNCATED TO MAKE THE
TREE BRANCH AS FOLLOWS:
1: EVERYTHING ABOVE THE HIGHEST OCCURRENCE OF THE PRODUCTION NUMBER .
BEING ENTERED (CS) IS DELETED.
2: ALL [1] (NULL) SEMANTICS ARE DELETED.
3: IF AN IDENTIFIER IS NOT A NAME (CONTAINS THE DESIGNATION 'NAM'), AND
IF THE FIRST PRODUCTION ABOVE IT HAS ONE ARGUMENT, IT IS ASSUMED
TO BE THE PRODUCTION <NAM>::=NAM", AND IS DELETED.
THE TRUNCATED PARSE IS THEN ENTERED IN THE TREE, TERMINATED BY A NEWLY
CREATED SEMANTIC ENTRY IN THE SEMANTICS TABLE. IT IS UP TO THE CALLING
ROUTINE TO COMPLETE THIS ENTRY.
NODES IN THE TREE MUST BE ORDERED SO THAT THE MORE SPECIFIC CASES ARE
ALWAYS ENCOUNTERED FIRST. THIS IS DONE BY CONSIDERING THE RESTRICTION
BYTE 'WSVCRN' AS A 6-BIT NUMBER (WITH THE W BIT COMPLEMENTED). THE
LOWER THE NUMBER, THE MORE RESTRICTIVE THE CASE. WHERE NUMBERS ARE
EQUAL, THE RESTRICTIONS ON THE REGISTERS AND CONSTANTS ARE CONSIDERED.
PRODUCTION NODES ARE ENTERED WITH THE LOWEST VALUE OF BITS 19-18 FIRST.,
EXCEPT THAT TERMINAL NODES (BITS 19-18=2) ARE ENTERED AFTER ALL OTHER
NODES. #
SUBR ENTREE(S,CS,SR,PN) IS (
PLY_NTBL_0; NODE_1;
INIT=0=>(FRELOT(CT,'TREE',550,TORGFIX);
SBITM IS 3 LONG; SBITM_0;
SBITM[1]_340; SBITM[2]_4;
INIT_NCT_3; FINCSET(CT,40);
FREES(CT+1,0); FREES(CT+2,0);
FRELOT(PRODS,'NTRE2',10,0); NODEN_-1;
FRELOT(TBL,'NTREE',10,0));
#TBL HOLDS NAMES OF IDENTIFIERS FOR NODES ALREADY ENTERED.
ENTRY POINT OF TREE IS TSCR(1);
NODE IS NEXT PLACE TO HANG A NODE AS AN ALT (POSITIVE) OR SCR (NEG.)#
ST_S;
NPRODS_0;
L24: (J_FREE(ST))=>(ST_ST+1; GO TO L24);
L23: (ST_ST-1)<S=>
(ERROR(1,'QUOTED SEMANTICS NOT AN INSTANCE OF PRODUCTION.');
GO TO ENTRX);
J_FREE(ST);
J NE CS=>GO TO L23;
SS_S; EATIT_0;
# NEXT ELEMENT IN PARSER OUTPUT #
NEXT: J_FREE(SS); SS_SS+1;
J<0=>(#IDENTIFIER. CHECK FOR CONSTANT. #
EATIT_1;
KON_CONVC(-J); KON=>(CONST IS COMMON;
NOTY_300001000000B OR -J;
FADD(TBL,NTBL,0);
GO TO L11);
CODEID(-J);
J_CODEID(0); KK_J;
FADD(TBL,NTBL,J);
J>0=>(#THIS ONE AT LEAST STARTS WITH A NAME - SEEN BEFORE? #
NTBL>1=>((K_FREE(TBL+I);
K=J=>(# YES. #
L22: J_CODEID(0);
J NE 0=>(
J=-10=>(EATIT_0; GO TO L22);
PNAME(K); PRINT STG 0,' ';
ERROR(1,'MODIFIER ON OTHER THAN FIRST OCCURRENCE OF NAME IS IGNORED');
GO TO L22);
NOTY_I OR 2 LS 33; GO TO L11)) FOR I TO NTBL-2);
J_CODEID(0));
# FIRST OCCURRENCE OF ID, SO CHECK FOR RESTRICTIONS. #
NOTY_160000000000B;
NTY1_007603700177B;
L12: J=>(J>0=>(PNAME(J); PRINT STG 0,' ';
ERROR(1,'BAD MODIFIER **');
GO TO L11);
(K_-J)>2=>K_K-1;
K=9=>(K_EATIT_0);
K=8 => (NOTY_NOTY AND NOT (3 LS 31); GO TO L21);
K>5=>(NOTY_NOTY AND NOT (1 LS 38-K); GO TO L21);
K=5=>(NOTY_NOTY OR 010000000000B; GO TO L21);
NTY1_0;
NOTY_NOTY OR 1 LS K+25;
J=-3=>NOTY_NOTY OR 200B;
K=2=>(N1<0=>N1_177B; N2<0=>N2_0;
NOTY_NOTY OR N2 OR N1 LS 8);
K=1=>(N1<0=>(N1_0; N2_37B);
N2<0=>N2_N1;
NOTY_NOTY OR (N1 LS 20) OR N2 LS 15);
L21: J_CODEID(0); GO TO L12);
NOTY_NOTY OR NTY1;
L11: NODE_INSNO(NODE,NOTY,KON,CONST); #INSERT NODE IN TREE #
FADD(PRODS,NPRODS,NODE);
GO TO NEXT);
SS LE ST=>(
J=1=>GO TO NEXT;
# CHECK FOR VAL/ PRODUCTION #
JJ_J;
(J RS 18)=>(FADD(TBL,NTBL,J);
JJ_1000000B OR (J_J AND 777777B));
EATIT=>(# EAT FIRST SEMANTICS NODE WITH 1 ARG DIRECTLY AFTER IDENTIFIER. #
EATIT_0;
K_SNARG(J); K=1=>GO TO NEXT);
EATIT_0;
J=CS=>CS NE PN=>ERROR(2,
'CASE CONTAINS SUBEXPRESSION WHICH IS CASE BUT WONT GENERALIZE.');
NOTEPROD(J,PLY);
SNO_SNODEN(J);
NODE_INSNO(NODE,JJ OR 100000000000B,0,0);
FADD(PRODS,NPRODS,NODE);
ENTMARK(SNO);
GO TO NEXT);
# MADE PRODUCTION - END OFF TREE AND RETURN #
NOTEPROD(PN,PLY);
NODE_INSNO(NODE,100002000000B,0,0);
ENPROD(PN,NODE,SR);
FADD(PRODS,NPRODS,NODE);
J_SNODEN(PN);
ENTMARK(J);
ENTRX: FADD(TBL,NTBL,-1); TBL);
SUBR ENTMARK(J) IS (
K_0;
(L_FREE(PRODS+I);
K=>[TORG1+L]<L> LE 100002B=>RETURN 0;
K_-1;
BITS(SBITM,TNODEN(L),J)) FOR I FROM NPRODS-1);
SUBR TORGFIX(NIL) IS (
TORG,TSCRBP,TALTBP,TNONBP ARE 1 LONG;
TORG_CT;
TSCRBP_BYTEP [TORG]<12,24>;
TALTBP_BYTEP [TORG]<12,12>;
TNONBP_BYTEP [TORG]<12,0>;
TORG1_TORG+1);
SUBR INSNO(HOOK,STUFF,K1,K2) IS (
# INSERTS NODE ON AS SCR TO HOOK, WD 2 = STUFF #
PLY_PLY+1;
SH_TSCR(HOOK);
SH=0=>(J_NUNO(STUFF,K1,K2); STSCR(HOOK,J); GO TO INSX);
K_COMPNO(SH,STUFF);
K=0=>GO TO INSXX;
K>0=>(J_NUNO(STUFF,K1,K2); STSCR(HOOK,J); STALT(J,SH); GO TO INSX);
L15: LSH_SH; SH_TALT(SH);
SH=0=>(J_NUNO(STUFF,K1,K2); STALT(LSH,J); GO TO INSX);
K_COMPNO(SH,STUFF);
K=>(K<0=>GO TO L15;
J_NUNO(STUFF,K1,K2);
STALT(J,SH); STALT(LSH,J);
GO TO INSX);
INSXX: J_SH;
INSX: SH_TSCR(HOOK);
# SET SPECIAL FIELD TO INDEX OF FIRST PROD'N NODE #
WHILE SH DO ([CT+SH+1]<L> LE 100002B=>GO TO L31; SH_TALT(SH));
L31: K_TSCR(HOOK);
WHILE K NE SH DO (FREES(CT+K-1,SH); K_TALT(K));
J);
SUBR NUNO(A,B,C) IS (
NCT_NCT+1;
FLEN(CT) LE (NCT+4) => FADDEX(CT,NCT+4);
Q_NCT; FREES(CT+NCT,0);
STNODEN(Q,(NODEN_NODEN+1));
(AA_A)=100002000000B=>AA_AA OR Q;
FREES(CT+NCT+1,AA); NCT_NCT+2;
B=>(FREES(CT+NCT,C); NCT_NCT+1);
Q);
SUBR COMPNO(NO,VV) IS (
# COMPARES NODE NO WITH VALUE VV. RETURNS 1,0,-1 ACCORDING AS VV
BELONGS ABOVE, IS EQUAL TO, BELONGS BELOW, NODE NO. #
V_FREE(CT+NO+1);
VL_0; V=VV=>GO TO COMPX;
VL_1;
(TV_V RS 33)=1=>TV_4; #CHECK TYPE #
(TVV_VV RS 33)=1=>TVV_4;
TVV<TV=>GO TO COMPX;
TVV=TV=>(TV NE 4=>GO TO COMPX;
TV_V RS 18; TVV_VV RS 18; # CHECK FOR PROD'N NODES #
TV LE 100002B=>(TV=TVV=>TV=100002B=>RETURN 0;
TVV>100002B=>GO TO COMPX;
TV>TVV=>GO TO COMPX;
GO TO COMPXX);
TVV LE 100002B=>GO TO COMPXX;
TV_77B AND 40B+V RS 25; # CHECK WSCVRN #
TVV_77B AND 40B+VV RS 25;
TVV<TV=>GO TO COMPX;
TVV=TV=>(
TV_V RS 31; # CHECK ARITH. TYPE #
TVV_VV RS 31;
TVV<TV=>GO TO COMPX;
TVV=TV=>(
KV_177B AND V RS 8; KVV_177B AND VV RS 8;
LV_177B AND V; LVV_177B AND VV;
# CHECK CONS # (KVV+LVV)>(KV+LV)=>GO TO COMPX;
(KVV+LVV)=(KV+LV)=>(LVV>LV=>GO TO COMPX;
LVV=LV=>(KV_37B AND V RS 20;
#CHECK REGS # KVV_37B AND VV RS 20;
KVV>KV=>GO TO COMPX;
KVV=KV=>(KV_37B AND V RS 15;
KVV_37B AND VV RS 15;
KVV<KV=>GO TO COMPX)
)))));
COMPXX: VL_-1;
COMPX: VL);
REMOTE IDTB: DATA('REG CON CNG VAR MEM WRD IGR FLT BYT NAM NSE');
SUBR CODEID(SW) IS (
# ROUTINE TO DISASSEMBLE AN IDENTIFIER. IF SW=0, RETURNS THE DIRECTORY
INDEX OF THE NEXT INDICATOR IN THE IDENTIFIER, OR 0 IF DONE. IF SW NE 0,
INITIALIZES ON IDENTIFIER ID. FOR SPECIAL IDENTIFIER, RETURNS MINUS DEXE
OF IDENTIFIER IN IDTB, AND N1 AND N2 ARE SET TO NUMERIC ARGS, OR -1 #
CINIT=0=>(CINIT_1;
(IDTB[I]_IDTB[I] RS 15) FOR I FROM 10);
SW=>(CHAR_SH_0; LCH_CHAR_-1;
IDDIR_SW; IDDIRX_-1; GO TO CODEIDX);
NSW_ANS_NAN_NA_0; NA IS 10 LONG;
LCH=0=>(ANS_0; GO TO CODEIDX);
N1_N2_-1;
CHAR LE 0=>(NXCH: LCH=0=>(CHAR_0; GO TO L9);
SH<1=>(IDDIRX_IDDIRX+1;
ID_DNAME(IDDIR,IDDIRX);
SH_29);
LCH_CHAR_177B AND ID RS SH;
SH_SH-7);
L9: NSW=>GO TO L3;
(NA=IDTB[C]=>GO TO L2) FOR C FROM 10;
ANS=0=>(# MAKE NAME #
CHAR NE 0 =>CHAR NE 60B =>(NA[NAN]_CHAR OR NA[NAN] LS 7;
(NA[NAN] RS 28)=>(
NA[NAN]_NA[NAN] LS 1;
(NAN_NAN+1)>9=>ERROR(0,'NAME TOO LONG **');
NA[NAN]_0);
GO TO NXCH);
(NA[NAN]_NA[NAN] LS 1)=>(
L1: (NA[NAN] RS 29)=0=>(NA[NAN]_NA[NAN] LS 7;
GO TO L1));
ANS_DIR(NA);
CHAR_0; GO TO CODEIDX);
L2: NSW_1; C=10=>C_5; ANS_-(C+1); C>2=>GO TO CODEIDX;
L3: NSW=5=>GO TO CODEIDX;
CHAR GE 60B=>CHAR LE 71B=>GO TO SWTB[NSW-1];
(1 AND NSW)=>GO TO CODEIDX;
L8: ERROR(1,'NUMBER MISSING OR OUT OF PLACE IN SEMANTICS IDENTIFIER **');
ANS_0; GO TO CODEIDX;
SWTB: GO TO L4; GO TO L5; GO TO L6; GO TO L7;
L4: N1_10*CHAR-60B; GO TO L10;
L5: N1_N1+CHAR-60B; GO TO L10;
L6: N2_10*CHAR-60B; L10: NSW_NSW+1; GO TO NXCH;
L7: N2_N2+CHAR-60B; GO TO L10;
CODEIDX: ANS);
SUBR MATCH(TN,SN,SNONR) IS (
VAL_-1;
S_FREE(SN);
STY_S AND 37B;
SDI_S RS 18;
SVAL_FREE(SN+1);
STY=0=>(TB_BYTEP [TORG1]<11,25>;
TY0AL0: <TN+TB> NE 400B=>((TN_[TORG+TN-1])=>GO TO TY0AL0;
RETURN 0);
(T_[TN+TORG1]) AND 2000000B=>(
(VAL_MATCHP(SDI,TN))=0=>GO TO TY0ALT;
RETURN VAL);
T<R>=SDI=>RETURN -1;
SVAL=0=>GO TO TY0ALT;
T<R>=SVAL<L>=>RETURN -2;
TY0ALT: (TN_TALT(TN))=>GO TO TY0AL0; RETURN 0);
SNN_SNONR;
SN1_SBITM+SBITM[1]*SNN/36; SN2_1 LS SNN//36;
TYALT: SNN GE 0=>(SN2 AND [SN1+TNODEN(TN)])=0=>GO TO NIX;
T_[TN+TORG1];
(TTY_T RS 33)=1=>(
# PRODUCTIONS ARE LAST # T<6,25>=0=>RETURN (TN_0);
(37B AND J_S AND T RS 25)=0=>(
NIX: (TN_TALT(TN))=>GO TO TYALT;
RETURN 0);
(J RS 6)=0=>(3 AND T LROT 5) NE 3=>GO TO NIX;
(STY AND 6)=0=>GO TO MEX;
STY=2=>(VAL_-RMATCH(T<5,20>,T<5,15>,SVAL<11,18>);
GO TO MEX);
# CHECK IF CONSTANT MATCHES REQUIREMENTS #
T<15,0>=177B=>GO TO MEX;
(MASK_((1 LS T<7,8>)-1) LS T<7,0>)=0=>GO TO MEX;
MASK_NOT MASK;
REST_0; (T AND 200B)=>REST_MASK;
(SVAL AND MASK)=REST=>GO TO MEX;
GO TO NIX);
TVAL_T AND 777777B;
TTY=0=>(VAL_TVAL; GO TO MEX);
TTY=2=>((VAL_SAMEAS(SN,TVAL))=0=>GO TO NIX; GO TO MEX);
# MATCH WITH IDENTIFIER - IF DI ENTRIES EQUAL AND NO OFFSET THEN MATCH. #
FREE(SN+2)=>GO TO NIX;
SDI=TVAL=>SVAL=0=>GO TO MEX;
(T AND 1000000B)=>STY=4=>(J_FREE(CT+TN+2);
J=SVAL=>GO TO MEX);
GO TO NIX;
MEX: (T AND 010000000000B)=>ONEWORD(SN)=0=>GO TO NIX;
VAL=0=>VAL_-1;
VAL);
SUBR ENTRCA(SEMN) IS (
# SUBROUTINE CALLED WHEN SEMN IS A CASE OF ANOTHER PRODN.
MUST COMPLETE SBITM MATRIX BY BRUTE FORCE.
USES THE UNUSED HIGH-ORDER BIT OF TYPE WORD TO MARK NODES. #
# FIRST MARK TERMINAL TREE NODES MATCHING SEMN #
ENTRNO_1;
WHILE (I_ENTRC1()) DO ([TORG1+I]<L>=100002B=>MATCHP(SEMN,I)=>
[TORG1+I]_[TORG1+I] OR 400000000000B);
# NOW MAKE MULTIPLE PASSES MARKING PREDECESSORS OF MARKED NODES
UP TO A PRODUCTION NODE #
(FLAG _0;
WHILE (I_ENTRC1()) DO ([TORG1+I] ARS 18 GT 100002B=>
(J_TSCR(I);
WHILE J DO ([TORG1+J]<0=>([TORG1+I]_[TORG1+I] OR 400000000000B;
FLAG_-1; J_0)
ELSE (J_TALT(J)))))) UNTIL FLAG=0;
# NOW CLEAR MARKER BIT, SETTING BIT MATRIX AT SAME TIME #
S_SNODEN(SEMN);
WHILE (I_ENTRC1()) DO ([TORG1+I]<0=>(
[TORG1+I]_[TORG1+I] AND NOT 400000000000B;
BITS(SBITM,TNODEN(I),S))));
SUBR ENTRC1() IS (
(J_TSCR(ENTRNO))=>(PUSHMI(ENTRNO); RETURN (ENTRNO_J));
EN1: (ENTRNO_TALT(ENTRNO))=>RETURN ENTRNO;
(ENTRNO_PULLYU(0)) NE 1=>GO TO EN1;
0);
SUBR TPRINT() IS (
LOC(TPRIN1) => J_TPRIN1(CT,NCT,SBITM,NODEN)
ELSE (TPR0CNT=0=>(TPR0CNT_1; J_0;
ERROR(2,'TPRIN1 DEBUGGING PGM NOT PRESENT')));
J) %%%