|
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: 14592 (0x3900)
Types: TextFile
Names: »tgensyntax«
└─⟦00964e8f7⟧ Bits:30007478 RC8000 Dump tape fra HCØ.
└─⟦b2ec5d50f⟧
└─⟦this⟧ »tgensyntax«
begin
message gensyntax .. 1 .. ;
<*
;
;
;
;
;
; ***********************************************************
; * *
; * ******* ******* ** ** ******* * *
; * * * * * * * * * * * * *
; * * * * * * * * * * * *
; * * * * * * * ********* * *
; * * * * * * * * * *
; * * * * * * * * * * * *
; * ******* ******* * * * * ********* *
; * *
; ***********************************************************
;
;
; comal/basic utility gensyntax
;
;
; generates the syntax table used by the
; comal/basic interpreter
;
;
; call:
; <outfile>=gensyntax in.<source> list.<bool>
;
; default:
; no output and no listing
*>
\f
message gensyntax .. 2 .. ;
real r,error;
long array undefined(1:100);
real array ra,outname,inname(1:2);
integer indate,page,lineno,undef,xrindex;
long array ids(1:300);
integer array ia(1:20),defined(1:300),xref(1:2000);
integer int,j,k,word,i;
boolean nl,outp,pageshift,list,ok;
long name;
boolean done;
integer array line(1:80);
integer cc,linelength;
integer class,oldstate,state,action,address;
integer index;
zone output(256,2,stderror);
zone input(256,2,stderror);
procedure sort(larr,iarr,iarr1,n);
value n; integer n;
long array larr;
integer array iarr,iarr1;
begin
integer i,j,k,k1; long l;
for i:=1 step 1 until n-1 do
for j:=1 step 1 until n-i do
if larr(j)>larr(j+1) then
begin
l:=larr(j);
k:=iarr(j);
k1:=iarr1(j);
larr(j):=larr(j+1);
iarr(j):=iarr(j+1);
iarr1(j):=iarr1(j+1);
larr(j+1):=l;
iarr(j+1):=k;
iarr1(j+1):=k1
end
end;
\f
message gensyntax .. 3 .. ;
procedure insert(x);
value x; integer x;
begin
integer i;
ids(index+1):=name;
i:=0;
for i:=i+1 while ids(i)<>name do;
if i>index then
begin
index:=index+1;
xrindex:=xrindex+1;
xref(xrindex):=0;
defined(index):=(address+1) add (x shift 12)
end
else
defined(i):=-1 <* multyply defined *>
end;
integer procedure lookup;
begin
integer i;
i:=0;
ids(index+1):=name;
for i:=i+1 while ids(i)<>name do;
if i>index then
begin
undefined(undef+1):=name;
i:=0;
for i:=i+1 while undefined(i)<>name do;
if i>undef then undef:=undef+1;
lookup:=0
end
else
begin
lookup:=defined(i);
while xref(i) shift (-12)<>0 do i:=xref(i) shift (-12);
xref(i):=xref(i) add ((xrindex+1) shift 12);
xrindex:=xrindex+1;
xref(xrindex):=address
end
end;
\f
message gensyntax .. 4 .. ;
integer procedure scanitem;
begin
integer i,ch;
boolean id,ok;
id:=false;
repeat
ok:=true;
if cc=linelength then
begin
cc:=1;
while readchar(input,line(cc))<>8 do cc:=cc+1;
linelength:=cc;
cc:=0
end;
repeat
cc:=cc+1;
ch:=line(cc);
until ch<>32;
if ch=64 then
begin
int:=0;
while line(cc+1)>=48 and line(cc+1)<=57 do
begin
cc:=cc+1;
int:=int*10+line(cc)-48
end;
int:=int add (2 shift 12);
scanitem:=8
end
else
if ch>=48 and ch<=57 then
begin
int:=0;
while line(cc)>=48 and line(cc)<=57 do
begin
int:=int*10+line(cc)-48;
cc:=cc+1
end;
cc:=cc-1;
scanitem:=2;
\f
message gensyntax .. 5 .. ;
end
else
if ch=59 then
begin
scanitem:=5;
cc:=linelength
end
else
if ch=97 then
begin
if line(cc+1)>=48 and line(cc+1)<=57 then
begin
scanitem:=3;
int:=0;
cc:=cc+1;
repeat
int:=int*10+line(cc)-48;
cc:=cc+1
until line(cc)<48 or line(cc)>57;
cc:=cc-1
end
else
id:=true
end
else
if ch>=97 and ch<=125 then
id:=true
else
if ch=25 then
scanitem:=1
else
if ch=10 or ch=12 then
scanitem:=5
else
if ch=43 then
ok:=false
else
begin
line(cc):=63;
ok:=false
end;
\f
message gensyntax .. 6 .. ;
if id then
begin
name:=0;
i:=5;
repeat
name:=name add ch shift 8;
i:=i-1;
cc:=cc+1; ch:=line(cc)
until i=0 or ch<48 or ch>57 and ch<97
or ch>125;
while i>0 do begin name:=name shift 8; i:=i-1 end;
while ch>=48 and ch<=57 or
ch>=97 and ch<=125 do
begin
cc:=cc+1;
ch:=line(cc)
end;
if ch=58 then
scanitem:=7
else
if ch=46 then
scanitem:=6
else
begin
cc:=cc-1;
scanitem:=4
end
end;
until ok
end;
procedure newpage;
begin
integer i;
pageshift:=true;
page:=page+1;
i:=1; write(out,false add 32,12-
write(out,string inname(increase(i))));
writedate(out,systime(6,indate,r),r,9);
write(out,<: page:>,<<_ddd>,page,nl,2);
end;
\f
message gensyntax .. 7 .. ;
procedure connect_output;
begin
integer array bases(1:20);
integer i;
open(output,4,outname,0);
system(11,0,bases);
i:=monitor(76,output,0,ia);
if i=0 then
begin
if ia(2)<bases(7) or ia(3)>bases(8) then i:=1;
end;
if i<>0 then
begin
ia(1):=ia(2):=1;
for i:=3 step 1 until 10 do ia(i):=0;
ia(6):=systime(7,0,0.0);
if monitor(40,output,0,ia)<>0 then goto noout;
end
else
begin
monitor(42,output,0,ia);
ia(6):=systime(7,0,0.0);
monitor(44,output,0,ia);
end;
if monitor(52,output,0,ia)<>0 then goto noout
end;
\f
message gensyntax .. 8 .. ;
nl:=false add 10;
write(out,<:<12>gensyntax :>); writedate(out,systime(5,0,r),r,9);
write(out,nl,2);
ok:=outp:=list:=false;
j:=0;
i:=system(4,j,ra);
if i extract 12=10 then
begin
outname(1):=ra(1); outname(2):=ra(2);
j:=j+1;
i:=system(4,j,ra);
if i shift (-12)=6 then
begin
outp:=true;
j:=j+1
end
end else
goto err;
i:=system(4,j,ra);
while i<>0 do
begin
if i extract 12<>10 or i shift (-12)<>4 then goto err;
j:=j+1;
if ra(1)=real <:list:> then
begin
i:=system(4,j,ra);
if i extract 12<>10 or i shift (-12)<>8 then goto err;
list:=ra(1)=real <:yes:>
end
else if ra(1)=real <:in:> then
begin
i:=system(4,j,ra);
if i extract 12<>10 or i shift (-12)<>8 then goto err;
inname(1):=ra(1); inname(2):=ra(2);
ok:=true
end
else goto err;
j:=j+1;
i:=system(4,j,ra)
end;
if -, ok then goto err;
\f
message gensyntax .. 9 .. ;
<* begin of pass 1: definition of symbols. *>
open(input,4,inname,0);
if monitor(42,input,0,ia)<>0 then goto noin; indate:=ia(6);
if monitor(52,input,0,ia)<>0 then goto noin;
if outp then connect_output;
index:=xrindex:=0; done:=false; state:=1; oldstate:=1;
cc:=0; linelength:=0;
address:=0; error:=real <: :>;
repeat
class:=scanitem+(state-1)*8;
action:=case class of
( 3,4,4,4,4,2,1,4,
3,4,4,4,4,4,4,4,
3,4,4,4,4,4,4,4,
3,4,4,4,4,4,4,4,
3,4,4,4,4,4,4,4,
3,4,4,4,4,4,4,4 );
state:=case class of
( 1,2,1,2,1,1,1,2,
1,1,1,1,3,1,1,1,
1,4,4,4,3,1,1,1,
1,4,4,4,5,1,1,1,
1,6,6,6,5,1,1,1,
1,6,6,6,1,1,1,1 );
if state<>oldstate then
begin
if state mod 2<>1 then address:=address+1
end;
oldstate:=state;
case action of
begin
insert(1);
insert(0);
done:=true;
<* no action *>
end;
until done;
close(input,true);
\f
message gensyntax .. 10 .. ;
<* begin of pass 2: table assembly. *>
open(input,4,inname,0);
done:=false; state:=1; oldstate:=1;
page:=undef:=cc:=linelength:=0;
address:=0; error:=real <: :>;
lineno:=10;
if list then newpage; pageshift:=false;
repeat
class:=scanitem+(state-1)*8;
action:=case class of
( 7,1,5,2,8,9,9,1,
6,5,5,5,8,5,5,5,
6,3,3,4,8,5,5,5,
6,3,3,4,8,5,5,5,
6,3,3,4,8,5,5,5,
6,3,3,4,8,5,5,5 );
state:=case class of
( 1,2,1,2,1,1,1,2,
1,1,1,1,3,1,1,1,
1,4,4,4,3,1,1,1,
1,4,4,4,5,1,1,1,
1,6,6,6,5,1,1,1,
1,6,6,6,1,1,1,1 );
if state<>oldstate then
begin
if state mod 2<>1 then
begin
address:=address+1;
word:=0
end
else
begin
if outp then write(output,<<d>,word,<:<10>:>);
if list or error<>real <: :> then
write(out,<<dddddd>,lineno,<: :>,
string error,<<zddd>,address,
<<___zddd>,word shift (-12),
<<_zddd>,word extract 12,<: :>)
end
end;
\f
message gensyntax .. 11 .. ;
case action of
begin
word:=int;
begin
i:=lookup;
if i=0 then
error:=real <:***u :>
else if i=-1 then
error:=real <:***m :>
else if i<4096 then
error:=real <:***i :>
else
word:=i
end;
word:=word add (int extract 12);
begin
i:=lookup;
if i>4095 then
error:=real <:***i :>
else if i=0 then
error:=real <:***u :>
else if i=-1 then
error:=real <:***m :>
else
word:=word add (i shift 12)
end;
error:=real <:***i :>;
begin
write(out,<:<10>**** end medium.<10>:>);
done:=true
end;
\f
message gensyntax .. 12 .. ;
done:=true;
begin
if list or error<>real <: :> then
begin
if oldstate=state then write(out,<<dddddd>,lineno,
<:_______________________:>);
for i:=1 step 1 until linelength do
outchar(out,line(i));
if line(linelength)=12 then newpage
else
begin
lineno:=if pageshift then (lineno//1000+1)*1000+10
else lineno+10;
pageshift:=false
end
end;
error:=real <: :>
end;
<* no action *>
end;
\f
message gensyntax .. 13 .. ;
oldstate:=state
until done;
if outp then
begin
outchar(output,25);
close(output,true);
getzone6(output,ia);
i:=ia(9);
monitor(42,output,0,ia);
ia(1):=i;
monitor(44,output,0,ia);
end;
close(input,true);
if list then
begin
outchar(out,12);
newpage;
write(out,<:symbol table:<10><10>:>);
\f
message gensyntax .. 14 .. ;
sort(ids,defined,xref,index);
for i:=1 step 1 until index do
begin
write(out,<: :>);
int:=write(out,string ids(i));
for cc:=1 step 1 until 8-int do outchar(out,32);
if defined(i)=-1 then
begin
error:=real <: m:>;
int:=0
end
else
begin
int:=defined(i);
error:=real (case int shift (-12)+1 of (
<: :>,<: s:>));
end;
write(out,<<zddd>,int extract 12,string error);
k:=-1; j:=i;
while xref(j) shift (-12)<>0 do
begin
k:=k+1;
j:=xref(j) shift (-12);
if k mod 12=0 and k<>0 then write(out,nl,1,false add 32,16);
write(out,<<_zddd>,xref(j) extract 12)
end;
write(out,nl,1)
end;
end;
if undef>0 then
begin
if list then begin outchar(out,12); newpage end;
write(out,<:undefined symbols:<10><10>:>);
for i:=1 step 1 until undef do
write(out,<: :>,string undefined(i),<:<10>:>)
end;
\f
message gensyntax .. 15 .. ;
if false then
begin
noout: i:=1; write(out,<:***gensyntax: connect :>,
string outname(increase(i)),
<:, not possible<10>:>)
end;
if false then
begin
noin: i:=1; write(out,<:***gensyntax: :>,string inname(increase(i)),
<:, area does not exist<10>:>);
end;
if false then
err: write(out,<:***gensyntax: param:>,nl,1,
<: try: <output=>gensyntax <list.bool> in.name<10>:>);
trapmode:=-1;
end
▶EOF◀