|
DataMuseum.dkPresents historical artifacts from the history of: RC4000/8000/9000 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about RC4000/8000/9000 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 35328 (0x8a00)
Types: TextFile
Names: »xfortran4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »xfortran4tx «
xfortran = algol index.no
begin
<* bobs-system parser *>
<* algol6 - version *>
<* rewritten from pascal *>
<* october 76 *>
message version id: 88 10 10, 4;
integer
linemax, <* max line length *>
stackmax, <* parse stack size *>
bufmax, <* max no of chars in name and consts *>
lrmax, <* size of lr-tables *>
lxmax, <* size of lexical tables *>
errorval, <* *>
nameval, <* internal value of name *>
constval, <* - - - const *>
stringval, <* - - - string *>
stringch, <* stringescape char *>
curchclass, <* class of curch *>
filemax, <* max no of files allowed to be defined *>
fpmax, <* max size of call of compiler *>
errormax; <* max no of marked errors*>
zone productions(128,1,stderror);
zone parsetables(128,1,stderror);
zone xref(128,1,stderror);
integer field f2,f4,f6,f8,f10,f12,f14,f16,f18;
f2:=2; f4:=4; f6:=6; f8:=8; f10:=10; f12:=12; f14:=14; f16:=16; f18:=18;
linemax := 150; fpmax:=60; stackmax := 60;
bufmax := 12; errormax := 10; filemax := 5;
open(productions,4,<:productions:>,0);
open(parsetables,4,<:parsetables:>,0);
inrec6(parsetables,18);
lrmax:=parsetables.f6; lxmax:=parsetables.f8;
errorval:=parsetables.f10; nameval:=parsetables.f12;
constval:=parsetables.f14; stringval:=parsetables.f16;
stringch:=parsetables.f18;
begin
integer array lrchain,lrnext,lr(0:lrmax);
<* lr(.) bit 0 - 2 kind
bit 3 - 11 symb/rs
bit 12 - 23 lb/prd (if kind=5 then this field is 0)
*>
integer kind, symb;
integer startinx; <* start of current state in lr *>
integer array stack(0:stackmax); <* parse stack *>
integer stacktop, newtop;
integer array entry(1:4,32:127);
<* entry(1,.) - np (0:lxmax)
entry(2,.) - hp ( - )
entry(3,.) - tv (0:symbmax)
entry(4,.) - ch4 ( charvalue )
*>
integer np,tv,hp,ch4;
integer array lx(1:4,0:lxmax); <* lexical tables *>
<* the entries are as above *>
integer
newsymb, <* current terminal symbol *>
curch; <* current char *>
integer array
name(1:bufmax), <* current name in chars *>
konst,konstbuf(0:bufmax); <* current const in chars *>
integer nameno, konstno;
integer
stringescape,
lineinx; <* pos in line of current char *>
boolean
letterordigit, <* true if current char is letter or digit *>
ok, <* false when parsing has to be stopped *>
moreinput; <* false when input is exhausted *>
integer array errormark(1:2,0:errormax);
<* errormark(1,.) - errornous lineno
- (2,.) - errornous char pos.
*>
integer array line1,line2,ltype1,ltype2(0:linemax); <* line buffer and type *>
integer errorcount,linecount1,linecount2,lineno ; <* index to line *>
integer linecount3;
boolean newline, <* newline char (local) *>
firsttime , <* used to handle output *>
more, <* true as long as more input in buffer2 *>
anything_left,
commentline; <* false when input line is skipped *>
integer startexp,konstlimit,s1,new1,i,j;
boolean readexp; <* true if read statement *>
integer endexp, <* pointer to exp in special read-write *>
startio, <* start of io list *>
fileinx; <* no of defined files *>
boolean firstdefine ,format;
integer array unit(1:2,1:filemax), <* unit no in define file *>
assvar(1:6,1:filemax), <* the associated variable *>
conv(0:225) , <* converted prod number *>
recsize(1:filemax), <* the recordsize *>
cheat(1:3),tcheat(1:3); <* used to avoid parsing formats *>
zone outfile(128,1,stderror); <* the zone name used to outputfile *>
integer array tail(1:20),fp(1:fpmax); <* tail of entry, fp-stack *>
real array workfile,fpparam(1:2); <* parameters to system-procedure *>
real array sourcename(1:2); <* filename for input to normal fortran *>
integer fpinx,sourceinx,paramno;
integer array rem(1:20), <* array to remember pos of dots *>
testword(1:10); <* contains some operators *>
integer reminx; <* index to rem *>
boolean dot, <* true if dots in line *>
random1, <* true if random access *>
xfortrantest, <* true if test-output *>
crossref; <* true if crossref of prg *>
procedure outfilno(inx);
value inx; integer inx;
begin integer i;
for i:=1,2 do
if unit(i,inx)=32 then i := 10000
else outchar(outfile, unit(i,inx));
end;
procedure outassvar(inx);
value inx; integer inx;
begin integer i;
for i:=1 step 1 until 6 do
if assvar(i,inx)=32 then i := 10000
else outchar(outfile,assvar(i,inx));
end;
procedure outfiledef(inx);
value inx; integer inx;
begin integer i;
if firstdefine then
begin
firstdefine := false;
lineno := lineno+1;
write(outfile, <: logical setposition:>, newline, 1);
end;
write(outfile, <: zone fil:>); outfilno(inx);
write(outfile, <:(:>, <<ddd>, 128*recsize(inx), <:, 1, stderror):>,
newline, 1, <: integer :>); outassvar(inx);
write(outfile, newline, 1);
lineno := lineno + 2;
write(outfile, <: common/comfil:>); outfilno(inx);
write(outfile, <:/fil:>); outfilno(inx);
write(outfile, <:/comass:>); outfilno(inx);
write(outfile, <:/:>); outassvar(inx);
write(outfile, newline, 1);
lineno := lineno + 1;
end;
procedure code(prodno);
value prodno; integer prodno;
begin integer ii;
if xfortrantest then write(productions,<<dddd>,prodno);
if conv(prodno)=0 then goto exitcode;
case conv(prodno) of
begin
<* -1- <simple statement> ::= <rewind> konst / <endfile> konst *>
begin
lineno:=lineno+1;
for i:=1 step 1 until 6 do outchar(outfile,line1(i));
if prodno=130 then
begin <* rewind *>
write(outfile,<:call setposition(fil:>);
for i:=1 step 1 until konstno do outchar(outfile,konst(i));
write(outfile,<:, 0, 0):>,newline,1);
end
else
begin <* endfile *>
write(outfile,<:call close(fil:>);
for i:=1 step 1 until konstno do outchar(outfile,konst(i));
write(outfile,<:, .true.):>,newline,1);
end
end;
<* -2- <rewind> ::= rewind
<endfile>::= endfile
*>
commentline := true;
<* -3- <special read statem> ::= read ( <fileno> '
<special write statem>::= write ( <fileno> '
*>
begin
if prodno = 174 then readexp:=true else readexp:=false;
commentline := true;
end;
<* -4- <special read write> ::= <special read statem> <expr> )
/ <special write statem> <expr> )
*>
begin
for ii:=1 step 1 until fileinx do
if unit(1,ii)=konstbuf(1) and
unit(2,ii)=konstbuf(2) then goto found;
markerror; ii:=1;
found :
if random1 then <* random access *>
begin lineno:=lineno+1;
write(outfile,<: call setposition(fil:>);
outchar(outfile,konstbuf(1)); outchar(outfile,konstbuf(2));
write(outfile,<:, 0, (:>);
for i:=1 step 1 until endexp do outchar(outfile,rem(i));
write(outfile,<: - 1)*:>,<<ddd>,recsize(ii),<:):>,newline,1);
end;
lineno:=lineno+1;
write(outfile,<: :>,if readexp then <:read:> else <:write:>,
<:(fil:>);
for i:=1 step 1 until konstlimit do outchar(outfile,konstbuf(i));
write(outfile,<:) :>);
for i:=startio step 1 until linecount1-1 do outchar(outfile,line1(i));
<* associated variable *>
write(outfile,newline,1);
lineno:=lineno+1;
for i:=1 step 1 until 6 do outchar(outfile,line1(i));
outassvar(ii);
write(outfile,<: = 1 + :>);
for i:=1 step 1 until endexp do outchar(outfile,rem(i));
write(outfile,newline,1);
startexp:=0;
end;
<* -5- <expr> ::= <prim5> *>
if startexp>0 then
begin startio:=lineinx;
if line1(startexp)<48 then startexp:=startexp+1;
for i:=startexp step 1 until lineinx-2 do rem(i-startexp+1):=line1(i);
endexp:=lineinx-1-startexp;
end;
<* -6- <unit> ::= konst *>
begin commentline := true;
if fileinx < filemax then fileinx := fileinx+1 else stop(4);
unit(1,fileinx) := konst(1);
unit(2,fileinx) := if konstno=1 then 32 else konst(2);
end;
<* -7- <noofrec> ::= konst *>
begin <* this is not used in this version *>
end;
<* -8- <max> ::= konst *>
begin j:=0;
for i:=1 step 1 until konstno do j:=j*10+konst(i)-48;
recsize(fileinx):=if j mod 256=0 then j/256 else j/256+1;;
end;
<* -9-<program start> ::= <prg> name <sep> <firstpart>
/ <prg> name <sep>
*>
begin
for i:=1 step 1 until fileinx do
begin
lineno:=lineno+1;
write(outfile,<: call open(fil:>);
outfilno(i);
write(outfile,<:, 4, 'fil:>);
outfilno(i);
write(outfile,<:', 0):>,newline,1,<: :>);
lineno:=lineno+1;
outassvar(i);
write(outfile,<: = 1 :>,newline,1);
end;
end;
<* -10- <filedef> ::= <unit> ( <noofrec>,<max>,name,name ) *>
begin
if nameno>6 then nameno:=6;
for i:=1 step 1 until nameno do
assvar(i,fileinx):=name(i);
for i:=nameno+1 step 1 until 6 do assvar(i,fileinx):=32;
outfiledef(fileinx);
end;
<* -11- <f> ::= format / formato *>
begin format :=true;
for i := i while true do
begin
lineno:=lineno+1;
j:=if linecount1>=72 then 72 else linecount1-1;
for i:=1 step 1 until j do outchar(outfile,line1(i));
write(outfile,newline,1);
if line1(linecount1)=59 then <* format statement terminated *>
begin <* copy cheat line into linebuf *>
j:=if curch=32 then lineinx+1 else lineinx;
for i:=j step 1 until j+2 do
begin line1(i):=cheat(i-j+1); ltype1(i):=tcheat(i-j+1);
end;
linecount1:=j+2; goto exit;
end;
nextline;
end while;
exit :
end;
<* -12- <fileno> ::= konst *>
begin
konstbuf(1):=konst(1);
konstbuf(2):=if konstno=1 then 32 else konst(2);
startexp:=lineinx; konstlimit:=konstno;
end;
<* -13- <statement> ::= <f> ( <format field> ) *>
format := false;
<* -14- <leftside> ::= <variable> =
<if> ::= if
*>
begin if reminx=0 then checkpoint;
if line1(linecount1)<>59 then dot:=true;
end;
<* -15- <simple statement> ::= <leftside> <expr>
<cond statement> ::= <if> ( <expr> ) <simple statement>
/ <if> ( <expr> ) konst, konst, konst
*>
begin dot := false; reminx:=0;
end;
<* -16- <sub-name> ::= name *>
begin <*used in crossref *>
i:=-1; write(xref,newline,1,i,nameno,<: :>);
for i:=1 step 1 until nameno do outchar(xref,name(i));
end;
<* -17- <prg> ::= program *>
begin <*used in crossref *>
i:=-1; j:=4; write(xref,newline,1,i,j,<: main:>);
end;
<* -18- <pause> ::= pause
<find> ::= find
*>
begin commentline:= true;
lineno:=lineno+1;
for i:=1 step 1 until 6 do outchar(outfile,line1(i));
write(outfile,<:continue:>,newline,1);
end;
<* -19- <program-unit> ::= <program-start> <statement-part> end
/ < do > end
<procedure> ::= <procedure start> < do > end
/ < do > end
*>
; <* empty *>
<* -20- <proceduredecl> ::= subroutine <sub-name> (separator>
/ subroutine <sub-name> ( <formalparameters> )
<separator>
/ function <sub-name> ( <formalparameters> )
<separator>
/ <type> function <sub-name> ( <formalparameters> )
<separator>
*>
begin
integer fileno;
firstdefine := true;
for fileno := 1 step 1 until fileinx do
outfiledef(fileno);
end;
end case ;
exitcode :
end proc code;
procedure checkpoint;
<* the routine makes some lexical work removing . around
some relational operators (because of lr-problems)
*>
begin integer i,k,t1;
reminx:=0; i:=7;
for i:=i while i< linecount1 do
if line1(i)=46 <* . *> then
begin k:=i; i:=i+1;
for i:=i while line1(i)=32 do i:=i+1;
if (ltype1(i)=6 and ltype1(i+1)=6) then
<* . followed by at least two letters *>
begin t1:= (line1(i) shift 16);
t1:=t1 add (line1(i+1) shift 8);
t1:=t1 add (if ltype1(i+2)<>6 then 32 else line1(i+2));
i:=i+1;
for j:=1 step 1 until 9 do
if t1=testword(j) then goto found;
j:=0;
found :
if j<> 0 then
begin reminx:=reminx+1;
rem(reminx):=k; line1(k):=32; ltype1(k):=7;
<* find the belonging . *>
for i:=i while line1(i)<>46 do i:=i+1;
reminx:=reminx+1; rem(reminx):=i;
line1(i):=32; ltype1(i):=7; i:=i+1;
end;
end;
end else i:=i+1;
end proc checkpoint ;
procedure markerror;
<* syntax errors are remembered by a call of this routine.
furthermore if the error recovery algorithm has problems
with loops this avoided by a call of lexical.
*>
begin
if (new1=newsymb) and (s1=startinx) then lexical;
new1:=newsymb; s1:=startinx;
if (errorcount<errormax) and errormark(1,errorcount) <> lineno then
begin errorcount := errorcount+1;
errormark(1,errorcount) := lineno;
errormark(2,errorcount) := lineinx;
end;
end proc errormark;
procedure unpackfp;
begin integer k,l;
write(productions,newline,2); i:=1;
for i:=i while i<fpinx do
begin j:=fp(i) extract 12;
k:=fp(i) shift (-12);
write(productions,k,<: shift 12 + :>,j,newline,1);
if j=0 then goto exit
else
if j=4 then
begin i:=i+1; write(productions,fp(i),newline,1);
end
else
if j=10 then
begin
for k:=1 step 1 until 4 do
for j:=2 step -1 until 0 do
begin l:=fp(i+k) shift (-8*j); outchar(productions,l);
end;
write(productions,newline,1);
i:=i+4;
end;
i:=i+1;
end;
exit :
end unpackfp;
procedure packfp(del);
<* the fp-stack is changed. repacking is done here *>
value del; integer del;
begin integer l, nextdel;
real array nextparam(1:2);
l:=del extract 12;
if l=10 then j:=4 else j:=1;
if (fpinx+j)>fpmax then stop(5);
fpinx:=fpinx+1; fp(fpinx):=del;
if l=4 then fp(fpinx+1):=fpparam(1) <* integer *>
else
begin <* name *>
nextdel := system(4,paramno+1,nextparam);
if nextdel=8 shift 12 + 10 and fpparam(1) = real <:xfort:>
and nextparam(1) = real <:test:> then
begin
xfortrantest := true;
j := -1;
paramno := paramno + 1; <* skip the compound parameter *>
end
else
if nextdel=8 shift 12 + 10 and fpparam(1)=real <:xref:> then
begin <* the param xref.yes or xref.no appear *>
paramno:=paramno+1; i:=system(4,paramno,fpparam);
if fpparam(1)=real <:yes:> then crossref:=true;
j:=-1;
end
else
if nextdel=8 shift 12 + 10 and fpparam(1)= real <:rand:> then
begin <* the parameter rand.yes or no appear *>
paramno:=paramno+1; i:=system(4,paramno,fpparam);
if fpparam(1)=real <:yes:> then random1:=true;
j:=-1;
end
else
if nextdel=8 shift 12 + 10 and fpparam(1)= real <:text:> then
begin
paramno := paramno+1;
for i:=1,2 do sourcename(i) := nextparam(i);
j := -1;
end
else
begin <* pack name *>
l:=1;
for i:=1,2 do
begin if i=2 then l:=3;
fp(fpinx+l):=fpparam(i) shift (-24) extract 24;
fp(fpinx+l+1):=fpparam(i) extract 24;
end;
end;
end;
fpinx:=fpinx+j;
end packfp;
procedure stop(n);
value n; integer n;
begin
write(out,newline,2);
case n of
begin
write(out,<: *** parse stack overflow (stackmax) :>);
write(out,<: *** end of file encountered :>);
begin
for i:=1 step 1 until errorcount do
write(out,newline,1,<: syntax in line :>,<<dddd>,errormark(1,i),
<: char.no. :>,<<dd>,errormark(2,i));
end case 3;
write(out,<: *** too many file definitions (filemax) :>);
write(out,<: *** parameter list too small (fpmax) :>);
write(out,<: *** line too long (linemax) :>);
end case ;
if n<>3 then write(out, <: in line:>, lineno);
write(out,newline,1);
if n<>3 then goto exitprg;
end proc stop;
procedure initialize;
<* variables and tables are initialized in this routine *>
begin
ok:=moreinput:=firstdefine:=firsttime:=more:=anything_left:=true;
format:=commentline:=false;
konstno:=nameno:=stacktop:=lineinx:=errorcount:=fileinx:=linecount1:=linecount2:=0;
stack(0):=0; curch:=32; lineno:=1;
startexp:=0;
<* initialization only concerning the algol 6 version : *>
np := 1; hp := 2; ch4 := 4; tv := 3;
newline := false add 10;
conv(0):=0;
for i:=1 step 1 until 180 do
conv(i):=case i of
(0,0,0,0,19,19,0,0,19,19,
0,0,20,20,20,20,0,0,0,0,
0,0,0,0,9,9,17,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,10,6,7,8,0,
0,0,13,0,0,16,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,11,11,0,0,0,0,
0,0,0,0,0,0,0,0,0,0,
0,0,0,0,0,0,0,15,0,0,
0,0,0,0,0,0,0,0,0,1,
1,0,0,0,15,15,14,0,5,0,
0,0,0,0,18,0,0,0,2,2,
2,18,0,0,0,0,0,0,0,0,
14,0,0,0,0,0,0,0,0,0,
0,4,4,3,3,12,0,0,0,0);
for i:=181 step 1 until 225 do conv(i):=0;
cheat(1):=120; cheat(2):=41; cheat(3):=59;
tcheat(1):=6; tcheat(2):=7; tcheat(3):=7;
reminx:=0; dot :=false;
for i:=1 step 1 until 9 do
testword(i):= long (case i of (<:lt :>,<:ge :>,<:eq :>,<:le :>,
<:ne :>,<:gt :>,<:and:>,<:or :>,<:shi:>))
shift (-24) extract 24;
for i:=1 step 1 until 63 do
begin
inrec6(parsetables,8);
j:=parsetables.f2;
if (j>64) and (j<94) then j:=j+32;
entry(ch4,j):=j;
entry(np,j):=parsetables.f4; entry(hp,j):=parsetables.f6;
entry(tv,j):=parsetables.f8;
end init entry;
for i:=0 step 1 until lxmax do
begin inrec6(parsetables,8);
j:=parsetables.f2;
if (j>64) and (j<94) then lx(ch4,i):=j+32 else lx(ch4,i):=j;
lx(np,i):=parsetables.f4;
lx(hp,i):=parsetables.f6; lx(tv,i):=parsetables.f8;
end;
stringescape:= entry(tv,stringch);
for i:=0 step 1 until lrmax do
begin
inrec6(parsetables,8);
lrchain(i):=parsetables.f2; lrnext(i):=parsetables.f4;
kind:=parsetables.f6; symb:=parsetables.f8;
if kind<>5 then
begin inrec6(parsetables,2); j:=parsetables.f2;
end;
if kind = 5 then lr(i) := (symb shift 3) add 5
else lr(i) := (j shift 12) add (symb shift 3) add kind;
end init lr;
close(parsetables,true);
end proc initialize;
procedure readaline(line,ltype,linecount);
<* the procedure reads the next line, comments are skipped *>
integer linecount; integer array line,ltype;
begin
linecount := 0;
more := anything_left;
if more then
begin
nextsymbol:
linecount := linecount + 1;
if linecount > linemax then stop(6);
ltype(linecount) := readchar(in,j);
if 64<j and j<94 then j := j+32; <* convert to small letters *>
if j=25 then
begin <* end medium *>
repeatchar(in);
more := false;
end;
line(linecount) := j;
if j <> 10 and j <> 25 then goto nextsymbol;
if line(1) = 47 then
begin
anything_left := false;
ltype(1) := 6; <* simulate letter *>
end;
linecount := linecount - 1;
end;
end; <* proc readaline *>
procedure nextline;
begin
own integer char73;
if firsttime then
begin firsttime := false;
readaline(line1,ltype1,linecount1);
readaline(line2,ltype2,linecount2);
end
else
begin
for i:=1 step 1 until reminx do line1(rem(i)):=46; <* . *>
if commentline then <* lines which are transformed to comments *>
begin if firstdefine or (line2(6)=32) then commentline:=false;
line1(1):=99; <* c *>
line1(2):=42; <* * *>
end;
if -, format then <* if format the line is written elsewhere *>
begin
repline : if line1(linecount3)<>59 then linecount3:=linecount3+1;
line1(linecount3):=10; line1(73):=char73;
for i:=1 step 1 until linecount3 do outchar(outfile,line1(i));
if linecount3>7 then lineno := lineno+1;
end;
for i:=1 step 1 until linecount2 do
begin line1(i):=line2(i); ltype1(i):=ltype2(i);
end;
linecount1:=linecount2;
readaline(line2,ltype2,linecount2);
if -, more then <* end of program *>
begin linecount1:=linecount1+1;
line1(linecount1):=59; ltype1(linecount1):=7;
linecount1:=linecount1+1;
if linecount1<7 then linecount1:=7;
line1(linecount1):=25; <*em*> ltype1(linecount1):=8;
linecount1:=linecount1+1;
end;
end;
<* if cardmode (72 signif. chars) *>
char73 := line1(73);
linecount3:=linecount1;
if ltype1(1) = 6 then
goto repline; <* comment line in source text *>
if linecount1>72 then linecount1:=72;
if more and linecount1<=7 then goto repline;
if dot then checkpoint; <* check points if cont. or if *>
if more and (ltype2(1)=6 <* commentline *> or line2(6)=32 or linecount2<=6) then
<* if not continuation line set seperator *>
begin linecount1:=linecount1+1;
line1(linecount1):=59; ltype1(linecount1):=7;
end;
end proc nextline;
procedure lexical;
<* returns the next terminal in newsymb *>
begin
integer bufi, newi, oldch ;
integer array buf(1:bufmax), lxnode(1:4);
boolean oldchclass;
procedure inchar;
<* the procedure reads the next character from the line-
buffer,if possible, else the linebuffer is changed and
the character is read from the new buffer. furthermore
some lexical work is done here.
*>
begin
if lineinx>= linecount1 and more then
begin <*change buffer*> nextline; lineinx:=6;
end;
lineinx :=lineinx+1;
curch := line1(lineinx); curchclass:=ltype1(lineinx);
if curch=25 then
begin moreinput:=false;
line1(linecount1-2):=10;
if linecount1>9 then
for i:=1 step 1 until linecount1-2 do outchar(outfile,line1(i));
end;
letterordigit := (curchclass=2) or (curchclass=6);
end; <*proc inchar *>
procedure packname;
<* the current name (identifier) is packed here *>
begin
newsymb := nameval;
if bufi>bufmax then bufi:=bufmax;
for i:=1 step 1 until bufi do name(i):=buf(i);
nameno:=bufi;
if xfortrantest then
begin
write(productions,newline,1,<: name :>);
for i:=1 step 1 until nameno do outchar(productions,name(i));
end;
write(xref,newline,1,lineno,nameno,<: :>);
for i:=1 step 1 until nameno do outchar(xref,name(i));
end proc packname;
procedure packstring;
<* the current string is read here *>
begin
for i:=i while true do
begin
if curch = stringch then
begin inchar;
if curch <> stringch then goto exitloop;
end;
inchar;
end for;
exitloop:
newsymb := stringval;
end proc packstring;
<* body of lexical *>
for i:=i while (curch=32) or (curch = 10) do inchar;
<* spaces and nl's are skipped *>
if -, 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 curchclass = 2 then <* charclass is digit *>
begin
for konstno := 1,konstno+1 while letterordigit do
begin
if konstno <= bufmax then konst(konstno) := curch;
inchar;
end;
konstno :=konstno-1;
newsymb := constval;
if xfortrantest then
begin
write(productions,newline,1,<: konst :>);
for i:=1 step 1 until konstno do outchar(productions,konst(i));
end;
end
else
begin <* not constant - search in termtree *>
bufi := 1; buf(1) := curch;
for i:= 1 step 1 until 4 do
lxnode(i):= entry(i,curch);
newi:= lxnode(hp);
inchar;
for i :=i while newi <> 0 do
begin
if lx(ch4,newi) = curch then
begin
if bufi<bufmax then
begin bufi:=bufi+1; buf(bufi):=curch;
end;
if (bufi=10) and buf(2) =113 then inchar;
<* if equivalence then skip last e *>
for i := 1 step 1 until 4 do
lxnode(i) := lx(i,newi);
newi := lxnode(hp);
inchar;
end
else newi := lx(np,newi);
end for i;
oldch := buf(bufi);
oldchclass := (oldch>96)and(oldch<=125)or(oldch>47)and(oldch<58);
if oldchclass and letterordigit then
begin
for bufi:=bufi+1,bufi+1 while letterordigit do
begin
if bufi<=bufmax then buf(bufi) := curch;
inchar;
end;
bufi:=bufi-1; packname;
end
else
if lxnode(tv)>0 then <* valid terminal *>
begin
newsymb := lxnode(tv);
if newsymb= stringescape then packstring;
end
else
if oldchclass then packname else markerror;
end;
if xfortrantest then
write(productions,newline,1,<: newsymb :>,newsymb);
end proc lexical;
procedure parse;
<* the parsing algorithm *>
begin integer lri,li,si,i;
procedure syntaxerror;
begin integer stackp,chainp;
<* the error is tried to be repaired by a stack-recovery algorithm *>
markerror;
if xfortrantest then
write(productions,newline,1,<: error :>,startinx,newsymb);
shiftstack;
if -, moreinput then ok := false;
for i:=i while moreinput do
begin
stackp := stacktop;
for i:=i while stackp>0 do
begin
chainp := stack(stackp);
for i:=i while chainp<>0 do
begin
if (lr(chainp) shift (-3) extract 9)=errorval then
begin
startinx:= stack(stackp);
stacktop:= stackp-1;
goto endrecover;
end;
chainp := lrchain(chainp);
end;
stackp:=stackp-1;
end stackp>0;
markerror; lexical;
end moreinput;
endrecover:
end proc syntaxerror;
procedure shiftstack;
begin
stacktop := stacktop+1;
if stacktop > stackmax then stop(1);
stack(stacktop) := startinx;
end proc shiftstack;
<* body of parse *>
startinx := 1; lexical;
for i:=i while ok do
begin
lri := startinx;
i := case lr(lri) extract 3 +1 of (1,2,3,4,3,5,3);
case i of
begin
<* 1 stop *> ok := false;
<* 2 shift *>
begin
for i:=i while (lr(lri) shift (-3)) extract 9 <> newsymb do
begin li := lrchain(lri);
if li = 0 then
begin syntaxerror; goto endshift;
end;
lri:=li;
end for i;
shiftstack; lexical;
startinx:=lrnext(lri);
endshift:
end shift case2;
<* 3 shift lookahead or reduce empty *>
begin
for i:=i while ((lr(lri) shift (-3)) extract 9)<>newsymb do
begin li :=lrchain(lri);
if li=0 then goto exitloop;
lri := li;
end;
exitloop:
kind := lr(lri) extract 3;
if kind=2 then
begin shiftstack; lexical;
end
else
if kind = 6 then
begin shiftstack; newtop := stacktop;
code(lr(lri) shift (-12));
end;
startinx:= lrnext(lri);
end case 3;
<* 4 reduce *>
begin
newtop := stacktop-(lr(lri) shift (-3) extract 9);
i :=lr(lri) shift (-12);
if conv(i) <> 0 then code(i);
stacktop := newtop;
startinx := lrnext(lri);
end;
<* 5 lookback *>
begin
si := stack(stacktop);
for i:=i while (lr(lri) shift (-3)) <> si do
begin
li := lrchain(lri);
if li = 0 then goto exlookback;
lri := li;
end;
exlookback:
startinx := lrnext(lri);
end
end case;
end while;
end proc parse;
<* m-a-i-n p-r-o-g-r-a-m *>
<* the most of the following contains code for
changing the fp-stack.
*>
fpinx:=0; random1:=xfortrantest:=crossref:=false; paramno:=1;
sourcename(1) := real <::>;
i:=system(4,paramno,fpparam);
if i=6 shift 12+10 then <*leftside exists *>
begin i:=system(4,0,fpparam);
packfp(i); i:=system(4,paramno,fpparam);
end
else
begin <* no leftside *>
i:=system(4,0,fpparam); paramno:=0;
end;
<* the parameter should be xfortran *>
fpinx:=fpinx+1; fp(fpinx):=i;
for j:=1 step 1 until 4 do
fp(fpinx+j) :=long (case j of (<:for:>,<:tra:>,<:n:>,<::>))
shift (-24) extract 24;
fpinx:=fpinx+4; paramno:=paramno+1;
<* next parameter should be source file if any *>
fpinx:=fpinx+1; fp(fpinx):=4 shift 12 + 10;
sourceinx := fpinx;
fpinx:=fpinx+4;
i:=system(4,paramno,fpparam);
j:=system(4,paramno+1,workfile);
if j shift (-12) <> 4 then packfp(i); <* no source file *>
paramno:=paramno+1; i:=system(4,paramno,fpparam);
for i:=i while i<>0 do
begin packfp(i); paramno:=paramno+1;
i:=system(4,paramno,fpparam);
end;
i:=1; open(outfile, 4, string sourcename(increase(i)), 0);
if if monitor(52) create area process:(outfile, 0, tail) = 0
then monitor( 8) reserve process :(outfile, 0 , tail) <> 0
else true
then
begin <* file did not exist or was not allowed for writing *>
tail(1) := 42; <* size *> tail(2) := 1; <* disc preferred *>
for i:=3 step 1 until 10 do tail(i) := 0;
monitor(40) create entry:(outfile, 0, tail);
end;
tail(1):=42; tail(2):=1;
for i:=3 step 1 until 10 do tail(i):=0;
open(xref,4,<::>,0);
monitor(40) create entry:(xref,0,tail);
getzone6(xref,tail);
if crossref then
begin <* make call of crossref program *>
fpinx:=fpinx+1; fp(fpinx):=2 shift 12 + 10;
for i:=1 step 1 until 4 do
fp(fpinx+i):=long (case i of(<:cro:>,<:ssr:>,<:ef:>,<::>))
shift (-24) extract 24;
fpinx:=fpinx+5; fp(fpinx):=4 shift 12 +10;
for i:=1 step 1 until 4 do
fp(fpinx+i):=tail(i+1);
fpinx:=fpinx+4;
end;
initialize;
parse;
write(outfile,false add 25 ,1);
getzone6(outfile, tail);
<* tail 2-5 contains the areaname for input to fortran *>
for i:= 1 step 1 until 4 do
fp(sourceinx+i) := tail(i+1);
close(outfile,true);
i:=0; write(xref,newline,1,i,i,newline,1);
close(xref,true);
if -, crossref then
monitor(48) remove entry:(xref,0,tail);
if xfortrantest then
begin
unpackfp;
write(productions,false add 25,1);
close(productions,true);
stop(3); <* write out possible errormessages *>
end;
fpexecute(fp,fpinx*2);
exitprg :
end inner block;
end
▶EOF◀