{ Read one character from the input file; check for end of file; count lines }
procedure getchar;
begin
if eof(infile) then ch := blank
else
if eoln(infile) then
begin readln(infile,ch); line := line + 1 end
else read(infile,ch)
end; { getchar }
{ Read an identifier from the input file; ignore names that start
with an upper case letter, comments, quoted strings, and other
characters. }
procedure getname;
var
done : boolean;
begin
done := false;
repeat
if ch in ['a'..'z'] then
begin
setlength(name,0); oldline := line;
while ch in ['a'..'z','A'..'Z','0'..'9','_'] do
begin
if length(name) < namelen then append(name,ch);
getchar
end; { while }
done := true
end
else
if ch = '{' then
begin repeat getchar until (ch = '}') or eof(infile); getchar end
else
if ch = '''' then
begin repeat getchar until (ch = '''') or eof(infile); getchar end
else getchar
until done or eof(infile)
end; { getname }
{ Store a name in one of the binary trees. The tree is chosen according
to the first letter of the name. The tree is searched with a REPEAT
loop rather than by recursion for speed. }
procedure storename;
var
entry : entryptr;
item : itemptr;
entered : boolean;
begin { storename }
entry := roots[name[1]]; entered := false;
repeat
if name < entry^.name then
if entry^.left = nil then makentry(entry^.left)
else entry := entry^.left
else
if name > entry^.name then
if entry^.right = nil then makentry(entry^.right)
else entry := entry^.right
else { name matched }
begin
if entry^.items^.line <> line then
begin
new(item);
item^.line := oldline;
item^.next := entry^.items;
entry^.items := item
end;
entered := true
end
until entered;
entcount := entcount + 1
end; { storename }
{ Print a tree given its root. The list of line numbers associated with
an identifier is LIFO and must be reversed before printing. }
procedure print (entry : entryptr);
var
forwards, backwards, temp : itemptr;
entcount : byte;
begin
if entry <> nil then
begin
print(entry^.left);
if length(entry^.name) > 0 then
begin
write(outfile,entry^.name,blank:namelen+2-length(entry^.name));
forwards := nil; backwards := entry^.items;
while backwards <> nil do { reverse list }
begin
temp := backwards; backwards := temp^.next;
temp^.next := forwards; forwards := temp
end; { while }
entcount := 0;
while forwards <> nil do
begin
if entcount >= maxent then
begin writeln(outfile); write(outfile,blank:namelen+2); entcount := 0 end;
write(outfile,forwards^.line:entlen); entcount := entcount + 1;
forwards := forwards^.next
end; { while }
writeln(outfile)
end;
print(entry^.right)
end
end; { print }
{ Main program }
begin
{ Open files }
getfilenames(extin,extout);
writeln('Reading from ',infilename);
reset(infilename,infile);
if eof(infile) then writeln(infilename,' is empty.')
else
begin
writeln('Writing to ',outfilename);
reset(infilename,infile);
rewrite(outfilename,outfile);
for ch := 'a' to 'z' do
begin
new(roots[ch]);
setlength(roots[ch]^.name,0);
roots[ch]^.items := nil;
roots[ch]^.left := nil;
roots[ch]^.right := nil
end; { for }
{ Initialize counters and space flag }
symcount := 0; entcount := 0; spaceleft := true;
{ Initialize input procedures }
line := 1; getchar; getname;
{ Scan the program }
while spaceleft and not eof(infile) do
begin
if (0 < space) and (space < minspace) then
begin writeln('Memory exhausted at line ',line:1); spaceleft := false end;
storename; getname
end; { while }
{ Define output layout }
entlen := 3;
if line > 99 then entlen := 4;
if line > 999 then entlen := 5;
maxent := (maxwidth - namelen - 2) div entlen;
{ Print the tree }
for ch := 'a' to 'z' do print(roots[ch]);
{ Display report }
writeln(line-1:1,' lines read, ',symcount:1,' symbols stored, ',
entcount:1,' entries recorded.');
if space > 0 then writeln('Space left: ',space:1,' bytes.')
end
end. { xref }
