Category : Miscellaneous Language Source Code
Archive   : ADAXREF.ZIP
Filename : XREF.ADA

--======================================================================

-- XREF cross reference program. See TITLE for version number.

-- Last Modified: 09 SEP 84 (by RR Software)
-- 24 DEC 84 (by M. Goldberg)
-- 05 NOV 86 (by RR Software)

-- This program started out as CROSSREF.PKG, a sample program written
-- by RR Software to demonstrate Access types and to provide a useful
-- tool. I have modified it so much that, in fairness to RR Software
-- and myself, I had to give it a new name. [M. Goldberg]

-- The [XREF'ed] words are stored in a Binary Sorted Tree, and then
-- printed in order by print_tree. The line numbers are stored in a
-- linked list attached to each tree node. Only the first MAXLINES
-- occurrences of a name will be recorded. Should memory become nearly
-- full, [XREF] will be aborted, and what already has been done will be
-- printed. The algorithm is from Wirth: Algorithms + Data Structures
-- = Programs. [RR Software]

-- Modification Log

-- 28 NOV 84
-- 1. Cross reference table is written to a file, not to the
-- standard output stream.
-- 2. Linking of line number lists revised so that line numbers
-- print out in ascending order.
-- 3. Format of cross reference table revised.
-- 4. Code from main procedure moved into new procedure STARTUP
-- 5. Bug in scanner fixed. (The scanner would put an empty
-- key into the symbol tree if the file being scanned ended
-- with a comment.)
-- 04 DEC 84
-- 1. Function OPSYM added to provide a solution to the OPSYM
-- string constant problem that does not violate Ada strong
-- typing rules.
-- 15 DEC 84
-- 1. Added "NOT" to the list of reserved words.
-- 2. Source file name and reserved word option can be specified
-- on the command line. When a source file name is specified
-- on the command line, the cross-reference file name is
-- derived from it by replacing the file extension with XRF;
-- e.g., source file SOME.PKG will produce cross reference file
-- SOME.XRF. If no file name is given on the command line, the
-- user is prompted for both source and cross-reference file
-- names. The inclusion of reserved words is specified by /r
-- or /R. Any other flag, say /X, suppresses the inclusion of
-- reserved words. If no flag appears on the command line, the
-- user is prompted for the reserved word option.
-- 24 DEC 84
-- 1. Replaced scanner with one based on state-transition model.
-- The new scanner correctly handles based and float constants
-- and quoted opsyms.
-- 05 NOV 86 (RLB)
-- 1. Changed this to use Ada strings & revised I/O packages.

--======================================================================

with UTIL; use UTIL;
with CMDLINE;
with CHRSTRM;
with TEXT_IO;

procedure XREF is

TITLE : constant STRING
:= "XREF -- Cross Reference Generator -- V2.4 -- 05 NOV 86";

package INT_IO is new TEXT_IO.INTEGER_IO(INTEGER);
use TEXT_IO, INT_IO;

OPSYM_MAX : constant := 3;
-- all opsyms are less than 4 characters
OPSYM_TABLE : array (1 .. 17) of STRING(1..OPSYM_MAX);

MAXLINES : constant := 50;
SYMBOL_MAX : constant := 32;

type IDENT is record
LEN : NATURAL;
STR : STRING(1..SYMBOL_MAX);
end record;

-- linked list of line numbers
type LN_NODE;
type LN_PTR is access LN_NODE;
type LN_NODE is
record
LNO : INTEGER;
NXT : LN_PTR;
end record;

-- symbol table, a binary sorted tree
type SYMBOL;
type SYM_PTR is access SYMBOL;
type SYMBOL is
record
KEY : IDENT; -- program symbol
CNT : INTEGER; -- number of occurrences found
LN_HEAD, LN_TAIL : LN_PTR;
-- pointers to head and tail nodes of line number list
LEFT, RIGHT : SYM_PTR;
-- pointers to left and right sub-trees
IGNORE : BOOLEAN; -- TRUE if ignoring Ada reserved words
end record;

ROOT : SYM_PTR := null; -- start of symbol table

CUR_LINE : INTEGER := 1; -- current line number

INP : CHRSTRM.FILE;
OUTP : TEXT_IO.FILE_TYPE; -- handles for input and output files

--------------------------------------------------------------------

procedure PRINT_TREE(NODE : SYM_PTR) is
-- This routine recursively prints the cross reference tree.
-- This means that is calls itself to print the left and right
-- subtrees of the node passed in. If the node passed in is
-- empty, nothing is done (this guarantees termination).

LINK : LN_PTR;
-- pointer to a link in the linked list of line numbers

CNTR : INTEGER := 0; -- counter for output fields

begin
if NODE /= null then
PRINT_TREE(NODE.LEFT);
if NODE.IGNORE then null;
else
PUT(OUTP, NODE.KEY.STR(1..NODE.KEY.LEN));
NEW_LINE(OUTP);
PUT(OUTP, " Occurrences: "); PUT(OUTP, NODE.CNT, 3);
-- print the line numbers by 'walking' the linked list
-- of line numbers
LINK := NODE.LN_HEAD; -- start of line number list
while LINK /= null loop
if CNTR mod 15 = 0 then
NEW_LINE(OUTP);
if CNTR = 0 then
PUT(OUTP, " Lines: ");
else
PUT(OUTP, " ");
end if;
end if;
PUT(OUTP, LINK.LNO, 4);
CNTR := CNTR + 1;
LINK := LINK.NXT; -- walk to next line number
end loop;
NEW_LINE(OUTP);
end if;
PRINT_TREE(NODE.RIGHT);
end if;

-- do nothing for a null pointer

end PRINT_TREE;

--------------------------------------------------------------------

procedure INSERT(KEY : IDENT; NODE : in out SYM_PTR) is
-- This routine recursively inserts a new word. The tree is
-- recursively searched for the word. If it is found, the line
-- number is added to the line number list. Otherwise, a new
-- node is created and added to the tree.

LINK : LN_PTR;
-- pointer to a link in the linked list of line numbers

begin

if NODE = null then
-- key is not present in tree, so insert it
NODE := new SYMBOL;
NODE.KEY := KEY;
NODE.CNT := 1;
NODE.LN_HEAD := new LN_NODE;
NODE.LN_TAIL := NODE.LN_HEAD;
NODE.LEFT := null;
NODE.RIGHT := null;
NODE.IGNORE := FALSE;
NODE.LN_HEAD.LNO := CUR_LINE;
NODE.LN_HEAD.NXT := null;
elsif KEY.STR(1..KEY.LEN) < NODE.KEY.STR(1..NODE.KEY.LEN) then
-- look for the key in the left sub-tree
INSERT(KEY, NODE.LEFT);
elsif KEY.STR(1..KEY.LEN) > NODE.KEY.STR(1..NODE.KEY.LEN) then
-- look for the key in the right sub-tree
INSERT(KEY, NODE.RIGHT);
else
-- the key is present
if NODE.IGNORE then return; end if;
NODE.CNT := NODE.CNT + 1;
if NODE.CNT <= MAXLINES and then
NODE.LN_TAIL.LNO /= CUR_LINE then
LINK := new LN_NODE;
LINK.LNO := CUR_LINE;
LINK.NXT := null;
NODE.LN_TAIL.NXT := LINK;
NODE.LN_TAIL := LINK;
end if;
end if;

if MEMAVAIL in 0 .. 400 then
-- dump the tree before the memory runs out; this should
-- raise an exception for the main procedure to handle
-- rather than handling the problem locally
PRINT_TREE(ROOT);
PUT("XREF halted at line "); PUT(CUR_LINE);
PUT(" of the source file"); NEW_LINE;
PUT("Symbol table has filled heap memory");
HALT;
end if;

end INSERT;

--------------------------------------------------------------------

procedure STUFF_RESERVED_SYMBOLS is
-- Stuff the reversed words into the tree with ignore flag set
-- so they will be ignored at printout time

----------------------------------------------------------------

procedure SET_IGNORE(NODE : in out SYM_PTR) is
-- Set the ignore flag on the entire tree

begin

if NODE /= null then
SET_IGNORE(NODE.LEFT);
NODE.IGNORE := TRUE;
SET_IGNORE(NODE.RIGHT);
end if;

end SET_IGNORE;

----------------------------------------------------------------

procedure INSERT_STRING (STR : STRING) Is
KEY : IDENT;
begin
KEY.LEN := STR'LENGTH;
if KEY.LEN > SYMBOL_MAX then
KEY.STR := STR(STR'FIRST .. STR'FIRST + SYMBOL_MAX - 1);
else
KEY.STR(1..KEY.LEN) := STR;
end if;
INSERT(KEY, ROOT);
end INSERT_STRING;

----------------------------------------------------------------

begin

-- these are scattered out in an attempt to provide a somewhat
-- balanced tree
INSERT_STRING("LOOP");
INSERT_STRING("ELSE");
INSERT_STRING("RAISE");
INSERT_STRING("IF");
INSERT_STRING("OUT");
INSERT_STRING("USE");
INSERT_STRING("CASE");
INSERT_STRING("ARRAY");
INSERT_STRING("DIGITS");
INSERT_STRING("END");
INSERT_STRING("IS");
INSERT_STRING("NULL");
INSERT_STRING("PACKAGE");
INSERT_STRING("RECORD");
INSERT_STRING("THEN");
INSERT_STRING("WHEN");
INSERT_STRING("ALL");
INSERT_STRING("ABORT");
INSERT_STRING("ACCEPT");
INSERT_STRING("AT");
INSERT_STRING("ABS");
INSERT_STRING("ACCESS");
INSERT_STRING("AND");
INSERT_STRING("BEGIN");
INSERT_STRING("BODY");
INSERT_STRING("CONSTANT");
INSERT_STRING("DECLARE");
INSERT_STRING("DELAY");
INSERT_STRING("DELTA");
INSERT_STRING("DO");
INSERT_STRING("FOR");
INSERT_STRING("EXCEPTION");
INSERT_STRING("GENERIC");
INSERT_STRING("ELSIF");
INSERT_STRING("ENTRY");
INSERT_STRING("EXIT");
INSERT_STRING("FUNCTION");
INSERT_STRING("GOTO");
INSERT_STRING("IN");
INSERT_STRING("LIMITED");
INSERT_STRING("MOD");
INSERT_STRING("NEW");
INSERT_STRING("NOT");
INSERT_STRING("OF");
INSERT_STRING("OR");
INSERT_STRING("OTHERS");
INSERT_STRING("PRIVATE");
INSERT_STRING("PRAGMA");
INSERT_STRING("PROCEDURE");
INSERT_STRING("RANGE");
INSERT_STRING("REM");
INSERT_STRING("SELECT");
INSERT_STRING("RETURN");
INSERT_STRING("RENAMES");
INSERT_STRING("REVERSE");
INSERT_STRING("SEPARATE");
INSERT_STRING("SUBTYPE");
INSERT_STRING("TASK");
INSERT_STRING("TERMINATE");
INSERT_STRING("TYPE");
INSERT_STRING("WHILE");
INSERT_STRING("WITH");
INSERT_STRING("XOR");

SET_IGNORE(ROOT);

end STUFF_RESERVED_SYMBOLS;

--------------------------------------------------------------------

use CHRSTRM;

procedure SCAN_INPUT is
-- break up the input into JANUS/Ada tokens, and store them in
-- the symbol tree

CHR : CHARACTER; -- holder for character read from input

EOFP : BOOLEAN; -- TRUE if end of input file encountered

----------------------------------------------------------------

procedure MAKE_UPPER(CHR : in out CHARACTER) is
-- make lowercase letters into uppercase

begin

if CHR in 'a' .. 'z' then
CHR := CHARACTER'VAL(CHARACTER'POS(CHR)
+ CHARACTER'POS('A') - CHARACTER'POS('a'));
end if;

end MAKE_UPPER;

----------------------------------------------------------------

procedure GOT_END_LINE is
-- handler for end-of-line condition

begin

CUR_LINE := CUR_LINE + 1;

if CUR_LINE mod 32 = 0 then
put('#'); -- Tell user that something is going on...
end if;

end GOT_END_LINE;

----------------------------------------------------------------

procedure SKIP_LINE is
-- skip the rest of the line, to skip comments.

begin

GET_CHAR(INP, CHR, EOFP);
while not (CHR = ASCII.CR or else EOFP) loop
GET_CHAR(INP, CHR, EOFP);
end loop;
GOT_END_LINE;

end SKIP_LINE;

----------------------------------------------------------------

procedure GOT_ALPHA is
-- handler for identifiers

TOKEN : IDENT;
-- place to accumulate identifier
INDX : NATURAL;
-- index to first free character in TOKEN

begin

TOKEN.LEN := 1;
TOKEN.STR(1) := CHR;
INDX := 2;

loop
GET_CHAR(INP, CHR, EOFP);
exit when EOFP;
MAKE_UPPER(CHR);
case CHR is
when 'A' .. 'Z' | '0' .. '9' | '_' =>
if INDX <= SYMBOL_MAX then
TOKEN.LEN := INDX;
TOKEN.STR(INDX) := CHR;
INDX := INDX + 1;
end if;
when others =>
UNGET_CHAR(INP,CHR);
exit;
end case;
end loop;

INSERT(TOKEN, ROOT);

end GOT_ALPHA;

----------------------------------------------------------------

procedure GOT_DIGIT is
-- handler for numbers

begin

loop
GET_CHAR(INP, CHR, EOFP);
exit when EOFP;
case CHR is
when '0' .. '9' | 'A' .. 'F' |
'#' | '.' | '_' | '+' | '-' => null;
when others =>
UNGET_CHAR(INP,CHR);
exit;
end case;
end loop;

end GOT_DIGIT;

----------------------------------------------------------------

procedure GOT_SGLE_QUOTE is
-- handler for character constants, attribute designators,
-- and qualified Expressions

TMP : CHARACTER;

begin

GET_CHAR(INP, CHR, EOFP);
GET_CHAR(INP, TMP, EOFP);

if EOFP or else TMP = ''' then
-- character constant or bad EOF
return;
elsif CHR = '(' then
-- qualified expression
CHR := TMP;
else
-- probably attribute designator
UNGET_CHAR(INP,TMP);
end if;

MAKE_UPPER(CHR);
if CHR in 'A' .. 'Z' then
GOT_ALPHA;
end if;

end GOT_SGLE_QUOTE;

----------------------------------------------------------------

procedure GOT_DBLE_QUOTE is
-- handler for string constants; quoted opsyms require
-- special handling

TOKEN : IDENT;
-- place to accumulate opsym
INDX : NATURAL := 1;
-- index to first free character in TOKEN
INSERT_IT : BOOLEAN := FALSE;
-- need to insert opsym?
begin

loop
GET_CHAR(INP, CHR, EOFP);
exit when EOFP or else CHR = '"';
if INDX <= OPSYM_MAX then
TOKEN.LEN := INDX;
MAKE_UPPER(CHR);
TOKEN.STR(INDX) := CHR;
INDX := INDX + 1;
end if;
end loop;

-- just in case it's an opsym
case TOKEN.LEN is
when 1 =>
for KK in 1 .. 7 loop
if TOKEN.STR(1) = OPSYM_TABLE(KK)(1) then
INSERT_IT := TRUE;
exit;
end if;
end loop;
when 2 =>
for KK in 8 .. 11 loop
if TOKEN.STR(1..2) = OPSYM_TABLE(KK)(1..2) then
INSERT_IT := TRUE;
exit;
end if;
end loop;

when 3 =>
for KK in 12 .. 17 loop
if TOKEN.STR(1..3) = OPSYM_TABLE(KK) then
INSERT_IT := TRUE;
exit;
end if;
end loop;
when others => null;
end case;

if INSERT_IT then
TOKEN.STR(2..TOKEN.LEN+1) := TOKEN.STR(1..TOKEN.LEN);
TOKEN.STR(1) := '"';
TOKEN.LEN := TOKEN.LEN + 2;
TOKEN.STR(TOKEN.LEN) := '"';
INSERT(TOKEN, ROOT);
end if;

end GOT_DBLE_QUOTE;

----------------------------------------------------------------

procedure GOT_MINUS is
-- handler for comments; also skips over minus signs

begin

GET_CHAR(INP, CHR, EOFP);

if EOFP then
null;
elsif CHR = '-' then
SCAN_INPUT.SKIP_LINE;
else
UNGET_CHAR(INP,CHR);
end if;

end GOT_MINUS;

--------------------------------------------------------------------

begin -- body of SCANNER

loop
GET_CHAR(INP, CHR, EOFP);
exit when EOFP;
MAKE_UPPER(CHR);
case CHR is
when 'A' .. 'Z' => GOT_ALPHA;
-- start of an identifier
when '0' .. '9' => GOT_DIGIT;
-- start of a number
when ''' => GOT_SGLE_QUOTE;
-- start of a character constant, attribute
-- designator, or expression that was qualified
when '"' => GOT_DBLE_QUOTE;
-- start of a string or an opsym
when '-' => GOT_MINUS;
-- minus sign operator or start of a comment
when ASCII.CR => GOT_END_LINE;
when OTHERS => null;
end case;
end loop;

end SCAN_INPUT;

--------------------------------------------------------------------

use CMDLINE;

procedure STARTUP is
-- prompt for file names and reserved word option

FILES_ASK : BOOLEAN := TRUE;
-- TRUE if user is to be prompted for file names
INAME, ONAME : ARGUMENT; -- input and output file names

RESERVED_ASK : BOOLEAN := TRUE;
-- TRUE if user is to be prompted for reserved word option
RESERVED_WANTED : BOOLEAN := FALSE;
-- TRUE if reserved word option requested by user
RSPNS : CHARACTER;
-- holds response to prompt for reserved word option

begin

for INDX in 1 .. ARG_COUNT loop
declare
ARG, NAME : ARGUMENT; -- temporary argument strings
begin
ARG := FETCH_ARG(INDX);
if ARG.TEXT(1..ARG.LENGTH) = "/r" or else
ARG.TEXT(1..ARG.LENGTH) = "/R" then
RESERVED_ASK := FALSE;
RESERVED_WANTED := TRUE;
elsif ARG.TEXT(1) = '/' then
-- any other option code voids reserve word option
RESERVED_ASK := FALSE;
else
NAME := NAME_PART(ARG);
if NAME.TEXT(NAME.LENGTH) /= '.' then
INAME := NAME;
else
INAME := ARG;
end if;
ONAME := NAME;
if NAME.TEXT(NAME.LENGTH) /= '.' then
ONAME.TEXT(ONAME.LENGTH+1..ONAME.LENGTH+4) :=
".XRF";
ONAME.LENGTH := ONAME.LENGTH + 4;
else
ONAME.TEXT(ONAME.LENGTH+1..ONAME.LENGTH+3) :=
"XRF";
ONAME.LENGTH := ONAME.LENGTH + 3;
end if;
FILES_ASK := FALSE;
end if;
end;
end loop;

if FILES_ASK then
PUT("Source file (input): ");
GET_LINE(INAME.TEXT, INAME.LENGTH);
PUT("Cross reference file (output): ");
GET_LINE(ONAME.TEXT, ONAME.LENGTH);
end if;

begin
CHRSTRM.OPEN_FILE(INP, INAME.TEXT(1..INAME.LENGTH));
exception
when others =>
PUT_LINE("Can't open source file");
UTIL.HALT;
end;

begin
CREATE(OUTP, OUT_FILE, ONAME.TEXT(1..ONAME.LENGTH));
exception
when others =>
PUT_LINE("Can't create cross reference file");
UTIL.HALT;
end;

if RESERVED_ASK then
PUT("Include reserved words? (y/n): ");
GET(RSPNS); SKIP_LINE;
if RSPNS = 'Y' or RSPNS = 'y' then
RESERVED_WANTED := TRUE;
end if;
end if;

if RESERVED_WANTED then
PUT("Including reserved words in cross reference table");
else
PUT("Omitting reserved words from cross reference table");
STUFF_RESERVED_SYMBOLS;
end if;
NEW_LINE;

PUT("Reading from: "); PUT(INAME.TEXT(1..INAME.LENGTH)); NEW_LINE;
PUT("Writing to: "); PUT(ONAME.TEXT(1..ONAME.LENGTH)); NEW_LINE;

end STARTUP;

--------------------------------------------------------------------

begin -- body of XREF

PUT(TITLE); NEW_LINE;

OPSYM_TABLE( 1) := "+ ";
OPSYM_TABLE( 2) := "- ";
OPSYM_TABLE( 3) := "* ";
OPSYM_TABLE( 4) := "/ ";
OPSYM_TABLE( 5) := "= ";
OPSYM_TABLE( 6) := "> ";
OPSYM_TABLE( 7) := "< ";
OPSYM_TABLE( 8) := ">= ";
OPSYM_TABLE( 9) := "<= ";
OPSYM_TABLE(10) := "/= ";
OPSYM_TABLE(11) := "OR ";
OPSYM_TABLE(12) := "ABS";
OPSYM_TABLE(13) := "AND";
OPSYM_TABLE(14) := "MOD";
OPSYM_TABLE(15) := "NOT";
OPSYM_TABLE(16) := "REM";
OPSYM_TABLE(17) := "XOR";


STARTUP;
SCAN_INPUT;
NEW_LINE;
PRINT_TREE(ROOT);
CLOSE(OUTP);
CHRSTRM.CLOSE_FILE(INP);

PUT_LINE("XREF done");

end XREF;

--======================================================================