⟦d61d548bc⟧

TextFileVerbose


(*     *)
(*  B O B S - SYSTEM      *)
(*     *)
(*  SKELETON COMPILER     *)
(*     *)
(*  version  1979.10.11   *)

program bobs(input,output,tables='bobstables');

label 10; (*EXIT LABEL*)
const
stackmax=50; (*SIZE OF ATTSTACK AND PARSESTACK *)
stringmax=100; (* SIZE OF ATTRIBUTE STRING *)
chbufmax=200; (* SIZE OF ARRAY CHBUF *)
minch=' '; maxch='~'; (*FIRST/LAST CHARACTER IN TYPE CHAR*)
test=true; (* IF TRUE THEN SNAPSHOTS ARE GENERATED*)
version = 'BOBS version 1979.10.11';
type
chbufinx=0..chbufmax;
stackinx=0..stackmax;
attributes=record
chbufp:  chbufinx;
end;
string=packed array[1..stringmax] of char;
var
attstack: array[stackinx] of attributes;

chbuf: array[chbufinx] of char;
chbufi: chbufinx;

ok: boolean;

tables: text;
snapshots: text;

(*CHBUF, CHBUFI, FIELD CHBUFP OF ATTRIBUTES, TABLES AND OK
(*SHOULD NOT BE CHANGED BY THE USER *)
procedure message( msg : string );
begin
(* dummy on RC8000 *)
end;



procedure stop(n: integer); forward;
(*dollar-f*)
procedure code(oldtop,newtop: stackinx; prod: integer);


procedure getstring(sy: integer; var str:string; var length: integer);
var i,j,t:integer;
begin
if sy>=0 then t:=newtop+(sy-1)
else t:=oldtop+(sy-1);
length:=attstack[t].chbufp-attstack[t-1].chbufp;
if length>stringmax then  stop(5);
j:=1;
for i:=attstack[t-1].chbufp to attstack[t].chbufp-1 do
begin
str[j]:=chbuf[i]; j:=j+1;
end;
end; (*GETSTRING*)


procedure outtest;
(*OUTTEST PRODUCES A SEQUENCE OF SNAPHOTS OF THE PARSE
(*OUTTEST MAY BE REMOVED BY THE USER *)
(*DURING THE PARSE, SNAPSHOTS ARE WRITTEN ON FILE SNAPSHOTS *)
(*WHEN CODE(0) IS CALLED, THESE SNAPSHOTS ARE COPIED TO FILE OUTPUT.*)
(*PROGRAM LINES WHICH WRITES SNAPSHOTS CONTAINS THE COMMENT:*)
(***SNAPSHOT***)
(*SNAPSHOTS ARE ONLY GENERATED IF CONST TEST IS TRUE*)
var s: string;
i,j,l:integer; ch:char;
begin
if prod <> 0 then
begin (* CODE(0) IS CALLED IN MAIN *)
writeln(snapshots);
write(snapshots,' PRODUCTION:',prod:3);
for i:=1 to oldtop-newtop+1 do
begin getstring(i,s,l);
if l>0 then
begin writeln(snapshots);
write(snapshots,'   SYMB',i:1,' ');
for j:=1 to l do write(snapshots,s[j]);
end;
end;
end
else
begin writeln(snapshots); reset(snapshots); writeln(output,' SNAPSHOT:');
while not eof(snapshots) do
if eoln(snapshots) then
begin
readln(snapshots); writeln(output);
end
else
begin read(snapshots,ch); write(output,ch);
end;
end;
end; (*OUTTEST*)
begin (*CODE*)
if test then outtest;
end; (*CODE*)

(*dollar-f*)
procedure stop;
begin
writeln(output);writeln(output);
case n of
1: begin
message('*** PARSE STACK OVERFLOW. CONST ''STACKMAX'' TOO SMALL');
writeln(output,' *** PARSE STACK OVERFLOW. CONST ''STACKMAX'' TOO SMALL');
end;

2: begin
message('*** END OF FILE ENCOUNTERED');
writeln(output,' *** END OF FILE ENCOUNTERED ');
end;
3: begin
message('*** RECOVERY ABANDONED');
writeln(output,' *** RECOVERY ABANDONED ');
end;
4: begin
message('*** REDUCTION BUFFER OVERFLOW. CONST ''REDUMAX'' TOO SMALL');
writeln(output,' *** REDUCTION BUFFER OVERFLOW. CONST ''REDUMAX'' TOO SMALL');
end;
5: begin
message('*** CONST ''STRINGMAX'' TOO SMALL');
writeln(output,' *** CONST ''STRINGMAX'' TOO SMALL ');
end;
6: begin
message('*** CONST ''CHBUFMAX'' TOO SMALL');
writeln(output,' *** CONST ''CHBUFMAX'' TO SMALL ');
end;
end;
goto 10; (*EXIT*);
end;(*STOP*)
(*dollar-f*)
procedure parser;

const
(*BOBS, CONSTANTS GENERATED BY THE GENERATOR *)
symbmax=6;
prodmax=4;
lrmax=11;
lxmax=5;
errorval=0;
nameval=0;
constval=0;
stringval=3;
stringch=
'''';
combegin=0;
comlength=1;
(*BOBS)
(*-END-OF-GENERATED-CONSTANTS-*)
linemax=120; (*MAX. LENGTH OF LINES*)
skipch = ' ';

(*-END-OF-PARSER-CONSTANTS-*)

type
symbol=0..symbmax;
errno=0..prodmax;
prodno=0..prodmax;
rslength=-1..symbmax;
mode=0..6;
lrinx=0..lrmax;
lrelm=packed record
chain: lrinx; (*NEXT ITEM IN THIS STATE*)
next: lrinx; (*NEXT STATE*)
case kind: mode of
1,2,4,6: (symb: symbol; err: errno);
0,3    : (rs: rslength; prod: prodno);
5:     (lb: lrinx)
end;

lxinx=0..lxmax;
lxelm=packed record
np,hp: lxinx;
tv: symbol; ch:char
end;

stackelm=packed record
link: stackinx;
table: lrinx
end;

(*-END-OF-PARSER-TYPES-*)

var
lr: array[lrinx] of lrelm; (* LR-PARSE TABLES *)

parsestack: array[stackinx] of stackelm; (*PARSE STACK*)

entry: array[char] of lxelm;
lx: array[lxinx] of lxelm; (*LEXICAL TABLES*)
namech,      (*CHARS USED IN NAMES*)
digitch: set of ' ' .. 'z';
      (*CHARS USED FOR DIGITS*)
newsymb: symbol;      (*CURRENT TERMINAL SYMBOL*)
ch: char;      (*CURRENT CHAR*)
stringescape: integer;     (*INTERNAL VALUE OF THE STRINGESCAPE TERMINAL*)
oldbufi: chbufinx;      (*FIRST CHAR IN CHBUF OF CURRENT LEXICAL TOKEN *)
moreinput,      (*BECOMES FALSE WHEN INPUT IS EXHAUSTED*)
error: boolean;      (*BECOMES TRUE WHEN SYNTAX ERRORS IN INPUT*)
line: array[1..linemax] of char; (*CONTAINS CURRENT LINE*)
linelength,    (*LENGTH OF CURRENT LINE*)
errorinx,    (*POSITION IN LINE OF LAST ERROR MARK*)
lineinx: integer;    (*POSITION IN LINE OF CURRENT CH*)
printed: boolean;    (*TRUE IF CURRENT LINE HAS BEEN PRINTED*)
cl: real;       (*VALUE OF STANDARD FUNCTION CLOCK AT START*)
comend : packed array[1..comlength] of char ; (*STRING WHICH ENDS A COMMENT *)

(*-END-OF-PARSER-VARIABLES-*)


procedure dumplr;
var i:integer;
begin writeln('  I ',' CHAIN NEXT KIND SYMB PROD');
for i:=1 to lrmax do
with lr[i] do
begin write(' ',i:3,chain:6,next:5,kind:5);
case kind of
1,2,4,6: writeln(symb:5,err:5);
0,3    : writeln(rs:5,prod:5);
5:     writeln(lb:5)
end;
end;
end;

(* PROCEDURES FOR INPUT/OUTPUT OF CHARACTERS*)
procedure readline;
var ch:char;
lgt : integer;
begin
lineinx:=1; lgt:=0; printed:=false; errorinx:=0;
if eof(input) then moreinput:=false
else
begin
while not eoln(input) and not eof(input) and (lgt<linemax) do
begin
lgt:=lgt+1;
read(ch);
line[lgt]:=ch;
end;
if eoln(input) and not eof(input) then readln(input);
end;
if lgt = 0 then
begin
lgt := 1; line[1] := ' ';
end;
linelength := lgt;
end; (*READLINE*)

procedure printline;
var i :integer;
begin write(' ');
for i:=1 to linelength do write(line[i]);
writeln; printed:=true;
end; (*PRINTLINE*)

procedure inchar;
begin
if lineinx=linelength then
begin
if not printed then printline;
if errorinx>0 then writeln;
readline;
if moreinput then ch:=line[1]
else ch:='.'; (* ch <> skipch *)
end
else
begin lineinx:=lineinx+1;
ch:=line[lineinx];
end;
if (ch>='a') and (ch <= 'z') then
(* convert lower case to upper case *)
ch := chr(ord(ch) - ord('a') + ord('A') );
end; (*INCHAR*)

procedure markerror(c: char; n: integer);
var i : integer;
begin  error:=true;
if not printed then printline;
for i:=errorinx to lineinx-2 do write(' ');
if lineinx=1 then write(' ');
write(c,n:3); (*N <=999 *)
errorinx:=lineinx+ 3;
end; (*MARKERROR*)

(*END OF INPUT/OUTPUT PROCEDURES*)

procedure initialize;
var cc,ch1:char;
a,b,c,d,e,i, firstlb:integer;
newlb : boolean;
begin ok:=true; error:=false;
moreinput:=true; lineinx:=1; chbufi:=0;
linelength:=1; printed:=true; errorinx:=0;
parsestack[0].table:=0; attstack[0].chbufp:=chbufi;
parsestack[0].link:=0; ch:=' ';
digitch:=['0'..'9']; namech:=['A'..'Z','_','0'..'9'];
reset(tables);
if test then rewrite(snapshots); (***SNAPSHOT***)
readln(tables,i); (* i := number of constants to skip *)
for i := i downto 1 do readln(tables);
(*THE VALUES OF THE CONSTANTS GENERATED BY THE GENERATOR
(*ARE ALSO WRITTEN ON FILE TABLES (PRECEDED BY THE NUMBER OF CONSTANTS).
 THEY ARE WRITTEN IN THE
(*SAME ORDER AS THEY APPEAR IN THE CONST PART OF PROCEDURE
(*PARSER. A VALIDITY CHECK BETWEEN FILE TABLES AND THIS
(*CONST PART COULD BE DONE, IN ORDER TO ASSURE THAT THE VALUES
(*ARE IN FACT IDENTICAL. *)

for i:=1 to comlength do begin comend[i]:=tables^; get(tables) end ;
readln(tables) ;
for ch1:=minch to maxch do
begin readln(tables,cc,cc,a,b,c);
with entry[cc] do
begin
ch:=cc; np:=a; hp:=b; tv:=c;
end;
end;
for i:=0 to lxmax do
with lx[i] do
begin readln(tables,cc,cc,a,b,c);
ch:=cc; np:=a; hp:=b; tv:=c;
end;
if stringch=' ' then (*STRING FACILITY IS NOT USED *) stringescape:=-2
else stringescape:= entry[stringch].tv;
newlb := true;

for i:=0 to lrmax do
with lr[i] do
begin read(tables,a,b,c,d);
if c <> 5 then readln(tables,e) else readln(tables) ;
chain:=a; next:=b; kind:=c;
case c of
1,2,4,6: begin symb:=d; err:=e end;
0,3    : begin rs:=d; prod:=e  end;
5      : begin
lb := d;
(* prepare a binary search *)
if newlb then
begin
firstlb := i;
newlb := false;
end;
if a = 0 then
begin
lr[firstlb].chain := i;
newlb := true;
end;
end

end;
end;
end;(*INITIALIZE*)

procedure lexical;
(* RETURNS NEXT TERMINAL IN NEWSYMB*)
var
newi: integer;
oldch: char;
lxnode: lxelm;

procedure skipcomment;
(* READ NEXT CHAR ON INPUT UNTIL COMEND IS RECOGNIZED *)
var
i,l : integer ;
b : packed array[1..comlength] of char ;

procedure nextch ;
begin
if (l > comlength) then inchar
else
begin
ch:=b[l] ;
l:=l+1 ;
end ;
end ;

begin
l:=comlength+1 ;
repeat
while ch<>comend[1] do nextch ;
b[1]:=ch ;
for i:=2 to comlength do
begin
nextch ;
b[i]:=ch ;
end ;
l:=2 ;
until (b=comend) ;
inchar ;
end (* SKIPCOMMENT *) ;



procedure pushch;
begin
chbuf[chbufi]:=ch;
if chbufi<chbufmax then chbufi:=chbufi+1
else stop(6);
if test then write(snapshots,ch); (***SNAPSHOT***)
end; (*PUSHCH*)

procedure readstring;
var strch : char;
instring : boolean;

begin
strch := oldch;
ch := line[lineinx]; (* maybe ch was converted to upper case *)
instring := true;
while
(instring    (* preceding character was not a string delimiter *)
or ( ch=strch ) (* this character is a delim. *)
) and ( lineinx<>linelength) (* stop at eoln *)
do
begin
instring := (ch<>strch) or not instring;
(* false at first delim. after character, else true *)
if instring then pushch;
lineinx := lineinx + 1;
ch := line[lineinx]; (* inchar, but without converting *)
end;
if instring or (ch=strch) then
writeln(output,'stringescape expected');
(* string did not terminate within line *)
newsymb:=stringval;
end; (*READSTRING*)

begin (*LEXICAL*)

if test then writeln(snapshots); (***SNAPSHOT***)
if test then write(snapshots,' LEXICAL: '); (***SNAPSHOT***)

while ch = skipch do inchar;
oldbufi:=chbufi;

if not moreinput then
begin
if newsymb=0 then (*THIRD*) stop(2)
else
if newsymb=1 then (*SECOND*) newsymb:=0
else (*FIRST*) newsymb:=1;
end
else
if ch in digitch then
begin (*KONST*)
repeat
pushch; inchar;
until not (ch in namech);
newsymb:=constval;
end
else (* NOT KONST *)
begin (* SEARCH IN TERMTREE *)
pushch;
lxnode:=entry[ch]; newi:=lxnode.hp;
inchar;
if newi <> 0 then
repeat
if lx[newi].ch=ch then
begin pushch;
lxnode:=lx[newi];
newi:=lxnode.hp;
inchar;
end
else newi:=lx[newi].np;
until newi=0;

oldch:=chbuf[chbufi-1];

if (oldch in namech) and (ch in namech) then
begin
repeat pushch;
inchar;
until not(ch in namech);
newsymb:=nameval;
end
else
if lxnode.tv > 0 then (*VALID TERMINAL*)
begin newsymb:=lxnode.tv;
chbufi:=oldbufi;
if newsymb=stringescape then readstring
else
if newsymb=combegin then begin skipcomment ;  lexical ; end ;
end
else
if oldch in namech then newsymb:=nameval
else markerror('^',0);
end;

end; (*LEXICAL*)

procedure parse;

const
redumax= 15; (* REDUCTION BUFFER SIZE *)

type
reduinx= 0..redumax;
reduelem= packed record
oldtop,newtop: stackinx;
prod: prodno
end;

var
redubuf: array[reduinx] of reduelem; (* REDUCTION BUFFER *)
redutop: reduinx;
stacktop,pseudotop,validtop,top : stackinx;
startinx,lri,start: lrinx;

dumpheads: integer;
value dumpheads = 0;
procedure dump(alf : alfa);

begin

if dumpheads mod 20 = 0 then
write(snapshots,nl,nl,' caller':13, 'startinx     lri   start     top',
' stackto validto pseudot redutop  (prod)');
dumpheads := dumpheads + 1;
write(snapshots, nl, alf, ':', startinx, lri, start, top, stacktop,
validtop, pseudotop, redutop);
end;


procedure advance;
var i: integer;
begin
(*PERFORM REDUCTIONS*)
dump('advance');
for i:=1 to redutop do
with redubuf[i] do
begin code(oldtop,newtop,prod);
attstack[newtop].chbufp:=attstack[newtop-1].chbufp;
end;

(*UPDATE STACK*)
for i:=1 to stacktop-validtop do
parsestack[validtop+i]:=parsestack[top+i];

if redutop>0 then (* POSSIBLE POP OF CHBUF *)
if oldbufi=chbufi then (* NEWSYMB NOTIN [NAME,KONST,STRING]*)
chbufi:=attstack[stacktop-1].chbufp
else (*NEWSYMB IN [NAME,KONST,STRING]*)
attstack[stacktop].chbufp:=oldbufi;

(*SHIFT*)
if stacktop=stackmax then stop(1);
stacktop:=stacktop+1;
parsestack[stacktop].table:=startinx;
attstack[stacktop].chbufp:=chbufi;

(* FREEZE NEW STACK SITUATION, READY FOR NEW LOOKAHEAD *)
top:=stacktop; pseudotop:=stacktop; validtop:=stacktop;
start:=lri; redutop:=0;
end; (*ADVANCE*)

procedure backtrack( btop: stackinx; bstart: lrinx);
begin
dump('backtrack1');
stacktop:= btop; validtop:= btop; pseudotop:= btop;
startinx:= bstart; lri:= bstart;
redutop:= 0;
dump('backtrack2');
end; (* BACKTRACK *)

procedure pseudoshift;
begin
if pseudotop=stackmax then stop(1);
stacktop:= stacktop+1;
pseudotop:= top+(stacktop-validtop);
parsestack[pseudotop].table:= startinx;
attstack[pseudotop].chbufp:=chbufi;
dump('pseudoshift');
end; (* PSEUDOSHIFT *)

function lookahead( lsymbol: symbol): boolean;
label 11,12;
var decided: boolean;
li,si, locallri, low, high, k, locallb: lrinx;
procedure queue( rs: rslength; p: prodno);
begin
dump('queue1');
if redutop=redumax then stop(4);
redutop:= redutop+1;
with redubuf[redutop] do
begin
oldtop:= stacktop; stacktop:= stacktop-rs; newtop:= stacktop;
if stacktop <= validtop then
begin
pseudotop:= stacktop; validtop:= stacktop;
end else pseudotop:= pseudotop-rs;
prod:=p;
end;
dump('queue2'); write(snapshots,p);
end; (* QUEUE *)

begin
decided:= false;
locallri := lri;
repeat
startinx:= locallri;
case lr[locallri].kind of
0: begin
decided:= true; lookahead:= true; ok:= false;
end;
1: begin
while lr[locallri].symb<>lsymbol do
begin li:= lr[locallri].chain;
if li=0 then goto 11; (* EXIT LOOP *)
locallri:= li;
end;
11: decided:= true; lookahead:= lr[locallri].symb=lsymbol;
end;
2,4,6:
begin
while lr[locallri].symb<>lsymbol do
begin li:= lr[locallri].chain;
if li=0 then goto 12; (* EXIT LOOP *)
locallri:= li;
end;
12: if lr[locallri].kind= 2 then
begin
decided:= true; lookahead:= true;
end
else if lr[locallri].kind= 6 then
begin
pseudoshift;
stacktop:=stacktop-1; pseudotop:=pseudotop-1;
queue(-1,lr[locallri].err);
end;
end;
3: begin
queue(lr[locallri].rs,lr[locallri].prod);
end;
5: begin
si:= parsestack[pseudotop].table;
low := locallri;
locallri := lr[locallri].chain;
high := locallri - 1;
while low < high do
begin
k := (low + high) div 2;
locallri := lr[k].lb;
if locallb > si then high := k - 1
else
if locallb < si then low := k + 1
else
begin
high := k;
low := high;
end;
end;
k := (low + high) div 2;
if lr[k].lb = si then locallri := k;
end;
end; (* CASE *)
locallri:= lr[locallri].next;
until decided;
lri := locallri;
end; (* LOOKAHEAD *)

procedure syntaxerror;
var success: boolean;
s,s1: stackinx;

begin
if test then write(snapshots,' <---SYNTAXERROR'); (***SNAPSHOT***)
markerror('^',lr[startinx].err);
backtrack(top,start);
pseudoshift;
s:= 0;
for s1:= 0 to top do
begin
backtrack(top, start);
pseudoshift;
backtrack(s1,parsestack[s1+1].table);
if lookahead(errorval) then
begin
parsestack[s1].link:= s; s:= s1;
end;
end;
success:= false;
repeat
s1:= s;
backtrack(top, start);
pseudoshift;
repeat
backtrack(s1,parsestack[s1+1].table);
if lookahead(errorval) then
begin
pseudoshift;
success:= lookahead(newsymb);
end;
s1:= parsestack[s1].link;
until (s1=0) or success;
if not success then
begin
(* MARK PREVIOUS SYMBOL SKIPPED *)
if test then write(snapshots,' <---SKIPPED'); (***SNAPSHOT***)
lexical;
end;
until success or (not ok);
if not ok then stop(3);
end; (* SYNTAXERROR *)


begin (* PARSE *)
top:=0; start:=1;
backtrack(top,start);
while ok do
begin
lexical;
if not lookahead(newsymb) then syntaxerror;
advance;
end;
end; (*PARSE*)

begin (* PARSER *)
cl:=clock;
writeln(output, version);
initialize;
parse;
code(2,0,0); (* COPY,SNAPSHOTS,OUTPUT *)
if error then message(' ERROR(S) IN BOBS-PROGRAM SORRY');
message('=END BOBS');
cl:=clock-cl;
writeln(output,' PARSETIME:',cl:8:3,' SECONDS');
end; (*PARSER*)

begin
parser;
10:
end. (*BOBS*)
«eof»
DataMuseum.dk

RC3500

⟦d61d548bc⟧ TextFileVerbose

Derivation

TextFileVerbose
