|
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: 9984 (0x2700)
Types: TextFile
Names: »crossref4tx «
└─⟦01e83a425⟧ Bits:30008166 Bånd med SW8010 og SW8500 source code
└─⟦75ff9bef3⟧
└─⟦this⟧ »crossref4tx «
crossref = algol index.no
begin
<* 77 05 13
crossreference for fortran programs which have
been preprocessed by xfortran
*>
integer variablelength, bintreelimit1, bintreelimit2, noofappear, rightptr,
leftptr, wordvarlength ;
variablelength :=12; <* max length of items must be multiplum of 3 *>
bintreelimit2 := 150; <* max no of items *>
noofappear := 40; <* max number of appearances for an item *>
bintreelimit1 := variablelength/3+4; <* explanation see below *>
wordvarlength := variablelength/3; <* variablelength in words *>
leftptr := wordvarlength+1; <* ptr to left subtree *>
rightptr := wordvarlength+2; <* ptr to right subtree *>
begin
integer i,j,k,l, itemlength, treeindex, linecount, line, page;
integer array item(1:variablelength+1),
bintree(1:bintreelimit1,1:bintreelimit2),
name(1:wordvarlength+1),
routine(1:variablelength),
tail(1:10),
lineno(1:bintreelimit2,1:noofappear);
boolean nl, sp, em;
zone outfile(128,1,stderror);
<* variable explanation :
item(.) - contains the next item on input.
itemlength - index to item().
bintree(.,.) - binary tree which contains the read information.
bintree(1-variablelength,.) - name in chars
- (leftptr,.) - ptr to left subtree
- (rightptr,.) - ptr to right subtree
- ( +1,.) - ptr to appearance array
- ( +2,.) - index to appearance array
treeindex - ptr to last used item in bintree.
lineno(.,.) - contains the linenumbers in which the read items exist.
line - the current line.
nl - newline.
sp - space.
page - number of page (used in writeinf).
linecount - used to make appropiate pages in writeinf
*>
procedure error(no);
value no; integer no;
begin
write(out,nl,2,sp,2,<:***:>);
case no of
begin
write(out,<: identifier appears too many times :>);
write(out,<: binary tree too small :>);
end;
write(out,nl,1);
end proc error;
procedure sort;
begin
integer array buf1(1:variablelength),buf2(1:variablelength);
integer i,line1,line2,l1,l2;
procedure write1;
begin write(outfile,nl,1,line1,l1,<: :>);
for i:=1 step 1 until l1 do outchar(outfile,buf1(i));
end proc write1;
procedure write2;
begin write(outfile,nl,1,line2,l2,<: :>);
for i:=1 step 1 until l2 do outchar(outfile,buf2(i));
end proc write2;
for i:=i while i=i do
begin read(in,line1,l1);
if line1=0 then
begin write(outfile,nl,1,line1,l1,nl,1); goto endsort;
end;
for i:=1 step 1 until l1 do readchar(in,buf1(i));
read(in,line2,l2);
if line2=0 then
begin write1;
write(outfile,nl,1,line2,l2,nl,1); goto endsort;
end;
for i:=1 step 1 until l2 do readchar(in,buf2(i));
if line2=-1 then
begin <* exchange *> write2; write1;
end
else
begin write1; write2;
end;
end;
endsort:
setposition(outfile,0,0);
end proc sort;
procedure newpage;
begin
page:=page+1;
write(out, false add 12,1, sp,2,<:<10>crossreference:>,sp,5);
for i:=1 step 1 until variablelength do outchar(out,routine(i));
write(out,sp,50-variablelength,<:page:>,<<ddd>,page,nl,2);
end proc newpage;
procedure readitem;
begin
<* the next name is read from input (only
letters and digits and are accepted *>
read(outfile,line,itemlength);
if line=-1 then goto exit1 else
if line=0 then
begin em:=true; goto exit1;
end;
for i:=1 step 1 until itemlength do readchar(outfile,item(i));
if itemlength<variablelength then
for i:= itemlength+1 step 1 until variablelength do item(i):=32;
exit1:
<*
write(out,nl,1,<: line,length,name : :>,line,itemlength);
for i:=1 step 1 until itemlength do outchar(out,item(i));
write(out,nl,1);
*>
end proc readitem;
procedure insertname(ptr);
value ptr; integer ptr;
begin
packname;
for i:=1 step 1 until wordvarlength do bintree(i,ptr):=name(i);
end proc insertname;
procedure packname;
begin j:=1;
for j:=j while j<= variablelength do
begin
k:=0;
for i:=2 step -1 until 0 do
k:=k add (item(j+2-i) shift (i*8));
name(j/3+1):=k;
j:=j+3;
end;
end proc packname;
procedure insert(ptr);
value ptr; integer ptr;
begin
integer procedure compare(ptr);
value ptr; integer ptr;
<* comparison of the names in bintree and name.
the result is :
0 if the names are the same.
1 if the name to insert is lexicographical before.
2 else.
*>
begin i:=1;
for i:=i while ((i<=wordvarlength) and (name(i)=bintree(i,ptr))) do i:=i+1;
if i> wordvarlength then compare:=0
else
if name(i)>bintree(i,ptr) then compare:=1
else compare :=2;
end proc compare;
procedure insertnode(ptr,pos);
value ptr,pos ; integer ptr,pos;
begin
if pos = 0 then <* the name has appeared before *>
begin <* the linenumber has to be remembered *>
i:=bintree(bintreelimit1,ptr)+1;
if i>noofappear then error(1);
lineno(bintree(bintreelimit1-1,ptr),i):=line;
bintree(bintreelimit1,ptr):=i;
end
else
begin <* new name *>
treeindex := treeindex+1;
if treeindex>bintreelimit2 then error(2);
<* leftptr and rightptr are init 0 *>
bintree(wordvarlength+3,treeindex):= treeindex;
bintree(wordvarlength+4,treeindex):=1;
lineno(treeindex,1):= line;
if pos=1 then bintree(leftptr,ptr):= treeindex
else bintree(rightptr,ptr):= treeindex;
<* insertion of the name *>
insertname(treeindex);
end new name;
end proc insertnode;
<* body of insert *>
packname; i:= compare(ptr) ;
if i=0 then insertnode(ptr,0)
else
if i=1 then
begin <* the name to insert is less than *>
if bintree(leftptr,ptr)=0 then insertnode(ptr,1)
else insert(bintree(leftptr,ptr))
end
else
begin
if bintree(rightptr,ptr)=0 then insertnode(ptr,2)
else insert(bintree(rightptr,ptr))
end
end proc insert;
procedure inorder(ptr);
value ptr; integer ptr;
begin <* the binary tree is crossed in inorder *>
if ptr<>0 then
begin
inorder(bintree(rightptr,ptr));
writeinf(ptr);
inorder(bintree(leftptr,ptr));
end;
end proc inorder;
procedure unpack(ptr);
value ptr; integer ptr;
begin
for l:=1 step 1 until wordvarlength do
for j:=2 step -1 until 0 do
outchar(out,(bintree(l,ptr) shift (-8*j)) extract 8 );
end proc unpack;
<*
procedure dump;
begin write(out,nl,1,<: bintree :>,nl,2);
for i:=1 step 1 until treeindex do
begin
unpack(i); write(out,nl,1);
for j:=4 step 1 until bintreelimit1 do
write(out,<<ddddddd>,bintree(j,i),nl,1);
write(out,nl,1);
end;
end proc dump;
*>
procedure writeinf(ptr);
value ptr; integer ptr;
begin
if linecount>= 40 then
begin newpage; linecount:=1;
end else linecount:=linecount+1;
write(out,nl,1,sp,2);
unpack(ptr);
write(out,sp,15-wordvarlength*3);
i:=bintree(wordvarlength+3,ptr);
j:=bintree(wordvarlength+4,ptr);
for k:=1 step 1 until j do
begin
write(out,<<dddddd>,lineno(i,k));
if k mod 11 = 0 then
begin
if linecount >= 40 then
begin newpage; linecount:=1
end
else
begin linecount := linecount+1;
write(out,nl,1,sp,17);
end;
end;
end
end proc writeinf;
<* main program *>
tail(1):=42; tail(2):=1;
for i:=3 step 1 until 10 do tail(i):=0;
open(outfile,4,<::>,0);
monitor(40) create entry :(outfile,0,tail);
nl := false add 10;
sp := false add 32;
em := false ;
sort;
readitem;
for i:=1 step 1 until itemlength do readchar(outfile,routine(i));
if itemlength<variablelength then
for i:=itemlength+1 step 1 until variablelength do routine(i):=32;
for i:=i while -, em do
begin
treeindex := page := 0;
linecount := 1;
for i := 1 step 1 until bintreelimit2 do
for j := 1 step 1 until bintreelimit1 do
bintree(j,i):= 0;
<* insert name in root *>
readitem;
if line=0 then goto outp;
treeindex:=treeindex+1;
bintree(wordvarlength+3,treeindex):=treeindex;
bintree(wordvarlength+4,treeindex):=1;
lineno(treeindex,1):=line;
insertname(1);
for i:= i while i=i do
begin
readitem;
if (line=0) or line=-1 then goto outp;
insert(1);
end;
<* now a routine of the input file has been read,
the output has to be produced
*>
outp :
newpage;
inorder(1);
if line<>0 then
begin
for i:=1 step 1 until itemlength do readchar(outfile,routine(i));
if itemlength<variablelength then
for i:=itemlength+1 step 1 until variablelength do routine(i):=32;
end;
end;
exit :
monitor(48) remove entry:(outfile, 0, item);
monitor(48) remove entry:(in, 0, item);
end
end
▶EOF◀