github.com/retro-software.B5500-software
1
0
Fork 0
mirror of https://github.com/retro-software/B5500-software.git synced 2026-02-03 22:42:31 +00:00
Code Issues Releases Wiki Activity

Commit original transcription of Nicklaus Wirth's EULER IV translator and interpreter, prepared and generously donated to the project by James Fehlinger, as of 2014-03-24.

Browse Source
This commit is contained in:
Paul Kimpel
2014-04-05 20:29:26 +00:00
parent 95b1cd3098
commit 2237be9923
4 changed files with 1882 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1183
source/EULER/EULERIV.alg_m Normal file
View File

File diff suppressed because it is too large Load Diff

242
source/EULER/GRAMMAR.card Normal file
View File

@@ -0,0 +1,242 @@
PROGRAM
BLOCK
BLOKHEAD
BLOKBODY
LABDEF
STAT
STAT-
EXPR
EXPR-
IFCLAUSE
TRUEPART
CATENA
DISJ
DISJHEAD
CONJ
CONJ-
CONJHEAD
NEGATION
RELATION
CHOICE
CHOICE-
SUM
SUM-
TERM
TERM-
FACTOR
FACTOR-
PRIMARY
PROCDEF
PROCHEAD
LIST*
LISTHEAD
REFERENC
NUMBER
REAL*
INTEGER*
INTEGER-
DIGIT
LOGVAL
VAR
VAR-
VARDECL
FORDECL
LABDECL
*
0
1
2
3
4
5
6
7
8
9
,
.
;
:
@
NEW
FORMAL
LABEL
IDENT*
[
]
BEGIN
END
(
)
LQ
RQ
GOTO
OUT
~
IF
THEN
ELSE
&
OR
AND
NOT
=
!
<
{
}
>
MIN
MAX
+
-
|
/
%
MOD
*
ABS
LENGTH
INTEGER
REAL
LOGICAL
LIST
TAIL
IN
ISB
ISN
ISR
ISL
ISLI
ISY
ISP
ISU
SYMBOL*
UNDEFINE
TEN
#
TRUE
FALSE
$
*
VARDECL NEW IDENT* 001
FORDECL FORMAL IDENT* 002
LABDECL LABEL IDENT* 003
VAR- IDENT* 004
VAR- VAR- [ EXPR ] 005
VAR- VAR- . 006
VAR VAR- 007
LOGVAL TRUE 010
LOGVAL FALSE 011
DIGIT 0 012
DIGIT 1 013
DIGIT 2 014
DIGIT 3 015
DIGIT 4 016
DIGIT 5 017
DIGIT 6 020
DIGIT 7 021
DIGIT 8 022
DIGIT 9 023
INTEGER- DIGIT 024
INTEGER- INTEGER- DIGIT 025
INTEGER* INTEGER- 026
REAL* INTEGER* . INTEGER* 027
REAL* INTEGER* 030
NUMBER REAL* 031
NUMBER REAL* TEN INTEGER* 032
NUMBER REAL* TEN # INTEGER* 033
NUMBER TEN INTEGER* 034
NUMBER TEN # INTEGER* 035
REFERENC @ VAR 036
LISTHEAD LISTHEAD EXPR , 037
LISTHEAD ( 040
LIST* LISTHEAD EXPR ) 041
LIST* LISTHEAD ) 042
PROCHEAD PROCHEAD FORDECL ; 043
PROCHEAD LQ 044
PROCDEF PROCHEAD EXPR RQ 045
PRIMARY VAR 046
PRIMARY VAR LIST* 047
PRIMARY LOGVAL 050
PRIMARY NUMBER 051
PRIMARY SYMBOL* 052
PRIMARY REFERENC 053
PRIMARY LIST* 054
PRIMARY TAIL PRIMARY 055
PRIMARY PROCDEF 056
PRIMARY UNDEFINE 057
PRIMARY [ EXPR ] 060
PRIMARY IN 061
PRIMARY ISB VAR 062
PRIMARY ISN VAR 063
PRIMARY ISR VAR 064
PRIMARY ISL VAR 065
PRIMARY ISLI VAR 066
PRIMARY ISY VAR 067
PRIMARY ISP VAR 070
PRIMARY ISU VAR 071
PRIMARY ABS PRIMARY 072
PRIMARY LENGTH VAR 073
PRIMARY INTEGER PRIMARY 074
PRIMARY REAL PRIMARY 075
PRIMARY LOGICAL PRIMARY 076
PRIMARY LIST PRIMARY 077
FACTOR- PRIMARY 100
FACTOR- FACTOR- * PRIMARY 101
FACTOR FACTOR- 102
TERM- FACTOR 103
TERM- TERM- | FACTOR 104
TERM- TERM- / FACTOR 105
TERM- TERM- % FACTOR 106
TERM- TERM- MOD FACTOR 107
TERM TERM- 110
SUM- TERM 111
SUM- + TERM 112
SUM- - TERM 113
SUM- SUM- + TERM 114
SUM- SUM- - TERM 115
SUM SUM- 116
CHOICE- SUM 117
CHOICE- CHOICE- MIN SUM 120
CHOICE- CHOICE- MAX SUM 121
CHOICE CHOICE- 122
RELATION CHOICE 123
RELATION CHOICE = CHOICE 124
RELATION CHOICE ! CHOICE 125
RELATION CHOICE < CHOICE 126
RELATION CHOICE { CHOICE 127
RELATION CHOICE } CHOICE 130
RELATION CHOICE > CHOICE 131
NEGATION RELATION 132
NEGATION NOT RELATION 133
CONJHEAD NEGATION AND 134
CONJ- CONJHEAD CONJ- 135
CONJ- NEGATION 136
CONJ CONJ- 137
DISJHEAD CONJ OR 140
DISJ DISJHEAD DISJ 141
DISJ CONJ 142
CATENA CATENA & PRIMARY 143
CATENA DISJ 144
TRUEPART EXPR ELSE 145
IFCLAUSE IF EXPR THEN 146
EXPR- BLOCK 147
EXPR- IFCLAUSE TRUEPART EXPR- 150
EXPR- VAR ~ EXPR- 151
EXPR- GOTO PRIMARY 152
EXPR- OUT EXPR- 153
EXPR- CATENA 154
EXPR EXPR- 155
STAT- LABDEF STAT- 156
STAT- EXPR 157
STAT STAT- 160
LABDEF IDENT* : 161
BLOKHEAD BEGIN 162
BLOKHEAD BLOKHEAD VARDECL ; 163
BLOKHEAD BLOKHEAD LABDECL ; 164
BLOKBODY BLOKHEAD 165
BLOKBODY BLOKBODY STAT ; 166
BLOCK BLOKBODY STAT END 167
PROGRAM $ BLOCK $ 170
*

24
source/EULER/SAMPLE.card Normal file
View File

@@ -0,0 +1,24 @@
BEGIN NEW FOR; NEW MAKE; NEW T; NEW A;
FOR ~ LQ FORMAL CV; FORMAL LB; FORMAL STEP; FORMAL UB; FORMAL S;
BEGIN
LABEL L; LABEL K;
CV ~ LB;
K: IF CV { UB THEN S ELSE GOTO L;
CV ~ CV + STEP;
GOTO K;
L: 0
END RQ;
MAKE ~ LQ FORMAL B; FORMAL X;
BEGIN NEW T; NEW I; NEW F; NEW L;
L ~ B; T ~ LIST L[1];
F ~ IF LENGTH L ! 1 THEN MAKE(TAIL L, X) ELSE X;
FOR (@I, 1, 1, L[1], LQ T[I] ~ F RQ);
T
END RQ;
A ~ ();
FOR (@T, 1, 1, 4, LQ BEGIN A ~ A & (T); OUT MAKE(@A,T) END RQ)
END $
DUMP

433
source/EULER/SYNTAX.alg_m Normal file
View File

@@ -0,0 +1,433 @@
BEGIN COMMENT SYNTAX-PROCESSOR. NIKLAUS WIRTH DEC.1964;
DEFINE NSY =150#; COMMENT MAX. NO. OF SYMBOLS;
DEFINE NPR =150#; COMMENT MAX. NO. OF PRODUCTIONS;
DEFINE UPTO = STEP 1 UNTIL #;
DEFINE LS = "<" #, EQ = "=" #, GR = ">" #, NULL = "" #;
FILE OUT PCH 0 (2,10); COMMENT PUNCH FILE;
INTEGER LT; COMMENT NUMBER OF LAST NONBASIC SYMBOL;
INTEGER K,M,N, MAX, OLDN; BOOLEAN ERRORFLAG;
ALPHA ARRAY READBUFFER[0:9], WRITEBUFFER[0:14];
ALPHA ARRAY TEXT[0:11]; COMMENT AUXILIARY TEXT ARRAY;
ALPHA ARRAY SYTB[0:NSY]; COMMENT SYMBOLTABLE;
INTEGER ARRAY REF[0:NPR,0:5]; COMMENT SYNTAX REFERENCE TABLE;
LABEL START,EXIT;
LABEL A,B,C,E,F,G;
STREAM PROCEDURE CLEAR(D,N); VALUE N;
BEGIN DI ~ D; DS ~ 8 LIT " "; SI ~ D; DS ~ N WDS
END;
STREAM PROCEDURE MARK(D,S); VALUE S;
BEGIN DI ~ D; SI ~ LOC S; SI ~ SI+7; DS ~ CHR
END;
BOOLEAN STREAM PROCEDURE FINIS(S);
BEGIN TALLY ~ 1; SI ~ S; IF SC = "*" THEN FINIS ~ TALLY
END;
STREAM PROCEDURE EDIT(S,D,N);
BEGIN DI ~ D; SI ~ N; DS ~ 3 DEC; SI ~ S; DS ~ 9 WDS;
END;
STREAM PROCEDURE MOVE(S,D);
BEGIN SI ~ S; DI ~ D; DS ~ WDS;
END;
STREAM PROCEDURE MOVETEXT(S,D,N); VALUE N;
BEGIN DI ~ D; SI ~ S; DS ~ N WDS;
END;
BOOLEAN STREAM PROCEDURE EQUAL(S,D);
BEGIN SI ~ S; DI ~ D; TALLY ~ 1; IF 8 SC = DC THEN EQUAL ~ TALLY;
END;
STREAM PROCEDURE SCAN(S,DD,N);
BEGIN LABEL A,B,C,D,E;
SI ~ S; DI ~ DD; DS ~ 48 LIT "0"; DI ~ DD; SI ~ SI+1;
IF SC = " " THEN DI ~ DI+8;
A: IF SC = " " THEN BEGIN SI ~ SI+1; GO TO A END;
IF SC > "9" THEN GO TO D;
8 (IF SC = " " THEN BEGIN DS ~ LIT " "; GO TO E END; DS ~ CHR; E:);
B: IF SC ! " " THEN BEGIN SI ~ SI+1; GO TO B END;
C: SI ~ SI+1; GO TO A;
D: DI ~ N; SI ~ SI+5; DS ~ 3 OCT
END;
STREAM PROCEDURE EDITTEXT(S,D,N); VALUE N;
BEGIN SI ~ S; DI ~ D; DI ~ DI+10; N(DI ~ DI+2; DS ~ 8 CHR)
END;
STREAM PROCEDURE SETTEXT(A,B,C,D,E,Z);
BEGIN DI ~ Z; DI ~ DI+8; SI ~ A; DS ~ 3 DEC; SI ~ B; DS ~ WDS;
DI ~ DI+5; SI ~ C; DS ~ 3 DEC; DI ~ DI+3; SI ~ D; DS ~ 3 DEC;
DI ~ DI+3; SI ~ E; DS ~ 3 DEC;
END;
STREAM PROCEDURE PCHTX(S,D,N); VALUE N;
BEGIN SI ~ S; DI ~ D; DI ~ DI+4;
N(DS ~ LIT """; DS ~ 8 CHR; DS ~ LIT """; DS ~ LIT ",");
END;
PROCEDURE INPUT;
READ (CARDFIL, 10, READBUFFER[*]) [EXIT];
PROCEDURE OUTPUT;
BEGIN WRITE (PRINTFIL, 15, WRITEBUFFER[*]);
CLEAR(WRITEBUFFER[0], 14);
END;
INTEGER PROCEDURE INX(X); REAL X;
BEGIN INTEGER I; LABEL F;
FOR I ~ 0 UPTO M DO
IF EQUAL(SYTB[I], X) THEN GO TO F;
WRITE (<"UNDEFINED SYMBOL">); ERRORFLAG ~ TRUE;
F: INX ~ I;
END;
START:
FOR N ~ 0 UPTO 5 DO
FOR M ~ 0 UPTO NPR DO REF[M,N] ~ 0;
M ~ N ~ MAX ~ OLDN ~ 0; ERRORFLAG ~ FALSE;
CLEAR(WRITEBUFFER[0],14);
COMMENT READ LIST OF SYMBOLS, ONE SYMBOL MUST APPEAR PER CARD,
STARTING IN COL.9 (8 CHARS. ARE SIGNIFICANT), THE LIST OF NON-
BASIC SYMBOLS IS FOLLOWED BY AN ENDCARD ("*" IN COL.1). THEN
FOLLOWS THE LIST OF BASIC SYMBOLS AND AGAIN AN ENDCARD;
WRITE (< "NONBASIC SYMBOLS:">);
A: INPUT;
IF FINIS(READBUFFER[0]) THEN GO TO E;
M ~ M+1;
MOVE(READBUFFER[1], SYTB[M]);
EDIT(READBUFFER[0], WRITEBUFFER[1], M);
OUTPUT; GO TO A;
E: WRITE (</"BASIC SYMBOLS:">); LT ~ M;
F: INPUT;
IF FINIS(READBUFFER[0]) THEN GO TO G;
M ~ M + 1;
MOVE(READBUFFER[1], SYTB[M]);
EDIT(READBUFFER[0], WRITEBUFFER[1], M);
OUTPUT; GO TO F;
COMMENT READ THE LIST OF PRODUCTIONS, ONE PER CARD. THE LEFTPART
IS A NONBASIC SYMBOL STARTING IN COL.2. NO FORMAT IS PRESCRIBED
FOR THE RIGHT PART. ONE OR MORE BLANKS ACT AS SYMBOL SEPARATORS.
IF COL.2 IS BLANK, THE SAME LEFTPART AS IN THE PREVIOUS PRODUCTION
IS SUBSTITUTED. THE MAX. LENGTH OF A PRODUCTION IS 6 SYMBOLS;
G: WRITE (</"SYNTAX:">);
B: INPUT;
IF FINIS(READBUFFER[0]) THEN GO TO C;
MOVETEXT(READBUFFER[0], WRITEBUFFER[1], 10); OUTPUT;
MARK(READBUFFER[9], 12); SCAN(READBUFFER[0],TEXT[0],N);
IF N { 0 OR N > NPR OR REF[N,0] ! 0 THEN
BEGIN WRITE (<"UNACCEPTABLE TAG">); ERRORFLAG ~ TRUE; GO TO B
END;
IF N > MAX THEN MAX ~ N;
COMMENT THE SYNTAX IS STORED IN REF, EACH SYMBOL REPRESENTED BY
ITS INDEX IN THE SYMBOL-TABLE;
FOR K ~ 0 UPTO 5 DO REF[N,K] ~ INX(TEXT[K]);
IF REF[N,0] = 0 THEN REF[N,0] ~ REF[OLDN,0] ELSE
IF REF[N,0] > LT THEN
BEGIN WRITE (<"ILLEGAL PRODUCTION">); ERRORFLAG ~ TRUE END;
OLDN ~ N; GO TO B;
C: IF ERRORFLAG THEN GO TO EXIT;
N ~ MAX;
COMMENT M IS THE LENGTH OF THE SYMBOL-TABLE, N OF THE REF-TABLE;
BEGIN COMMENT BLOCK A;
INTEGER ARRAY H[0:M, 0:M]; COMMENT PRECEDENCE MATRIX;
INTEGER ARRAY F, G [0:M]; COMMENT PRECEDENCE FUNCTIONS;
BEGIN COMMENT BLOCK B1;
INTEGER ARRAY LINX, RINX [0:LT]; COMMENT LEFT / RIGHT INDICES;
INTEGER ARRAY LEFTLIST, RIGHTLIST[0:1022];
BEGIN COMMENT BLOCK C1, BUILD LEFT- AND RIGHT-SYMBOL LISTS;
INTEGER I,J;
INTEGER SP, RSP; COMMENT STACK- AND RECURSTACK-POINTERS;
INTEGER LP, RP; COMMENT LEFT/RIGHT LIST POINTERS;
INTEGER ARRAY INSTACK[0:M];
BOOLEAN ARRAY DONE, ACTIVE [0:LT];
INTEGER ARRAY RECURSTACK, STACKMARK [0:LT+1];
INTEGER ARRAY STACK[0:1022]; COMMENT HERE THE LISTS ARE BUILT;
PROCEDURE PRINTLIST(LX,L); ARRAY LX, L [0];
BEGIN INTEGER I,J,K;
FOR I ~ 1 UPTO LT DO IF DONE[I] THEN
BEGIN K ~ 0; MOVE(SYTB[I], WRITEBUFFER[0]);
FOR J ~ LX[I],J+1 WHILE L[J] ! 0 DO
BEGIN MOVE(SYTB[L[J]], TEXT[K]); K ~ K+1;
IF K } 10 THEN
BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0],10); OUTPUT;
K ~ 0;
END;
END;
IF K > 0 THEN
BEGIN EDITTEXT(TEXT[0], WRITEBUFFER[0], K); OUTPUT END;
END
END;
PROCEDURE DUMPIT;
BEGIN INTEGER I,J; WRITE ([PAGE]);
WRITE (<X9,"DONE ACTIVE LINX RINX">);
WRITE (<5I6>, FOR I ~ 1 UPTO LT DO
[I, DONE[I], ACTIVE[I], LINX[I], RINX[I]]);
WRITE (</"STACK: SP =",I3>, SP);
WRITE (<I10,": ",10I6>, FOR I ~ 0 STEP 10 UNTIL SP DO
[I, FOR J ~ I UPTO I+9 DO STACK[J]]);
WRITE (</"RECURSTACK:">);
WRITE (<3I6>, FOR I ~ 1 UPTO RSP DO
[I, RECURSTACK[I], STACKMARK[I]]);
END;
PROCEDURE RESET(X); VALUE X; INTEGER X;
BEGIN INTEGER I;
FOR I ~ X UPTO RSP DO STACKMARK[I] ~ STACKMARK[X];
END;
PROCEDURE PUTINTOSTACK(X); VALUE X; INTEGER X;
COMMENT X IS PUT INTO THE WORKSTACK. DUPLICATION IS AVOIDED!
BEGIN IF INSTACK[X] = 0 THEN
BEGIN SP ~ SP+1; STACK[SP] ~ X; INSTACK[X] ~ SP END
ELSE IF INSTACK[X] < STACKMARK[RSP] THEN
BEGIN SP ~ SP+1; STACK[SP] ~ X;
STACK[INSTACK[X]] ~ 0; INSTACK[X] ~ SP;
END;
IF SP > 1020 THEN
BEGIN WRITE (</"STACK OVERFLOW"/>); DUMPIT; GO TO EXIT END;
END;
PROCEDURE COPYLEFTSYMBOLS(X); VALUE X; INTEGER X;
COMMENT COPY THE LIST OF LEFTSYMBOLS OF X INTO THE STACK;
BEGIN FOR X ~ LINX[X], X+1 WHILE LEFTLIST[X] ! 0 DO
PUTINTOSTACK(LEFTLIST[X]);
END;
PROCEDURE COPYRIGHTSYMBOLS(X); VALUE X; INTEGER X;
COMMENT COPY THE LIST OF RIGHTSYMBOLS OF X INTO THE STACK;
BEGIN FOR X ~ RINX[X], X+1 WHILE RIGHTLIST[X] ! 0 DO
PUTINTOSTACK(RIGHTLIST[X]);
END;
PROCEDURE SAVELEFTSYMBOLS(X); VALUE X; INTEGER X;
COMMENT THE LEFTSYMBOLLISTS OF ALL SYMBOLS IN THE RECURSTACK
WITH INDEX > X HAVE BEEN BUILT AND MUST NOW BE REMOVED, THEY ARE
COPIED INTO "LEFTLIST" AND THE SYMBOLS ARE MARKED "DONE";
BEGIN INTEGER I,J,U; LABEL L,EX;
L: IF STACKMARK[X] = STACKMARK[X+1] THEN
BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END;
STACKMARK[RSP+1] ~ SP+1;
FOR I ~ X+1 UPTO RSP DO
BEGIN LINX[RECURSTACK[I]] ~ LP+1;
ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE;
FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO
IF STACK[J] ! 0 THEN
BEGIN LP ~ LP+1; LEFTLIST[LP] ~ STACK[J];
IF LP > 1020 THEN
BEGIN WRITE (</"LEFTLIST OVERFLOW"/>); DUMPIT;
PRINTLIST(LINX, LEFTLIST); GO TO EXIT
END;
END
END;
LP ~ LP+1; LEFTLIST[LP] ~ 0;
EX: RSP ~ X;
END;
PROCEDURE SAVERIGHTSYMBOLS(X); VALUE X; INTEGER X;
COMMENT ANALOG TO "SAVELEFTSYMBOLS";
BEGIN INTEGER I,J; LABEL L,EX;
L: IF STACKMARK[X] = STACKMARK[X+1] THEN
BEGIN X ~ X+1; IF X < RSP THEN GO TO L ELSE GO TO EX END;
STACKMARK[RSP+1] ~ SP+1;
FOR I ~ X+1 UPTO RSP DO
BEGIN RINX[RECURSTACK[I]] ~ RP+1;
ACTIVE[RECURSTACK[I]] ~ FALSE; DONE[RECURSTACK[I]] ~ TRUE;
FOR J ~ STACKMARK[I] UPTO STACKMARK[I+1]-1 DO
IF STACK[J] ! 0 THEN
BEGIN RP ~ RP+1; RIGHTLIST[RP] ~ STACK[J];
IF RP > 1020 THEN
BEGIN WRITE (</"RIGHTLIST OVERFLOW"/>); DUMPIT;
PRINTLIST(RINX,RIGHTLIST); GO TO EXIT
END;
END
END;
RP ~ RP+1; RIGHTLIST[RP] ~ 0;
EX: RSP ~ X;
END;
PROCEDURE BUILDLEFTLIST(X); VALUE X; INTEGER X;
COMMENT THE LEFTLIST OF THE SYMBOL X IS BUILT BY SCANNING THE
SYNTAX FOR PRODUCTIONS WITH LEFTPART = X. THE LEFTMOST SYMBOL IN
THE RIGHTPART IS THEN INSPECTED: IF IT IS NONBASIC AND NOT MARKED
DONE, ITS LEFTLIST IS BUILT FIRST. WHILE A SYMBOL IS BEING INSPECTED
IT IS MARKED ACTIVE;
BEGIN INTEGER I,R,OWNRSP;
ACTIVE[X] ~ TRUE;
RSP ~ OWNRSP ~ LINX[X] ~ RSP+1;
RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1;
FOR I ~ 1 UPTO N DO
IF REF[I,0] = X THEN
BEGIN IF OWNRSP < RSP THEN SAVELEFTSYMBOLS(OWNRSP);
R ~ REF[I,1]; PUTINTOSTACK(R);
IF R { LT THEN
BEGIN IF DONE[R] THEN COPYLEFTSYMBOLS(R) ELSE
IF ACTIVE[R] THEN RESET(LINX[R]) ELSE
BUILDLEFTLIST(R);
END
END;
END;
PROCEDURE BUILDRIGHTLIST(X); VALUE X; INTEGER X;
COMMENT ANALOG TO "BUILDLEFTLIST";
BEGIN INTEGER I,R,OWNRSP; LABEL QQ;
ACTIVE[X] ~ TRUE;
RSP ~ OWNRSP ~ RINX[X] ~ RSP+1;
RECURSTACK[RSP] ~ X; STACKMARK[RSP] ~ SP+1;
FOR I ~ 1 UPTO N DO
IF REF[I,0] = X THEN
BEGIN IF OWNRSP < RSP THEN SAVERIGHTSYMBOLS(OWNRSP);
FOR R ~ 2,3,4,5 DO IF REF[I,R] = 0 THEN GO TO QQ;
QQ: R ~ REF[I,R-1]; PUTINTOSTACK(R);
IF R { LT THEN
BEGIN IF DONE[R] THEN COPYRIGHTSYMBOLS(R) ELSE
IF ACTIVE[R] THEN RESET(RINX[R]) ELSE
BUILDRIGHTLIST(R);
END
END
END;
SP ~ RSP ~ LP ~ 0;
FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE;
FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN
BEGIN SP ~ RSP ~ 0;
FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0;
BUILDLEFTLIST(I); SAVELEFTSYMBOLS(0);
END;
WRITE ([PAGE]); WRITE (<X20,"*** LEFTMOST SYMBOLS ***"/>);
PRINTLIST(LINX, LEFTLIST);
SP ~ RSP ~ RP ~ 0;
FOR I ~ 1 UPTO LT DO DONE[I] ~ FALSE;
FOR I ~ 1 UPTO LT DO IF NOT DONE[I] THEN
BEGIN SP ~ RSP ~ 0;
FOR J ~ 1 UPTO M DO INSTACK[J] ~ 0;
BUILDRIGHTLIST(I); SAVERIGHTSYMBOLS(0);
END;
WRITE ([3]); WRITE (<X20,"*** RIGHTMOST SYMBOLS ***"/>);
PRINTLIST(RINX, RIGHTLIST);
END BLOCK C1;
BEGIN COMMENT BLOCK C2, BUILD PRECEDENCE RELATIONS;
INTEGER J,K,P,Q,R,L,T;
LABEL NEXTPRODUCTION;
PROCEDURE ENTER(X,Y,S); VALUE X,Y,S; INTEGER X,Y,S;
COMMENT ENTER THE RELATION S INTO POSITION [X,Y]. CHECK FOR DOUBLE-
OCCUPATION OF THIS POSITION;
BEGIN T ~ H[X,Y]; IF T ! NULL AND T ! S THEN
BEGIN ERRORFLAG ~ TRUE;
WRITE (<"PRECEDENCE VIOLATED BY ",2A1," FOR PAIR",2I4,
" BY PRODUCTION",I4>, T, S, X, Y, J);
END;
H[X,Y] ~ S;
END;
WRITE ([PAGE]);
FOR K ~ 1 UPTO M DO
FOR J ~ 1 UPTO M DO H[K,J] ~ NULL;
FOR J ~ 1 UPTO N DO
BEGIN FOR K ~ 2,3,4,5 DO IF REF[J,K] ! 0 THEN
BEGIN P ~ REF[J,K-1]; Q ~ REF[J,K];
ENTER(P,Q,EQ);
IF P { LT THEN
BEGIN FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO
ENTER(RIGHTLIST[R],Q,GR);
IF Q { LT THEN
FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO
BEGIN ENTER(P, LEFTLIST[L], LS);
FOR R ~ RINX[P],R+1 WHILE RIGHTLIST[R] ! 0 DO
ENTER(RIGHTLIST[R],LEFTLIST[L],GR)
END
END
ELSE IF Q { LT THEN
FOR L ~ LINX[Q],L+1 WHILE LEFTLIST[L] ! 0 DO
ENTER(P, LEFTLIST[L], LS);
END
ELSE GO TO NEXTPRODUCTION;
NEXTPRODUCTION: END J;
WRITE (</X3,39I3/>, FOR J ~ 1 UPTO M DO J);
FOR K ~ 1 STEP 1 UNTIL M DO
WRITE (</X3,39(X2,A1)/>, FOR J ~ 1 UPTO M DO H[K,J]);
END BLOCK C2;
END BLOCK B1;
IF ERRORFLAG THEN GO TO EXIT;
WRITE (</"SYNTAX IS A PRECEDENCE GRAMMAR"/>);
BEGIN COMMENT BLOCK B2. BUILD F AND G PRECEDENCE FUNCTIONS;
INTEGER I, J, K,K1, N, FMIN, GMIN, T;
PROCEDURE THRU(I,J,X); VALUE I,J,X; INTEGER I,J,X;
BEGIN WRITE (</"NO PRIORITY FUNCTIONS EXIST ",3I6>, I,J,X);
GO TO EXIT
END;
PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X; FORWARD;
PROCEDURE FIXUPROW(I,L,X); VALUE I,L,X; INTEGER I,L,X;
BEGIN INTEGER J; F[I] ~ G[L] + X;
IF K1 = K THEN
BEGIN IF H[I,K]= EQ AND F[I] ! G[K] THEN THRU(I,K,0) ELSE
IF H[I,K]= LS AND F[I] } G[K] THEN THRU(I,K,0)
END;
FOR J ~ K1 STEP -1 UNTIL 1 DO
IF H[I,J]= EQ AND F[I] ! G[J] THEN FIXUPCOL(I,J,0) ELSE
IF H[I,J]= LS AND F[I] } G[J] THEN FIXUPCOL(I,J,1);
END;
PROCEDURE FIXUPCOL(L,J,X); VALUE L,J,X; INTEGER L,J,X;
BEGIN INTEGER I; G[J] ~ F[L] + X;
IF K1 ! K THEN
BEGIN IF H[K,J] = EQ AND F[K] ! G[J] THEN THRU(K,J,1) ELSE
IF H[K,J] = GR AND F[K] { G[J] THEN THRU(K,J,1)
END;
FOR I ~ K STEP -1 UNTIL 1 DO
IF H[I,J] = EQ AND F[I] ! G[J] THEN FIXUPROW(I,J,0) ELSE
IF H[I,J] = GR AND F[I] { G[J] THEN FIXUPROW(I,J,1);
END;
K1 ~ 0;
FOR K ~ 1 UPTO M DO
BEGIN FMIN ~ 1;
FOR J ~ 1 UPTO K1 DO
IF H[K,J] = EQ AND FMIN < G[J] THEN FMIN ~ G[J] ELSE
IF H[K,J] = GR AND FMIN { G[J] THEN FMIN ~ G[J]+1;
F[K] ~ FMIN;
FOR J ~ K1 STEP -1 UNTIL 1 DO
IF H[K,J] = EQ AND FMIN > G[J] THEN FIXUPCOL(K,J,0) ELSE
IF H[K,J] = LS AND FMIN } G[J] THEN FIXUPCOL(K,J,1);
K1 ~ K1+1; GMIN ~ 1;
FOR I ~ 1 UPTO K DO
IF H[I,K]= EQ AND F[I] > GMIN THEN GMIN ~ F[I] ELSE
IF H[I,K]= LS AND F[I] } GMIN THEN GMIN ~ F[I]+1;
G[K] ~ GMIN;
FOR I ~ K STEP -1 UNTIL 1 DO
IF H[I,K] = EQ AND F[I] < GMIN THEN FIXUPROW(I,K,0) ELSE
IF H[I,K] = GR AND F[I] { GMIN THEN FIXUPROW(I,K,1);
END K;
END BLOCK B2;
WRITE ([PAGE]);
BEGIN COMMENT BLOCK B3. BUILD TABLES OF PRODUCTION REFERENCES;
INTEGER I,J,K,L;
INTEGER ARRAY MTB[0:M]; COMMENT MASTER TABLE;
INTEGER ARRAY PRTB[0:1022]; COMMENT PRODUCTION TABLE;
L ~ 0;
FOR I ~ 1 UPTO M DO
BEGIN MTB[I] ~ L+1;
FOR J ~ 1 UPTO N DO
IF REF[J,1] = I THEN
BEGIN FOR K ~ 2,3,4,5 DO
IF REF[J,K] ! 0 THEN
BEGIN L ~ L+1; PRTB[L] ~ REF[J,K]
END;
L ~ L+1; PRTB[L] ~ -J; L ~ L+1; PRTB[L] ~ REF[J,0];
END;
L ~ L+1; PRTB[L] ~ 0
END;
COMMENT PRINT AND PUNCH THE RESULTS:
SYMBOLTABLE, PRECEDENCE FUNCTIONS, SYNTAX REFERENCE TABLES;
WRITE (<X8,"NO.",X5,"SYMBOL",X8, "F",X5,"G",X4,"MTB"/>);
FOR I ~ 1 UPTO M DO
BEGIN SETTEXT(I,SYTB[I],F[I],G[I], MTB[I], WRITEBUFFER[0]);
OUTPUT
END;
WRITE (</"PRODUCTION TABLE:"/>);
FOR I ~ 0 STEP 10 UNTIL L DO
WRITE (<I9,X2,10I6>, FOR I ~ 0 STEP 10 UNTIL L DO
[I, FOR J ~ I UPTO I+9 DO PRTB[J]]);
WRITE (</"SYNTAX VERSION ",A5>, TIME(0));
WRITE (PCH, <X4,"FT ~",I3,"; LT ~",I4,"; LP ~",I4,";">,LT+1,M,L);
FOR I ~ 1 STEP 6 UNTIL M DO
BEGIN PCHTX(SYTB[I], WRITEBUFFER[0], IF M-I } 6 THEN 6 ELSE M-I+1);
WRITE (PCH,10,WRITEBUFFER[*]); CLEAR(WRITEBUFFER[0],9)
END;
WRITE (PCH, <X4,12(I4,",")>, FOR I ~ 1 UPTO M DO F[I]);
WRITE (PCH, <X4,12(I4,",")>, FOR I ~ 1 UPTO M DO G[I]);
WRITE (PCH, <X4,12(I4,",")>, FOR I ~ 1 UPTO M DO MTB[I]);
WRITE (PCH, <X4,12(I4,",")>, FOR I ~ 1 UPTO L DO PRTB[I]);
END BLOCK B3
END BLOCK A;
EXIT:
END.