|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 122716 (0x1df5c)
Types: TextFile
Names: »BOBS.PAS«
└─⟦7d3116ab8⟧ Bits:30010531 BOBS Sourcer RTP25,RTP11,RTP86,RTP ASN1 grammatikken DVBS1.SW2114.src.2.6-9 BB920506
└─⟦this⟧ »SRC\BOBS.PAS«
\r
(*B O B S - SYSTEM *)\r
(*PARSER GENERATOR *)\r
(* *)\r
(* UNIVERSITY OF AARHUS, DENMARK *)\r
(* *)\r
(* AUTHORS: *)\r
(* SQREN HENRIK ERIKSEN *)\r
(* BENT BAEK JENSEN *)\r
(* BENT BRUUN KRISTENSEN *)\r
(* OLE LEHRMANN MADSEN *)\r
(* *)\r
(* VERSION: MARCH 1977 *)\r
(* THIS VERSION CORRESPONS TO THE MANUAL: *)\r
(* "THE B O B S - SYSTEM" *)\r
(* DAIMI PB-71. FIRST PRINTING *)\r
(* DEPT. OF COMPUTER SCIENCE, UNIVERSITY OF AARHUS, *)\r
(* NY MUNKEGADE, DK8000 AARHUS C, DENMARK. *)\r
(* *)\r
(* THIS PROGRAM WAS ORIGINALLY IMPLEMENTED IN THE FIRST VERSION OF *)\r
(* PASCAL RELEASED FROM N.WIRTH. THIS IMPLEMENTATION WAS FULFILLED IN *)\r
(* MARCH 1972. SINCE THEN, THE SYSTEM HAS BEEN CHANGED IN SEVERAL WAYS.*)\r
(* AMONG OTHERS, IT HAS BEEN CONVERTED INTO STANDARD PASCAL. *)\r
(* THE SYSTEM IS INTENDED TO BE PORTABLE, HOWEVER THERE IS NO GUARANTEE*)\r
(* FOR THIS. YOU SHOULD BE AWARE OF (AT LEAST) THE FOLLOWING THINGS: *)\r
(*- THE TYPE CHAR, - THE TYPE ALFA, - THE MAXIMUM SIZE OF SETS. *)\r
(*SEE THE CONSTANTS: MINCH,MAXCH,SETMAX,ALFALENGTH IN THE PROGRAM. *)\r
(*THESE CONSTANTS SHOULD EASE MOVING THE SYSTEM. NOTE, IF YOU CHANGE *)\r
(*THE CONSTANT ALFALENGTH, YOU MAY HAVE PROBLEMS WITH STRINGS. *)\r
(* *)\r
(* DUE TO THE MANY CHANGES IN THE SYSTEM, THE PROGRAMMING IS NOT SO *)\r
(* NICE AS WE WOULD LIKE IT TO BE. YOU SHOULD NOT TRY TO MAKE CHANGES *)\r
(* YOURSELF. IF YOU FIND ERRORS OR 'OTHERS' YOU MAY WISH TO CHANGE, *)\r
(* PLEASE WRITE TO US. WRITE IN ANY CASE AND TELL US WHAT PROBLEMS *)\r
(* YOU HAD IN GETTING THE SYSTEM TO RUN. *)\r
(* NOTE: WE CANNOT GUARANTEE ANY SUPPORT OF THE SYSTEM . *)\r
(* *)\r
\r
\r
program bobs(parsin = 'bobsparsin',parsout = 'bobsparsout',tables = 'bobstables',input,output);\r
\r
label 999;\r
const\r
listoption = 99; (* option(99) = list.yes or no *)\r
const1 = 350; (* maximum number of productions *)\r
const2 = 286; (* maximum number of terminal and nonterminal symbols *)\r
const3 = 50; (* maximum size of array fcq *)\r
const4 = 6500; (* maximum size of array rhs *)\r
const5 = 63; (* maximum number of elements in a basis set of an lr(0) table *)\r
const6 = 6000; (* maximum value of 'frekvens' *)\r
const7 = 1500; (* maximum size of final parse tables *)\r
const8 = 100; (* maximum number of lookahead elements of a nonterminal *)\r
const9 = 800; (* maximum size of array stack in procedure lr0 *)\r
const10 = 800; (* maximum number of parse tables *)\r
const11 = 130; (* maximum number of nonterminals *)\r
const12 = 300; (* maximum number of terminals *)\r
const13 = 1; (* = const2 div (setmax + 1) *)\r
const14 = 15; (* maximum size of a parse table *)\r
const16 = 1200; (* maximum size of array ll in procedure lalrlookahead\r
notice: const16 > const2 *)\r
const18 = 99; (* maximum number of options *)\r
const19 = 4500; (* max size of array labelbuf - sum of length\r
of all production labels ( options[34]) *)\r
\r
minch=' '; maxch='~'; (*THE FIRST/LAST CHAR IN TYPE CHAR*)\r
setmax=143; (*MAX. VALUE OF INTEGERS IN A SET *)\r
alfalength=18; (* NO. OF CHARS IN TYPE ALFA *)\r
alf3=55; (*MUST BE 3*ALFALENGTH+1 *)\r
\r
rhsnil=0; (*THE EMPTY REFERENCE OF CHAINS IN RHS*)\r
blank=' ';\r
version = 'bobs8000 version 1988.02.16';\r
\r
type\r
alfa = packed array [1..alfalength] of char;\r
rtype=record r: array[0..const13] of set of 0..setmax end;\r
pointer=^konfigt;\r
pointer1= ^ nontelm;\r
nontelm= packed\r
record word1,word2,word3: alfa;\r
rlink,llink: pointer1;\r
nontermvaerdi: 0..const2;\r
end;\r
pointer2=0..const4;\r
termpointer= ^ termelm;\r
termelm= packed\r
record niveaup,higherp: termpointer;\r
intern: -1..const2;\r
tegn: char;\r
ok: boolean;\r
end;\r
prodtype=packed\r
record leftside: 0..const2;\r
start: pointer2;\r
lookbackp: pointer;\r
laengde: 0..15;\r
end;\r
entrytyp=packed\r
record termp: termpointer;\r
intern1: -1..const2;\r
ok1: boolean;\r
end;\r
\r
bitmatrix=array[0..const2]of rtype;\r
modetype=0..15;\r
konfigt= packed record\r
derivp,nextp: pointer;\r
case mode: modetype of\r
1,2,3,4: (inf:0..const2; xprodnr, prodnr:0..const1);\r
5: (lookbp: pointer);\r
end;\r
erastype=(firsttim,finish);\r
chtype=(alfanum,special,sep);\r
dayfilemsg=packed array[1..40] of char;\r
var\r
entry: array[char] of entrytyp;\r
rhs: array[pointer2] of packed\r
record symbol: 0..const2;\r
parserp: pointer;\r
link: pointer2;\r
basisl: 1..const5;\r
basis: boolean;\r
first:0..const19; length:0..100;\r
(*ADDRESS OF PRODUCTION LABEL IN LABELBUF (OPTIONS[34])*)\r
end;\r
firstleftside, lastleftside : 0..const2; (* used to link 'help' in input sequence *)\r
lefthelp :array[0..const2] of pointer2;\r
prod:array[0..const1] of prodtype;\r
help:array[0..const2] of packed\r
record afledt,overgang: boolean;\r
prodindex: 0..const1; (* also used as 0..const2 during init *)\r
rightp: pointer2;\r
status: erastype;\r
term: boolean;\r
end;\r
tilstand:array[0..const10] of \r
record\r
errorno: 0..const10;\r
oldstart: pointer; newstart: 0..const7;\r
end;\r
internrep:array[-1..const2] of alfa;\r
buffer,buf: array[1..alf3] of char;\r
metasymbol: array[1..4] of char;\r
husk:array[1..const2] of integer;\r
husknonterm:array[0..const2] of packed\r
record nontermp: pointer1;\r
leftboo,rightboo: boolean;\r
end;\r
m:array[0..4] of alfa;\r
\r
emptyvalue,errorval,nameval,cstval,stringval : integer;\r
stringch: char;\r
\r
last,first,dynp,statp: pointer1;\r
point,huskp,helpp,top: pointer2;\r
termtop,gl,gn,gc,gs,go: termpointer;\r
\r
chgroup: array[char] of chtype;\r
ch,s: char;\r
\r
alfav,metavar: alfa;\r
internv: 0..const2;\r
antalprod,antaltilst,lalaengde,tilstnr,lbbegin,lbend,trmax,\r
nontslut,nontstart,\r
k,j,i,tal,count,goalhusk,empty,kkk,\r
termantal,termrep,symb,termg,optno: integer;\r
error,nontermboo,goaltest,emptyboo,goalboo,errorboo,venstreboo,\r
nboo1,nboo2,noword,firstboo,error1,error2,error3: boolean;\r
\r
rodp,begintilst,lqbep,classtop,gemp,oldp,freeptr: pointer;\r
\r
parsin,parsout,tables: text;\r
\r
fcq: array[1..const3] of\r
packed record\r
udgang: pointer;\r
frekvens : 0..const6;\r
end;\r
fcqi :integer;\r
(* FCQ AND FCQI ARE USED IN PROCEDURE\r
REMEMBER AND OPTIMIZE, *)\r
pt1s,ph1s: bitmatrix ;\r
options: array[1..const18] of boolean;\r
listing : boolean; (* listing = options(listoption), default=no *)\r
oldch : integer; (* 0 after readln, else ord(ch) *)\r
\r
\r
combegin,comlength : integer ;\r
comend : packed array[1..alfalength] of char ;\r
\r
(*VARIABLES TO STORE AND READ PRODUCTION LABELS (OPTIONS[33,34])*)\r
labelbuf: packed array[0..const19] of char;\r
linx: 0..const19;\r
prodseqno: integer;\r
\r
(*----------------------------------------------------------*)\r
\r
procedure msg(m: dayfilemsg);\r
(* WRITES A MESSAGE IN THE KRONOS DAYFILE *)\r
(* THIS PROCEDURE MAY BEE REMOVED *)\r
begin\r
(* message(m); *)\r
end;\r
\r
function lf:char;\r
begin\r
writeln; lf:=' ';\r
end; (*LF*)\r
\r
procedure outterminal; forward;\r
\r
procedure outgrammar; forward;\r
\r
procedure stop(n:integer);\r
(* ALL ABNORMAL TERMINATION IS THROUGH THIS PROCEDURE*)\r
begin\r
case n of\r
0: (*MISCELLANEOUS*);\r
1: (*CONSTERROR*);\r
2: (*ERROR(S) IN INPUT*);\r
3: (*ERROR(S) IN GRAMMAR*)\r
begin outgrammar;\r
writeln(' -ERROR(S) IN GRAMMAR ');\r
msg('=ERROR(S) IN GRAMMAR');\r
end;\r
4: (*NOT SLR/LALR(1) *);\r
5: (*ERRONEOUS PARSIN FILE*)\r
end;\r
goto 999;\r
end;(*STOP*)\r
\r
procedure constval(c:integer; var r:alfa);\r
var\r
gem:array[0..20] of char;\r
a,b,j:integer;\r
d:alfa;\r
begin\r
if c<1000000 then\r
begin\r
a:=c;gem[11]:=')';\r
for j:=12 to 20 do gem[j]:=' ';\r
j:=10;\r
repeat\r
b:=a mod 10;\r
a:=a div 10;\r
gem[j]:=chr(ord('0')+b);\r
j:=j-1;\r
until a=0;\r
gem[j]:='(';\r
pack(gem,j,d);\r
r:=d;\r
end else r:='(********)';\r
end;\r
\r
procedure consterror(s1,s2:alfa; cc:integer);\r
var aa:alfa;\r
m: array[1..4] of alfa;\r
ms: dayfilemsg;\r
i,j: integer;\r
begin\r
write(lf,lf,' error in ', s1, s2, 'too small (= ',cc:1, ')' );\r
constval(cc,aa);\r
m[1]:=s2; m[3]:=aa;\r
m[2]:=' TO SMALL '; m[4]:=' ';\r
for i:=1 to 4 do\r
for j:=1 to 10 do ms[(i-1)*10+j]:=m[i,j];\r
msg(ms);\r
stop(0)\r
end;\r
\r
procedure allocate(var p:pointer2);\r
begin\r
if p >= const4 then consterror('ALLOCATE','CONST4 ',const4);\r
p:=p+1;\r
end; (*ALLOCATE*)\r
\r
procedure newelm(var top:pointer2; rname:alfa);\r
begin\r
if top >= const4 then consterror(rname,'CONST4',const4);\r
top:=top+1;\r
end; (*NEWELM*)\r
\r
function testch(ch1,ch2: char): boolean;\r
(* USED BY TERMINPUT AND TERMINAL *)\r
begin\r
testch:=(chgroup[ch1]=chgroup[ch2]) and (chgroup[ch2]<>sep)\r
(*TRUE- IF CH1 AND CH2<>SEP AND IN SAME GROUP OF CHARS *)\r
or\r
options[5] and (chgroup[ch1]<>sep) and (chgroup[ch2]<>sep);\r
(*TRUE- IF OPTIONS[5] AND CH1,CH2<>SEP *)\r
end; (*TESTCH*)\r
\r
procedure inch; forward;\r
\r
(*dollar-f*)\r
procedure terminput;\r
label 22,10,11,12;\r
(*INDLAESNING AF TERMINALER ADSKILT MED SPACE EL. EOL\r
OG AFSLUTTET MED METASYMBOL 4 *)\r
var\r
c: array[1..alfalength] of char;\r
runp,gemp:termpointer;\r
alfac,emptyalfa,namealfa,cstalfa,stringalfa,erroralfa: alfa;\r
stoperror: boolean;\r
\r
procedure inputerror(nr:integer);\r
(* ERROR-PROCEDURE LOCAL FOR TERMINPUT*)\r
var\r
j:integer;\r
begin\r
if odd(nr) then write(lf,' ');\r
case nr of\r
1: write(' *** end of file encountered. ');\r
2: begin write(lf,' '); write(' *** TERMINAL DUPLICATED.');\r
end;\r
3: consterror('TERMINPUT ','CONST12 ',const12);\r
6: begin stoperror:= true;\r
repeat inch until ch=' '; write(lf,' ');\r
write(' *** TERMINAL MORE THAN ',alfalength:2,' CHARACTERS.');\r
write(lf,' ');;\r
end;\r
7: consterror('TERMINPUT ','CONST2 ',const2);\r
4: begin stoperror:= true;\r
repeat inch until ch=' '; write(lf,' ');\r
write(' *** ILLEGAL CONCATENATION.');\r
end;\r
end;\r
(* VED ULIGE NR. HELT UD- ELLERS HUSK FEJLEN *)\r
if (nr in [1 ]) then msg('=ERROR(S) IN INPUT ');\r
write(lf,' ');\r
if odd(nr) then stop(0);\r
end;\r
\r
procedure fresh;\r
(* NY CELLE I TERMTREE ALLOCERES OG INITIALISERES *)\r
begin new(termtop);\r
if termtop=nil then inputerror(3);\r
with termtop^ do\r
begin ok:= false; tegn:=ch;intern:=-1;\r
niveaup:= nil; higherp:= nil;\r
end;\r
trmax:=trmax+1; (*USED IN PROCEDURE FINALPARSER*)\r
end;\r
\r
begin\r
(* INITIALISERING *)\r
trmax:=0; (*SEE PROCEDURE FRESH*)\r
for ch:= minch to maxch do\r
with entry[ch] do\r
begin termp:= nil; ok1:= false; intern1:=-1 end;\r
errorval:=0;\r
erroralfa:='ERROR ';\r
emptyvalue:= 0;\r
emptyalfa:= 'EMPTY ';\r
nameval:= 0;\r
namealfa:= 'NAME ';\r
cstval:= 0;\r
cstalfa:= 'KONST ';\r
stringval:= 0;\r
stringalfa:= 'STRING ';\r
stringch:=' ';\r
gl:= nil; gn:= nil; gc:= nil; gs:=nil; go:=nil;\r
termantal:=1;\r
stoperror:= false;\r
(* LQKKE SAALAENGE FLERE TERMINALER *)\r
ch:=s;\r
while ch=' ' do inch;\r
while ch<>metasymbol[4] do\r
begin c[1]:=ch; i:=1;inch;\r
(* LQKKE -SAALAENGE NAESTE CHAR-VAERDI GODKENDT *)\r
while ((ch<>metasymbol[4]) and testch(c[i],ch)) do\r
begin\r
if (i=alfalength) and not options[4] then inputerror(6);\r
if i<alfalength then\r
begin i:=i+1;\r
c[i]:=ch;\r
end;\r
(* NAESTE CHAR-V. SQGES I ALLEREDE OPBYGGET TRAE *)\r
if i=2 then\r
with entry[c[1]] do\r
begin if termp=nil then\r
begin fresh;termp:=termtop;\r
gemp:= termtop; goto 10;\r
end else runp:= termp;\r
end else\r
with gemp^ do\r
begin if higherp=nil then\r
begin fresh; higherp:=termtop;\r
gemp:= termtop; goto 10;\r
end else runp:= higherp;\r
end;\r
while runp^.tegn<>ch do\r
with runp^ do\r
begin if niveaup=nil then goto 11;\r
runp:= niveaup;\r
end;\r
gemp:= runp;\r
if i<>i then 11:\r
(* CHAR NOT FOUND - NY CELLE OPRETTES *)\r
begin fresh;\r
runp^.niveaup:= termtop;\r
gemp:= termtop;\r
end;\r
10: inch;\r
end;\r
if ((ch=' ') or (ch=metasymbol[4])) then\r
begin\r
if options[3] and (ch=' ') then\r
begin inch;\r
if ch= metasymbol[1] then\r
begin inch; goto 12 end;\r
end;\r
(* NY TERMINAL REGISTRERES - TEST FOR GENGANGERI *)\r
if termantal<const2 then termantal:=termantal+1 else inputerror(7);\r
12: (*GOTO 12 LIG NY TERMINAL IKKE NYT NUMMER*)\r
if i=1 then\r
with entry[c[1]] do\r
begin intern1:= termantal;\r
if ok1 then inputerror(2) else ok1:= true;\r
end else\r
with gemp^ do\r
begin intern:= termantal;\r
if ok then inputerror(2) else ok:= true;\r
end;\r
(* TERMINAL PAKKES OG GEMMES- TEST FOR EVT. EMPTY-TERMINAL *)\r
for i:=i+1 to alfalength do c[i]:= ' ';\r
pack(c,1,alfac);\r
if erroralfa=alfac then begin errorval:=termantal; go:=termtop; end else\r
if emptyalfa= alfac then begin emptyvalue:=termantal;gl:=termtop end else\r
if namealfa=alfac then begin nameval:=termantal;gn:=termtop end else\r
if cstalfa=alfac then begin cstval:=termantal;gc:=termtop end else\r
if stringalfa=alfac then begin stringval:= termantal;gs:= termtop end;\r
internrep[termantal] := alfac;\r
end else inputerror(4);\r
22: while ch=' ' do inch;\r
end;\r
inch;\r
internrep[0]:= 'BOBS-GO';\r
internrep[1]:='-EOF- ';\r
if options[1] then outterminal;\r
if stoperror then\r
begin\r
msg('=ERROR(S) IN INPUT ');\r
stop(0);\r
end;\r
end;\r
(*----------------------------------------------------------*)\r
\r
\r
procedure outterminal;\r
(* OUTPUT THE INTERN VALUES OF TERMINALS *)\r
var\r
i: integer;\r
begin\r
write(lf,lf,lf);\r
write(' TERMINAL INTERN VAERDI');\r
write(lf,lf);\r
for i:= 0 to termantal do write(' ',internrep[i],blank,i,lf);\r
write(lf,lf,' ');\r
end; (*OUTTERMINAL*)\r
\r
procedure gramerror(a : integer);\r
forward;\r
\r
\r
(*----------------------------------------------------------*)\r
procedure terminal;\r
(* KALDES MED CHAR-VALUE I CH; LEVERER I TERMREP DEN INTERNE\r
REPRAESENTATION AF NAESTE TERMINAL PAA INPUT-\r
HVIS EN FINDES- ELLERS -1 *)\r
label 77,88;\r
var\r
buf: array[1..alf3] of char;\r
gemp,runp: termpointer;\r
\r
procedure inputerror(nr:integer);\r
(* ERROR-PROC. LOCAL FOR TERMINAL *)\r
var\r
j:integer;\r
begin\r
errorboo:=true; error2:=true;\r
case nr of\r
6:begin error:=true;termrep:=0;\r
write(lf,' '); write(' *** ILLEGAL TERMINAL.');\r
write(lf,lf,' ');\r
gramerror(23); (*GOTO88;*)\r
end;\r
end;\r
end;\r
\r
function metach(ch:char):boolean;\r
var\r
b:boolean;\r
j:integer;\r
begin b:= false;\r
for j:=1 to 4 do b:=(b or (ch=metasymbol[j]));\r
metach:= b;\r
end; (*METACH*)\r
\r
begin\r
(* IN DEC 10 PASCAL, JUMPS OUT OF A PROCEDURE ARE NOT ALLOWED *)\r
(* INPUTERROR(6) SHOULD TERMINATE BY GOTO 88; THIS IS INSTEAD *)\r
(* SIMULATED BY LABEL 77 AND GOTO 77 *)\r
while ch=' ' do inch;\r
i:=2; buf[1]:=ch; inch; buf[2]:=ch;\r
while testch(buf[i-1],ch) and not metach(ch) do\r
(* NAESTE CHAR-VAL. TESTES;OPSAMLING ELLER UDSPRING *)\r
begin\r
if i=2 then\r
with entry[buf[1]] do\r
if termp=nil then goto 77 else runp:= termp else\r
with gemp^ do\r
if higherp=nil then goto 77 else runp:= higherp;\r
while runp^.tegn<>ch do\r
with runp^ do\r
begin\r
if niveaup=nil then goto 77;\r
runp:= niveaup;\r
end;\r
gemp:= runp;\r
inch; if i< (alf3-1) then begin i:=i+1; buf[i]:= ch; end;\r
end;\r
(* OPSAMLET ALFA-VAERDI TESTES SOM TERMINAL *)\r
if i=2 then\r
with entry[buf[1]] do\r
if ok1 then termrep:= intern1 else goto 77 else\r
with gemp^ do\r
if ok then termrep:= intern else goto 77;\r
while false do 77 : inputerror(6);\r
88: ;\r
end;\r
(* SLUT PROCEDURE TERMINAL *)\r
(*----------------------------------------------------------*)\r
\r
\r
procedure space;\r
forward;\r
\r
\r
procedure nterminal(var meta : char);\r
forward;\r
\r
procedure fejl( i : integer);\r
begin write(lf); if not (i in [8,9,12,13]) then write(lf); write(' *** ');\r
case i of\r
1 : write(' EOF ENCOUNTERED IN READING THE GRAMMAR');\r
2 : write(' = EXPECTED IN GOALSYMBOLCARD');\r
3 : write(' GOALSYMBOLCARD EXPECTED');\r
4 : write(' EMPTY IS NOT THE ONLY SYMBOL IN RIGHTSIDE');\r
5 : write(' ERROR(S) IN METASYMBOLS');\r
6 : write(' METASYMBOLCARD EXPECTED');\r
7 : consterror('INGRAMMAR ','CONST2',const2);\r
8 : write(' AN ALTERNATIVE ON A RIGHTSIDE HAS NO SYMBOLS');\r
9 : write(' THE STRING-ESCAPE CHAR MUST APPEAR IN THE LIST OF TERMINALS');\r
10 : write(' TWO OR MORE METASYMBOLS ARE ALIKE');\r
17 : write(' ERROR(S) IN STRINGCARD ');\r
18 : write(' TOO LONG NONTERMINAL ');\r
19 : write(' TOO LONG RIGHTSIDE (MAX 15) ');\r
\r
11 : write(' INPUT FILE EMPTY ');\r
12 : write(' METASYMBOL 3 APPEARS IN WRONG CONTEXT');\r
13 : write(' METASYMBOL 1 WAS EXPECTED');\r
14 : consterror('INGRAMMAR ','CONST11 ',const11);\r
15: write(' ILLEGAL CHARACTER IN OPTION LIST');\r
16: write(' OPTION NUMBER IS NOT DEFINED');\r
20: write(' METASYMBOL 4 WAS EXPECTED IN COMMENT-DEFINITION');\r
21: write(' METASYMBOL 4 WAS EXPEXTED AFTER COMMENT-DEFINITION');\r
22: write(' COMMENT = WAS EXPECTED ') ;\r
\r
\r
end;\r
if i in [1,2,3,5,6,10,11] then msg('=ERROR(S) IN INPUT ');\r
write(lf,' ');\r
errorboo:=true;\r
if i=4 then nboo2:=true else\r
if not (i in [8,9,12,15,16,13,18,19]) then stop(0);\r
end;\r
\r
\r
procedure gramerror;\r
begin\r
if a < 23 then (*NOT CALLED FROM TERMINAL*) fejl(a);\r
while metasymbol[4]<>s do space;\r
space;\r
end;\r
\r
\r
procedure goalsymb;\r
(* PROCEDUREN LAESER GOALSYMBOLKORTET*)\r
const\r
length_of_goalsymbol = 10;\r
begin\r
for i:=1 to length_of_goalsymbol do\r
begin\r
buffer[i]:=s;\r
space;\r
end;\r
for i := length_of_goalsymbol + 1 to alfalength do buffer [ i ] := ' ';\r
pack(buffer,1,alfav);\r
if alfav='GOALSYMBOL' then\r
begin\r
if s='=' then\r
begin\r
nterminal(metasymbol[4]);\r
goalhusk:=count;\r
end else fejl(2);\r
end else fejl(3);\r
goaltest:=true;\r
nboo1:=false;\r
space;\r
end;\r
\r
\r
procedure goalprod;\r
(* INDSAETTELSE AF GOALPRODUKTIONEN*)\r
begin\r
(* INDSAETTELSE AF HQJRESIDE*)\r
with rhs[point] do\r
begin\r
basisl:=3;\r
huskp:=point;\r
end;\r
newelm(point,'GOALPROD ');\r
rhs[point].symbol:=0;\r
newelm(point,'GOALPROD ');\r
with rhs[point] do\r
if goaltest then symbol:=goalhusk else symbol:=count;\r
newelm(point,'GOALPROD ');\r
rhs[point].symbol:=1;\r
for i:=1 to 4 do\r
with rhs[huskp] do\r
begin\r
allocate(huskp);\r
link:=rhsnil;\r
parserp:=nil;\r
end;\r
goalboo:=false;\r
point:=huskp;\r
end;\r
\r
\r
procedure comment ;\r
(* THE PROCEDURE READS THE COMMENT CARD IF ANY *)\r
var\r
buf : packed array[1..8] of char ;\r
begin\r
for i:=1 to 8 do\r
begin\r
buf[i]:=s ;\r
space ;\r
end ;\r
if buf='COMMENT=' then\r
begin\r
ch:=s ;\r
terminal ;\r
combegin:=termrep ;\r
if ch<> ' ' then s:=ch else space ;\r
if s<> metasymbol[4] then\r
gramerror(20)\r
else\r
begin\r
i:=1 ; space ;\r
while ((s<>metasymbol[4]) and (i<=alfalength)) do\r
begin\r
comend[i]:=s;\r
space ;\r
i:=i+1 ;\r
end ;\r
comlength:=i-1 ;\r
if s<> metasymbol[4] then gramerror(21)\r
else space ;\r
end ;\r
end\r
else\r
gramerror(22) ;\r
end ;\r
\r
\r
procedure unused;\r
forward;\r
\r
procedure inch;\r
begin\r
if listing then\r
if oldch = 0 then write(lf,' ')\r
else write(chr(oldch));\r
if eoln(input) then\r
begin\r
if eof(input) then fejl(1);\r
readln; ch:=' ';\r
oldch := 0;\r
end\r
else\r
begin\r
read(ch); oldch := ord(ch);\r
if ch in ['a'..'z'] then ch := chr(ord(ch)-ord('a') + ord('A'));\r
\r
end;\r
end;(*INCH*)\r
\r
procedure space;\r
begin\r
repeat\r
inch;\r
until ch <> ' ';\r
s:=ch;\r
end;\r
\r
\r
procedure laes( a : integer);\r
begin\r
i:=1;\r
while(i<=a) do\r
begin\r
buffer[i]:=s;\r
i:=i+1; space;\r
end;\r
if i<=alfalength then for i:=i to alfalength do buffer[i]:=' '\r
end;\r
\r
\r
procedure string;\r
var\r
buf: packed array[1..9] of char;\r
begin\r
for i:=1 to 9 do\r
begin\r
buf[i]:=s;\r
space;\r
end ;\r
if buf='STRINGCH=' then stringch:=s else fejl(17);\r
if entry[stringch].ok1=false then fejl(9);\r
space;if s=metasymbol[4] then space;\r
end; (*SLUT PAA STRING *)\r
\r
\r
\r
\r
\r
\r
procedure nterminal;\r
var\r
alfa1,alfa2,alfa3 :alfa;\r
boo : boolean;\r
\r
\r
\r
procedure nextword;\r
label 26;\r
begin\r
space;\r
if s=metasymbol[3] then\r
begin gramerror(12); error1:=true;\r
goto 26;\r
end;\r
i:=1;\r
while s<> meta do\r
begin\r
if i <= alf3-1 then buffer[i]:=s;\r
space; i:=i+1;\r
end;\r
for i:=i to alf3-1 do buffer[i]:=' ';\r
pack(buffer,1,alfa1);\r
pack(buffer,alfalength+1,alfa2);\r
pack(buffer,2*alfalength+1,alfa3);\r
26:\r
(*END NEXTWORD*)\r
end;\r
\r
\r
\r
procedure udord(p:pointer1);\r
procedure visitnode(p:pointer1);\r
begin\r
with p^ do write(' ',word1,word2,word3);\r
write(' INTERNAL VALUE'); write(' ',p^.nontermvaerdi,lf);\r
end;\r
\r
begin if p<>nil then\r
begin udord(p^.llink);\r
visitnode(p);\r
udord(p^.rlink);\r
end;\r
end;\r
\r
\r
procedure indord;\r
begin boo:=true; dynp:=first;\r
while((dynp<>nil) and boo) do\r
with dynp^ do\r
if ((alfa1=word1) and (alfa2=word2) and (alfa3=word3)) then\r
begin(*ORDET VAERET FQR*)\r
boo:=false;\r
count:=nontermvaerdi;\r
if venstreboo then\r
begin\r
i:=1;(*UNDERSQGE OM VSIDE VAERET FQR*)\r
while (i<k) and (husk[i]<>count) do i:=i+1;\r
if (i<k) then rhs[lefthelp[count]].link:=point;\r
(*HVIS VAERET FQR DA I<K POINTER SAETTES*)\r
end;\r
end else\r
begin last:=dynp;\r
if (alfa1<word1) then dynp:=llink else\r
if (alfa1=word1) and (alfa2<word2) then dynp:=llink else\r
if (alfa1=word1) and (alfa2=word2) and (alfa3<word3) then dynp:=llink else\r
dynp:=rlink;\r
end;\r
if boo then\r
begin new(statp); if statp=nil then fejl(14);\r
with statp^ do\r
begin word1:= alfa1; word2:=alfa2;\r
word3:=alfa3;\r
llink:=nil;\r
rlink:=nil;\r
nontermvaerdi:=internv; count:=internv;\r
if internv >= const2 then fejl(7);\r
internv:=internv+1;\r
husknonterm[count].nontermp:=statp;\r
end;\r
with last^ do\r
if (word1>alfa1) then llink:=statp else\r
if (word1=alfa1) and (word2>alfa2) then llink:=statp else\r
if (word1=alfa1) and (word2=alfa2) and (word3>alfa3) then llink:=statp else\r
rlink:=statp;\r
end;\r
end;\r
\r
begin\r
if noword then\r
begin\r
if nontermboo then\r
begin\r
nextword; new(first);\r
with first^ do\r
begin word1:=alfa1;\r
word2:=alfa2; word3:=alfa3;\r
llink:=nil;\r
rlink:=nil;\r
count:=internv;\r
husknonterm[count].nontermp:=first;\r
nontermboo:=false;\r
nontermvaerdi:=internv;\r
internv:=internv+1;\r
end;\r
end else begin nextword; if (errorboo=false) then indord end;\r
end else udord(first);\r
end;\r
\r
\r
procedure metasymb;\r
(* METASYMB LAESER ET KORT MED FQLGENDE UDSEENDE : *)\r
(* METAVARIABLE M1= M2= M3= M4= *)\r
begin\r
count:=11; laes(count);\r
pack(buffer,1,alfav);\r
if alfav=metavar then\r
begin (*METAVARIABLE GENKENDT*)\r
j:=1;\r
while j <= 4 do\r
begin\r
count:=3; laes(count);\r
pack(buffer,1,alfav);\r
if m[j]=alfav then\r
begin\r
metasymbol[j]:=s;\r
i:=j;\r
if i>1 then\r
while i>1 do\r
begin\r
i:=i-1;\r
if s=metasymbol[i] then fejl(10);\r
end;\r
j:=j+1;\r
end else fejl(5);\r
if j <= 4 then space;\r
end\r
end else fejl(6);\r
end;\r
\r
(*dollar-f*)\r
procedure ingrammar;\r
label 111,10,13;\r
\r
procedure init;\r
var c: char; i: integer;\r
begin\r
for c:=minch to maxch do chgroup[c]:=special;\r
for c:='A' to 'Z' do chgroup[c]:=alfanum;\r
for c:='0' to '9' do chgroup[c]:=alfanum;\r
chgroup[' ']:=sep;\r
error:=false;\r
for i:=1 to const18 do options[i]:=false;\r
options[27(*LALR*)]:=true;\r
listing := true; oldch := 0;\r
combegin:=0 ;\r
comlength:=1 ;\r
for i:=1 to alfalength do comend[i]:=' ' ;\r
linx:=0; prodseqno:=0;\r
\r
antalprod := -1;\r
\r
for i:=0 to const2 do\r
with help[i] do\r
begin\r
afledt := true;\r
overgang := true;\r
prodindex := const1;\r
rightp := rhsnil; (* important!? *)\r
status := finish;\r
term := true;\r
end;\r
\r
firstleftside := 0;\r
lastleftside := 0;\r
\r
end; (*INIT*)\r
\r
procedure readlabel(pt:integer);\r
var lo,i:integer; sa:alfa;\r
begin\r
if options[33] or options[34] then\r
begin lo:=linx;\r
rhs[pt].first:=lo;\r
if options[33] then\r
begin prodseqno:=prodseqno+1;\r
if linx+15>const19 then consterror('READLABEL ','CONST19 ',const19);\r
constval(prodseqno,sa); i:=2;\r
while sa[i]<>')' do\r
begin labelbuf[linx]:=sa[i];\r
i:=i+1; linx:=linx+1;\r
end;\r
labelbuf[linx]:=' '; linx:=linx+1;\r
end;\r
if options[34] then\r
begin space;\r
while s<> metasymbol[1] do\r
begin labelbuf[linx]:=s;\r
linx:=linx+1; inch; s:=ch;\r
if (linx+1)>=const19 then consterror('READLABEL ','CONST19 ',const19);\r
end;\r
end;\r
if (linx-lo)>100 then\r
begin lo:=linx;\r
writeln(' *** A PRODUCTION LABEL MUST NOT EXCEED 100 CHARS');\r
end;\r
rhs[pt].length:=linx-lo;\r
end;\r
end; (*READLABEL*)\r
\r
begin init;\r
page(output);\r
write('************ A LIST OF INPUT WITH POSSIBLE ERRORMESSAGES ************');\r
write(lf,lf,' ');\r
space; (* READ FIRST NON-BLANK CHARACTER ON INPUT*)\r
if s='O' then\r
(* OPTIONS INDLAESES *)\r
begin\r
repeat if s='M' then begin fejl(15); goto 111 end;\r
space;\r
until s='(';\r
space;\r
repeat\r
while s=',' do space;\r
if (s >= '0') and (s <= '9') then\r
begin\r
optno:=0;\r
repeat\r
optno:=optno*10+ord(s)-ord('0');\r
space;\r
until (s<'0') or (s>'9');\r
if optno>const18 then fejl(16) else options[optno]:=not options[optno];\r
end else\r
if s<>')' then\r
begin\r
fejl(15);\r
repeat if s='M' then goto 111;\r
space;\r
until s=')';\r
end;\r
until s=')';\r
space;\r
111:\r
end;\r
listing := options[listoption];\r
(* SLUT PAA INDLAESNING AF OPTIONS *)\r
\r
metavar:='METASYMBOLS';\r
m[1]:='M1= '; m[2]:='M2= ';\r
m[3]:='M3= '; m[4]:='M4= ';\r
for i:=0 to const2 do\r
begin\r
(* INITIALISERING AF NONTERMHUSK*)\r
husknonterm[i].rightboo:=false;\r
husknonterm[i].leftboo:=false;\r
end;\r
for i:=0 to const2 do help[i].rightp:=rhsnil;\r
emptyboo:=false; error1:=false;\r
errorboo:=false; error2:=false;\r
if s='M' then begin metasymb;space end else\r
begin (*DEFAULT VAERDIER FOR METASYMBOLER *)\r
metasymbol[1]:='=';\r
metasymbol[2]:='/';\r
metasymbol[3]:='<';\r
metasymbol[4]:=';';\r
write(lf);\r
write(' NO METASYMBOLS HAVE BEEN CHOSEN THE FOLLOWING ARE USED '); write(lf);\r
for i := 1 to 4 do\r
write(' m', i:1, '=', metasymbol[i]);\r
write(lf,lf,' ');\r
end;\r
\r
terminput; (*READ TERMINAL SYMBOLS *)\r
\r
k:=1; top:=1;\r
termg:=termantal; venstreboo:=false;\r
termantal:=termantal+1;\r
nontstart:=termantal;\r
help[nontstart].rightp:=top;\r
termantal:=termantal+1; if termantal>=const2 then consterror('INGRAMMAR ','CONST2 ',const2);\r
internv:=termantal;\r
nontermboo:=true;\r
empty:=127; error3:=false;\r
noword:=true;\r
space;\r
for point := 0 to const4 do\r
with rhs[point] do\r
begin\r
symbol := const2;\r
parserp:= nil;\r
link := const4;\r
basisl := const5;\r
basis := true;\r
first := const19;\r
length := 100;\r
end;\r
point:=top;\r
goaltest:=false;\r
nboo1:=true; nboo2:=false;\r
while s in ['G','S','C'] do\r
case s of\r
'G' : goalsymb ;\r
'S' : string ;\r
'C' : comment ;\r
end ;\r
goalboo:=true;\r
13 : while s<>metasymbol[4] do\r
begin\r
firstboo:=true; tal:=0;\r
if s='M' then\r
begin (* METASKIFT*)\r
metasymb;\r
end else\r
begin\r
if s<>metasymbol[3] then\r
begin\r
gramerror(12);goto 13 ;\r
end else\r
begin\r
(* NY VENSTRE SIDE*) venstreboo:=true;\r
nterminal(metasymbol[3]);\r
if error1 then begin error1:=false; goto 13 end;\r
husk[k]:=count;\r
k:=k+1;\r
if goalboo then goalprod;\r
husknonterm[count].leftboo:=true;\r
if help[count].rightp = rhsnil then\r
begin\r
help[count].rightp := point;\r
(* chain the left sides in input order using 'prodindex' *)\r
if firstleftside = 0 then\r
firstleftside := count\r
else\r
help[lastleftside].prodindex := count;\r
lastleftside := count;\r
help[lastleftside].prodindex := 0;\r
end;\r
rhs[point].parserp:=nil;\r
rhs[point].link:=rhsnil;\r
helpp:=point; huskp:=point;\r
newelm(point,'INGRAMMAR ');\r
end;\r
space; venstreboo:=false;\r
if s<>metasymbol[1] then\r
begin gramerror(13);\r
goto 13 ;\r
end else\r
begin readlabel(helpp);\r
space;\r
10 : if s=metasymbol[2] then\r
begin (*END OF ALTERNATIVE/BEGINNING OF NEXT*)\r
if tal=0 then\r
begin gramerror(8); goto 13 end;\r
if emptyboo and (tal>1) then fejl(4);\r
emptyboo:=false;\r
rhs[helpp].basisl:=tal; tal:=0;\r
helpp:=point;\r
rhs[huskp].link:=point;\r
rhs[point].link:=rhsnil;\r
rhs[point].parserp:=nil;\r
newelm(point,'INGRAMMAR ');\r
readlabel(helpp);\r
space;\r
goto 10;\r
end else\r
if s=metasymbol[3] then\r
begin (*READ NONTERMINAL*)\r
nterminal(metasymbol[3]);\r
if error1 then begin error1:=false; goto 13 end;\r
tal:=tal+1;\r
if tal>15 then\r
begin gramerror(19); goto 13 end;\r
husknonterm[count].rightboo:=true;\r
rhs[point].parserp:=nil;\r
rhs[point].link:=rhsnil;\r
rhs[point].symbol:=count;\r
huskp:=point; newelm(point,'INGRAMMAR ');\r
firstboo:=false;\r
space; goto 10;\r
end else\r
if s<>metasymbol[4] then (*READ TERMINAL*)\r
begin ch:=s; terminal;\r
if error2 then begin error2:=false; goto 13 end;\r
if emptyvalue=termrep then emptyboo:=true;\r
rhs[point].parserp:=nil;\r
rhs[point].link:=rhsnil;\r
tal:=tal+1;\r
if tal>15 then\r
begin gramerror(19); goto 13 end;\r
rhs[point].symbol:=termrep;\r
huskp:=point; newelm(point,'INGRAMMAR ');\r
firstboo:=false;\r
if ch<>' ' then s:=ch else space;\r
goto 10\r
end else\r
begin (*ENDOF ALTERNATIVE/NO MORE FOR THIS LHS*)\r
if tal=0 then\r
begin gramerror(8); goto 13 end;\r
if emptyboo and (tal>1) then fejl(4);\r
emptyboo:=false;\r
rhs[helpp].basisl:=tal;\r
lefthelp[husk[k-1]]:=huskp;\r
end;\r
end\r
end;\r
space; emptyboo:=false;\r
end;\r
write(lf,lf,lf) ;\r
write(' ***************************** END OF LIST *****************************') ;\r
write(lf,lf) ;\r
if errorboo=false then\r
begin\r
unused;\r
end else begin msg('=ERROR(S) IN INPUT '); stop(0); end;\r
end;\r
\r
\r
(*dollar-f*)\r
procedure unused;\r
begin page(output);\r
write('**************************** GRAMMARCHECKS ****************************') ;\r
write(lf,lf) ;\r
(* TEST AF OM DER EX NONTERMINALER ,DER KUN BRUGES PAA ENTEN HQJRE ELLER*)\r
(* VENSTRE SIDE,HELE GRAMMATIKKEN CHECKES PAANAER GOALPROD. DENNE OVER - *)\r
(*OVERSPRINGES,FINDES DER FEJL STANDSER PROGRAMMET *)\r
if nboo1 then goalhusk:=husk[1];\r
for i:=termantal to internv-1 do\r
begin\r
with husknonterm[i] do\r
begin\r
if not (leftboo and rightboo) then\r
begin\r
with nontermp^ do\r
if nontermvaerdi<>goalhusk then\r
(* VITESTER KUN HVIS DET IKKE ER GOALSYMBOLET*)\r
begin\r
write(' ',word1,word2,word3);\r
if leftboo then write(' APPEARS ONLY IN LEFTSIDE ')\r
else write(' APPEARS ONLY IN RIGHTSIDE');\r
write(lf);\r
nboo2:=true;\r
end\r
end\r
end\r
end;\r
nontslut:=internv-1;\r
if nboo2 then\r
stop(3)\r
else\r
begin\r
write(' IT HAS BEEN CHECKED THAT ALL NONTERMINALS');\r
write(lf);\r
write(' EXCEPT THE GOALSYMBOL APPEAR IN BOTH');\r
write(lf);\r
write(' LEFT AND RIGHTSIDE OF A PRODUCTION');\r
write(lf,lf);\r
end;\r
if options[6] then\r
begin write(lf,lf,lf);\r
write(' A LIST OF NONTERMINALS WITH INTERNAL REPRESENTATION ');\r
write(lf,lf);\r
noword:=false;\r
nterminal(metasymbol[3]);\r
end;\r
end;\r
\r
procedure dump2;\r
var\r
lqb: pointer2;\r
begin\r
lqb:=top;\r
write(lf,lf);\r
write(' RIGTHSIDE ');\r
write(lf);\r
write(' ' : 8, 'symbol' : 8, 'link' : 8, 'basisl' : 8, 'parserp' : 8);\r
repeat\r
write(lf);\r
with rhs[lqb] do write(ord(lqb),symbol,ord(link),basisl,ord(parserp));\r
allocate(lqb);\r
until lqb=point;\r
end;\r
\r
\r
procedure dump3;\r
var\r
i: integer;\r
begin\r
write(lf,lf);\r
write(' HUSKNONTERM '); write(lf);\r
write(' NONTERMP LEFTBOO RIGHTBOO');\r
for i:=nontstart to nontslut do\r
with husknonterm[i] do\r
write(lf,ord(nontermp),ord(leftboo),ord(rightboo));\r
end;\r
\r
\r
procedure dump4;\r
begin\r
write(lf,lf);\r
write(' HELP'); write(lf);\r
for i:=nontstart to nontslut do write(' ',ord(help[i].rightp),lf);\r
end;\r
\r
procedure outalf(a:alfa; var t: integer);\r
var i: integer;\r
begin\r
if a<>blank then\r
begin i:=alfalength;\r
while a[i]=' ' do i:=i-1;\r
write(a:i); t:=t+i;\r
end;\r
end;\r
\r
procedure nontwrit(i: integer;var t: integer);\r
begin\r
write('<'); t:=t+1;\r
with husknonterm[i].nontermp^ do\r
begin\r
outalf(word1,t); outalf(word2,t); outalf(word3,t);\r
end;\r
write('>'); t:=t+1;\r
end;\r
\r
procedure dump5;\r
var\r
i: integer;\r
begin\r
write(lf,lf,' PROD',lf,lf);\r
write(' LEFTSIDE START LOOKBACKP LAENGDE ');\r
write(lf);\r
for i:=0 to antalprod do\r
with prod[i] do write(lf,ord(leftside),ord(start),ord(lookbackp),ord(laengde));\r
write(lf,lf);\r
end;\r
\r
procedure initprod;\r
var\r
p: pointer2;\r
k,i,l: integer;\r
begin\r
k:=-1;\r
i := nontstart;\r
repeat (* changed at rc 79.11.12 *)\r
p:=help[i].rightp;\r
while p<>rhsnil do\r
begin k:=k+1;\r
if k>const1 then consterror('INITPROD ','CONST1 ',const1);\r
with prod[k] do\r
begin\r
leftside:=i; start:=p; laengde:=rhs[p].basisl;\r
for l:=1 to laengde do allocate(p);\r
if (laengde=1) and (rhs[start+1].symbol=emptyvalue) (*EMPTY RIGHT HAND SIDE*)\r
then laengde:=0;\r
end;\r
p:=rhs[p].link;\r
end;\r
if i = nontstart then i := firstleftside\r
else i := help[i].prodindex;\r
until i = 0;\r
prod[k+1].leftside:=0; antalprod:=k;\r
end;\r
\r
procedure outgrammar;\r
var\r
p,p1: pointer2;\r
k,j,i, oldi,l,t,tt,prodno: integer;\r
begin\r
page(output); write(' '); for i:=1 to 30 do write('*');\r
write(' THE GRAMMAR '); for i:=1 to 30 do write('*');\r
writeln;\r
writeln; writeln;\r
\r
oldi := 0; (* used to indicate new leftside *)\r
\r
for prodno := 1 to antalprod do\r
with prod[prodno] do\r
begin\r
\r
i := leftside;\r
p := start;\r
\r
if i <> oldi then writeln; (* new leftside *)\r
writeln; write(prodno:5, ' ');\r
\r
if i <> oldi then\r
begin\r
t := 0; nontwrit(i,t);\r
write(' ::= '); t := t + 3; \r
oldi := i;\r
end\r
else\r
write(' ' : t, '! ');\r
p1:=p;\r
tt:=t;\r
for k:=1 to rhs[p].basisl do\r
begin\r
if tt>60 then\r
begin writeln;\r
write(' ' : t + 5 (* prodno *) + 3 (* leading spaces *) + 2 (* indention *) );\r
tt := t;\r
end;\r
allocate(p);\r
symb:=rhs[p].symbol;\r
if symb <= termg then\r
outalf(internrep[symb],tt)\r
else nontwrit(symb,tt);\r
write(' '); tt:=tt+1;\r
end;\r
if options[33] or options[34] then\r
with rhs[p1] do\r
begin for tt:=tt+1 to 60 do write(' ');\r
if length>70 then writeln;\r
write(':');\r
for k:=first to first+length-1 do write(labelbuf[k]);\r
end;\r
end;\r
write(lf,' ');\r
for i:=1 to 73 do write('*');\r
write(lf);\r
end;\r
\r
\r
\r
\r
procedure erasure;\r
label 10,100;\r
var\r
lambda,m,ll,kk,k,i,j,l: integer;\r
pq,oldp,p,pp,ppp: pointer2;\r
boo,ok,slut: boolean;\r
begin if not options[31] then goto 100; (* OBS. ERASURE IS NOT PERFORMED*)\r
boo:=false;\r
lambda:=emptyvalue;\r
if lambda=0 then\r
begin\r
write(lf,lf,lf);\r
write(' IT HAS BEEN CHECKED THAT NO NONTERMINAL'); write(lf);\r
write(' CAN PRODUCE THE EMPTY STRING '); write(lf);\r
goto 100;\r
end;\r
ok:=false;\r
kkk:=kkk+1;\r
for i:=nontstart to nontslut do\r
help[i].status:=firsttim;\r
10:\r
for i:=nontstart to nontslut do\r
(* I GENNEMLQBER ALLE VENSTRESIDER *)\r
begin\r
p:=help[i].rightp;\r
while p<>rhsnil do\r
begin\r
pp:=p;\r
ll:=rhs[p].basisl;\r
allocate(p);\r
if ll=1 then\r
if rhs[p].symbol=lambda then\r
(* EN HQJRESIDE ER GENKENDT SOM DEN TOMME STRENG *)\r
begin\r
ok:=true; (* OK ER TRUE HVIS EMPTY FINDES PAA EN HQJRE SIDE *)\r
(* PROD. A..LAMBDA FJERNES *)\r
if pp=help[i].rightp then help[i].rightp:=rhs[p].link\r
else rhs[oldp].link:=rhs[p].link;\r
if help[i].status=firsttim then\r
begin\r
help[i].status:=finish;\r
for j:= nontstart+1 to nontslut do\r
begin\r
p:=help[j].rightp;\r
while p<>rhsnil do\r
begin\r
k:=rhs[p].basisl; l:=ord(p)+k;\r
pp:=p;\r
for m:=1 to k do\r
begin\r
allocate(pp);\r
symb:=rhs[pp].symbol;\r
if symb=i then\r
begin\r
pq:=p;\r
newelm(point,'ERASURE '); ppp:=point; rhs[point].parserp:=nil;\r
if k=1 then\r
begin\r
rhs[point].basisl:=1;\r
newelm(point,'ERASURE ');\r
rhs[point].symbol:=lambda;\r
rhs[point].parserp:=nil;\r
allocate(pq);\r
end else\r
begin\r
rhs[point].basisl:=k-1;\r
while ord(pq)<l do\r
begin\r
allocate(pq);\r
if pq<>pp then\r
begin\r
newelm(point,'ERASURE '); rhs[point].parserp:=nil;\r
rhs[point].symbol:=rhs[pq].symbol;\r
end;\r
end;\r
end;\r
rhs[point].link:=rhs[pq].link;\r
rhs[pq].link:=ppp;\r
end;\r
end;\r
oldp:=pp;\r
p:=rhs[pp].link;\r
end;\r
end;\r
goto 10; (* DER STARTES NU FORFRA MED GRAMMATIKKEN *)\r
end;\r
end;\r
for kk:=2 to ll do allocate(p);\r
oldp:=p;\r
p:=rhs[p].link;\r
end;\r
end;\r
repeat\r
slut:=true;\r
for i:=nontstart to nontslut do\r
begin\r
p:=help[i].rightp;\r
while p<>rhsnil do\r
begin\r
pp:=p; ll:=rhs[p].basisl;\r
boo:=false;\r
for kk:=1 to ll do\r
begin\r
allocate(pp); symb:=rhs[pp].symbol;\r
if symb>termg then\r
boo:=boo or (help[symb].rightp=rhsnil);\r
end;\r
if boo then\r
begin if p=help[i].rightp then\r
begin\r
pq:=rhs[pp].link;\r
help[i].rightp:=pq;\r
if pq=rhsnil then slut:=false;\r
end\r
else rhs[oldp].link:=rhs[pp].link;\r
end else\r
oldp:=pp;\r
p:=rhs[pp].link;\r
end;\r
end;\r
until slut;\r
write(lf,lf);\r
if ok then\r
begin\r
write(' THE GRAMMAR IS MODIFIED FOR ERASURE '); write(lf);\r
write(' I. E. NO NONTERMINAL CAN NOW PRODUCE THE EMPTY STRING')\r
end else\r
begin\r
write(' EMPTY HAS BEEN SPECIFIED AS A TERMINAL SYMBOL,'); write(lf);\r
write(' BUT IT HAS NOT BEEN USED ')\r
end;\r
write(lf);\r
100:\r
end;\r
\r
procedure matrixout(s:bitmatrix);\r
var\r
i,j: integer;\r
begin\r
write(lf,lf);\r
write(' BITMATRIX');\r
for i:=0 to nontslut do\r
begin write(lf,' ');\r
for j:=0 to nontslut do\r
if ((j mod (setmax+1)) in s[i].r[j div (setmax+1)]) then write('1') else write('0');\r
end;\r
write(lf,lf);\r
end;\r
\r
procedure writeheadsandtails;\r
label 10,20;\r
const textlength = 7; (* number of printed chars from internrep *)\r
var\r
nomoretails,nomoreheads: boolean;\r
headsymb,tailsymb,symb,tael,i :integer;\r
begin\r
page(output); write('A LIST OF PRODUCED 1-HEADS AND 1-TAILS FOR ALL NONTERMINALS '); write(lf,lf);\r
for i:=1 to 34 do write(' '); write('!');\r
for i:=1 to 4*(1+textlength) + 1 do write(' '); write('!',lf);\r
write('symbol' : 9, '!' : (35-9), 'heads' : 9, '!' : (4*(1+textlength)+2 - 9),\r
'tails':9);\r
write(lf);\r
for i:=1 to 34 do write(' '); write('!');\r
for i:=1 to 4*(1+textlength) + 1 do write(' '); write('!');\r
for symb:=nontstart+1 to nontslut do\r
begin\r
tael:=1; nomoreheads:=false; nomoretails:=false;\r
headsymb:=0; tailsymb:=0;\r
write(lf,' ');\r
for i:=1 to 33 do write('-'); write('!');\r
for i:= 1 to 4*(1+textlength) + 1 do write('-'); write('!');\r
for i:=1 to 4*(1+textlength) + 1 do write('-');\r
write(lf,' ');\r
nontwrit(symb,tael);\r
repeat\r
if headsymb<>0 then write(lf); (*NO LINESHIFT FIRST TIME IN LOOP *)\r
for tael:=tael+1 to 34 do write(' '); write('!');\r
for i:=1 to 4 do (* PRINT 4 HEADS IF THEY EXIST ELSE SPACES *)\r
begin\r
headsymb:=headsymb+1;\r
while headsymb<nontstart do\r
if(headsymb mod (setmax+1))in ph1s[symb].r[headsymb div (setmax+1) ] then goto 10\r
else headsymb:=headsymb+1;\r
nomoreheads:=true;\r
10:\r
if nomoreheads then write(' ', ' ' : textlength)\r
else write(' ',internrep[headsymb] : textlength);\r
end;\r
write(' ','!');\r
for i:=1 to 4 do (* PRINT 4 TAILS IF THEY EXIST ELSE SPACES *)\r
begin\r
tailsymb:=tailsymb+1;\r
while tailsymb<nontstart do\r
if(tailsymb mod (setmax+1))in pt1s[symb].r[tailsymb div (setmax+1) ] then goto 20\r
else tailsymb:=tailsymb+1;\r
nomoretails:=true;\r
20:\r
if nomoretails then write(' ', ' ' : textlength)\r
else write(' ',internrep[tailsymb] : textlength);\r
end;\r
tael:=0;\r
until nomoretails and nomoreheads;\r
end;\r
write(lf,' ');\r
end;\r
\r
\r
procedure iterer(var matrix: bitmatrix);\r
var\r
n,up1,up2,nn,m,k,kk,l,i,j: integer;\r
slut:boolean;\r
gem,boo: set of 0..setmax;\r
trans: bitmatrix;\r
fresh: rtype;\r
begin\r
n:=nontslut div (setmax+1);\r
nn:=nontslut-n*(setmax+1);\r
if options[19] then write(lf,' NONTSLUT',nontslut,' N',n,' NN',nn,lf);\r
\r
\r
repeat up1:=setmax; slut:=true;\r
(* MATRIXEN MATRIX TRANSPONERES OVER I MATRIXEN TRANS *)\r
k:=-1;\r
for m:=0 to n do\r
begin\r
if m=n then up1:=nn;\r
for kk:=0 to up1 do\r
begin\r
k:=k+1;\r
j:=-1; up2:=setmax;\r
for l:=0 to n do\r
begin\r
boo:=[]; if l=n then up2:=nn;\r
for i:=0 to up2 do\r
begin\r
j:=j+1;\r
if(kk in matrix[j].r[m]) then boo:=boo + [i];\r
end;\r
trans[k].r[l]:=boo;\r
end;\r
end;\r
end;\r
\r
for i:=0 to const13 do fresh.r[i]:=[];\r
(* HER STARTES SELVE ITERERINGEN *)\r
for k:=nontstart to nontslut do\r
with matrix[k] do\r
begin\r
i:=-1; up2:=setmax;\r
for l:=0 to n do\r
begin\r
gem:=[]; if l=n then up2:=nn;\r
for m:=0 to up2 do\r
begin\r
i:=i+1; boo:=[];\r
for j:=0 to n do\r
boo:=boo + (r[j] * trans[i].r[j]);\r
if boo<>[] then gem:=gem + [m];\r
end;\r
fresh.r[l]:=gem;\r
end;\r
for j:=0 to n do\r
begin\r
gem:=r[j] + fresh.r[j];\r
if gem<>r[j] then\r
begin r[j]:=gem;\r
slut:=false;\r
end;\r
end;\r
end;\r
until slut;\r
end;\r
\r
\r
\r
procedure vhrecurs;\r
label 10;\r
var\r
sn: record case b: boolean of\r
true: (p: pointer2);\r
false: (pvaerdi: integer);\r
end;\r
boo: boolean;\r
ii,ll,i,l: integer;\r
start: integer;\r
begin\r
if options[25] then goto 10;\r
i:=nontslut div (setmax+1);\r
if i>const13 then\r
begin\r
write(lf,lf,' CONST13',' MUST BE',i,lf);\r
consterror('VHRECURS ','CONST13 ',const13);\r
end;\r
for i:=0 to const2 do\r
for j:=0 to const13 do\r
begin\r
ph1s[i].r[j]:=[];\r
pt1s[i].r[j]:=[];\r
end;\r
with sn do\r
for i:=nontstart to nontslut do\r
begin\r
p:=help[i].rightp;\r
while p<>rhsnil do\r
begin\r
l:=rhs[p].basisl;\r
allocate(p);\r
ll:=rhs[p].symbol;\r
ii:=ll div (setmax+1);\r
ph1s[i].r[ii]:=ph1s[i].r[ii] + [ll mod (setmax+1)];\r
pvaerdi:=pvaerdi+l-1;\r
ll:=rhs[p].symbol;\r
ii:=ll div (setmax+1);\r
pt1s[i].r[ii]:=pt1s[i].r[ii] + [ll mod (setmax+1)];\r
p:=rhs[p].link;\r
end;\r
end;\r
if options[20] then\r
begin\r
matrixout(ph1s);\r
matrixout(pt1s);\r
end;\r
iterer(ph1s);\r
iterer(pt1s);\r
if options[20] then\r
begin\r
matrixout(ph1s);\r
matrixout(pt1s);\r
end;\r
if options[18] then writeheadsandtails;\r
boo:=false; l:=1;\r
start:=nontstart+1;\r
for ii:=start to nontslut do\r
begin i:=ii div (setmax+1);\r
if( ph1s[ii].r[i] * pt1s[ii].r[i] * [ii mod (setmax+1)])<>[] then\r
begin\r
boo:=true;\r
write(lf,' '); nontwrit(ii,l);\r
end;\r
end;\r
if boo then\r
begin\r
write(lf);\r
write(' THE ABOVE STANDING NONTERMINALS ');write(lf);\r
write(' IS BOTH LEFT AND RIGHT RECURSIVE ');write(lf);\r
write(' THE PROGRAM TERMINATES ');\r
stop(3);\r
end;\r
write(lf,lf);\r
write(' IT HAS BEEN CHECKED THAT NO NONTERMINAL'); write(lf);\r
write(' IS BOTH LEFT AND RIGHT RECURSIVE'); write(lf);\r
10:\r
end;\r
\r
procedure termination;\r
var\r
p: pointer2;\r
nonew,termboo: boolean;\r
i,j,k: integer;\r
begin\r
for i:=nontstart to nontslut do help[i].term:=false;\r
repeat\r
nonew:=true;\r
for i:=nontstart to nontslut do\r
if ( not help[i].term)then\r
begin\r
p:=help[i].rightp;\r
while p<>rhsnil do\r
begin\r
k:=rhs[p].basisl; termboo:=true;\r
for j:=1 to k do\r
begin\r
allocate(p);\r
with rhs[p] do\r
if symbol>termg then termboo:=termboo and (help[symbol].term);\r
end;\r
if termboo then\r
begin\r
nonew:=false;\r
help[i].term:=true; p:=rhsnil;\r
end else p:=rhs[p].link;\r
end;\r
end;\r
until nonew;\r
termboo:=false;\r
k:=0;\r
for i:=nontstart+1 to nontslut do\r
if(help[i].rightp<>rhsnil) and ( not help[i].term) then\r
begin\r
write(lf,lf,' '); nontwrit(i,k);\r
termboo:=true;\r
end;\r
if termboo then\r
begin write(lf,lf);\r
write(' THE ABOVE STANDING NONTERMINALS CANNOT PRODUCE');write(lf);\r
write(' A STRING OF ONLY TERMINAL SYMBOLS ');\r
stop(3);\r
end else\r
begin write(lf,lf,lf);\r
write(' IT HAS BEEN CHECKED THAT ALL NONTERMINALS CAN');write(lf);\r
write(' PRODUCE A STRING OF ONLY TERMINAL SYMBOLS'); write(lf);\r
end;\r
end;\r
\r
\r
\r
\r
procedure idogfjern( b:boolean) ;\r
var\r
i : integer ;\r
boo1,boo2,boo3,boo4,fjboo : boolean ;\r
function fjernkaede(var t:boolean) : boolean ;\r
var\r
i,k,l,m,n,s,fjern,indsat :integer ;\r
j : pointer2 ;\r
procedure fjskriv ;\r
var\r
z : integer ;\r
begin\r
z:=1 ;\r
write(' ') ;\r
nontwrit(fjern,z) ;\r
write(' HAS BEEN SUBSTITUTED BY ') ;\r
nontwrit(indsat,z) ;\r
write(lf) ;\r
end ;\r
\r
begin\r
fjernkaede:=false ;\r
k:=nontslut ;\r
i:=nontstart-1 ;\r
repeat\r
i:=i+1 ;\r
j:=help[i].rightp ;\r
if (j<>rhsnil) then\r
begin\r
if (rhs[j].basisl=1) then\r
begin\r
allocate(j) ;\r
if((rhs[j].link=rhsnil) and (rhs[j].symbol > termg)) then\r
begin\r
indsat:=rhs[j].symbol ;\r
fjern:=i ;\r
help[i].rightp:=rhsnil;\r
fjernkaede:=true ;\r
fjboo:=true ;\r
if (t) then\r
fjskriv ;\r
s:=nontstart-1 ;\r
repeat\r
s:=s+1 ;\r
j:=help[s].rightp ;\r
if (j<>rhsnil) then\r
begin\r
l:=rhs[j].basisl ;\r
m:=0 ;\r
repeat\r
for n:=1 to l do\r
begin\r
allocate(j) ;\r
if (rhs[j].symbol=fjern) then\r
rhs[j].symbol:=indsat ;\r
end ;\r
if (rhs[j].link<>rhsnil) then\r
begin\r
j:=rhs[j].link ;\r
l:=rhs[j].basisl ;\r
end\r
else m:=1 ;\r
until m=1 ;\r
end ;\r
until s=k ;\r
end ;\r
end ;\r
end ;\r
until i=k ;\r
end ;\r
\r
\r
function identprod (var t:boolean) :boolean ;\r
var\r
laengde1,laengde2,i,j,kk :integer ;\r
ens,idboo : boolean ;\r
startp1,startp2,stepp1,stepp2,lastok : pointer2 ;\r
\r
procedure skriv(var x:integer) ;\r
var\r
l,jj,ll : integer ;\r
stepp3 : pointer2 ;\r
begin\r
(*UDSKRIVNING OM AENDRING I GRAMMATIKKEN *)\r
stepp3:=startp2 ;\r
if (x=1) then\r
begin\r
write(lf,lf) ;\r
write(' IDENTICALS PRODUCTIONS EXIST ') ;\r
write(lf) ;\r
write(' AND THE GRAMMAR IS MODIFIED ') ;\r
write(lf) ;\r
write(' THE FOLLOWING PRODUCTION(S) EXIST MORE THAN ONCE ') ;\r
write(lf) ;\r
end ;\r
write(' ') ;\r
jj:=1 ;\r
nontwrit(j,jj) ;\r
write(' ::= ') ;\r
for l:=1 to laengde2 do\r
begin\r
allocate(stepp3) ;\r
ll:=rhs[stepp3].symbol ;\r
if (ll <= termg) then\r
(* HQJRE SIDE ER ET TERMINAL SYMBOL *)\r
outalf(internrep[ll],jj)\r
else\r
(*HQJRE SIDE ER ET NONTERMINAL SYMBOL *)\r
nontwrit(ll,jj) ;\r
write(' ') ;\r
end ;\r
write(lf) ;\r
end ;\r
\r
\r
begin\r
kk:=0 ;\r
idboo:=false ;\r
\r
for j:=nontstart to nontslut do\r
begin\r
startp1:=help[j].rightp ;\r
if (startp1<>rhsnil) then\r
begin\r
repeat\r
laengde1:=rhs[startp1].basisl ;\r
startp2:=startp1 ;\r
for i:=1 to laengde1 do allocate(startp2) ;\r
lastok:=startp2 ;\r
startp2:=rhs[startp2].link ;\r
if (startp2<>rhsnil) then\r
begin\r
repeat\r
ens:=false ;\r
stepp1:=startp1 ;\r
stepp2:=startp2 ;\r
laengde2:=rhs[stepp2].basisl ;\r
if (laengde1=laengde2) then\r
begin\r
ens:=true ;\r
for i:=1 to laengde1 do\r
begin\r
allocate(stepp1) ; allocate(stepp2) ;\r
if (rhs[stepp1].symbol<>rhs[stepp2].symbol) then ens:=false ;\r
end ;\r
if (ens) then\r
begin\r
kk:=kk+1 ;\r
if (t) then\r
skriv(kk) ;\r
idboo:=true ;\r
rhs[lastok].link:=rhs[stepp2].link ;\r
end ;\r
end\r
else\r
for i:=1 to laengde2 do allocate(stepp2) ;\r
if ( not ens) then\r
lastok:=stepp2 ;\r
stepp2:=rhs[stepp2].link ;\r
if (stepp2<>rhsnil ) then\r
startp2:=stepp2 ;\r
until stepp2=rhsnil ;\r
for i:=1 to laengde1 do allocate(startp1) ;\r
startp1:=rhs[startp1].link ;\r
if (startp1=rhsnil) then startp1:=startp2 ;\r
end\r
else\r
startp2:=startp1 ;\r
until startp1=startp2 ;\r
end ;\r
end;\r
if((idboo=false) and t) then\r
begin\r
write(lf,lf) ;\r
write(' IT HAS BEEN CHECKEDTHAT THERE ') ;\r
write(lf) ;\r
write(' EXISTS NO IDENTICAL PRODUCTIONS ') ;\r
write(lf) ;\r
end ;\r
if (t) then\r
write(lf,lf) ;\r
identprod:=idboo;\r
end;\r
\r
begin\r
if (b and options[23]) then\r
begin\r
write(lf) ;\r
write(' DUMP BEFOR IDOGFJERN ') ;\r
write(lf,lf) ;\r
dump2 ;\r
write(lf,lf) ;\r
end ;\r
fjboo:=false ;\r
boo1:=b ;\r
boo2:=b ;\r
boo3:=true ;\r
while (boo3) do\r
begin\r
boo4:=identprod(boo1) ;\r
if options[28] then\r
boo3:=false\r
else\r
boo3:=fjernkaede(boo2) ;\r
boo3:=boo3 or boo4 ;\r
boo1:=false ;\r
end ;\r
if (options[28]=false) then\r
begin\r
if (fjboo and b) then\r
begin\r
write(' THE GRAMMER HAS BEEN MODIFIED FOR SIMPLE CHAINS ') ;\r
write(lf) ;\r
write(' USING THE ABOVE STANDING SUBSTITUTIONS ') ;\r
write(lf) ;\r
end ;\r
if (b and (fjboo=false)) then\r
begin\r
write(' THE GRAMMER HAS BEEN CHECKED FOR ') ;\r
write(lf) ;\r
write(' SIMPLE CHAINS ') ;\r
write(lf) ;\r
end ;\r
end ;\r
if (b and options[24]) then\r
begin\r
write(lf) ;\r
write(' DUMP AFTER IDOGFJERN ') ;\r
write(lf,lf) ;\r
dump2 ;\r
write(lf,lf) ;\r
end ;\r
end ;\r
\r
\r
\r
procedure inithelp;\r
var\r
i,symb:integer;\r
begin\r
i:=0;\r
while i <= antalprod do\r
begin\r
symb:= prod[i].leftside;\r
help[symb].prodindex:= i;\r
repeat i:=i+1;\r
until symb<> prod[i].leftside;\r
end;\r
end;\r
\r
\r
(*dollar-f*)\r
procedure skrivparser( p: pointer);\r
(* PROCEDURE TIL TEST AF GENERERET PARSER *)\r
var\r
t,i: integer; lqbep: pointer;\r
begin\r
write(lf,lf,' PARSER',lf,lf);\r
write(' TILSTADR MODE PRODNR INF DERIVP NEXTP');\r
write(lf);\r
if antaltilst=0 then t:=tilstnr else t:=antaltilst;\r
for i:=0 to t do\r
begin\r
lqbep:=tilstand[i].oldstart;\r
repeat\r
with lqbep^ do\r
begin write(ord(lqbep),mode);\r
if (lbbegin <= i) and (i <= lbend) then write(' ',ord(lookbp))\r
else write(prodnr,inf);\r
write(ord(derivp),ord(nextp),lf);\r
lqbep:=derivp;\r
end;\r
until lqbep=nil;\r
write(lf);\r
end;\r
end; (*SKRIVPARSER*)\r
\r
procedure allocp(var p: pointer; m:integer; a: alfa);\r
begin\r
if freeptr <> nil then\r
begin\r
p:=freeptr; freeptr:=freeptr^.derivp;\r
end\r
else\r
begin\r
case m of\r
1: new(p,1);\r
5: new(p,5);\r
end;\r
end;\r
p^.derivp:=nil;\r
end; (*ALLOCP*)\r
\r
procedure freelist(pt: pointer);\r
var p: pointer;\r
begin p:=pt;\r
while p^.derivp<>nil do p:=p^.derivp;\r
p^.derivp:=freeptr;\r
freeptr:=pt;\r
end; (*FREELIST*)\r
\r
\r
(*dollar-f*)\r
procedure lr0;\r
label 20;\r
(******PROC. LR(0) KRAEVER : *)\r
(* GOALPRODUKTIONSNUMMER I 'GOALPROD' *)\r
(* FQRSTE FRIE CELLE I RIGHTSIDE I 'TOP' *)\r
(* 'LEFTSIDE' I PROD-ARRAY FQRSTE TOMME CELLE NULSTILLET *)\r
var\r
stack: array[1..const9] of\r
packed record\r
symbovg: 0..const2;\r
tilstp: pointer\r
end;\r
helpp,closp,oldp:pointer;\r
lqbep2: pointer2;\r
baslae,modeh,stacktop,stacktael,i,symb,prodno:integer;\r
errorprodno : 0 .. const1;\r
kopi: boolean;\r
goalprod: integer;\r
\r
procedure niceparser ;\r
var\r
i,pnr,l,count,nbcount,nextcount,suc,statenr,nr : integer ;\r
p : pointer ;\r
rightp :pointer2 ;\r
\r
function sqg( p : pointer) : integer ;\r
var\r
i : integer ;\r
begin\r
i:=0 ;\r
while (p<>tilstand[i].oldstart) do\r
i:=i+1;\r
sqg:=i ;\r
end (*SQG*) ;\r
\r
procedure linemark ;\r
var\r
i : integer ;\r
begin\r
write(lf) ;\r
for i:= 1 to nextcount do write(' ') ;\r
write('^',lf) ;\r
end (*LINEMARK*) ;\r
\r
procedure udskriv ;\r
var\r
k,j : integer ;\r
begin\r
with prod[pnr] do\r
begin\r
k:=leftside ;\r
rightp:=start ;\r
l:=laengde ;\r
end ;\r
if (statenr>0) then\r
write(' ',blank)\r
else\r
write(' ',i) ;\r
if (suc >= 0) then\r
write(suc,' ')\r
else\r
begin\r
if (nr=0) then\r
write(' REDUCE ')\r
else\r
write(blank,' ') ;\r
end ;\r
write(' ') ;\r
count:=26 ;\r
if (k=nontstart) then\r
begin\r
write('<GOALSYMBOL>') ;\r
count:=count+12 ;\r
end\r
else\r
nontwrit(k,count) ;\r
write(' ::= ') ;\r
count:=count+5 ;\r
nbcount:=count ;\r
nextcount:=-1 ;\r
for k:=1 to l do\r
begin\r
if (k=nr) then\r
nextcount:=count ;\r
allocate(rightp) ;\r
with rhs[rightp] do\r
begin\r
if (symbol >= nontstart) then\r
nontwrit(symbol,count)\r
else\r
outalf(internrep[symbol],count);\r
write(' ') ;\r
count:=count+1 ;\r
if (count >= 110) then\r
begin\r
if (nextcount >= 0) then\r
linemark\r
else\r
write(lf) ;\r
for j:=1 to nbcount do write(' ') ;\r
nextcount:=-1 ;\r
count:=nbcount ;\r
end ;\r
end ;\r
end ;\r
if (nextcount >= 0) then\r
linemark\r
else\r
write(lf) ;\r
end (*UDSKRIV *) ;\r
\r
begin\r
page(output);\r
write('*************************');\r
write(' THE LR(0)-MACHINE ');\r
write('**************************') ;\r
write(lf,lf) ;\r
write(' STATE NUMBER SUCCESSOR CONFIGURATION SETS') ;\r
write(lf) ;\r
for i:=0 to tilstnr do\r
begin\r
p:=tilstand[i].oldstart ;\r
statenr:=0 ;\r
repeat\r
with p^ do\r
begin\r
pnr:=prodnr ;\r
nr:=mode ;\r
if (nextp<>nil) then\r
suc:=sqg(nextp)\r
else\r
suc:=-1 ;\r
p:=derivp ;\r
end ;\r
udskriv ;\r
statenr:=statenr+1 ;\r
until (p=nil) ;\r
write(lf) ;\r
end ;\r
write(lf) ;\r
end (*NICEPARSER*) ;\r
\r
procedure juster(startp:pointer; boo:boolean);\r
(****** FOR NY TILSTAND NOTERES FOREKOMST AF*)\r
(* (PROD. NR., SYMBOL NR.) FOR DENNE *)\r
var\r
i: integer;\r
begin\r
lqbep:= startp;\r
while lqbep<>nil do\r
with lqbep^ do\r
begin\r
lqbep2:= prod[prodnr].start;\r
for i:= mode downto 1 do allocate(lqbep2);\r
if rhs[lqbep2].parserp<>nil then\r
begin\r
while rhs[lqbep2].link<>rhsnil do lqbep2:= rhs[lqbep2].link;\r
rhs[lqbep2].link:= top;\r
lqbep2:= top;\r
newelm(top,'LR0 ');\r
end;\r
with rhs[lqbep2] do\r
begin\r
basis:= boo;\r
if boo then basisl:= baslae;\r
parserp:= begintilst;\r
link:= rhsnil;\r
end;\r
lqbep:= derivp;\r
end\r
end;\r
\r
procedure stackellerej;\r
(****** CHECKER HVORVIDT (TILSTAND, OVERGANGSSYMBOL)\r
ER STAKKET ELLER SKAL STAKKES *)\r
begin\r
with classtop^ do\r
with help[inf] do\r
if not overgang then\r
begin\r
stacktael:= stacktael+1;\r
if stacktop= const9 then consterror('LR0 ','CONST9 ',const9);\r
stacktop:= stacktop+1;\r
overgang:= true;\r
with stack[stacktop] do\r
begin\r
symbovg:= inf;\r
tilstp:= begintilst;\r
end\r
end\r
end;\r
\r
(****** INITIALISERING *)\r
begin\r
goalprod:= 0;\r
top:=point; newelm(top,'LR0');\r
freeptr:=nil; antaltilst:=0; lbbegin:=0; lbend:=-1;\r
allocp(rodp,1,'LR0 ');\r
classtop:= rodp;\r
with rodp^ do\r
begin\r
prodnr:= goalprod;\r
xprodnr := prodnr;\r
mode:= 1;\r
lqbep2:= prod[goalprod].start;\r
allocate(lqbep2);\r
inf:= rhs[lqbep2].symbol;\r
derivp:= nil;\r
end;\r
baslae:=1;\r
stacktop:= 1;\r
with stack[1] do\r
begin\r
tilstp:= rodp;\r
symbovg:= rodp^.inf\r
end;\r
tilstnr:= 0;\r
tilstand[tilstnr].oldstart:= rodp;\r
juster(rodp,true);\r
allocp(classtop,1,'LR0 ');\r
begintilst:= classtop;\r
while stacktop>0 do\r
begin\r
(****** TILSTAND,OVERGANGSSYMBOL AFSTAKKES. *)\r
with stack[stacktop] do\r
begin\r
oldp:=tilstp;\r
symb:= symbovg;\r
end;\r
lqbep:= oldp;\r
stacktael:= 0;\r
baslae:= 0;\r
stacktop:= stacktop- 1;\r
for i:=0 to const2 do\r
with help[i] do\r
begin\r
afledt:= false;\r
overgang:= false;\r
end;\r
(****** NYT BASIS-SET GENERERES *)\r
while lqbep^.inf<>symb do lqbep:= lqbep^.derivp;\r
closp:= lqbep;\r
while true do\r
begin\r
if baslae= const5 then consterror('LR0 ','CONST5 ',const5);\r
baslae:= baslae+ 1;\r
with classtop^ do\r
begin\r
nextp:= nil;\r
prodnr:= lqbep^.prodnr;\r
xprodnr := prodnr;\r
modeh:= lqbep^.mode+1;\r
if prod[prodnr].laengde<modeh then\r
begin\r
mode:= 0;\r
inf:=0;\r
end else\r
begin\r
mode:= modeh;\r
lqbep2:= prod[prodnr].start;\r
for i:= mode downto 1 do allocate(lqbep2);\r
inf:= rhs[lqbep2].symbol;\r
stackellerej;\r
end;\r
end;\r
repeat\r
lqbep:= lqbep^.derivp;\r
if lqbep = nil then goto 20;\r
until lqbep^.inf=symb;\r
helpp:= classtop;\r
allocp(classtop,1,'LR0 ');\r
helpp^.derivp:= classtop\r
end;\r
20: classtop^.derivp:= nil;\r
(****** TEST OM BASIS-SET ER GENGANGER *)\r
kopi:= false;\r
lqbep2:= prod[begintilst^.prodnr].start;\r
for i:= begintilst^.mode downto 1 do allocate(lqbep2);\r
if rhs[lqbep2].parserp<>nil then\r
while (lqbep2<>rhsnil) and ( not kopi) do\r
with rhs[lqbep2] do\r
begin\r
if basis then\r
if baslae=basisl then\r
begin\r
kopi:= true;\r
lqbep:= begintilst;\r
while (lqbep<>nil) and kopi do\r
with lqbep^ do\r
begin\r
kopi:= false;\r
helpp:= parserp;\r
while helpp<>nil do\r
begin\r
kopi:=((prodnr=helpp^.prodnr) and (mode=helpp^.mode)) or kopi;\r
helpp:= helpp^.derivp\r
end;\r
lqbep:= derivp\r
end;\r
end;\r
if not kopi then lqbep2:= link\r
end;\r
if kopi then\r
(****** BASIS-SET GENKENDT *)\r
begin\r
closp^.nextp:= rhs[lqbep2].parserp;\r
stacktop:= stacktop- stacktael;\r
freelist(begintilst);\r
allocp(classtop,1,'LR0');\r
begintilst:=classtop;\r
end else\r
(****** BASIS-SET ACCEPTERET SOM NYT *)\r
begin\r
closp^.nextp:= begintilst;\r
if tilstnr= const10 then consterror('LR0 ','CONST10 ',const10);\r
tilstnr:= tilstnr+1;\r
tilstand[tilstnr].oldstart:= begintilst;\r
juster(begintilst,true);\r
(****** TILHQRENDE CLOSURE-SET GENERERES. *)\r
closp:= classtop;\r
errorprodno := closp^.prodnr;\r
lqbep:= begintilst;\r
while lqbep<>nil do\r
with lqbep^ do\r
with help[inf] do\r
begin\r
if mode > 0 then\r
if not (inf <=termg) then\r
if not afledt then\r
begin\r
afledt:= true;\r
prodno:= prodindex;\r
while prod[prodno].leftside = inf do\r
with prod[prodno] do\r
begin\r
helpp:= classtop;\r
allocp(classtop,1,'LR0 ');\r
helpp^.derivp:= classtop;\r
with classtop^ do\r
begin\r
lqbep2:= start;\r
allocate(lqbep2);\r
inf:= rhs[lqbep2].symbol;\r
if prod[prodno].laengde=0 then (*EMPTY RIGHTHAND SIDE*) mode:=0\r
else mode:=1;\r
prodnr:= prodno;\r
xprodnr := errorprodno;\r
derivp:= nil;\r
nextp:= nil;\r
end;\r
if classtop^.mode>0 then stackellerej;\r
prodno:= prodno+1;\r
end;\r
end;\r
lqbep:= derivp;\r
end;\r
with closp^ do\r
if derivp<>nil then juster(derivp,false);\r
allocp(classtop,1,'LR0');\r
begintilst:= classtop\r
end;\r
end;\r
gemp:= classtop;\r
if options[2] then skrivparser(classtop);\r
if options[30] then niceparser ;\r
end;\r
(****** END OF PROCEDURE LR0*)\r
\r
\r
procedure dump1;\r
var\r
i: integer;\r
begin\r
write(lf,lf,lf,' TILSTAND');\r
for i:=0 to antaltilst do\r
with tilstand[i]do\r
write(lf,' ',ord(oldstart),ord(newstart));\r
end;\r
\r
\r
procedure remember(p:pointer);\r
(* REMEMBER IS USED TO COUNT THE\r
FREQUENCY OF HOW OFTEN\r
THE DIFFERENT VALUES OF NEXTP\r
IN A LOOKBACKSTATE ARE USED *)\r
label 5;\r
var i: integer;\r
begin\r
for i:=1 to fcqi do\r
if fcq[i].udgang=p then goto 5;\r
if i<>i then\r
5: with fcq[i] do\r
begin\r
if frekvens = const6 then\r
consterror('remember','const6 ',const6);\r
frekvens := frekvens + 1;\r
end\r
else\r
begin\r
fcqi:=fcqi+1;\r
if fcqi>const3 then consterror(' REMEMBER ','CONST3',const3);\r
fcq[fcqi].udgang:=p;\r
fcq[fcqi].frekvens:=1;\r
end;\r
end (* REMEMBER *) ;\r
\r
procedure optimize(var maxnextp:pointer; var md:integer);\r
(* OPTIMIZE FINDS THE NEXTP,WHICH IS MOST OFTEN USED IN\r
THE STATE,AND DELETES THE STATEELEMENTS WHERE IT OCCURS*)\r
label 10;\r
var p:pointer;\r
max,i,husk:integer;\r
begin\r
if options[21] then\r
begin write(lf,' ','FCQ',lf,lf,' UDGANG','FREKVENS',lf);\r
for i:=1 to fcqi do with fcq[i] do\r
write(ord(udgang),frekvens,lf);\r
write(lf,lf);\r
end;\r
maxnextp:=fcq[1].udgang;\r
max:=fcq[1].frekvens;\r
for i:=2 to fcqi do\r
with fcq[i] do\r
if frekvens >max then\r
begin max:=frekvens; maxnextp:=udgang end;\r
\r
if md=4 then\r
begin\r
p:=begintilst;\r
while p^.nextp<>maxnextp do p:=p^.derivp;\r
husk:=p^.prodnr;\r
(* THE LOOKAHEAD-SET OF PROD. <>HUSK' WILL BE DELETED *)\r
end;\r
\r
\r
while(begintilst^.nextp=maxnextp) and (begintilst^.mode=md) do\r
begintilst:=begintilst^.derivp;\r
\r
p:=begintilst;\r
repeat\r
oldp:=p;\r
repeat\r
p:=p^.derivp;\r
if p=nil then goto 10;\r
until ( p^.nextp<>maxnextp) or (p^.mode<>md);\r
10:\r
oldp^.derivp:=p;\r
until p=nil;\r
if md=4 then md:=husk;\r
\r
end (* END OPTIMIZE *) ;\r
\r
\r
(*dollar-f*)\r
procedure lookb;\r
(* LOOKB GENERATES THE LOOKBACKSTATES *)\r
var\r
prodnr,symb,md,r1:integer;\r
point: pointer2;tilstp:pointer;\r
begin\r
prod[0].lookbackp:=nil;\r
antaltilst:=tilstnr;\r
lbbegin:=tilstnr+1;\r
freeptr:=nil;\r
\r
for prodnr:=1 to antalprod do\r
with prod[prodnr] do\r
begin\r
fcqi:=0;\r
allocp(classtop,5,'LOOKBP ');\r
begintilst:=classtop; symb:=leftside;\r
point:=start; if laengde>0 then (*RHS NOT EMPTY*) allocate(point);\r
while point<>rhsnil do\r
with classtop^ do\r
begin mode:=5;\r
tilstp:=rhs[point].parserp;\r
if tilstp=nil then\r
begin\r
msg('=ERROR(S) IN GRAMMAR '); write(lf,lf);\r
write(' THE STARTSYMBOL CANNOT PRODUCE A STRING CONTAINING ');\r
write(lf,' '); r1:=1; nontwrit(leftside,r1);\r
write(lf,lf); stop(0);\r
end;\r
lookbp:=tilstp;\r
while tilstp^.inf<>symb do tilstp :=tilstp^.derivp;\r
tilstp:=tilstp^.nextp; remember(tilstp);\r
nextp:=tilstp; oldp:=classtop;\r
allocp(classtop,5,'LOOKB ');\r
oldp^.derivp:=classtop;\r
point:=rhs[point].link;\r
end;\r
oldp^.derivp:=nil;\r
if fcqi=1 then\r
begin\r
lookbackp:=begintilst^.nextp;\r
freelist(begintilst);\r
end else\r
begin\r
md:=5; optimize(tilstp,md);\r
oldp^.derivp:=classtop;\r
with classtop^ do\r
begin derivp:=nil;\r
nextp:=tilstp;\r
lookbp:=nil ;\r
mode:=5;\r
end;\r
\r
antaltilst:=antaltilst+1;\r
if antaltilst>const10 then consterror('LOOKB ','CONST10 ',const10);\r
tilstand[antaltilst].oldstart:=begintilst;\r
lookbackp:=begintilst;\r
end;\r
\r
while prod[prodnr+1].leftside=symb do\r
begin prodnr:=prodnr+1;\r
prod[prodnr].lookbackp:=lookbackp;\r
end;\r
end;\r
lbend:=antaltilst;\r
freeptr:=nil;\r
\r
if options[15] then skrivparser(gemp);\r
if options[16] then dump5; (* PROD ARRAY*)\r
if options[17] then dump1; (* TILSTANDS ARRAY *) (* nb: newstart is undefined *)\r
end (* END LOOKB *) ;\r
\r
\r
\r
(*dollar-f*)\r
procedure adequad ;\r
\r
type\r
tilstcheck=(nyindgang,nyvej,udenom) ;\r
\r
var\r
i,prodant,termant,k,pnr,lsymb,l :integer ;\r
boo,slr1,headwrite : boolean ;\r
start,helpp,lqbep1,lqbep2,lqbep3,lastok,stopp : pointer ;\r
lookant : array[1..const14] of packed record\r
ant : 1..const8 ;\r
point : pointer ;\r
end ;\r
la : array[0..const8] of integer ;\r
stack : array[1..const2] of packed record\r
symb : 0..const2 ;\r
pnr : 0..const1 ;\r
token : modetype ;\r
end ;\r
\r
\r
\r
\r
\r
procedure lookahead( var a : integer) ; forward ;\r
\r
\r
procedure alllookaheads ;\r
var\r
i,j,l,k : integer ;\r
begin\r
write(lf) ;\r
write('1 SLR(1) LOOKAHEADS FOR ALL NONTERMINALS ') ;\r
write(lf,lf) ;\r
for i:= nontstart+1 to nontslut do\r
begin\r
j:=0 ;\r
k:=i ;\r
lookahead(k) ;\r
write(lf,' ') ;\r
nontwrit(i,j) ;\r
for l:=j to 30 do write(' ') ;\r
for j:=1 to lalaengde do\r
begin\r
l:=j-1 ;\r
write(' ',internrep[la[l]]) ;\r
if (j mod 9 = 0) then\r
write(lf,blank,blank,blank);\r
end ;\r
end ;\r
write(lf) ;\r
end ;\r
\r
procedure lalrlookahead(pointp : pointer ; prodno : integer) ;\r
\r
var\r
j,l,info,lltop : integer; (*LLTOP IS LAST USED ELEMENT OF LL *)\r
ll: array[0..const16] of\r
packed record\r
mrk,lamrk: boolean;\r
lnk: 0..const16;\r
hidep: pointer;\r
end;\r
ir: record\r
case b:boolean of\r
false:(i:integer);\r
true :(r:pointer2) (*POINTER TO RIGHTSIDE *)\r
end;\r
\r
procedure lalr1(statep,testp:pointer;prodno:integer);\r
label 2;\r
\r
var\r
leftinf,plngd,hinx: integer;\r
rightp,prodp: pointer2; (*POINTER TO RIGHTSIDE *)\r
runp,transp,loopp,chckp: pointer;\r
\r
begin\r
with prod[prodno],ir do\r
begin leftinf:=leftside; plngd:=laengde; r:=start; if laengde>0 then (*RHS NOT EMPTY*) i:=i+1; rightp:=r;\r
end;\r
prodp:=rightp;\r
if (testp<>nil) and (plngd>0) then\r
begin plngd:=plngd-1; chckp:=testp;\r
end else chckp:=statep;\r
while prodp<>rhsnil do\r
begin runp:=rhs[prodp].parserp; loopp:=runp; ir.r:=rightp;\r
for hinx:=1 to plngd do\r
begin info:=rhs[ir.r].symbol;\r
while loopp^.inf<>info do loopp:=loopp^.derivp;\r
loopp:=loopp^.nextp; ir.i:=ir.i+1;\r
end;\r
if loopp=chckp then\r
begin\r
if ll[leftinf].mrk then\r
begin hinx:=leftinf;\r
repeat with ll[hinx] do\r
begin if runp=hidep then goto 2;\r
l:=hinx; hinx:=lnk;\r
end;\r
until hinx=0;\r
lltop:=lltop+1; if lltop>const16 then consterror('LALRLOOKAH','CONST16 ',const16);\r
hinx:=lltop; ll[l].lnk:=hinx;\r
end else hinx:=leftinf;\r
with ll[hinx] do\r
begin mrk:=true; hidep:=runp; lnk:=0;\r
end;\r
transp:=runp;\r
while transp^.inf<>leftinf do transp:=transp^.derivp;\r
transp:=transp^.nextp; loopp:=transp;\r
while loopp<>nil do with loopp^ do\r
begin\r
if mode=0 then lalr1(transp,runp,prodnr) else ll[inf].lamrk:=true;\r
loopp:=derivp;\r
end;\r
end;\r
2: (*TRY NEXT *)\r
prodp:= rhs[prodp].link;\r
end;\r
end; (*LALR1*)\r
\r
\r
begin\r
lltop:=const2;\r
for j:=0 to const2 do with ll[j] do\r
begin mrk:=false; lamrk:=false;\r
end;\r
lalr1(pointp,nil,prodno);\r
lalaengde:=0;\r
for j:=0 to termg do\r
if ll[j].lamrk then\r
begin la[lalaengde]:= j;\r
if lalaengde<const8 then lalaengde:=lalaengde+1 else consterror('LALRLOOKAH','CONST8 ',const8);\r
end;\r
if lalaengde=0 then write(lf,lf,' ***** ','PROD',prodno,lf,lf);\r
end; (* LALRLOOKAHEAD *)\r
\r
\r
\r
\r
\r
\r
\r
procedure lookahead;\r
label 10,20,30,100;\r
var s,j,pnr,tal,husk,prodnr,naeste,tegn,i : integer;\r
graense,intern : integer;\r
begyndp,p1,huskp :pointer2 ;\r
first : boolean;\r
stack,buffer: array[0..const8] of integer;\r
\r
begin\r
for pnr:=nontstart to nontslut do help[pnr].status:=firsttim;\r
for i:=0 to const8 do la[i]:=0 ;\r
begyndp:=prod[0].start ;\r
intern:=a;\r
naeste:=0; j:=0;\r
lalaengde:=0;\r
30 : prodnr:=0;\r
husk:=100; i:=1;\r
p1:=begyndp;\r
10 : allocate(p1);\r
if i>prod[prodnr].laengde then\r
begin\r
prodnr:=prodnr+1; i:=1;\r
if prodnr <= antalprod then p1:=prod[prodnr].start else goto 100;\r
allocate(p1); (*P1 PEGER NU PAA FQRSTE ELEMENT I DEN NYE\r
PRODUKTION*)\r
end;\r
while (rhs[p1].symbol<>a) and (p1<top) do\r
begin\r
(* LEDER EFTER A PAA HQJRE SIDE*)\r
allocate(p1); i:=i+1;\r
if i>prod[prodnr].laengde then\r
begin\r
prodnr:=prodnr+1; i:=1;\r
if prodnr <= antalprod then p1:=prod[prodnr].start else goto 100;\r
allocate(p1); (*P1 PEGER NU PAA FQRSTE ELEMENT I DEN NYE\r
PRODUKTION*)\r
end;\r
end;\r
if p1<top then\r
begin\r
(* A FUNDET, PRODUKTIONSNR STAAR I PRODNR*)\r
if i<prod[prodnr].laengde then\r
begin\r
(* A ER IKKE SIDSTE TEGN P H S*)\r
allocate(p1);\r
tegn:=rhs[p1].symbol;\r
huskp:=p1; i:=i+1;\r
end else\r
begin (* A ER SIDSTE TEGN PAA H S *)\r
pnr:=prod[prodnr].leftside;\r
(* TO STACK *)\r
with help[pnr] do\r
if (status=firsttim) and (pnr<>a) then\r
begin if j<const8 then\r
begin j:=j+1;\r
status:=finish;\r
stack[j]:=pnr;\r
end else consterror('LOOKAHEAD ','CONST8 ',const8);\r
end;\r
i:=i+1;\r
goto 10;\r
end;\r
end else goto 100;\r
if tegn>termg then\r
begin (* TEGN ER NONTERMIMAL*)\r
for s:=0 to nontstart-1 do\r
begin\r
if ( s mod (setmax+1) in ph1s[tegn].r[s div (setmax+1)]) then\r
begin\r
buffer[naeste]:=s;\r
naeste:=naeste+1;\r
if naeste>const8 then consterror('LOOKAHEAD ','CONST8 ',const8);\r
lalaengde:=lalaengde+1;\r
end;\r
end;\r
end\r
\r
else begin (*TEGN ER TERMINAL*)\r
buffer[naeste]:=tegn;\r
lalaengde:=lalaengde+1;\r
naeste:=naeste+1;\r
if naeste>const8 then consterror('LOOKAHEAD ','CONST8 ',const8);\r
end; p1:=huskp; i:=i+1; goto 10;\r
100 : (*AFSTAK*)\r
if j>0 then\r
begin a:=stack[j];\r
j:=j-1; goto 30;\r
end;\r
20 : (*END LOOKAHEAD*)\r
if(lalaengde-1 >= 0) then la[0]:=buffer[0];\r
j:=1;\r
i:=0; graense:=1; tal:=lalaengde;\r
while (j<tal) do\r
begin\r
while (la[i]<>buffer[j]) and (i<graense) do i:=i+1;\r
if i=graense then\r
begin\r
la[graense]:=buffer[j];\r
graense:=graense+1;\r
end else lalaengde:=lalaengde-1;\r
j:=j+1; i:=0;\r
end ;\r
end;\r
\r
\r
procedure optimalisering( x : tilstcheck ) ;\r
begin\r
case x of\r
nyindgang :\r
begin\r
lastok^:=helpp^;\r
end ;\r
nyvej :\r
begin\r
lastok^.derivp:=helpp ;\r
lastok:=helpp ;\r
end ;\r
udenom :\r
begin\r
lastok^.derivp:=helpp ;\r
end ;\r
end ;\r
end ;\r
\r
\r
procedure slrtext ( x : integer ) ;\r
var\r
i : integer ;\r
begin\r
page(output);\r
for i:=1 to 71 do\r
write('*') ;\r
write(lf,lf) ;\r
write(' ') ;\r
case x of\r
1 :\r
begin\r
write('THE GRAMMAR IS SLR1 ') ;\r
msg('=THE GRAMMAR IS SLR1 ') ;\r
write(lf,lf) ;\r
write(' ') ;\r
for i:=1 to 71 do\r
write('*') ;\r
write(lf) ;\r
end ;\r
2 :\r
begin\r
write('THE GRAMMAR IS NOT SLR1 ') ;\r
write(lf) ;\r
write(' ') ;\r
write('THE PROGRAM STOPS ') ;\r
msg('=THE GRAMMAR IS NOT SLR1 ') ;\r
write(lf,lf) ;\r
write(' ') ;\r
for i:=1 to 71 do\r
write('*') ;\r
stop(0) ;\r
end ;\r
end ;\r
end ;\r
\r
\r
procedure lalrtext ( x : integer ) ;\r
var\r
i : integer ;\r
begin\r
page(output);\r
for i:=1 to 71 do\r
write('*');\r
write(lf,lf) ;\r
write(' ') ;\r
case x of\r
1 :\r
begin\r
write('THE GRAMMAR IS LALR1 ');\r
msg('=THE GRAMMAR IS LALR1 ') ;\r
write(lf,lf) ;\r
write(' ') ;\r
for i:=1 to 71 do\r
write('*');\r
write(lf) ;\r
end ;\r
2 :\r
begin\r
write('THE GRAMMAR IS NOT LALR1 ') ;\r
write(lf) ;\r
write(' ') ;\r
msg('=THE GRAMMAR IS NOT LALR1 ') ;\r
write('THE PROGRAM STOPS ') ;\r
write(lf,lf) ;\r
write(' ') ;\r
for i:=1 to 71 do\r
write('*') ;\r
stop(0) ;\r
end ;\r
end ;\r
end ;\r
\r
\r
procedure adeqwrite ( x : integer ) ;\r
var\r
i,j,k,l,kk,m : integer ;\r
helpp : pointer ;\r
begin\r
case x of\r
1 :\r
begin\r
(*OVERSKRIFT TIL LOOKAHEAD-MAENGDERNE *)\r
page(output);\r
write('*********************') ;\r
write(' A LIST OF NON-SLR1 STATES ') ;\r
write('*********************') ;\r
write(lf,lf) ;\r
write(' ') ;\r
write('IN EACH OF THE FOLLOWING STATES THE ') ;\r
write(lf) ;\r
write(' ') ;\r
write('SETS OF SYMBOLS ARE NOT DISJOINT ') ;\r
write(lf) ;\r
end ;\r
2 :\r
begin\r
(*UDSKRIFT AF AFSLUTNING PAA LOOKAHEAD-MAENGDERNE *)\r
write(lf) ;\r
write(' ***********************') ;\r
write(' END OF NON-SLR1 STATES ') ;\r
write('**********************') ;\r
write(lf,lf) ;\r
end ;\r
3 :\r
begin\r
(*UDSKRIVNING AF LOOKAHEAD MAENGDERNE *)\r
write(lf) ;\r
write(' ') ;\r
for j:=1 to 61 do\r
write('-') ;\r
write(lf) ;\r
if (termant>0) then\r
begin\r
write(' ') ;\r
write('READING CONTINUES IF THE NEXT INPUTSYMBOL') ;\r
write(lf) ;\r
write(' ') ;\r
write('IS ONE OF THE FOLLOWING : ') ;\r
write(lf) ;\r
write(' ') ;\r
write('SYMBOL PRODUCTION SYMBOL NO ') ;\r
write(lf) ;\r
(*UDSKRIVNING AF TERMINALSYMBOLERNE *)\r
for j:=1 to termant do\r
begin\r
kk:=stack[j].pnr ;\r
l:=stack[j].token ;\r
k:=stack[j].symb ;\r
write(' ') ;\r
write(internrep[k]) ;\r
write(kk) ;\r
write(l) ;\r
write(lf) ;\r
end ;\r
write(lf) ;\r
end ;\r
(*UDSKRIVNING AF LOOKAHEAD FOR REDUKTIONERNE *)\r
for j:=1 to prodant do\r
begin\r
l:=lookant[j].ant ;\r
helpp:=lookant[j].point ;\r
write(' ') ;\r
write('REDUCTION NO ') ;\r
m:=helpp^.prodnr ;\r
write(m:4);\r
write(' IS PERFORMED IF THE NEXT INPUTSYMBOL') ;\r
write(lf) ;\r
write(' ') ;\r
write('IS ONE OF THE FOLLOWING : ') ;\r
write(lf) ;\r
kk:=0 ;\r
repeat\r
kk:=kk+1 ;\r
write(' ') ;\r
k:=helpp^.inf ;\r
write(internrep[k]) ;\r
write(lf) ;\r
helpp:=helpp^.derivp ;\r
until (kk=l) ;\r
write(lf) ;\r
end ;\r
end ;\r
4 : (* EARLIER USER FOR WRITING WARNING STATES *) ;\r
5 :\r
begin\r
(*OVERSKRIFT TIL LOOKAHEAD-MAENGDERNE LALR1 *)\r
page(output);\r
write('*********************') ;\r
write(' A LIST OF NON-LALR1 STATES ') ;\r
write('********************') ;\r
write(lf,lf) ;\r
write(' ') ;\r
write('IN EACH OF THE FOLLOWING STATES THE') ;\r
write(lf) ;\r
write(' ') ;\r
write('SETS OF SYMBOLS ARE NOT DISJOINT') ;\r
write(lf) ;\r
end ;\r
6 :\r
begin\r
(*UDSKRIFT AF AFSLUTNING PAA LOOKAHEAD-MAENGDERNE LALR1 *)\r
write(lf) ;\r
write(' **********************') ;\r
write(' END OF NON-LALR1 STATES ') ;\r
write('*********************') ;\r
write(lf,lf) ;\r
end ;\r
end ;\r
end ;\r
\r
\r
function maengdecheck (var x : boolean ) : boolean ;\r
var\r
boo : boolean ;\r
count,checksymb,k,step1,step2,l1,l2,j,l : integer ;\r
step1p,step2p,stepp1,stepp2 : pointer ;\r
begin\r
(*FQRST CHECKES OM TERMINALSYMBOLERNE\r
LIGGER I ET AF LOOKAHEADMAENGDERNE *)\r
boo:=true ;\r
helpp:=start ;\r
count:=0 ;\r
if (termant>0) then\r
begin\r
for count:=1 to termant do\r
begin\r
checksymb:=stack[count].symb ;\r
j:=0 ;\r
repeat\r
j:=j+1 ;\r
k:=lookant[j].ant ;\r
lqbep1:=lookant[j].point ;\r
l:=0 ;\r
repeat\r
l:=l+1 ;\r
if (lqbep1^.inf=checksymb) then\r
begin\r
boo:=false ;\r
l:=k ;\r
j:=prodant ;\r
count:=termant ;\r
end ;\r
lqbep1:=lqbep1^.derivp ;\r
until (l=k) ;\r
until (j=prodant) ;\r
end ;\r
end ;\r
if ((boo) and (prodant>1)) then\r
begin\r
(*DET VIDES STADIG IKKE OM TILSTANDEN GQR\r
GRAMMATIKKEN NON-SLR1.NU CHECKES OM LOOK-\r
AHEADMAENGDERNE ER DISJUNKTE *)\r
k:=0 ;\r
repeat\r
k:=k+1 ;\r
step1:=lookant[k].ant ;\r
step1p:=lookant[k].point ;\r
j:=k ;\r
repeat\r
stepp1:=step1p ;\r
j:=j+1 ;\r
step2:=lookant[j].ant ;\r
step2p:=lookant[j].point ;\r
l1:=0 ;\r
repeat\r
l1:=l1+1 ;\r
l2:=0 ;\r
stepp2:=step2p ;\r
repeat\r
l2:=l2+1 ;\r
if (stepp1^.inf=stepp2^.inf) then\r
begin\r
l2:=step2 ;\r
l1:=step1 ;\r
j:=prodant ;\r
boo:=false ;\r
k:=prodant-1 ;\r
end ;\r
stepp2:=stepp2^.derivp ;\r
until (l2=step2) ;\r
stepp1:=stepp1^.derivp ;\r
until (l1=step1) ;\r
until (j=prodant) ;\r
until (k=prodant-1) ;\r
end ;\r
(*ER BOO STADIG TRUE GJORDE DENNE TILSTAND\r
IKKE GRAMMATIKKEN NON-SLR1 *)\r
maengdecheck:=boo ;\r
end ;\r
\r
\r
function findreduce(pnr:integer):pointer;\r
\r
var\r
p1,p2: pointer2;\r
pt: pointer;\r
\r
begin\r
with prod[pnr] do\r
if laengde=0 then findreduce:=lookbackp\r
else\r
begin p1:=start;\r
while rhs[p1].parserp^.derivp<>nil do\r
begin p2:=p1; p1:=rhs[p1].link;\r
if p1=rhsnil then\r
begin allocp(pt,1,'FINDREDUCE');\r
with pt^ do\r
begin mode:=3; inf:=laengde-1; prodnr:=pnr; nextp:=lookbackp; derivp:=nil;\r
end;\r
antaltilst:=antaltilst+1;\r
if antaltilst>const10 then consterror('FINDREDUCE','CONST10 ',const10);\r
tilstand[antaltilst].oldstart:= pt;\r
newelm(top,'FINDREDUCE'); p1:= top;\r
rhs[p1].parserp:=pt; rhs[p1].link:=rhsnil; rhs[p2].link:=p1;\r
end;\r
end;\r
findreduce:= rhs[p1].parserp;\r
end;\r
end; (* FINDREDUCE *)\r
\r
\r
\r
begin\r
(*START AF SUBRUTINE ADEQUAD *)\r
if options[7] then\r
alllookaheads ;\r
slr1:=true ;\r
headwrite:=true ;\r
boo:=true ;\r
for i:=1 to tilstnr do\r
begin\r
start:=tilstand[i].oldstart ;\r
prodant:=0 ;\r
termant:=0 ;\r
helpp:=start ;\r
repeat\r
k:=helpp^.mode ;\r
if (k=0) then\r
prodant:=prodant+1\r
else\r
if ((helpp^.inf <= termg) and (helpp^.nextp<>nil)) then\r
termant:=termant+1 ;\r
helpp:=helpp^.derivp ;\r
until (helpp=nil) ;\r
if (prodant>const14) then\r
consterror('ADEQUAD ','CONST14 ',const14) ;\r
(*NU VIDES DET OM TILSTANDEN KRAEVER KALD AF\r
LOOKAHEAD ELLER EJ\r
ER ANTAL PRODUKTIONER LIG 0\r
ELLER ER\r
ANTAL PRODUKTIONER LIG 1\r
OG ANTAL TERMINALER LIG 0\r
KRAEVES DER IKKE LOOKAHEAD,I ALLE ANDRE\r
TILFAELDE KRAEVES LOOKAHEAD *)\r
if ((prodant>1) or ((prodant=1) and (termant>0))) then\r
begin\r
(*LOOKAHEAD SKAL KALDES OG INDSAETTES *)\r
prodant:=0 ;\r
termant:=0 ;\r
helpp:=start ;\r
repeat\r
k:=helpp^.mode ;\r
if (k=0) then\r
begin\r
pnr:=helpp^.prodnr ;\r
lsymb:=prod[pnr].leftside ;\r
if options[27] then\r
lalrlookahead(start,pnr)\r
else\r
lookahead(lsymb) ;\r
l:=lalaengde-1 ;\r
allocp(lqbep1,1,'ADEQUAD ');\r
helpp^.nextp:=lqbep1 ;\r
prodant:=prodant+1 ;\r
lookant[prodant].ant:=lalaengde ;\r
lookant[prodant].point:=lqbep1 ;\r
lqbep3:= findreduce(pnr);\r
for j:=0 to l do\r
begin\r
lqbep2:=lqbep1 ;\r
with lqbep2^ do\r
begin\r
nextp:=lqbep3 ;\r
inf:=la[j] ;\r
prodnr:=pnr ;\r
mode:=4 ;\r
if (j=l) then\r
derivp:=helpp^.derivp\r
else\r
begin\r
allocp(lqbep1,1,'ADEQUAD ');\r
derivp:=lqbep1 ;\r
end ;\r
end ;\r
end ;\r
end\r
else\r
with helpp^ do\r
begin\r
if ((inf <= termg) and (nextp<>nil)) then\r
begin\r
termant:=termant+1 ;\r
if (termant > const2) then\r
consterror('ADEQUAD ','CONST2 ',const2)\r
else\r
begin\r
stack[termant].symb:=inf ;\r
stack[termant].pnr:=prodnr ;\r
stack[termant].token:=mode ;\r
end ;\r
end ;\r
mode:=2 ;\r
end ;\r
helpp:=helpp^.derivp ;\r
until (helpp=nil) ;\r
(*NU KAN DET CHECKES OM GRAMMATIKKEN\r
ER SLR1 ELLER EJ *)\r
boo:=maengdecheck(boo) ;\r
if((boo=false) or (options[12])) then\r
begin\r
if ((slr1) and (headwrite)) then\r
begin\r
if (options[27]) then\r
adeqwrite(5)\r
else\r
adeqwrite(1) ;\r
if (boo=false) then\r
slr1:=false\r
else\r
headwrite:=false ;\r
end ;\r
adeqwrite(3) ;\r
end\r
end\r
else\r
if (prodant=0) then\r
begin\r
helpp:=start ;\r
while (helpp<>nil) do\r
begin\r
helpp^.mode:=1 ;\r
helpp:=helpp^.derivp ;\r
end ;\r
end ;\r
(*NU ER DENNE TILSTAND FAERDIG,HVIS LOOKAHEAD\r
VAR NQDVENDIG ER DEN SAT IND\r
DER MANGLER NU KUN AT BLIVE JUSTERET POINTERE.\r
DER SKER UNDER OPTIMALISERING.OPTIMALISE-\r
RING VIL KUN SKE HVIS GRAMMATIKKEN ER SLR1 *)\r
end ;\r
if (slr1) then\r
begin\r
(*GRAMMATIKKEN ER SLR1 OG DER KAN OPTIMALISERES *)\r
for i:=1 to tilstnr do\r
begin\r
start:=tilstand[i].oldstart ;\r
lastok:=start ;\r
prodant:=0 ;\r
termant:=0 ;\r
count:=0 ;\r
lqbep1:=start ;\r
repeat\r
helpp:=lqbep1 ;\r
count:=count+1 ;\r
with lqbep1^ do\r
begin\r
stopp:=derivp ;\r
if ((mode=0) and (nextp<>nil)) then\r
begin\r
(*NU ER DET EN REDUKTION\r
PRODANT,TERMANT,COUNT SIGER OM DER SKAL\r
VAERE NY INDGANG *)\r
if ((prodant=0) and (termant=0)) then\r
begin\r
helpp:=nextp;\r
optimalisering(nyindgang);\r
end\r
else\r
begin\r
helpp:=nextp ;\r
optimalisering(nyvej) ;\r
end ;\r
prodant:=prodant+1 ;\r
(*LASTOK SKAL VAERE DET SIDSTE\r
AF LOOKAHEADELEMENTERNE *)\r
repeat\r
lqbep3:=lastok^.derivp ;\r
if (lqbep3<>stopp) then\r
lastok:=lqbep3 ;\r
until (lqbep3=stopp) ;\r
end\r
else\r
if (mode=0) then\r
(*IN THIS STATE: ONLY ONE REDUCTION *)\r
(*IF ITS AN EMPTY REDUCTION, THEN *)\r
(*SOME NONTERMINAL TRANSITIONS MAY APPEAR *)\r
with prod[prodnr] do\r
begin mode:=3; nextp:=lookbackp; prodant:=prodant+1;\r
if laengde=0 then inf:=0 else inf:=laengde-1;\r
if count>1 then optimalisering(nyindgang);\r
end\r
else\r
begin\r
if (inf <= termg) then\r
begin\r
(*NU ER DET ET TERMINAL SYMBOL *)\r
if (count>1) then\r
begin\r
if (nextp<>nil) then\r
begin\r
helpp:=lqbep1 ;\r
if ((prodant=0) and (termant=0)) then\r
optimalisering(nyindgang)\r
else\r
optimalisering(nyvej) ;\r
end\r
else\r
begin\r
helpp:=stopp ;\r
optimalisering(udenom) ;\r
termant:=termant-1 ;\r
end ;\r
end ;\r
termant:=termant+1 ;\r
end\r
else\r
begin (*NONTERMINAL TRANSITION *)\r
helpp:=derivp ;\r
if ((termant=0) and (prodant=0)) then\r
optimalisering(nyindgang)\r
else\r
begin\r
helpp:=stopp ;\r
optimalisering(udenom) ;\r
end ;\r
end ;\r
end ;\r
end ;\r
lqbep1:=stopp ;\r
until (lqbep1=nil) ;\r
end ;\r
if (options[12]) then\r
begin\r
if (options[27]) then\r
adeqwrite(6)\r
else\r
adeqwrite(2) ;\r
end ;\r
if (options[27]) then\r
lalrtext(1)\r
else\r
slrtext(1) ;\r
end\r
else\r
begin\r
if (options[27]) then\r
begin\r
adeqwrite(6) ;\r
lalrtext(2) ;\r
end\r
else\r
begin\r
adeqwrite(2) ;\r
slrtext(2) ;\r
end ;\r
stop(0) ;\r
end ;\r
end ;\r
\r
\r
\r
(*dollar-f*)\r
procedure finalparser;\r
\r
type\r
symbol=-1..const2;\r
errno=0..const1;\r
rslength=0..15;\r
prodno=0..const1;\r
lrinx=0..const7;\r
lrelm=packed record\r
chain: lrinx;(*NEXT ITEM IN THIS STATE*)\r
next : lrinx;(*NEXT STATE*)\r
case kind: rslength (*TYPE OF STATE*) of\r
1,2,4,6: (symb: symbol; err: errno);\r
0,3: (rs: rslength; prodn: prodno);\r
5: (lb: lrinx);\r
end; (*RECORD*)\r
var\r
lr: array[lrinx] of lrelm;\r
count,smax: integer;\r
\r
\r
procedure copy(var ch:char; skip: boolean);\r
begin\r
if eof(parsin) then\r
begin\r
write(lf); write(' FILE PARSIN IS NOT A CORRECT PARSER ');\r
msg('=ERROR(S) IN FILE PARSIN');\r
stop(0);\r
end\r
else\r
begin\r
if eoln(parsin) then ch := ' ' else ch := parsin^;\r
if not skip then\r
if eoln(parsin) then writeln(parsout)\r
else write(parsout,ch);\r
end;\r
get(parsin);\r
end; (*COPY*)\r
\r
\r
procedure search(skip : boolean);\r
var\r
a: array[1..5] of char;\r
i: integer; found:boolean; ch: char;\r
begin found:=false;\r
a[1]:='B'; a[2]:='O'; a[3]:='B'; a[4]:='S'; a[5]:=' ';\r
repeat copy(ch,skip);\r
if ch='*' then\r
begin repeat copy(ch,skip) until ch<>'*';\r
i:=1;\r
while (a[i]=ch) and (i<5) do\r
begin\r
copy(ch,skip); i:=i+1;\r
end;\r
found:=i>4;\r
end;\r
until found;\r
while not eoln(parsin) do copy(ch,skip); copy(ch,skip);\r
end;(*SEARCH*)\r
\r
procedure emitconstants;\r
begin\r
if not options[32] then (*USE STANDARD SKELETON COMPILER *)\r
begin reset(parsin);(*ON FILE PARSIN, AND DELIVER IT *)\r
rewrite(parsout); (*ON FILE PARSOUT WITH INITIALISED CONSTANTS*)\r
search(false);\r
writeln(parsout,' SYMBMAX=',nontslut:1,';');\r
writeln(parsout,' PRODMAX=',antalprod:1,';');\r
writeln(parsout,' LRMAX=',smax:1,';');\r
writeln(parsout,' LXMAX=',trmax:1,';');\r
writeln(parsout,' ERRORVAL=',errorval:1,';');\r
writeln(parsout,' NAMEVAL=',nameval:1,';');\r
writeln(parsout,' CONSTVAL=',cstval:1,';');\r
writeln(parsout,' STRINGVAL=',stringval:1,';');\r
writeln(parsout,' STRINGCH=');\r
if stringch='''' then writeln(parsout,''''''''';')\r
else writeln(parsout,'''',stringch,''';');\r
writeln(parsout,' COMBEGIN=',combegin:1,';') ;\r
writeln(parsout,' COMLENGTH=',comlength:1,';') ;\r
search(true); writeln(parsout,' (*BOBS) ');\r
search(false);\r
end;\r
writeln(tables, 11); (* number of constants *)\r
writeln(tables,nontslut);writeln(tables,antalprod);\r
writeln(tables,smax);writeln(tables,trmax);\r
writeln(tables,errorval);writeln(tables,nameval);\r
writeln(tables,cstval);writeln(tables,stringval);\r
writeln(tables,' ',stringch);\r
writeln(tables,combegin);writeln(tables,comlength);\r
end; (*EMITCONSTANTS*)\r
\r
procedure emitlex;\r
type\r
lxinx=-200..const12; (* NOTE! CHAR MAY NOT CONTAIN MORE THAN 200 CHARS*)\r
lxelm=packed record\r
np,hp: 0..const12;\r
tv: symbol;\r
ch: char;\r
end;\r
\r
var\r
lx: array[lxinx] of lxelm;\r
tinx,t: integer;\r
\r
procedure convertlex;\r
var c: char;\r
\r
procedure incrtinx;\r
begin\r
if tinx<const12 then tinx:=tinx+1\r
else consterror('CONVERTLEX',' CONST12 ',const12);\r
end;\r
\r
procedure visit(p: termpointer);\r
begin\r
with p^, lx[tinx] do\r
begin tv:=intern; ch:=tegn;\r
if niveaup<>nil then\r
begin incrtinx; np:=tinx;\r
visit(niveaup);\r
end\r
else np:=0;\r
if higherp<>nil then\r
begin incrtinx; hp:=tinx;\r
visit(higherp);\r
end\r
else hp:=0;\r
end;\r
end; (*VISIT*)\r
begin\r
(*TRANSFORM CLASS TERMTREE INTO ARRAY LX*)\r
tinx:=0;\r
lx[0].ch:=' '; lx[0].hp:=0; lx[0].np:=0; lx[0].tv:=0;\r
(* LX[0] IS NOT USED *)\r
for c:=minch to maxch do\r
with lx[ord(c)-ord(maxch)-1], entry[c] do\r
begin tv:=intern1; ch:=c; np:=0;\r
if termp<>nil then\r
begin incrtinx; hp:=tinx;\r
visit(termp);\r
end\r
else hp:=0;\r
end;\r
end; (*CONVERTLEX*)\r
\r
begin convertlex;\r
for t:=-(ord(maxch)-ord(minch)+1) to tinx do\r
with lx[t] do\r
begin write(tables,' ',ch,np:1,' ',hp:1,' ');\r
if tv<0 then writeln(tables,0:1) else writeln(tables,tv:1);\r
end;\r
end; (*EMITLEX*)\r
\r
procedure emitpars;\r
var si: lrinx;\r
\r
begin\r
for si:=0 to smax do\r
with lr[si] do\r
begin write(tables,chain:1,' ',next:1,' ',kind:1,' ');\r
case kind of\r
1,2,4,6: writeln(tables,symb:1,' ',err:1);\r
0,3 : writeln(tables,rs:1,' ',prodn:1);\r
5 : writeln(tables,lb:1);\r
end;\r
end;\r
end; (*EMITPARS*)\r
\r
procedure compress;\r
(* THE CLASS PARSER IS COMPRESSED INTO THE ARRAY LR*)\r
var\r
state,incr,first,last: integer;\r
laoptim,tailoptim: boolean;\r
statep: pointer;\r
si,sstart: lrinx;\r
\r
procedure lapres(var start:pointer);\r
var\r
sp:pointer; m: integer;\r
begin sp:=start;\r
begintilst:=sp;\r
fcqi:=0; (*BEGINTILST AND FCQI ARE USED IN OPTIMIZE*)\r
while sp<>nil do\r
with sp^ do\r
begin\r
if mode = 4 then remember(nextp);\r
sp:=derivp;\r
end;\r
m:=4;\r
optimize(sp,m);\r
allocp(classtop,1,'LAPRES ');\r
oldp^.derivp:=classtop; (*OLDP IS SET IN OPTIMIZE*)\r
with classtop^ do\r
begin inf:=0; prodnr:=m;\r
mode:=4 ;nextp:=sp; derivp:=nil\r
end;\r
start:=begintilst;\r
end; (*LAPRES*)\r
\r
procedure deletetail(s:integer);\r
label 10,20;\r
var t:integer;\r
sinx,tinx,sx,tx,oldsinx,smatch: lrinx;\r
sptr,tptr,sp,tp: pointer;\r
maxmatch: boolean;\r
begin t:=1; smatch:=const7; maxmatch:=false;\r
while (t<s) and not maxmatch do\r
begin sinx:=lr[sstart].chain; oldsinx:=sstart;\r
sptr:=tilstand[s].oldstart^.derivp;\r
while (sinx>0) and (sinx<smatch) do\r
begin tinx:=tilstand[t].newstart; tptr:=tilstand[t].oldstart;\r
while tinx>0 do\r
begin\r
if lr[sinx].symb=lr[tinx].symb then\r
begin sx:=sinx; tx:=tinx; sp:=sptr; tp:=tptr;\r
while (sx>0) and (tx>0) do\r
with lr[sx],sp^ do\r
if (symb=lr[tx].symb) and (kind=lr[tx].kind)\r
and (nextp=tp^.nextp) then\r
begin sx:=chain; sp:=derivp;\r
tx:=lr[tx].chain; tp:=tp^.derivp;\r
end\r
else goto 10;\r
if sx=tx then (*SX=TX=0*)\r
begin (*SUCCESSFUL MATCH*)\r
maxmatch:=oldsinx=sstart;\r
smatch:=oldsinx; si:=smatch+1;\r
lr[smatch].chain:=tinx;\r
goto 20;\r
end;\r
end;\r
10:tinx:=lr[tinx].chain; tptr:=tptr^.derivp;\r
end; (*WHILE TINX>0 DO*)\r
oldsinx:=sinx; sinx:=lr[sinx].chain;\r
sptr:=sptr^.derivp;\r
end; (*WHILE SINX>0....*)\r
20:t:=t+1;\r
end;\r
end; (*DELETETAIL*)\r
\r
\r
function stateno(pt: pointer): integer;\r
var\r
k,l,u: integer;\r
begin\r
if pt=nil then stateno:=0\r
else\r
begin (*BINARY SEARCH*)\r
l:=first; u:=last;\r
repeat k:=(l+u) div 2;\r
if ord(tilstand[k].oldstart) <= ord(pt) then l:=k+incr;\r
if ord(tilstand[k].oldstart) >= ord(pt) then u:=k-incr;\r
until (l*incr) > (u*incr);\r
stateno:=tilstand[k].newstart;\r
end;\r
end;(*STATENO*)\r
\r
begin (*COMPRESS*)\r
laoptim:= not options[22]; tailoptim:= not options[29];\r
si:=0;\r
\r
(*COPY PARSER TO LR AND MERGE IDENTICAL TAILS OF STATES*)\r
for state:=0 to antaltilst do\r
begin statep:=tilstand[state].oldstart;\r
sstart:=si;\r
tilstand[state].newstart:=sstart;\r
if laoptim and (statep^.mode in [2,4]) then\r
begin lapres(statep);\r
tilstand[state].oldstart^:=statep^;\r
end;\r
while statep<>nil do\r
with lr[si],statep^ do\r
begin\r
if derivp=nil then chain:=0 else chain:=si+1;\r
if (mode in [3,4]) then (*PRODNR IS UNDEF IF MODE=5*)\r
if (prod[prodnr].laengde=0) then mode:=6;\r
kind:=mode;\r
case mode of\r
1,2,4,6:\r
begin\r
symb:=inf; err:=prodnr;\r
end;\r
3:\r
begin\r
rs:=inf; prodn:=prodnr;\r
if prodn=0 then kind:=0;\r
end;\r
5: ;\r
end; (*CASE*)\r
statep:=derivp;\r
if si>=(const7-1) then consterror('COMPRESS ','CONST7 ',const7);\r
si:=si+1;\r
end;\r
if tailoptim and (lr[sstart].kind in [1,2,4]) then deletetail(state);\r
end;\r
\r
smax:=si-1; (*INDEX OF LAST ELEMENT USED IN LR*)\r
\r
(*ADJUST NEXT AND LB IN LR BY MEANS OF ARRAY TILSTAND*)\r
\r
(*INITIALIZATIONS FOR THE FUNCTION STATENO*)\r
if ord(tilstand[0].oldstart) < ord(tilstand[antaltilst].oldstart) then\r
begin incr:=1;\r
first:=0; last:=antaltilst;\r
end\r
else\r
begin incr:=-1;\r
first:=antaltilst; last:=0;\r
end;\r
\r
for state:=0 to antaltilst do\r
begin sstart:=tilstand[state].newstart;\r
statep:=tilstand[state].oldstart;\r
si:=sstart;\r
while statep<>nil do\r
with lr[si], statep^ do\r
begin next:=stateno(nextp);\r
if mode=5 then lb:=stateno(lookbp);\r
si:=chain;\r
if si<sstart then statep:=nil (*REST OF THE STATE IS A TAIL*)\r
else statep:=derivp;\r
end;\r
end;(*FOR*)\r
if options[17] then dump1; (* tilstand *)\r
end;(*COMPRESS*)\r
\r
procedure errortable ;\r
label 33;\r
var\r
i,i5,no,j,ct,ctmax: integer;\r
lqbep,testp,gemp: lrinx;\r
begin page(output); no:=0;\r
write('***********************COMPILER ERROR MESSAGES ***********************'\r
);\r
write(lf,lf,lf,' ');\r
write(' ERRORNO : 0 ** SPECIAL ERROR **'); write(lf,lf,lf,' ');\r
write(' ERRORNO : EXPECTED SYMBOL:');\r
for i:=1 to antaltilst do tilstand[i].errorno:= 0;\r
for i:=1 to antaltilst do with tilstand[i] do\r
if ((lr[newstart].kind =1) and (errorno=0)) then\r
begin if no<const1 then no:= no+1 else consterror('ERRORTABLE','CONST1 ',const1);\r
errorno:= no; i5:=1; lr[newstart].err:= no;\r
lqbep:= newstart; write(lf,lf,no,' :',blank);\r
while lqbep<>0 do with lr[lqbep] do\r
begin\r
if ((i5 mod 5 =1) and (i5>1)) then write(lf,blank,blank);\r
write(internrep[symb]:10,' ');\r
lqbep:= chain; i5:=i5+1;\r
end;\r
writeln(lf,' nr=', oldstart^.xprodnr :1);\r
for j:= i+1 to antaltilst do\r
if ((lr[tilstand[j].newstart].kind =1) and (tilstand[j].errorno=0)) then\r
begin lqbep:=newstart; gemp:=tilstand[j].newstart; ctmax:=0;\r
while lqbep<>0 do with lr[lqbep] do\r
begin testp:= gemp; ct:=2;\r
while symb<> lr[testp].symb do\r
begin testp:= lr[testp].chain; ct:= ct+1;\r
if testp=0 then goto 33;\r
end;\r
lqbep:= chain; if lr[testp].chain=0 then ctmax:= ct;\r
end;\r
if i5=ctmax then with tilstand[j] do\r
begin errorno:=no; lr[newstart].err:=no;\r
writeln(' nr=', oldstart^.xprodnr :1);\r
end;\r
33: (* NOT IDENTICAL *)\r
end;\r
end; write(lf,lf,lf,' ');\r
write('*************************************************************************'\r
);\r
end;\r
\r
procedure emitlabels;\r
var pn,i: integer;\r
begin writeln(tables);\r
for pn:=1 to antalprod do\r
begin write(tables,pn:5,' ');\r
with rhs[prod[pn].start] do\r
for i:=first to first+length-1 do\r
write(tables,labelbuf[i]);\r
writeln(tables);\r
end;\r
end; (*EMITLABELS*)\r
\r
begin (*FINALPARSER*)\r
(*DELETE 'ERROR','NAME','KONST','STRING' AND 'EMPTY' FROM TERMTREE*)\r
if go<>nil then with go^ do\r
begin intern:=0; ok:=false; end;\r
if gs<>nil then with gs^ do\r
begin intern:=0; ok:=false; end;\r
if gl<>nil then with gl^ do\r
begin intern:=0; ok:=false; end;\r
if gn<>nil then with gn^ do\r
begin intern:=0; ok:=false; end;\r
if gc<>nil then with gc^ do\r
begin intern:=0; ok:=false; end;\r
\r
rewrite(tables);\r
\r
compress;\r
errortable;\r
emitconstants;\r
writeln(tables,comend:comlength) ;\r
emitlex;\r
emitpars;\r
if options[33] or options[34] then emitlabels;\r
end; (*FINALPARSER*)\r
\r
(**************************************************)\r
(* *)\r
(* MAIN PROGRAM *)\r
(* *)\r
(**************************************************)\r
\r
\r
\r
\r
begin\r
write(lf, version, lf);\r
ingrammar ;\r
idogfjern(true) ;\r
termination ;\r
erasure ;\r
idogfjern(false);\r
vhrecurs;\r
initprod ;\r
inithelp;\r
outgrammar ;\r
lr0;\r
lookb;\r
adequad;\r
finalparser;\r
999: writeln;\r
end.\r
\r
\r