|
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: 53560 (0xd138)
Types: TextFile
Names: »CROSS.PAS«
└─⟦e2123b2a1⟧ Bits:30010498 DVBS1.SW2103.src.1.8-1 Pascal TOOLS JTAS 1989-04-26 LEIF NIELSEN E.d.
└─⟦this⟧ »CROSS.PAS«
{[A = 20, I = 2, L = 4, E = 3, W = 1-100] PASCFORM directive }\r
PROGRAM CROSS;\r
(* Originaly CROSS was a RC8000 Pascal program made by RegneCentralen.\r
Changed to INTEL Pascal by RC (version 84-08-22) *)\r
(*--------------------------------------------------------------------------\r
Date. Init. Vers. Explanation.\r
1989-01-25 LEI 1.1 Changed to Turbo Pascal 5.0 by Leif Nielsen JTAS\r
--------------------------------------------------------------------------*)\r
\r
{$R+,S+ }\r
{$M 16000, 0, 655360 }\r
\r
USES\r
Dos,\r
DosUtil,\r
Help,\r
Param;\r
\r
CONST\r
version: STRING = ('1.1');\r
default_maxline = 46;\r
default_max_columns = 15;\r
\r
MaxParam = 2;\r
MaxOption = 8;\r
\r
ParamList : ARRAY [1..MaxParam] OF ParamRec =\r
((Kind:KnownFile; Defined:FALSE; KeyWord:'I'; NumVal:0; TextVal:'.IND'),\r
(Kind:FileType; Defined:FALSE; KeyWord:'O'; NumVal:0; TextVal:''));\r
\r
OptionList : ARRAY [1..MaxOption] OF ParamRec =\r
((Kind:OnOff; Defined:FALSE;KeyWord:'INCLUDE'; NumVal:0; TextVal:'ON'), (*include*)\r
(Kind:OnOff; Defined:FALSE;KeyWord:'KEYWORDS'; NumVal:0; TextVal:'ON'),(*Keyword list*)\r
(Kind:OnOff; Defined:FALSE;KeyWord:'HEADDER'; NumVal:0; TextVal:'ON'), (*Header*)\r
(Kind:TextType; Defined:FALSE;KeyWord:'TITLE'; NumVal:0; TextVal:'' ), (*title*)\r
(Kind:Numeric; Defined:FALSE;KeyWord:'PAGELGT'; NumVal:Default_maxline; TextVal:''), (*Page*)\r
(Kind:Numeric; Defined:FALSE;KeyWord:'COLUMNS'; NumVal:default_max_columns; TextVal:''), (*columns*)\r
(Kind:OnOff; Defined:FALSE;KeyWord:'XRAY'; NumVal:0; TextVal:'OFF'), (*test*)\r
(Kind:TextType; Defined:FALSE;KeyWord:'PASCAL'; NumVal:0; TextVal:'TURBO') ); (*pascal type*)\r
\r
\r
hashsize = 2039; (* 85 04 23 changed from 1373 *)\r
(* 88 08 05 changed from 1579 *)\r
maxq = 35; (* maximum number of queued names *)\r
sp = ' ';\r
FF = 12;\r
space = 32;\r
blank = ' ';\r
alfalength = 12;\r
max_read_line = 240;\r
File_buff_size = 1024;\r
\r
TYPE\r
alfa = STRING[alfalength];\r
usestate = ( declaration, assignem, labeldef, otheruse );\r
language_type = ( Not_implemented, Turbo_pascal, Pascal_86,\r
Common_rtp, rtp_8000, rtp_286 );\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
Hash_table_type = RECORD\r
Hash_table: ARRAY [hashindex] OF hashrec;\r
END;\r
\r
Hash_ptr_type = ^ Hash_table_type;\r
\r
VAR\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_ptr: Hash_ptr_type;\r
\r
language: language_type;\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: boolean;\r
\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
I_buff, IC_buff, O_buff: ARRAY [1..File_buff_size] OF byte;\r
incl_path: STRING;\r
incl_path_alfa, outpfile, inpfile: STRING;\r
Test_requested: boolean;\r
\r
line, incl_line, tmp_line: STRING[max_read_line];\r
line_pos, incl_line_pos, line_lgth, incl_line_lgth: integer;\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
InitialFree: longint; { Heap storage available }\r
\r
\r
FUNCTION insert_id(nid: alfa; ide: whats): occptr; FORWARD;\r
\r
PROCEDURE add_to_id(VAR newid:alfa; symbol:char); FORWARD;\r
\r
\r
PROCEDURE error(e_text: alfa);\r
BEGIN\r
writeln(Output, ' *** CROSS ERROR *** ', e_text);\r
Halt; (* exit program *)\r
END; (* error *)\r
\r
\r
PROCEDURE insert_Keyw(nid: STRING);\r
VAR\r
keyw: alfa;\r
i: integer;\r
BEGIN\r
i := 1;\r
keyw := blank;\r
\r
WHILE ( i <= length(nid) ) AND ( nid[i] <> sp )DO\r
BEGIN\r
add_to_id( keyw, nid[i]);\r
i := i + 1;\r
END;\r
\r
currentnode := insert_id( keyw, keyword );\r
END;\r
\r
PROCEDURE init_turbo_pascal;\r
CONST\r
num_keyw = 48;\r
\r
TYPE\r
key_tab_type = ARRAY [ 1..num_keyw ] OF STRING[20];\r
\r
VAR\r
i: integer;\r
key_tab: key_tab_type;\r
\r
BEGIN\r
i := 1;\r
key_tab[i] := 'ABSOLUTE '; i := i + 1;\r
key_tab[i] := 'AND '; i := i + 1;\r
key_tab[i] := 'ARRAY '; i := i + 1;\r
key_tab[i] := 'BEGIN '; i := i + 1;\r
key_tab[i] := 'CASE '; i := i + 1;\r
key_tab[i] := 'CONST '; i := i + 1;\r
key_tab[i] := 'DIV '; i := i + 1;\r
key_tab[i] := 'DO '; i := i + 1;\r
key_tab[i] := 'DOWNTO '; i := i + 1;\r
key_tab[i] := 'ELSE '; i := i + 1;\r
key_tab[i] := 'END '; i := i + 1;\r
key_tab[i] := 'EXTERNAL '; i := i + 1;\r
key_tab[i] := 'FILE '; i := i + 1;\r
key_tab[i] := 'FOR '; i := i + 1;\r
key_tab[i] := 'FORWARD '; i := i + 1;\r
key_tab[i] := 'FUNCTION '; i := i + 1;\r
key_tab[i] := 'GOTO '; i := i + 1;\r
key_tab[i] := 'IF '; i := i + 1;\r
key_tab[i] := 'IMPLEMENTATION'; i := i + 1;\r
key_tab[i] := 'IN '; i := i + 1;\r
key_tab[i] := 'INLINE '; i := i + 1;\r
key_tab[i] := 'INTERFACE'; i := i + 1;\r
key_tab[i] := 'INTERRUPT'; i := i + 1;\r
key_tab[i] := 'LABEL '; i := i + 1;\r
key_tab[i] := 'MOD '; i := i + 1;\r
key_tab[i] := 'NIL '; i := i + 1;\r
key_tab[i] := 'NOT '; i := i + 1;\r
key_tab[i] := 'OF '; i := i + 1;\r
key_tab[i] := 'OR '; i := i + 1;\r
key_tab[i] := 'PACKED '; i := i + 1;\r
key_tab[i] := 'PROCEDURE'; i := i + 1;\r
key_tab[i] := 'PROGRAM '; i := i + 1;\r
key_tab[i] := 'RECORD '; i := i + 1;\r
key_tab[i] := 'REPEAT '; i := i + 1;\r
key_tab[i] := 'SET '; i := i + 1;\r
key_tab[i] := 'SHL '; i := i + 1;\r
key_tab[i] := 'SHR '; i := i + 1;\r
key_tab[i] := 'STRING '; i := i + 1;\r
key_tab[i] := 'THEN '; i := i + 1;\r
key_tab[i] := 'TO '; i := i + 1;\r
key_tab[i] := 'TYPE '; i := i + 1;\r
key_tab[i] := 'UNIT '; i := i + 1;\r
key_tab[i] := 'UNTIL '; i := i + 1;\r
key_tab[i] := 'USES '; i := i + 1;\r
key_tab[i] := 'VAR '; i := i + 1;\r
key_tab[i] := 'WHILE '; i := i + 1;\r
key_tab[i] := 'WITH '; i := i + 1;\r
key_tab[i] := 'XOR '; i := i + 1;\r
\r
FOR i := num_keyw DOWNTO 1 DO\r
insert_keyw( key_tab[i] );\r
\r
keywordtop := top;\r
top := hashsize;\r
\r
language := Turbo_Pascal;\r
END;\r
\r
PROCEDURE init_Pascal_86;\r
CONST\r
num_keyw = 40;\r
\r
TYPE\r
key_tab_type = ARRAY [ 1..num_keyw ] OF STRING[20];\r
\r
VAR\r
i: integer;\r
key_tab: key_tab_type;\r
\r
BEGIN\r
i := 1;\r
key_tab[i] := 'AND '; i := i + 1;\r
key_tab[i] := 'ARRAY '; i := i + 1;\r
key_tab[i] := 'BEGIN '; i := i + 1;\r
key_tab[i] := 'CASE '; i := i + 1;\r
key_tab[i] := 'CONST '; i := i + 1;\r
key_tab[i] := 'DIV '; i := i + 1;\r
key_tab[i] := 'DO '; i := i + 1;\r
key_tab[i] := 'DOWNTO '; i := i + 1;\r
key_tab[i] := 'ELSE '; i := i + 1;\r
key_tab[i] := 'END '; i := i + 1;\r
key_tab[i] := 'EXTERNAL '; i := i + 1;\r
key_tab[i] := 'FILE '; i := i + 1;\r
key_tab[i] := 'FOR '; i := i + 1;\r
key_tab[i] := 'FORWARD '; i := i + 1;\r
key_tab[i] := 'FUNCTION '; i := i + 1;\r
key_tab[i] := 'GOTO '; i := i + 1;\r
key_tab[i] := 'IF '; i := i + 1;\r
key_tab[i] := 'IN '; i := i + 1;\r
key_tab[i] := 'LABEL '; i := i + 1;\r
key_tab[i] := 'MOD '; i := i + 1;\r
key_tab[i] := 'NIL '; i := i + 1;\r
key_tab[i] := 'NOT '; i := i + 1;\r
key_tab[i] := 'OF '; i := i + 1;\r
key_tab[i] := 'OR '; i := i + 1;\r
key_tab[i] := 'OTHERWISE'; i := i + 1;\r
key_tab[i] := 'PACKED '; i := i + 1;\r
key_tab[i] := 'PRIVATE '; i := i + 1;\r
key_tab[i] := 'PROCEDURE'; i := i + 1;\r
key_tab[i] := 'PROGRAM '; i := i + 1;\r
key_tab[i] := 'PUBLIC '; i := i + 1;\r
key_tab[i] := 'RECORD '; i := i + 1;\r
key_tab[i] := 'REPEAT '; i := i + 1;\r
key_tab[i] := 'SET '; i := i + 1;\r
key_tab[i] := 'THEN '; i := i + 1;\r
key_tab[i] := 'TO '; i := i + 1;\r
key_tab[i] := 'TYPE '; i := i + 1;\r
key_tab[i] := 'UNTIL '; i := i + 1;\r
key_tab[i] := 'VAR '; i := i + 1;\r
key_tab[i] := 'WHILE '; i := i + 1;\r
key_tab[i] := 'WITH '; i := i + 1;\r
\r
FOR i := num_keyw DOWNTO 1 DO\r
insert_keyw( key_tab[i] );\r
\r
keywordtop := top;\r
top := hashsize;\r
\r
language := Pascal_86;\r
END;\r
\r
PROCEDURE init_Common_RTP;\r
CONST\r
num_keyw = 51;\r
\r
TYPE\r
key_tab_type = ARRAY [ 1..num_keyw ] OF STRING[20];\r
\r
VAR\r
i: integer;\r
key_tab: key_tab_type;\r
\r
BEGIN\r
i := 1;\r
key_tab[i] := 'AND '; i := i + 1;\r
key_tab[i] := 'ARRAY '; i := i + 1;\r
key_tab[i] := 'AS '; i := i + 1;\r
key_tab[i] := 'BEGIN '; i := i + 1;\r
key_tab[i] := 'CASE '; i := i + 1;\r
key_tab[i] := 'CONST '; i := i + 1;\r
key_tab[i] := 'CONTINUELOOP'; i := i + 1;\r
key_tab[i] := 'DIV '; i := i + 1;\r
key_tab[i] := 'DO '; i := i + 1;\r
key_tab[i] := 'DOWNTO '; i := i + 1;\r
key_tab[i] := 'ELSE '; i := i + 1;\r
key_tab[i] := 'END '; i := i + 1;\r
key_tab[i] := 'ENDLOOP '; i := i + 1;\r
key_tab[i] := 'EXIT '; i := i + 1;\r
key_tab[i] := 'EXITLOOP '; i := i + 1;\r
key_tab[i] := 'EXTERNAL '; i := i + 1;\r
key_tab[i] := 'FOR '; i := i + 1;\r
key_tab[i] := 'FORWARD '; i := i + 1;\r
key_tab[i] := 'FUNCTION '; i := i + 1;\r
key_tab[i] := 'GETSWITCH'; i := i + 1;\r
key_tab[i] := 'GOTO '; i := i + 1;\r
key_tab[i] := 'IF '; i := i + 1;\r
key_tab[i] := 'IN '; i := i + 1;\r
key_tab[i] := 'INSPECT '; i := i + 1;\r
key_tab[i] := 'LOCKBUF '; i := i + 1;\r
key_tab[i] := 'LOCKDATA '; i := i + 1;\r
key_tab[i] := 'LOOP '; i := i + 1;\r
key_tab[i] := 'MOD '; i := i + 1;\r
key_tab[i] := 'NOT '; i := i + 1;\r
key_tab[i] := 'OF '; i := i + 1;\r
key_tab[i] := 'OR '; i := i + 1;\r
key_tab[i] := 'OTHERWISE'; i := i + 1;\r
key_tab[i] := 'PACKED '; i := i + 1;\r
key_tab[i] := 'PROCEDURE'; i := i + 1;\r
key_tab[i] := 'PROGRAM '; i := i + 1;\r
key_tab[i] := 'RECORD '; i := i + 1;\r
key_tab[i] := 'REGION '; i := i + 1;\r
key_tab[i] := 'REPEAT '; i := i + 1;\r
key_tab[i] := 'SET '; i := i + 1;\r
key_tab[i] := 'SHARED '; i := i + 1;\r
key_tab[i] := 'SHIFT '; i := i + 1;\r
key_tab[i] := 'THEN '; i := i + 1;\r
key_tab[i] := 'TO '; i := i + 1;\r
key_tab[i] := 'TYPE '; i := i + 1;\r
key_tab[i] := 'TYPESIZE '; i := i + 1;\r
key_tab[i] := 'UNTIL '; i := i + 1;\r
key_tab[i] := 'VAR '; i := i + 1;\r
key_tab[i] := 'VARSIZE '; i := i + 1;\r
key_tab[i] := 'WHILE '; i := i + 1;\r
key_tab[i] := 'WITH '; i := i + 1;\r
key_tab[i] := 'XOR '; i := i + 1;\r
\r
FOR i := num_keyw DOWNTO 1 DO\r
insert_keyw( key_tab[i] );\r
\r
keywordtop := top;\r
top := hashsize;\r
\r
language := Common_RTP;\r
END;\r
\r
PROCEDURE init_RTP_8000;\r
CONST\r
num_keyw = 50;\r
\r
TYPE\r
key_tab_type = ARRAY [ 1..num_keyw ] OF STRING[20];\r
\r
VAR\r
i: integer;\r
key_tab: key_tab_type;\r
\r
BEGIN\r
i := 1;\r
key_tab[i] := 'AND '; i := i + 1;\r
key_tab[i] := 'ARRAY '; i := i + 1;\r
key_tab[i] := 'AS '; i := i + 1;\r
key_tab[i] := 'BEGIN '; i := i + 1;\r
key_tab[i] := 'BEGINBODY'; i := i + 1;\r
key_tab[i] := 'CASE '; i := i + 1;\r
key_tab[i] := 'CHANNEL '; i := i + 1;\r
key_tab[i] := 'CONST '; i := i + 1;\r
key_tab[i] := 'CONTINUELOOP'; i := i + 1;\r
key_tab[i] := 'DIV '; i := i + 1;\r
key_tab[i] := 'DO '; i := i + 1;\r
key_tab[i] := 'DOWNTO '; i := i + 1;\r
key_tab[i] := 'ELSE '; i := i + 1;\r
key_tab[i] := 'END '; i := i + 1;\r
key_tab[i] := 'ENDLOOP '; i := i + 1;\r
key_tab[i] := 'EXIT '; i := i + 1;\r
key_tab[i] := 'EXITLOOP '; i := i + 1;\r
key_tab[i] := 'EXPORT '; i := i + 1;\r
key_tab[i] := 'EXTERNAL '; i := i + 1;\r
key_tab[i] := 'FOR '; i := i + 1;\r
key_tab[i] := 'FORWARD '; i := i + 1;\r
key_tab[i] := 'FUNCTION '; i := i + 1;\r
key_tab[i] := 'GOTO '; i := i + 1;\r
key_tab[i] := 'IF '; i := i + 1;\r
key_tab[i] := 'IN '; i := i + 1;\r
key_tab[i] := 'INCLUDE '; i := i + 1;\r
key_tab[i] := 'LABEL '; i := i + 1;\r
key_tab[i] := 'LOCK '; i := i + 1;\r
key_tab[i] := 'LOCKMES '; i := i + 1;\r
key_tab[i] := 'LOOP '; i := i + 1;\r
key_tab[i] := 'MOD '; i := i + 1;\r
key_tab[i] := 'NOT '; i := i + 1;\r
key_tab[i] := 'OF '; i := i + 1;\r
key_tab[i] := 'OR '; i := i + 1;\r
key_tab[i] := 'OTHERWISE'; i := i + 1;\r
key_tab[i] := 'PACKED '; i := i + 1;\r
key_tab[i] := 'POOL '; i := i + 1;\r
key_tab[i] := 'PREFIX '; i := i + 1;\r
key_tab[i] := 'PROCEDURE'; i := i + 1;\r
key_tab[i] := 'PROCESS '; i := i + 1;\r
key_tab[i] := 'RECORD '; i := i + 1;\r
key_tab[i] := 'REPEAT '; i := i + 1;\r
key_tab[i] := 'SET '; i := i + 1;\r
key_tab[i] := 'THEN '; i := i + 1;\r
key_tab[i] := 'TO '; i := i + 1;\r
key_tab[i] := 'TYPE '; i := i + 1;\r
key_tab[i] := 'UNTIL '; i := i + 1;\r
key_tab[i] := 'VAR '; i := i + 1;\r
key_tab[i] := 'WHILE '; i := i + 1;\r
key_tab[i] := 'WITH '; i := i + 1;\r
\r
FOR i := num_keyw DOWNTO 1 DO\r
insert_keyw( key_tab[i] );\r
\r
keywordtop := top;\r
top := hashsize;\r
\r
language := RTP_8000;\r
END;\r
\r
PROCEDURE init_RTP_286;\r
CONST\r
num_keyw = 50;\r
\r
TYPE\r
key_tab_type = ARRAY [ 1..num_keyw ] OF STRING[20];\r
\r
VAR\r
i: integer;\r
key_tab: key_tab_type;\r
\r
BEGIN\r
i := 1;\r
key_tab[i] := 'AND '; i := i + 1;\r
key_tab[i] := 'ARRAY '; i := i + 1;\r
key_tab[i] := 'AS '; i := i + 1;\r
key_tab[i] := 'BEGIN '; i := i + 1;\r
key_tab[i] := 'CASE '; i := i + 1;\r
key_tab[i] := 'CONST '; i := i + 1;\r
key_tab[i] := 'CONTINUELOOP'; i := i + 1;\r
key_tab[i] := 'DIV '; i := i + 1;\r
key_tab[i] := 'DO '; i := i + 1;\r
key_tab[i] := 'DOWNTO '; i := i + 1;\r
key_tab[i] := 'ELSE '; i := i + 1;\r
key_tab[i] := 'END '; i := i + 1;\r
key_tab[i] := 'ENDLOOP '; i := i + 1;\r
key_tab[i] := 'EXIT '; i := i + 1;\r
key_tab[i] := 'EXITLOOP '; i := i + 1;\r
key_tab[i] := 'EXTERNAL '; i := i + 1;\r
key_tab[i] := 'FOR '; i := i + 1;\r
key_tab[i] := 'FORWARD '; i := i + 1;\r
key_tab[i] := 'FUNCTION '; i := i + 1;\r
key_tab[i] := 'GOTO '; i := i + 1;\r
key_tab[i] := 'IF '; i := i + 1;\r
key_tab[i] := 'IN '; i := i + 1;\r
key_tab[i] := 'INSPECT '; i := i + 1;\r
key_tab[i] := 'LOCK '; i := i + 1;\r
key_tab[i] := 'LOCKBUF '; i := i + 1;\r
key_tab[i] := 'LOCKDATA '; i := i + 1;\r
key_tab[i] := 'LOCKMES '; i := i + 1;\r
key_tab[i] := 'LOOP '; i := i + 1;\r
key_tab[i] := 'MOD '; i := i + 1;\r
key_tab[i] := 'NOT '; i := i + 1;\r
key_tab[i] := 'OF '; i := i + 1;\r
key_tab[i] := 'OR '; i := i + 1;\r
key_tab[i] := 'OTHERWISE'; i := i + 1;\r
key_tab[i] := 'PACKED '; i := i + 1;\r
key_tab[i] := 'PROCEDURE'; i := i + 1;\r
key_tab[i] := 'PROGRAM '; i := i + 1;\r
key_tab[i] := 'RECORD '; i := i + 1;\r
key_tab[i] := 'REGION '; i := i + 1;\r
key_tab[i] := 'REPEAT '; i := i + 1;\r
key_tab[i] := 'SET '; i := i + 1;\r
key_tab[i] := 'SHARED '; i := i + 1;\r
key_tab[i] := 'SHIFT '; i := i + 1;\r
key_tab[i] := 'THEN '; i := i + 1;\r
key_tab[i] := 'TO '; i := i + 1;\r
key_tab[i] := 'TYPE '; i := i + 1;\r
key_tab[i] := 'UNTIL '; i := i + 1;\r
key_tab[i] := 'VAR '; i := i + 1;\r
key_tab[i] := 'WHILE '; i := i + 1;\r
key_tab[i] := 'WITH '; i := i + 1;\r
key_tab[i] := 'XOR '; i := i + 1;\r
\r
FOR i := num_keyw DOWNTO 1 DO\r
insert_keyw( key_tab[i] );\r
\r
keywordtop := top;\r
top := hashsize;\r
\r
language := RTP_286;\r
END;\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
\r
PROCEDURE date_and_time(VAR date_alfa, time_alfa: alfa);\r
VAR\r
yr, mo, da, da_of_w, hr, mi, sc, sc100: word;\r
\r
FUNCTION strwzero( i: longint; size, base: integer ): STRING;\r
VAR\r
k, l, m, low : longint;\r
temp: STRING[33];\r
CONST\r
digit: ARRAY [ 0..15 ] OF char =\r
( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9',\r
'A', 'B', 'C', 'D', 'E', 'F' );\r
BEGIN\r
temp[0] := chr(size);\r
FOR k := 1 TO size DO\r
temp[k] := '0';\r
\r
k := abs(i);\r
IF i < 0 THEN\r
BEGIN\r
low := 2;\r
temp[1] := '-';\r
END\r
ELSE\r
low := 1;\r
\r
l := size + 1;\r
WHILE ( k <> 0 ) AND ( l > low ) DO\r
BEGIN\r
l := l - 1;\r
temp[l] := digit[ k MOD base ];\r
k := k DIV base;\r
END;\r
IF k <> 0 THEN { overflow }\r
temp[low] := '*';\r
strwzero := temp;\r
END;\r
\r
BEGIN\r
GetDate(yr, mo, da, da_of_w);\r
GetTime(hr, mi, sc, sc100);\r
\r
date_alfa := strwzero(yr, 4, 10) + '-' + strwzero(mo, 2, 10) +\r
'-' + strwzero(da, 2, 10) + ' ';\r
time_alfa := strwzero(hr, 2, 10) + ':' + strwzero(mi, 2, 10) +\r
' ';\r
\r
END; (* date and time *)\r
\r
\r
BEGIN\r
\r
date_and_time(current_date, current_time); (* get current date and time *)\r
\r
\r
(* initialize global variables *)\r
inside_inclusion := false;\r
line_lgth := 0;\r
line_pos := 1;\r
incl_line_lgth := 0;\r
incl_line_pos := 1;\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
Test_requested := false { until parameter options processed };\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
\r
IF MemAvail <= SizeOf( Hash_table_type ) THEN\r
BEGIN\r
Writeln(' Not sufficient Heap storage. CROSS aborted. ');\r
Halt;\r
END\r
ELSE\r
new(hash_ptr); { allocate on heap, to free space in data segment }\r
\r
FOR i := 0 TO hashsize DO\r
Hash_ptr^.hash_table[i].id := blank;\r
\r
(* default settings *)\r
maxline := default_maxline;\r
max_columns := default_max_columns;\r
\r
linenumber := maxline; (* force newpage at start *)\r
\r
END;\r
\r
\r
PROCEDURE read_callparameters;\r
VAR\r
i, k: integer;\r
key_text: STRING;\r
dir_st: DirStr;\r
name_st: NameStr;\r
ext_st: ExtStr;\r
ch: char;\r
\r
PROCEDURE output_header;\r
CONST\r
n_lin = 14;\r
VAR\r
step: integer;\r
BEGIN\r
FOR step := 1 TO n_lin DO\r
writeln(outputfil, '******************************');\r
FOR step := 1 TO n_lin DO\r
writeln(outputfil, ' ': 30, title, ' ', current_date, current_time);\r
FOR step := 1 TO n_lin DO\r
writeln(outputfil, '******************************');\r
END; (* output header *)\r
\r
BEGIN\r
\r
IF ( ParamCount = 0 ) OR\r
( ParamCount >= 1) AND ( ParamStr(1 ) = '?') THEN\r
BEGIN { The user must give at least the input file as parameter }\r
Showhelp;\r
Halt;\r
END;\r
\r
GetParams( Paramlist, MaxParam, OptionList, MaxOption);\r
\r
\r
inclusion := OptionList[1].TextVal = 'ON';\r
\r
\r
IF OptionList[2].TextVal = 'ON' THEN\r
no_of_keywords := 1\r
ELSE\r
no_of_keywords := 0;\r
\r
header := OptionList[3].TextVal = 'ON';\r
\r
maxline := OptionList[5].Numval;\r
linenumber := maxline;\r
\r
max_columns := OptionList[6].NumVal;\r
\r
Test_requested := OptionList[7].TextVal = 'ON';\r
\r
CASE MatchOptionStr( OptionList[8].TextVal, 9,\r
'TURBO PASCAL86 C-RTP RTP8000 RTP286 ') OF\r
\r
-1: Error(' Option not unique ');\r
\r
0: Error(' Option not valid ');\r
\r
1: init_Turbo_pascal;\r
\r
2: init_Pascal_86;\r
\r
3: init_Common_RTP;\r
\r
4: init_RTP_8000;\r
\r
5: init_RTP_286;\r
\r
END (*case *);\r
\r
\r
inpfile := ParamList[1].TextVal;\r
\r
\r
IF ParamList[2].Defined THEN\r
outpfile := ParamList[2].TextVal\r
ELSE\r
BEGIN\r
FSplit(inpfile, dir_st, name_st, ext_st);\r
IF UpperStr(ext_st) = 'CRL' THEN\r
Error(' FileName Clash');\r
outpfile := name_st + '.CRL' { use current drive and directory };\r
END;\r
\r
IF FileExist(outpfile) THEN\r
BEGIN\r
(* query to user*)\r
write(Output, outpfile:1);\r
write(Output, ', already exists, OVERWRITE (Y/N)?');\r
read(Input, ch);\r
IF NOT ((ch = 'y') OR (ch = 'Y')) THEN\r
halt; (*i.e.: exit program*)\r
END;\r
\r
assign(infil, inpfile);\r
SetTextBuf(infil, I_buff);\r
reset(infil);\r
assign(outputfil, outpfile);\r
SetTextBuf(outputfil, O_buff);\r
rewrite(outputfil);\r
assign(Output, '');\r
rewrite(Output);\r
\r
writeln(Output, ' CROSS (v.', Version, ')' );\r
write(Output, ' Date: ', current_date);\r
write(Output, ' Time: ', current_time);\r
write(Output, ' Page: 0');\r
\r
\r
IF Test_requested THEN\r
writeln(Output, 'Input path: ', inpfile:1 );\r
\r
IF OptionList[4].Defined THEN\r
BEGIN\r
IF Test_requested THEN\r
writeln(Output, 'option: title ', OptionList[4].TextVal:1 );\r
title := copy( OptionList[4].TextVal, 1, alfalength);\r
END\r
ELSE\r
BEGIN\r
FSplit(inpfile, dir_st, name_st, ext_st);\r
title := name_st + ext_st;\r
END;\r
\r
IF header THEN\r
output_header;\r
\r
InitialFree := MaxAvail; { Heap storage available now for cross-ref data }\r
\r
END (* READ_CALLPARAMS *);\r
\r
\r
PROCEDURE newpage;\r
BEGIN\r
write(outputfil, chr(FF) );\r
pagenumber := pagenumber+1;\r
write(outputfil, ' CROSS (v.',version, '): ', title:alfalength,\r
' ', current_date, current_time);\r
write(outputfil, 'Page':7, pagenumber: 6);\r
writeln(outputfil);\r
writeln(outputfil);\r
linenumber := 0;\r
write(Output, 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(Output, '??? 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
BEGIN\r
IF incl_line_pos < incl_line_lgth THEN\r
lookahead := incl_line[incl_line_pos+1]\r
ELSE\r
lookahead := sp (*dummy*);\r
END\r
ELSE\r
BEGIN\r
IF line_pos < line_lgth THEN\r
lookahead := line[line_pos+1]\r
ELSE\r
lookahead := sp (*dummy*);\r
END;\r
\r
END;\r
\r
\r
PROCEDURE nextsymbol;\r
(* return next symbol in global variable 'symbol' *)\r
VAR\r
i: integer;\r
\r
BEGIN\r
IF inside_inclusion THEN\r
BEGIN\r
IF ( incl_line_pos >= incl_line_lgth ) AND eof(include_file) THEN\r
BEGIN\r
writeln(Output, ' INCLUDE terminated. '); (* indicate end of include *)\r
write(Output, 'page: ', pagenumber:3);\r
\r
symbol := sp; (* dummy *)\r
\r
inside_inclusion := false;\r
close(include_file);\r
incl_line_pos := 1;\r
incl_line_lgth := 0;\r
\r
END\r
ELSE\r
BEGIN\r
IF incl_line_pos < incl_line_lgth THEN\r
BEGIN\r
incl_line_pos := incl_line_pos + 1;\r
symbol := incl_line[incl_line_pos]\r
END\r
ELSE\r
BEGIN\r
readln(include_file, incl_line);\r
incl_line_lgth := length( incl_line);\r
IF incl_line_lgth = max_read_line THEN\r
BEGIN\r
writeln(Output, 'Warning: too long line found in include file: ',\r
incl_path);\r
\r
incl_line[max_read_line] := ' ';\r
END\r
ELSE\r
BEGIN\r
incl_line := incl_line + ' ';\r
incl_line_lgth := length(incl_line);\r
END;\r
incl_line_pos := 1;\r
symbol := incl_line[incl_line_pos];\r
IF incl_line_lgth = 0 THEN\r
symbol := sp (* dummy *);\r
END;\r
END;\r
END (* inside inclusion *)\r
ELSE (* normal reading *)\r
BEGIN\r
IF line_pos < line_lgth THEN\r
BEGIN\r
line_pos := line_pos + 1;\r
symbol := line[line_pos]\r
END\r
ELSE\r
BEGIN\r
IF eof(infil) THEN\r
BEGIN\r
symbol := skipend;\r
END\r
ELSE\r
BEGIN\r
readln(infil, tmp_line);\r
IF length(tmp_line) = max_read_line THEN\r
BEGIN\r
writeln(Output, 'Warning: too long line found, was truncated.');\r
tmp_line[max_read_line] := ' ';\r
END\r
ELSE\r
tmp_line := tmp_line + ' ';\r
\r
\r
\r
(* LINENUMBER IS INCREMENTED JUST WHEN READING THE\r
FIRST CHARACTER ON THE NEW LINE *)\r
IF Pos(chr(ff), tmp_line) > 0 THEN\r
linenumber := maxline; (* force newpage *)\r
\r
line := '';\r
{ skip non graphich characters }\r
FOR i := 1 TO length(tmp_line) DO\r
IF ord(tmp_line[i]) >= ord(sp) THEN\r
line := line + tmp_line[i];\r
\r
line_lgth := length(line);\r
line_pos := 1;\r
symbol := line[line_pos];\r
IF line_lgth = 0 THEN\r
symbol := sp (* dummy *);\r
IF linenumber >= maxline THEN newpage;\r
linenumber := linenumber+1;\r
pasline := pasline+1;\r
writeln(outputfil, pasline:5, ' ', line);\r
END;\r
END;\r
\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
FUNCTION insert_id (nid: alfa; ide: whats): occptr; (* forward declared *)\r
VAR\r
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_ptr^.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
\r
identifier:\r
BEGIN\r
IF MemAvail <= SizeOf( occ_list ) THEN\r
BEGIN\r
Writeln(' Not sufficient Heap storage. CROSS aborted. ');\r
Halt;\r
END\r
ELSE\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
\r
keyword:\r
BEGIN\r
\r
hash_ptr^.hash_table[h].key_occ := hash_ptr^.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(Output, '??? 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_requested THEN\r
IF d > 1 THEN writeln(Output, nid, d, ' collision');\r
\r
found := true;\r
id := nid;\r
restofname := startofcurrent;\r
what := ide;\r
CASE ide OF\r
\r
identifier:\r
BEGIN\r
IF MemAvail <= SizeOf( occ_list ) THEN\r
BEGIN\r
Writeln(' Not sufficient Heap storage. CROSS aborted. ');\r
Halt;\r
END\r
ELSE\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
\r
keyword:\r
BEGIN\r
hash_ptr^.hash_table[h].key_occ := 0;\r
END\r
END;\r
hash_ptr^.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\r
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
\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
IF MemAvail <= SizeOf( restname ) THEN\r
BEGIN\r
Writeln(' Not sufficient Heap storage. CROSS aborted. ');\r
Halt;\r
END\r
ELSE\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
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_ptr^.hash_table[i].id;\r
least := i;\r
beforeleast := -1; beforej := i;\r
j := hash_ptr^.hash_table[i].following;\r
WHILE j < hashsize DO\r
BEGIN\r
IF hash_ptr^.hash_table[j].id < nextid THEN\r
BEGIN\r
least := j;\r
nextid := hash_ptr^.hash_table[j].id;\r
beforeleast := beforej;\r
END;\r
beforej := j;\r
j := hash_ptr^.hash_table[j].following;\r
END;\r
(*CHANGE POINTERS*)\r
IF beforeleast > -1 THEN\r
BEGIN\r
hash_ptr^.hash_table[beforeleast].following\r
:= hash_ptr^.hash_table[least].following;\r
hash_ptr^.hash_table[least].following := i;\r
IF beforei > -1 THEN\r
hash_ptr^.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_ptr^.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_ptr^.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_ptr^.hash_table[i].id );\r
current_name := hash_ptr^.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_ptr^.hash_table[i].restofname <> NIL THEN\r
BEGIN\r
writeln(outputfil);\r
write(outputfil, ' ');\r
linenumber := linenumber+1;\r
END;\r
\r
l := 0;\r
x := hash_ptr^.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, ' ' );\r
l := 0;\r
END;\r
write(outputfil, (x^.where):5);\r
CASE x^.usekind OF\r
declaration: write(outputfil, '*');\r
assignem : 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_ptr^.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_ptr^.hash_table[i].key_occ > 0 THEN\r
writeln(outputfil, hash_ptr^.hash_table[i].id,\r
hash_ptr^.hash_table[i].key_occ:8);\r
i := hash_ptr^.hash_table[i].following;\r
END;\r
END; (* key word table *)\r
END;\r
\r
\r
BEGIN (*---- MAIN PROGRAM ----*)\r
\r
init;\r
\r
read_callparameters;\r
\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\r
AND NOT inside_inclusion THEN\r
BEGIN\r
incl_path := '';\r
skipend := '(';\r
WHILE symbol <> '(' DO\r
nextsymbol;\r
nextsymbol;\r
skipend := ')';\r
WHILE symbol <> ')' DO\r
BEGIN (* pick up name of file to be included *)\r
IF symbol <> sp THEN\r
BEGIN\r
incl_path := incl_path + symbol;\r
END;\r
nextsymbol;\r
END; (* while *)\r
IF fileExist(incl_path) THEN\r
BEGIN (* start of alternative input file *)\r
writeln(Output);\r
write(Output, '$include(', incl_path, ')');\r
assign(include_file, incl_path);\r
SetTextBuf(include_file, IC_buff);\r
reset(include_file);\r
inside_inclusion := true;\r
END (* file exist *)\r
ELSE\r
writeln(Output, 'include(', incl_path, ') 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(Output, ' 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 'assignem' 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 := assignem\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
\r
'[':\r
BEGIN\r
(* push bracket level *)\r
brackcount := brackcount+1;\r
\r
END; (* left bracket *)\r
\r
'(': (* prepare comment or push level *)\r
BEGIN\r
\r
IF (lookahead = '*') THEN\r
(* comment *)\r
BEGIN\r
incl_path := '';\r
\r
IF language = Turbo_pascal THEN\r
BEGIN\r
nextsymbol;\r
nextsymbol;\r
\r
IF ( symbol = '$' )\r
AND ( (lookahead = 'I' ) OR ( lookahead = 'i' ))\r
AND inclusion AND NOT inside_inclusion THEN\r
BEGIN { Include requested }\r
nextsymbol;\r
nextsymbol;\r
\r
WHILE symbol = sp DO\r
nextsymbol;\r
\r
WHILE symbol IN (. 'A'..'Z', '0'..'9', '.' .) DO\r
BEGIN\r
incl_path := incl_path + symbol;\r
nextsymbol;\r
END;\r
END;\r
END\r
ELSE\r
BEGIN\r
nextsymbol;\r
nextsymbol;\r
END;\r
\r
skipend1 := ')';\r
\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
IF ( language = turbo_pascal )\r
AND ( incl_path <> '' ) THEN\r
BEGIN\r
IF fileExist(incl_path) THEN\r
BEGIN (* start of alternative input file *)\r
writeln(Output);\r
write(Output, '(*$I ', incl_path, ' *) - ');\r
assign(include_file, incl_path);\r
SetTextBuf(include_file, IC_buff);\r
reset(include_file);\r
inside_inclusion := true;\r
END (* file exist *)\r
ELSE\r
writeln(Output, 'Include( ', incl_path, ' ) not possible');\r
END;\r
\r
END (* comment *)\r
\r
ELSE\r
(* push bracket level *)\r
brackcount := brackcount+1;\r
\r
END; (* left parentesis *)\r
\r
'<': (* prepare comment or push level *)\r
BEGIN\r
\r
IF (lookahead = '*') AND (language <> Turbo_pascal ) THEN\r
(* comment *)\r
BEGIN\r
skipend := symbol;\r
nextsymbol;\r
\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
IF brackcount = 0 THEN\r
lastqueued := 0; (* mark the queue as otheruse *)\r
\r
END; (* left bracket *)\r
\r
'{': (* prepare comment or push level *)\r
BEGIN\r
\r
IF language = Turbo_pascal THEN\r
BEGIN\r
incl_path := '';\r
nextsymbol;\r
\r
IF ( symbol = '$' )\r
AND ( (lookahead = 'I' ) OR ( lookahead = 'i' ))\r
AND inclusion AND NOT inside_inclusion THEN\r
BEGIN { Include requested }\r
nextsymbol;\r
nextsymbol;\r
\r
WHILE symbol = sp DO\r
nextsymbol;\r
\r
WHILE symbol IN (. 'A'..'Z', '0'..'9', '.' .) DO\r
BEGIN\r
incl_path := incl_path + symbol;\r
nextsymbol;\r
END;\r
END;\r
\r
skipend := '}';\r
\r
WHILE symbol <> skipend DO\r
nextsymbol;\r
\r
IF incl_path <> '' THEN\r
BEGIN\r
IF fileExist(incl_path) THEN\r
BEGIN (* start of alternative input file *)\r
writeln(Output);\r
write(Output, '{$I ', incl_path, ' } - ');\r
assign(include_file, incl_path);\r
SetTextBuf(include_file, IC_buff);\r
reset(include_file);\r
inside_inclusion := true;\r
END (* file exist *)\r
ELSE\r
writeln(Output, 'include(', incl_path, ') not possible');\r
END;\r
\r
END (* comment *)\r
ELSE\r
IF brackcount = 0 THEN\r
lastqueued := 0; (* mark the queue as otheruse *)\r
\r
END; (* left brace *)\r
\r
'-': (* prepare comment *)\r
BEGIN\r
\r
IF (lookahead = '-') AND (language <> Turbo_pascal ) THEN\r
(* comment *)\r
BEGIN\r
line_pos := line_lgth + 1;\r
\r
END (* comment *)\r
ELSE\r
IF brackcount = 0 THEN\r
lastqueued := 0; (* mark the queue as otheruse *)\r
\r
END; (* -- comment *)\r
\r
')', ']': (* but not '>' or '}' *)\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
ELSE\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 ( line_pos >= line_lgth ) AND eof(infil);\r
\r
sort_table;\r
print_table;\r
\r
close(outputfil);\r
close(infil);\r
\r
writeln(Output);\r
IF table_full_at_line <> -1 THEN\r
BEGIN\r
writeln(output); writeln(output); writeln(output);\r
writeln(Output, '***** warning: hash table overflow at line: '\r
, table_full_at_line:1 );\r
END;\r
\r
IF test_requested THEN\r
writeln(' Heap storage used: ', InitialFree - MaxAvail:0, ' bytes. ',\r
MaxAvail:0, ' remaining. ');\r
END.\r