|
DataMuseum.dkPresents historical artifacts from the history of: DANOSI |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about DANOSI Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 35840 (0x8c00)
Types: TextFile
Names: »CROSS.ORG«
└─⟦e2123b2a1⟧ Bits:30010498 DVBS1.SW2103.src.1.8-1 Pascal TOOLS JTAS 1989-04-26 LEIF NIELSEN E.d.
└─⟦this⟧ »CROSS.ORG«
MODULE cross;\r
\r
$include(pscplm.ext)\r
$include(pscudi.ext)\r
$include(rtp86rmx.ext)\r
\r
PROGRAM cross;\r
(* version 84.08.22 *)\r
LABEL\r
9999; (* exit point *)\r
\r
CONST\r
test_output= false;\r
hashsize= 2039; (* 85 04 23 changed from 1373 *)\r
(* 88 08 05 changed from 1579 *)\r
default_maxline= 46;\r
default_max_columns= 15;\r
default_no_of_keywords= 48;\r
maxq= 35; (* maximum number of queued names *)\r
sp= ' ';\r
ff= 12;\r
space= 32;\r
blank= ' ';\r
alfalength= 12;\r
\r
TYPE\r
alfa= PACKED ARRAY [1..alfalength] OF char;\r
usestate= ( declaration, assign, labeldef, otheruse );\r
options= (dummy_opt, title_option, keywords_, nokeywords,\r
include_, noinclude, head_option, nohead_option, error_);\r
whats= (keyword, identifier);\r
hashindex= 0..hashsize;\r
\r
occptr= ^ occ_list;\r
prestname= ^restname;\r
\r
occ_list= PACKED RECORD\r
where: word;\r
usekind: usestate;\r
next: occptr\r
END;\r
\r
\r
restname= RECORD\r
next: prestname;\r
namepart: alfa;\r
END;\r
\r
hashrec= PACKED RECORD\r
id: alfa;\r
restofname: prestname;\r
following: hashindex;\r
CASE what: whats OF\r
identifier: (first, last: occptr);\r
keyword: (key_occ: integer);\r
END;\r
\r
hashc = RECORD\r
CASE con:integer OF\r
1: (int: integer);\r
2: (al : alfa)\r
END;\r
\r
VAR\r
option_text: ARRAY [options] OF alfa;\r
prio: byte;\r
exc: word;\r
\r
skipend, (* if eof infil then nextsymbol:= skipend *)\r
skipend1,\r
symbol: char;\r
table_full_at_line,\r
step, (* temporary variable used in for-statements *)\r
brackcount, (* counting number of unsatisfied left brackets *)\r
blockcount, (* begin-counter *)\r
othercount, (* record and case-statement counter *)\r
pasline, (* pascal line number *)\r
pagenumber,\r
linenumber: integer; (* number of lines on this page *)\r
current_date,\r
current_time,\r
title , (* input file name used as default heading on outputfil *)\r
newid: alfa;\r
\r
\r
currentnode,\r
occurrence: occptr;\r
hashconv: hashc;\r
top: hashindex;\r
keywordtop: hashindex;\r
\r
hash_table: ARRAY[hashindex] OF hashrec;\r
\r
inside_inclusion, (*if true then read from includefile *)\r
inclusion, (* option include/exclude externals *)\r
header, (* option header/noheader, if header then add printerheader *)\r
outputfile,\r
before_program,\r
endline: boolean;\r
opmess, (* opened to:co: for messages *)\r
outputfil, (* result file *)\r
include_file, (* file with externals or text to be incorporated during compilation *) \r
infil: text; (* input file to be cross referenced *)\r
incl_path: string;\r
incl_path_alfa, outpfile, inpfile: path_alfa;\r
\r
idlength: integer;\r
\r
current_name, (* current chunk *)\r
startofcurrent: prestname; (* start of current chunk chain *)\r
\r
alfanum: SET OF char;\r
\r
lastqueued: 0..maxq;\r
queue: ARRAY [1..maxq] OF occptr;\r
maxline, max_columns, no_of_keywords: integer;\r
\r
\r
\r
FUNCTION insert_id(nid: alfa; ide: whats): occptr; FORWARD;\r
\r
PROCEDURE error(e_text: alfa);\r
BEGIN\r
writeln(opmess, ' *** CROSS ERROR *** ', e_text);\r
GOTO 9999; (* exit program *)\r
END; (* error *)\r
\r
\r
\r
\r
PROCEDURE read_call_parameters;\r
CONST\r
e_ok = 0;\r
cr= 13;\r
\r
VAR\r
step, step1: integer;\r
d, key: byte;\r
e: word;\r
key_string,\r
inp_path, outp_path: string;\r
\r
PROCEDURE check_argument(d,key: byte;e: word);\r
BEGIN\r
\r
IF test_output THEN\r
writeln(opmess,'delim: ',d,' key: ',key);\r
\r
IF (e<>e_ok) OR\r
((d<>cr) AND (d<>space)) OR\r
(key = ord(error_)) THEN\r
BEGIN\r
writeln(opmess,'key: ',key:3);\r
error('argument err');\r
END;\r
END (*check_argument*);\r
\r
\r
BEGIN (** body of READ_PARAMS **)\r
\r
d:= get_argument(inp_path,key,e);\r
check_argument(d,key,e);\r
\r
(* default title *)\r
title:= blank;\r
IF test_output THEN\r
writeln(opmess, 'input path: ', inp_path.alfa: inp_path.length);\r
step:= inp_path.length;\r
WHILE (inp_path.alfa[step]<>':') AND (inp_path.alfa[step]<>'/') AND (step>1) DO\r
step:= step-1;\r
IF step=1 THEN\r
step:= 0;\r
FOR step1:= 1 TO inp_path.length-step DO\r
IF step1<=alfalength THEN\r
title[step1]:= inp_path.alfa[step+step1];\r
\r
IF file_exist(inp_path) THEN\r
BEGIN (* open inp-file *)\r
path_to_alfa(inp_path,inpfile);\r
reset(infil,inpfile);\r
END\r
ELSE\r
BEGIN\r
(* try file with default extension: ind *)\r
change_ext(inp_path, key_string, 'IND ');\r
IF file_exist(key_string) THEN\r
BEGIN (* open inp-file *)\r
path_to_alfa(key_string,inpfile);\r
reset(infil,inpfile);\r
END\r
ELSE\r
BEGIN (* non existent input file, stop program *)\r
writeln(opmess,inp_path.alfa:inp_path.length);\r
error('E$F_N_EXIST ');\r
END;\r
END; (* inp_path not found *)\r
\r
\r
(** set up default-outputfile **)\r
change_ext(inp_path,outp_path,'CRL ');\r
\r
(* open outputfile *)\r
path_to_alfa(outp_path,outpfile);\r
rewrite(outputfil, outpfile);\r
\r
WHILE d = space (*delimiter telling there are more arguments*) DO\r
BEGIN\r
d:= get_argument(key_string, key, e);\r
check_argument(d, key, e);\r
CASE options(key) OF\r
title_option: BEGIN\r
d:= get_argument(key_string, key, e);\r
check_argument(d, key, e);\r
IF test_output THEN writeln(opmess, 'option: title ',\r
key_string.alfa:key_string.length);\r
title:= blank;\r
IF key_string.length>alfalength THEN\r
key_string.length:= alfalength;\r
FOR step:= 1 TO key_string.length DO\r
title[step]:= key_string.alfa[step];\r
END;\r
\r
keywords_: BEGIN\r
no_of_keywords:= default_no_of_keywords;\r
IF test_output THEN writeln(opmess, 'option: keywords');\r
END;\r
\r
nokeywords: BEGIN\r
no_of_keywords:= 0;\r
IF test_output THEN writeln(opmess, 'option: nokeywords');\r
END;\r
\r
include_,\r
noinclude: inclusion:= options(key)=include_;\r
\r
head_option,\r
nohead_option: header:= options(key)=head_option;\r
\r
OTHERWISE BEGIN\r
writeln(opmess,key_string.alfa:key_string.length);\r
error('ill. option:');\r
END;\r
\r
END; (* case *)\r
\r
END; (*while*)\r
\r
END (* READ_CALLPARAMS *);\r
\r
\r
PROCEDURE init;\r
TYPE\r
string40= PACKED ARRAY [1..40] OF char;\r
\r
VAR\r
opt: options;\r
input_met: boolean;\r
int, int1, sys, sys1, paramno, (* variables for call interpretation *)\r
step, ii, i,j: integer;\r
id, id1: alfa;\r
tail: ARRAY [1..10] OF integer; (* for the entry tail *)\r
keywords: ARRAY[1..default_no_of_keywords] OF alfa;\r
\r
\r
PROCEDURE output_header;\r
CONST\r
lines= 14;\r
VAR\r
step: integer;\r
BEGIN\r
FOR step:= 1 TO lines DO\r
writeln(outputfil, '******************************');\r
FOR step:= 1 TO lines DO\r
writeln(outputfil, ' ': 30, title, ' ', current_date, current_time);\r
FOR step:= 1 TO lines DO\r
writeln(outputfil, '******************************');\r
END; (* output header *)\r
\r
PROCEDURE date_and_time(VAR date_alfa, time_alfa: alfa);\r
CONST\r
e_ok= 0;\r
VAR\r
d_t: coded_time;\r
exc: word;\r
step: integer;\r
BEGIN\r
exc:= e_ok;\r
WITH d_t DO\r
BEGIN\r
WITH system_time DO\r
BEGIN\r
word1:= 0; word2:= 0; (* get date and time *)\r
END; (* with dword *)\r
dqdecodetime(d_t, exc);\r
IF exc<>e_ok THEN error('dqdecodetime');\r
writeln(opmess, ' RC 3900 CROSS REFERENCE PROGRAM ');\r
write(opmess, 'date: ');\r
FOR step:= 1 TO 8 DO\r
write(opmess, date[step]);\r
write(opmess, ' time: ');\r
FOR step:= 1 TO 8 DO\r
write(opmess, time[step]);\r
writeln(opmess);\r
write(opmess, 'page: 0');\r
\r
date_alfa:= blank; time_alfa:= blank;\r
date_alfa[1]:= date[7]; date_alfa[2]:= date[8]; (* year *)\r
date_alfa[3]:= '.';\r
FOR step:= 4 TO 8 DO\r
date_alfa[step]:= date[step-3];\r
date_alfa[6]:= '.';\r
FOR step:= 1 TO 8 DO\r
time_alfa[step]:= time[step];\r
time_alfa[3]:= '.'; time_alfa[6]:= '.';\r
END; (* with *)\r
END; (* date and time *)\r
\r
\r
BEGIN\r
rewrite(opmess, ':CO:');\r
\r
date_and_time(current_date, current_time); (* get current date and time *)\r
\r
init_argument;\r
option_text[title_option]:= 'TITLE ';\r
option_text[keywords_]:= 'KEYWORDS ';\r
option_text[nokeywords]:= 'NOKEYWORDS ';\r
option_text[include_]:= 'INCLUDE ';\r
option_text[noinclude]:= 'NOINCLUDE ';\r
option_text[head_option]:= 'HEAD ';\r
option_text[nohead_option]:= 'NOHEAD ';\r
\r
FOR opt:= succ(dummy_opt) TO pred(error_) DO\r
j:= insert_key(option_text[opt]);\r
\r
\r
(* initialize global variables *)\r
inside_inclusion:= false;\r
inclusion:= true;\r
header:= true;\r
brackcount:= 0;\r
blockcount:= 0;\r
othercount:= 0;\r
pasline:= 0;\r
pagenumber:= 0;\r
newid:= blank; (* be ready for a new name *)\r
idlength:= 0; (* current name is empty *)\r
current_name:= nil; (* no chunks are in use *)\r
startofcurrent:= nil; (* current chain of chunks is empty *)\r
top:= hashsize; (* hashsize is stopmark for the lists ( one list of keywords \r
and one list of identifiers) *)\r
outputfile:= false;\r
endline:= true;\r
\r
alfanum:= ['a'..'z', 'A'..'Z', '0'..'9', '$', '_'] ;\r
\r
lastqueued:= 0; (* empty queue *)\r
FOR step:= 1 TO maxq DO\r
queue [step]:= nil;\r
\r
currentnode:= nil;\r
\r
table_full_at_line:= -1;\r
no_of_keywords:= default_no_of_keywords;\r
FOR i:= 0 TO hashsize DO\r
hash_table[i].id:= blank;\r
step:= 1;\r
keywords [step]:= 'WITH '; step:= step+1;\r
keywords [step]:= 'WHILE '; step:= step+1;\r
keywords [step]:= 'VAR '; step:= step+1;\r
keywords [step]:= 'UNTIL '; step:= step+1;\r
keywords [step]:= 'TYPE '; step:= step+1;\r
keywords [step]:= 'TO '; step:= step+1;\r
keywords [step]:= 'THEN '; step:= step+1;\r
keywords [step]:= 'SHARED '; step:= step+1;\r
keywords [step]:= 'SET '; step:= step+1;\r
keywords [step]:= 'REPEAT '; step:= step+1;\r
keywords [step]:= 'RECORD '; step:= step+1;\r
keywords [step]:= 'PUBLIC '; step:= step+1;\r
keywords [step]:= 'PROGRAM '; step:= step+1;\r
keywords [step]:= 'PROCEDURE '; step:= step+1;\r
keywords [step]:= 'PRIVATE '; step:= step+1;\r
keywords [step]:= 'PACKED '; step:= step+1;\r
keywords [step]:= 'OTHERWISE '; step:= step+1;\r
keywords [step]:= 'OR '; step:= step+1;\r
keywords [step]:= 'OF '; step:= step+1;\r
keywords [step]:= 'NOT '; step:= step+1;\r
keywords [step]:= 'MODULE '; step:= step+1;\r
keywords [step]:= 'MOD '; step:= step+1;\r
keywords [step]:= 'LOOP '; step:= step+1;\r
keywords [step]:= 'LOCK '; step:= step+1;\r
keywords [step]:= 'LABEL '; step:= step+1;\r
keywords [step]:= 'IN '; step:= step+1;\r
keywords [step]:= 'IF '; step:= step+1;\r
keywords [step]:= 'GOTO '; step:= step+1;\r
keywords [step]:= 'FUNCTION '; step:= step+1;\r
keywords [step]:= 'FORWARD '; step:= step+1;\r
keywords [step]:= 'FOR '; step:= step+1;\r
keywords [step]:= 'FILE '; step:= step+1;\r
keywords [step]:= 'EXTERNAL '; step:= step+1;\r
keywords [step]:= 'EXITLOOP '; step:= step+1;\r
keywords [step]:= 'EXIT '; step:= step+1;\r
keywords [step]:= 'ENDLOOP '; step:= step+1;\r
keywords [step]:= 'END '; step:= step+1;\r
keywords [step]:= 'ELSE '; step:= step+1;\r
keywords [step]:= 'DOWNTO '; step:= step+1;\r
keywords [step]:= 'DO '; step:= step+1;\r
keywords [step]:= 'DIV '; step:= step+1;\r
keywords [step]:= 'CONTINUELOOP'; step:= step+1;\r
keywords [step]:= 'CONST '; step:= step+1;\r
keywords [step]:= 'CASE '; step:= step+1;\r
keywords [step]:= 'BEGIN '; step:= step+1;\r
keywords [step]:= 'AS '; step:= step+1;\r
keywords [step]:= 'ARRAY '; step:= step+1;\r
keywords [step]:= 'AND ';\r
\r
(* default settings *)\r
maxline:= default_maxline;\r
max_columns:= default_max_columns;\r
\r
linenumber:= maxline; (* force newpage at start *)\r
\r
read_call_parameters;\r
\r
before_program:= false; (* do not remove the keywords *)\r
\r
FOR i:= 1 TO no_of_keywords DO\r
currentnode:= insert_id( keywords [i], keyword );\r
keywordtop:= top;\r
top:= hashsize;\r
\r
before_program:= true; (* decide on which keys to remove from now on *)\r
\r
IF header THEN\r
output_header;\r
\r
END;\r
\r
\r
PROCEDURE newpage;\r
BEGIN\r
page(outputfil);\r
pagenumber:= pagenumber+1;\r
write(outputfil, title, sp, current_date, current_time);\r
write(outputfil, 'page':50, pagenumber: 6);\r
writeln(outputfil);\r
writeln(outputfil);\r
linenumber:= 0;\r
write(opmess, chr(8), chr(8), chr(8), pagenumber:3);\r
END;\r
\r
\r
PROCEDURE checkbracket;\r
(* check: (brackcount=0) and (blockcount>0 ) *)\r
BEGIN\r
IF (blockcount>0) AND (brackcount<>0) THEN\r
BEGIN\r
writeln(opmess,'??? error in bracket structure, detected at line: ',\r
pasline: 6 );\r
brackcount:= 0; (* recover *)\r
END;\r
END; (* check bracket *)\r
\r
\r
\r
FUNCTION lookahead: char;\r
(* return next character of current input file, without reading *)\r
BEGIN\r
IF inside_inclusion THEN\r
lookahead:= include_file^\r
ELSE\r
lookahead:= infil^;\r
END;\r
\r
\r
PROCEDURE nextsymbol;\r
(* return next symbol in global variable 'symbol' *)\r
BEGIN\r
IF inside_inclusion THEN\r
BEGIN\r
IF eof(include_file) THEN\r
BEGIN\r
inside_inclusion:= false;\r
writeln(opmess); (* indicate end of include *)\r
write(opmess, 'page: ', pagenumber:3);\r
\r
symbol:= sp; (* dummy *)\r
END\r
ELSE\r
read(include_file, symbol);\r
END (* inside inclusion *)\r
ELSE (* normal reading *)\r
BEGIN\r
IF endline THEN\r
BEGIN\r
IF linenumber=maxline THEN newpage;\r
linenumber:= linenumber+1;\r
pasline:= pasline+1;\r
write(outputfil,pasline:5);\r
END;\r
IF eoln(infil) THEN\r
BEGIN\r
IF (infil^=chr(ff)) THEN \r
BEGIN\r
linenumber:= maxline; (* force newpage at next nl *)\r
endline:= false;\r
END\r
ELSE\r
BEGIN\r
endline:= true;\r
writeln(outputfil);\r
END;\r
\r
END\r
ELSE endline:= false;\r
(* LINENUMBER IS INCREMENTED JUST BEFORE READING THE\r
FIRST CHARACTER ON THE NEW LINE *)\r
IF eof(infil) THEN\r
symbol:= skipend\r
ELSE\r
read(infil, symbol);\r
\r
IF NOT endline AND (symbol>=' ') THEN write(outputfil,symbol);\r
END; (* normal input *)\r
\r
IF (symbol>='a') AND (symbol<='z') THEN\r
symbol:= chr(ord(symbol)-ord('a')+ord('A'));\r
END;\r
\r
\r
PROCEDURE remove_non_keys( VAR which_kind: alfa );\r
CONST\r
last_non_pascal=5; (* index in table of names to remove *)\r
no_of_non_pascal80=4;\r
VAR\r
d: integer; (* help variable in case of rehash *)\r
h: hashindex;\r
start_delete, end_delete, (* step limits *)\r
step: integer;\r
special_keys: ARRAY [1..9 (* total number of special keys *)] OF alfa;\r
\r
BEGIN\r
before_program:= false;\r
FOR step:= 1 TO 9 DO\r
CASE step OF\r
1: special_keys [step]:= 'AS ';\r
2: special_keys [step]:= 'LOCK ';\r
3: special_keys [step]:= 'PREFIX ';\r
4: special_keys [step]:= 'PROCESS ';\r
5: special_keys [step]:= 'CHANNEL ';\r
\r
(* non rtp keywords *)\r
6: special_keys [step]:= 'FILE ';\r
7: special_keys [step]:= 'VALUE ';\r
8: special_keys [step]:= 'MODULE ';\r
9: special_keys [step]:= 'PROGRAM ';\r
END; (* case *)\r
\r
IF which_kind='PROGRAM ' THEN\r
BEGIN\r
start_delete:= 1;\r
end_delete:= last_non_pascal;\r
END\r
ELSE\r
BEGIN\r
start_delete:= last_non_pascal+1;\r
end_delete:= start_delete+no_of_non_pascal80-1;\r
END;\r
FOR step:= start_delete TO end_delete DO\r
BEGIN\r
hashconv.al:= special_keys [step];\r
h:= abs( hashconv.int ) MOD hashsize; (* the hashfunction !!! *)\r
d:= 1; (* start value of rehash variable *)\r
WHILE hash_table [h].id<>special_keys [step] DO\r
BEGIN\r
(* rehash *)\r
h:= ( h+d ) MOD hashsize; d:= d+2;\r
END;\r
(* replace the name with a non-identifier, i.e. the entry will not be used *)\r
hash_table [h].id:= '------------';\r
END; (* for ... *)\r
END; (* remove non keys *)\r
\r
\r
\r
FUNCTION insert_id (nid: alfa; ide: whats): occptr; (* forward declared *)\r
VAR found:boolean;\r
h:hashindex;\r
step,\r
d:integer;\r
\r
BEGIN\r
insert_id:= nil;\r
IF nid<>blank THEN\r
BEGIN\r
\r
IF (nid [1]>= '0') AND (nid [1]<= '9' ) THEN\r
(* right justify numbers *)\r
FOR step:= 0 TO idlength-1 DO\r
BEGIN\r
nid [alfalength-step]:= nid [idlength-step] ;\r
nid [idlength-step]:= sp;\r
END; (* right justify *)\r
hashconv.al:= nid;\r
h:= abs(hashconv.int) MOD hashsize;\r
(*THE 2 MOST SIGNIFICANT CHARACTERS ARE USED AS AN INTEGER*)\r
found:= false;\r
d:= 1;\r
REPEAT\r
WITH hash_table [h] DO\r
BEGIN\r
\r
IF id=nid THEN\r
IF (startofcurrent<>nil) AND (restofname<>nil) THEN\r
found:= startofcurrent^.namepart=restofname^.namepart\r
ELSE\r
found:= (startofcurrent=nil) AND (restofname=nil) ;\r
IF found THEN\r
BEGIN (*ALL OK*)\r
IF startofcurrent<>nil THEN dispose( startofcurrent );\r
CASE what OF\r
identifier: BEGIN\r
new(occurrence);\r
last^.next:= occurrence;\r
occurrence^.where:= pasline;\r
IF blockcount<>0 THEN\r
BEGIN\r
occurrence^.usekind:= otheruse;\r
IF brackcount=0 THEN\r
insert_id:= occurrence; (* candidate for change to assign *)\r
END\r
ELSE\r
occurrence^.usekind:= declaration;\r
\r
last:= occurrence;\r
END;\r
keyword : BEGIN\r
\r
hash_table[h].key_occ:= hash_table[h].key_occ+1;\r
IF nid='BEGIN ' THEN\r
BEGIN\r
blockcount:= blockcount+1;\r
checkbracket;\r
END\r
ELSE\r
IF nid='END ' THEN\r
BEGIN\r
IF othercount>0 THEN (*record or case match *)\r
othercount:= othercount-1\r
ELSE\r
IF blockcount>0 THEN\r
BEGIN (* begin-match *)\r
checkbracket;\r
blockcount:= blockcount-1;\r
END\r
ELSE writeln(opmess,'??? error in blockstructure, detected at line:',\r
pasline:6);\r
END\r
ELSE\r
IF (nid='THEN ') OR (nid='ELSE ')\r
OR (nid='DO ') OR (nid='OF ')\r
OR (nid='UNTIL ') THEN\r
checkbracket\r
\r
ELSE\r
IF (nid='RECORD ') THEN\r
othercount:= othercount+1\r
ELSE\r
IF nid ='CASE ' THEN\r
IF blockcount>0 THEN (* case-statement *)\r
othercount:= othercount+1;\r
END;\r
END;\r
END\r
ELSE\r
IF id=blank THEN\r
BEGIN (*MAKE NEW ENTRY*)\r
IF test_output THEN\r
IF d>1 THEN writeln(opmess, nid, d, ' collision');\r
\r
found:= true;\r
id:= nid;\r
restofname:= startofcurrent;\r
what:= ide;\r
CASE ide OF\r
identifier: BEGIN\r
new(occurrence);\r
first:= occurrence;\r
\r
last:= occurrence;\r
occurrence^.where:= pasline;\r
IF blockcount<>0 THEN\r
BEGIN\r
occurrence^.usekind:= otheruse;\r
IF brackcount=0 THEN\r
insert_id:= occurrence;\r
END\r
ELSE\r
occurrence^.usekind:= declaration;\r
\r
END;\r
keyword : BEGIN\r
hash_table[h].key_occ:= 0;\r
END\r
END;\r
hash_table[h].following:= top;\r
top:= h;\r
END\r
ELSE\r
BEGIN (*COLLISION*)\r
h:= (h+d) MOD hashsize; d:= d+2;\r
IF d=hashsize THEN\r
BEGIN (*TABLE QUASI-FULL*)\r
IF table_full_at_line=-1 THEN table_full_at_line:= pasline;\r
found:= true; (*WE DO NOT INSERT THE NID*)\r
IF startofcurrent<>nil THEN dispose ( startofcurrent ) ;\r
END;\r
END; (* collision *)\r
\r
END; (* with hashtable [h] *)\r
\r
UNTIL found;\r
END;\r
nid:= blank;\r
idlength:= 0;\r
current_name:= nil;\r
startofcurrent:= nil;\r
\r
END; (*INSERT_ID*)\r
\r
\r
PROCEDURE add_to_id(VAR newid:alfa; symbol:char);\r
VAR old: prestname;\r
BEGIN\r
IF idlength<alfalength THEN\r
BEGIN\r
idlength:= idlength+1;\r
newid[idlength]:= symbol;\r
END\r
ELSE\r
BEGIN\r
IF idlength MOD alfalength=0 THEN\r
BEGIN\r
(* get a new chunk *)\r
old:= current_name;\r
new( current_name );\r
current_name^.next:= nil;\r
current_name^.namepart:= blank;\r
IF old<>nil THEN\r
old^.next:= current_name\r
ELSE (* first element after the head *)\r
startofcurrent:= current_name;\r
END;\r
\r
current_name^.namepart [(idlength MOD alfalength)+1]:= symbol;\r
idlength:= idlength+1;\r
\r
END;\r
\r
END;\r
\r
\r
\r
\r
\r
PROCEDURE sort_table;\r
VAR i,j,least:integer;\r
beforei,beforej,beforeleast:-1..hashsize;\r
nextid:alfa;\r
BEGIN\r
i:= top;\r
beforei:= -1;\r
WHILE i<hashsize DO\r
BEGIN\r
nextid:= hash_table[i].id;\r
least:= i;\r
beforeleast:= -1; beforej:= i;\r
j:= hash_table[i].following;\r
WHILE j<hashsize DO\r
BEGIN\r
IF hash_table[j].id<nextid THEN\r
BEGIN\r
least:= j;\r
nextid:= hash_table[j].id;\r
beforeleast:= beforej;\r
END;\r
beforej:= j;\r
j:= hash_table[j].following;\r
END;\r
(*CHANGE POINTERS*)\r
IF beforeleast>-1 THEN\r
BEGIN\r
hash_table[beforeleast].following\r
:= hash_table[least].following;\r
hash_table[least].following:= i;\r
IF beforei>-1 THEN\r
hash_table[beforei].following:= least\r
ELSE top:= least;\r
(*WE KEEP THE I*)\r
beforei:= least;\r
END\r
ELSE\r
BEGIN (*HASH_TABLE[I] WAS THE LEAST*)\r
IF beforei=-1 THEN top:= i;\r
beforei:= i;\r
i:= hash_table[i].following;\r
END;\r
\r
END; (*I<HASHSIZE*)\r
END;\r
\r
\r
PROCEDURE print_table;\r
VAR l,i:integer;\r
length_of_name: integer; (* number of alfas in a name *)\r
x: occptr;\r
\r
PROCEDURE writealfa( alf: alfa );\r
(* write the parameter with small letters *)\r
VAR step: integer;\r
BEGIN\r
FOR step:= 1 TO alfalength DO\r
IF (alf [step]>= 'A') AND (alf [step]<= 'Z') THEN\r
write(outputfil, chr( ord( alf [step] )+32 ) )\r
ELSE\r
write(outputfil, alf [step] );\r
END; (* writealfa *)\r
\r
\r
BEGIN\r
i:= top;\r
linenumber:= maxline; (* force a new page *)\r
WHILE i<hashsize DO\r
BEGIN\r
(* CLOSE END OF OCC_LIST *)\r
hash_table[i].last^.next:= nil;\r
IF linenumber>maxline-3 THEN\r
newpage; (* reserve room for at least 2 lines *)\r
length_of_name:= 1; (* at least one alfa *)\r
writealfa(hash_table [i].id );\r
current_name:= hash_table [i].restofname;\r
WHILE current_name<>nil DO\r
WITH current_name^ DO\r
BEGIN\r
length_of_name:= length_of_name+1;\r
writealfa( namepart );\r
current_name:= next;\r
END;\r
\r
IF hash_table [i].restofname<>nil THEN\r
BEGIN\r
write(outputfil, cr, lf, sp: alfalength );\r
linenumber:= linenumber+1;\r
END;\r
\r
l:= 0;\r
x:= hash_table[i].first;\r
REPEAT\r
IF l=max_columns THEN\r
BEGIN\r
writeln(outputfil);\r
linenumber:= linenumber+1;\r
IF (linenumber MOD maxline)=0 THEN newpage;\r
write(outputfil, sp: alfalength );\r
l:= 0;\r
END;\r
write(outputfil,(x^.where):5);\r
CASE x^.usekind OF\r
declaration: write(outputfil, '*');\r
assign : write(outputfil, '=');\r
labeldef : write(outputfil, ':');\r
otheruse : write(outputfil, sp);\r
END; (* case *)\r
\r
l:= l+1;\r
x:= x^.next;\r
UNTIL x=nil;\r
writeln(outputfil);\r
linenumber:= linenumber+1;\r
i:= hash_table[i].following;\r
END;\r
\r
IF no_of_keywords<>0 THEN\r
BEGIN\r
i:= keywordtop;\r
newpage;\r
WHILE i<hashsize DO\r
BEGIN\r
IF hash_table[i].key_occ>0 THEN\r
writeln(outputfil,hash_table[i].id,hash_table[i].key_occ:8);\r
i:= hash_table[i].following;\r
END;\r
END; (* key word table *)\r
END;\r
\r
\r
(*HOVEDPROGRAM*)\r
BEGIN\r
init;\r
skipend:= sp;\r
\r
REPEAT\r
nextsymbol;\r
\r
IF symbol IN alfanum THEN\r
BEGIN\r
IF symbol='$' THEN\r
BEGIN (* skip possible spaces between leading '$' and option name *)\r
add_to_id(newid, symbol);\r
REPEAT\r
nextsymbol;\r
UNTIL symbol<>sp;\r
END;\r
\r
WHILE symbol IN alfanum DO\r
BEGIN\r
add_to_id( newid, symbol );\r
nextsymbol;\r
END;\r
\r
IF (newid='$INCLUDE ') AND inclusion AND NOT inside_inclusion THEN\r
BEGIN\r
incl_path.length:= 0;\r
WHILE symbol<>'(' DO\r
nextsymbol;\r
nextsymbol;\r
WITH incl_path DO\r
WHILE symbol<>')' DO\r
BEGIN (* pick up name of file to be included *)\r
IF symbol<>sp THEN\r
BEGIN\r
length:= length+1;\r
alfa[length]:= symbol;\r
END;\r
nextsymbol;\r
END; (* while *)\r
IF file_exist(incl_path) THEN\r
BEGIN (* start of alternative input file *)\r
WITH incl_path DO\r
IF alfa[1]=':' THEN\r
IF (alfa[2]<>'S') OR (alfa[3]<>'D') THEN\r
BEGIN\r
FOR step:= length DOWNTO 2 DO\r
alfa[step+3]:= alfa[step];\r
length:= length+3;\r
alfa[2]:= 'S'; alfa[3]:= 'D'; alfa[4]:= ':';\r
step:= 5;\r
WHILE alfa[step]<>':' DO step:= step+1;\r
alfa[step]:='/';\r
END; (* insert:SD: *)\r
\r
path_to_alfa(incl_path, incl_path_alfa);\r
writeln(opmess);\r
write(opmess, '$include(', incl_path.alfa: incl_path.length, ')');\r
reset(include_file, incl_path_alfa);\r
inside_inclusion:= true;\r
END (* file exist *)\r
ELSE\r
WITH incl_path DO\r
writeln(opmess, 'include(', alfa: length, ') not possible');\r
\r
symbol:= sp;\r
END; (* $include met *)\r
\r
currentnode:= insert_id( newid, identifier);\r
newid:= blank;\r
IF currentnode<>nil THEN\r
BEGIN (* queue the element *)\r
IF lastqueued<maxq THEN\r
lastqueued:= lastqueued+1\r
ELSE \r
writeln(opmess, ' constant maxq too small ');\r
\r
queue [lastqueued]:= currentnode;\r
\r
END (* queue *)\r
\r
ELSE\r
\r
IF brackcount=0 THEN\r
lastqueued:= 0; (* empty the queue *)\r
\r
\r
END; (* symbol in alfanum *)\r
\r
\r
CASE symbol OF\r
sp, ',', '!': (* no action *) ;\r
\r
':': (* mark the queued elements as 'assign' or 'labeldef' *)\r
BEGIN\r
IF brackcount=0 THEN\r
BEGIN\r
FOR step:= 1 TO lastqueued DO\r
IF queue [step]<>nil THEN\r
WITH queue [step]^ DO\r
IF lookahead='=' THEN\r
usekind:= assign\r
ELSE\r
usekind:= labeldef;\r
\r
(* empty the queue *)\r
lastqueued:= 0;\r
\r
END; (* if brackcount=0 *)\r
\r
END; (* colon *)\r
\r
'"', '''': (* skip the string *)\r
BEGIN\r
skipend:= symbol;\r
\r
REPEAT\r
nextsymbol;\r
UNTIL symbol=skipend;\r
\r
END; (* string *)\r
\r
'(', '[', '<': (* prepare comment or push level *)\r
BEGIN\r
skipend:= symbol;\r
\r
IF (lookahead='*') AND (skipend<>'[') THEN\r
(* comment *)\r
BEGIN\r
nextsymbol;\r
\r
IF skipend='(' THEN\r
skipend1:= ')'\r
ELSE\r
skipend1:= '>';\r
\r
nextsymbol;\r
REPEAT\r
skipend:= '*'; (* prepare end-while in case of eof *)\r
WHILE symbol<>skipend DO\r
nextsymbol;\r
\r
skipend:= skipend1; (* prepare end-repeat in case of eof *)\r
nextsymbol;\r
UNTIL symbol=skipend;\r
\r
END (* comment *)\r
\r
ELSE\r
\r
IF symbol<>'<' THEN\r
(* push bracket level *)\r
brackcount:= brackcount+1\r
ELSE (* '<' as an operator *)\r
IF brackcount=0 THEN\r
lastqueued:= 0; (* mark the queue as otheruse *)\r
\r
END; (* left bracket *)\r
\r
')', ']': (* not '>' *)\r
(* unstack bracket level *)\r
brackcount:= brackcount-1;\r
\r
';': (* syntax check and recovery *)\r
(* if not declaration part then brackcount must be 0 *)\r
BEGIN\r
checkbracket;\r
lastqueued:= 0; (* empty the queue, the elements are marked as otheruse *)\r
END;\r
\r
OTHERWISE\r
(* anything else *)\r
(* empty the queue, the elements are marked as otheruse *)\r
IF brackcount=0 THEN\r
lastqueued:= 0;\r
END; (* case *)\r
\r
UNTIL eof(infil);\r
\r
\r
sort_table;\r
print_table;\r
\r
9999: (* exit label *)\r
\r
writeln(opmess);\r
IF table_full_at_line<>-1 THEN\r
writeln(opmess,cr,lf,lf,lf,'***** warning: hash table overflow at line: '\r
,table_full_at_line:1 );\r
END.\r
«eof»