⟦a35dadda7⟧

TextFileVerbose

program pascal_cross(infil,outputfil, output);

(* version 80.03.19 *)
label 10;

const hashsize=1373;
maxline=46;
maxq = 35; (* maximum number of queued names *)
sp = ' ';


type
usestate = ( declaration, assign, labeldef, otheruse );
whats=(keyword, identifier);
hashindex=0..hashsize;
occ_list = packed  record
where : 1..100000;
usekind : usestate;
next : ^occ_list
end;

occptr = ^ occ_list;

restname = record
next : ^ restname;
namepart : alfa;
end;

hashrec = packed  record
id : alfa;
restofname : ^ restname;
following : hashindex;
case what : whats of
identifier : (first, last : ^occ_list);
keyword : (key_occ : integer);
end;

hashc  =record
case con:integer of
1 : (int : integer);
2 : (al  : alfa)
end;

var
 
outputfil : text;

skipend,  (* if eof infil then nextsymbol := skipend *)
skipend1,
symbol : char;
table_full_at_line,
step,             (* temporary variable used in for-statements *)
brackcount,       (* counting number of unsatisfied left brackets *)
blockcount,       (* begin-counter *)
othercount,       (* record and case-statement counter *)
localline,        (* procedure-local line numbers *)
pasline,          (* pascal line number *)
pagenumber,
linenumber : integer;  (* number of lines on this page *)
curdate,
curtime,
filename,        (* input file name used as heading on outputfil *)
newid : alfa;


currentnode,
occurrence : occptr;
hashconv : hashc;
top : hashindex;
keywordtop : hashindex;

hash_table : array[hashindex] of hashrec;
outputfile,
endline : boolean;
infil : text;
idlength : integer;

current_name,    (* 80.03.17 current chunk *)
startofcurrent : ^ restname; (* start of current chunk chain *)

alfanum : set of char;

lastqueued : 0 .. maxq;
queue : array [ 1 .. maxq ] of occptr;



value
brackcount = 0;
blockcount = 0;
othercount = 0;
localline=-1;
linenumber=0;
pasline = 0;
pagenumber = 0;
newid='  ';  (* be ready for a new name *)
idlength = 0; (* current name is empty *)
current_name = nil;  (*  no chunks are in use *)
startofcurrent = nil; (* current chain of chunks is empty *)
top = hashsize; (* hashsize is stopmark for the lists ( one list of keywords 
and one list of identifiers) *)
outputfile = false;
endline = true;

alfanum = [ 'a' .. 'z', 'A' .. 'Z', '0' .. '9', '_' ] ;

lastqueued = 0; (* empty queue *)
queue = (<1..maxq> * nil );

currentnode = nil;




function insert_id(  nid : alfa; ide : whats) : occptr; forward;



procedure init;
const
power12 = 4096;
equality = 6;
noof_keywords = 38;
var
i,j : integer;
id : alfa;
keywords : array[1..noof_keywords] of alfa;
value
keywords=('WITH',
'WHILE',
'VAR',
'VALUE',
'UNTIL',
'TYPE',
'TO',
'THEN',
'SET',
'REPEAT',
'RECORD',
'PROGRAM',
'PROCEDURE',
'PACKED',
'OTHERWISE',
'OR',
'OF',
'NOT',
'NIL',
'MOD',
'LABEL',
'IN',
'IF',
'GOTO',
'FUNCTION',
'FORWARD',
'FOR',
'FILE',
'END',
'ELSE',
'DOWNTO',
'DO',
'DIV',
'CONST',
'CASE',
'BEGIN',
'ARRAY',
'AND');


begin
date(curdate); time(curtime);
table_full_at_line := -1;
for i:=0 to hashsize do hash_table[i].id:='          ';
for i:=1 to noof_keywords do
begin
currentnode := insert_id(keywords[i],keyword);
end;
keywordtop:=top;
top:=hashsize;

i:=system(1,j,id);
if i div power12 = equality then
begin (* get outputfilfile *)
i:=system(0,j,id);
if i mod power12 = 10 then
begin
outputfile:=true;
open(outputfil,id);
rewrite(outputfil);
end
else
begin
writeln(' ??? illegal outputfil-filename');
goto 10;
end;
i:=2;
end
else i:=1;

(* get input file *)
i:=system(i,j,id);
if i mod power12 = 10 then
begin
open(infil,id);
reset(infil);
filename := id;
end
else
begin
if outputfile then close(outputfil);
writeln(' ??? illegal input-filename');
goto 10;
end;
end;


procedure newpage;
begin
page(outputfil);
pagenumber := pagenumber + 1;
write(outputfil, filename, curdate, curtime);
write(outputfil, 'page':50, pagenumber : 6);
writeln(outputfil);
writeln(outputfil);
linenumber := 0;
end;


procedure checkbracket;
(* check : (brackcount = 0) and (blockcount > 0 ) *)
begin
if (blockcount > 0) and (brackcount <> 0) then
begin
writeln(output,'??? error in bracket structure, detected at line : ',
pasline : 6 );
brackcount := 0; (* recover *)
end;
end; (* check bracket *)



procedure nextsymbol;
(* return next symbol in global variable 'symbol' *)
begin
if endline then
begin
if (linenumber mod maxline)=0 then newpage;
linenumber:=linenumber+1;
pasline := pasline + 1;
write(outputfil,pasline:5);
if localline >= 0 then
begin
localline := localline + 1;
write(outputfil, localline : 5, ' ');
end
else write(outputfil,' ':6);
end;
if eoln(infil) then
begin
endline:=true;
writeln(outputfil);
if (infil^ = ff) and ((linenumber mod maxline) <> 0) then newpage;
end
else endline:=false;
(* LINENUMBER IS INCREMENTED JUST BEFORE READING THE
FIRST CHARACTER ON THE NEW LINE *)
if eof(infil) then
symbol := skipend
else
read(infil, symbol);

if not endline then write(outputfil,symbol);
if symbol > '_' then symbol :=chr(ord(symbol)-32);
end;


function insert_id (  nid : alfa; ide : whats) : occptr; (* forward declared *)
var found:boolean;
h:hashindex;
step,
d:integer;

begin
insert_id := nil;
if nid <> '    ' then
begin

if (nid [ 1 ] >= '0') and (nid [ 1 ] <= '9' ) then
(* right justify numbers *)
for step := 0 to idlength - 1 do
begin
nid [ alfalength - step ] := nid [ idlength - step ] ;
nid [ idlength - step ] := ' ' ;
end; (* right justify *)
hashconv.al:=nid;
h:=abs(hashconv.int) mod hashsize;
(*THE 3 MOST SIGNIFICANT CHARACTERS ARE USED AS AN INTEGER*)
found:=false;
d:=1;
repeat
with hash_table [ h ] do
begin

if id = nid then
if (startofcurrent <> nil) and (restofname <> nil) then
found := startofcurrent^.namepart = restofname^.namepart
else
found := (startofcurrent = nil) and (restofname = nil) ;
if found then
begin  (*ALL OK*)
if startofcurrent <> nil then dispose( startofcurrent );
case what of
identifier : begin
new(occurrence);
last^.next := occurrence;
occurrence^.where:=pasline;
if blockcount <> 0 then
begin
occurrence^.usekind := otheruse;
if brackcount = 0 then
insert_id := occurrence; (* candidate for change to assign *)
end
else
occurrence^.usekind := declaration;

last := occurrence;
end;
keyword    : begin
hash_table[h].key_occ:=hash_table[h].key_occ+1;
if nid = 'BEGIN       ' then
begin
blockcount := blockcount + 1;
if localline = -1 then localline := 0; (* start of block *)
checkbracket;
end
else
if nid = 'END         ' then
begin
if othercount > 0 then (*record or case match *)
othercount := othercount - 1
else
if blockcount > 0 then
begin (* begin-match *)
checkbracket;
blockcount := blockcount - 1;
if blockcount = 0 then (* end block *)
localline := -1;
end
else writeln(output,'??? error in blockstructure, detected at line:',
pasline:6);
end
else
if (nid = 'THEN ') or (nid = 'ELSE')
or (nid = 'DO ') or ( nid = 'OF')
or (nid = 'UNTIL')  then
checkbracket

else
if nid = 'RECORD      ' then othercount := othercount + 1
else
if nid ='CASE        ' then if blockcount > 0 then (* case-statement *)
othercount := othercount + 1;
end;
end;
end
else
if id = '       ' then
begin  (*MAKE NEW ENTRY*)
found:=true;
id := nid;
restofname := startofcurrent;
what := ide;
case ide of
identifier : begin
new(occurrence);
first := occurrence;

last := occurrence;
occurrence^.where:=pasline;
if blockcount <> 0 then
begin
occurrence ^ . usekind := otheruse;
if brackcount = 0 then
insert_id := occurrence;
end
else
occurrence ^ . usekind := declaration;

end;
keyword    : begin
hash_table[h].key_occ:=0;
end
end;
hash_table[h].following:=top;
top:=h;
end
else
begin  (*COLLISION*)
h:=(h+d) mod hashsize; d:=d+2;
if d=hashsize then
begin  (*TABLE QUASI-FULL*)
if table_full_at_line = -1 then table_full_at_line := pasline;
found:=true; (*WE DO NOT INSERT THE NID*)
if startofcurrent <> nil then dispose ( startofcurrent ) ;
end;
end; (* collision *)

end; (* with hashtable [ h ]  *)

until found;
end;
nid:='          ';
idlength:=0;
current_name := nil;
startofcurrent := nil;

end; (*INSERT_ID*)


procedure add_to_id(var newid:alfa; symbol:char);
var old : ^ restname;
begin
if idlength<alfalength then
begin
idlength:=idlength+1;
newid[idlength]:=symbol;
end
else
begin
if idlength mod alfalength = 0 then
begin
(* get a new chunk *)
old := current_name;
new( current_name );
current_name ^ . next := nil;
current_name ^ . namepart := '       ';
if old <> nil then
old ^ . next := current_name
else (* first element after the head *)
startofcurrent := current_name;
end;

current_name ^ . namepart [ (idlength mod alfalength) + 1 ] := symbol;
idlength := idlength + 1;

end;

end;





procedure sort_table;
var i,j,least:integer;
beforei,beforej,beforeleast:-1..hashsize;
nextid:alfa;
begin
i:=top;
beforei:=-1;
while i<hashsize do
begin
nextid:=hash_table[i].id;
least:=i;
beforeleast:=-1; beforej:=i;
j:=hash_table[i].following;
while j<hashsize do
begin
if hash_table[j].id<nextid then
begin
least:=j;
nextid:=hash_table[j].id;
beforeleast:=beforej;
end;
beforej:=j;
j:=hash_table[j].following;
end;
(*CHANGE POINTERS*)
if beforeleast>-1 then
begin
hash_table[beforeleast].following
:=hash_table[least].following;
hash_table[least].following:=i;
if beforei>-1 then
hash_table[beforei].following:=least
else top:=least;
(*WE KEEP THE I*)
beforei:=least;
end
else
begin  (*HASH_TABLE[I] WAS THE LEAST*)
if beforei=-1 then top:=i;
beforei:=i;
i:=hash_table[i].following;
end;

end; (*I<HASHSIZE*)
end;


procedure print_table;
var l,i:integer;
x : ^occ_list;

procedure writealfa( alf : alfa );
(* write the parameter with small letters *)
var step : integer;
begin
for step := 1 to alfalength do
if (alf [ step ] >= 'A') and (alf [ step ] <= 'Z') then
write(outputfil, chr( ord( alf [ step ] ) + 32 ) )
else
write(outputfil, alf [ step ]  );
end; (* writealfa *)


begin
i:=top;
linenumber := maxline; (* force a new page *)
while i<hashsize do
begin
(* CLOSE END OF OCC_LIST *)
hash_table[i].last^.next:=nil;
if linenumber > maxline - 3 then
newpage; (* reserve room for at least 2 lines *)
writealfa(hash_table [ i ] . id );
current_name := hash_table [ i ] . restofname;
while current_name <> nil do
with current_name ^ do
begin
writealfa( namepart );
current_name := next;
end;

if hash_table [ i ] . restofname <> nil then
begin
write(outputfil, sp : 65 - 2 * alfalength, 
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<');
write(outputfil, nl, sp : alfalength );
linenumber := linenumber + 1;
end;

l := 0;
x:=hash_table[i].first;
repeat
if l>=15 then
begin
writeln(outputfil);
linenumber:=linenumber+1;
if (linenumber mod maxline)=0 then newpage;
write(outputfil, sp : alfalength );
l:=0;
end;
write(outputfil,(x^.where):5);
case x ^ . usekind of
declaration : write(outputfil, '*');
assign      : write(outputfil, '=');
labeldef    : write(outputfil, ':');
otheruse    : write(outputfil, sp);
end; (* case *)

l:=l+1;
x:=x^.next;
until x=nil;
writeln(outputfil);
linenumber:=linenumber+1;
i:=hash_table[i].following;
end;
i:=keywordtop;
newpage;
while i<hashsize do
begin
if hash_table[i].key_occ>0 then
writeln(outputfil,hash_table[i].id,hash_table[i].key_occ:8);
i:=hash_table[i].following;
end;
end;


(*HOVEDPROGRAM*)
begin
init;
skipend := sp;

repeat
nextsymbol;

if symbol in alfanum then
begin
while symbol in alfanum do
begin
add_to_id( newid, symbol );
nextsymbol;
end;

currentnode := insert_id( newid, identifier);
newid := '    ';
if currentnode <> nil then
begin (* queue the element *)
if lastqueued < maxq then
lastqueued := lastqueued + 1
else 
writeln(output, ' constant maxq too small ');

queue [ lastqueued ] := currentnode;

end (* queue *)

else

if brackcount = 0 then
lastqueued := 0; (* empty the queue *)


end; (* symbol in alfanum *)


case symbol of
' ', ',', '!' : (* no action *) ;

':' : (* mark the queued elements as 'assign'  or 'labeldef' *)
begin
if brackcount = 0 then
begin
for step := 1 to lastqueued do
if queue [ step ] <> nil then
with queue [ step ] ^ do
if infil ^ = '=' then
usekind := assign
else
usekind := labeldef;

(* empty the queue *)
lastqueued := 0;

end; (* if brackcount = 0 *)

end; (* colon *)

'"', "'" : (* skip the string *)
begin
skipend := symbol;

repeat
nextsymbol;
until symbol = skipend;

end; (* string *)

'(', '[', '<' : (* prepare comment or push level *)
begin
skipend := symbol;

if (infil ^ = '*') and (skipend <> '[') then
(* comment *)
begin
nextsymbol;

if skipend = '(' then
skipend1 := ')'
else
skipend1 := '>';

nextsymbol;
repeat
skipend := '*'; (* prepare end-while in case of eof *)
while symbol <> skipend do
nextsymbol;

skipend := skipend1; (* prepare end-repeat in case of eof *)
nextsymbol;
until symbol = skipend;

end (* comment *)

else

if symbol <> '<' then
(* push bracket level *)
brackcount := brackcount + 1
else (* '<' as an operator *)
if brackcount = 0 then
lastqueued := 0; (* mark the queue as otheruse *)

end; (* left bracket *)

')', ']': (* not '>' *)
(* unstack bracket level *)
brackcount := brackcount - 1;

';' : (* syntax check and recovery *)
(* if not declaration part then brackcount must be  0 *)
begin
checkbracket;
lastqueued := 0; (* empty the queue, the elements are marked as otheruse *)
end;



end (* case *)

otherwise
(* anything else *)
(* empty the queue, the elements are marked as otheruse *)
if brackcount = 0 then
lastqueued := 0;


until eof(infil);


sort_table;
print_table;
if outputfile then close(outputfil);


if table_full_at_line <> -1 then
writeln(output,nl,nl,nl,'***** warning: hash table overflow at line: '
,table_full_at_line :1 );
10:;
end.
«eof»
DataMuseum.dk

RC3500

⟦a35dadda7⟧ TextFileVerbose

Derivation

TextFileVerbose
