home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
database
/
xrefprg2.zip
/
XREFPRG2.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1986-03-10
|
34KB
|
1,088 lines
{$C-} {* essential for programmed pause-abort facility;
see procedure dealwithuser *}
program xrefprg;
(*
==========================================================================
1/6/86
Modified to produce cross reference listings of DB3 Ver 1.1 files
Existing programs like SL.COM and DTUN31 seem to work very well
except in the area of producing a cross reference. This quick
conversion of a pascal lister seems to work pretty well.
I have stripped out most of the Pascal specific code and changed
the Reserved word list to work with DB3. There are many other
enhancements I would like to include but want to get this into
use quickly.
----------------------------------------------------------------------
3/2/86
Added new keywords for dBASE + and ability to recognize end-of-line
comments (&& comment).
See document file for other changes/additions.
If (when?) you discover problems with this program, please let me
know at:
Robert F. Hicks
6508 Harwood Place
Springfield, VA 22152
Many thanks to the original author(s) for code that could be easily
modified.
==========================================================================
Cross reference generator Version 1.10, 5/8/85
------> REQUIRES TURBO PASCAL 3.0 <------
--- (explained below)
This program, in its original form, was downloaded off of some bulletin
board somewhere. At that point, it only listed a Pascal program to the
LST device and generated a cross reference of whatever reserved words
were in the list in function rsvdword, with those reserved boldfaced in
the printout. I have made numerous improvements.
You should note that many of the new functions of XREF use TURBO features
which are specific to the IBM-PC version, such as the reverse video and
use of wherex and wherey.
I can't think of anything else one would need in a source listing program.
If someone else can, or has any questions about the program, please contact
me at this address:
Larry Jay Seltzer
657 Seventh Street
Lakewood, NJ 08701
The compressed and default mode options work for the Epson FX-100 and
any compatable printer. The codes are stored in CONSTants, so as to
be easily changeable for any printer with this capacity. There are three
basic ways to invoke the program:
1) XREF from command line. You will be prompted for everything.
2) XREF [pathname][filename].[ext]
You will be prompted for all applicable parameters.
3) XREF [pathname][filename].[ext] [/ { C, D, F, I, N, S } ]
C means print out in compressed mode (EPSON)
D means print out in default mode
F means print out to disk file
I means list include files within the main
N means exclude the cross refernce
S means send output to the screen instead of printer.
The program requires TURBO 3.0 because it uses TURBO FIBs, which have been
altered for version 3.0. The FIB no longer contains the file's date of
creation, so the file handle is passed to DOS function call $57, which
returns the date.
>>>> This should be compiled into a COM file
by Turbo Pascal(tm) 3.0 or later before running.
What Borland hath wrought!!! <<<<
*)
const
ch_per_word = 22; { characters per word }
linenums = 11; { line numbers per printed reference line }
linenum_size = 5; { size of displayed line numbers }
reserved_count = 303; { number of reserved words }
{*** printer control sequences ***}
compressed_on : array[1..1] of char = (#15);
default_on : array[1..2] of char = (#27,#64);
boldface_on : array[1..2] of char = (#27,#71);
boldface_off : array[1..2] of char = (#27,#72);
type
datestr = string[10];
option_type = string[1];
switchsettype = set of char;
wordref = ^word;
itemref = ^item;
word = record key: string[ch_per_word];
first, last: itemref;
left, right: wordref;
end ;
item = record lno: integer;
next: itemref;
end ;
state = (none,symbol,quote1,quote2,com1,com2);
filstring = string[64];
titletype = string[10];
var
answer : option_type;
filename, outname : filstring;
root: wordref;
xx,temp_adjust,ind_cnt,
next_case,next_do,next_if,
curr_case,curr_do,curr_if,
m,n,indent_amt,cutoff,pageno,
st_err_page,st_err_tot,
blk_err_page,blk_err_tot : integer;
upid,id: string[255];
blanks, ind_string : string[60];
fv,iv,
outf : text;
f : char;
switches : switchsettype;
scan : state;
title : titletype;
lead,test_sec_key,in_quotes,
auto_ind,taken_careof : boolean;
function get_answer(opt1,opt2 : option_type) : option_type; forward;
function file_exists(var thefile : filstring) : boolean;
type
Registertype = record
AX,BX,CX,DX,
BP,SI,DI,DS,ES,flags: integer;
end;
var
registers:registertype;
begin
thefile := thefile + #0;
with registers do
begin
ds := seg(thefile);
dx := ofs(thefile)+1;
ax := $4E00;
cx := $0000
end;
intr($21,registers);
file_exists := not ((registers.flags and $0001) = $0001)
end;
function currdate: DateStr;
type
regpack = record
ax,bx,cx,dx,bp,si,ds,es,flags: integer;
end;
var
recpack: regpack; {record for MsDos call}
month,day: string[2];
year: string[4];
tempdate: datestr;
i,dx,cx: integer;
begin
with recpack do
begin
ax := $2a shl 8;
end;
MsDos(recpack); { call function }
with recpack do
begin
str(cx,year); {convert to string}
str(dx mod 256,day); { " }
str(dx shr 8,month); { " }
end;
tempdate := month+'/'+day+'/'+year;
for i:= 1 to 10 do if tempdate[i] = ' ' then tempdate[i]:= '0';
currdate := tempdate
end;
function filedate(var thefile : text) : datestr;
type
regpack = record
al, ah : byte;
bx,cx,dx,bp,si,ds,es,flags: integer;
end;
var
sortofdate,
i, handle : integer;
month,day : string[2];
year : string[4];
date : datestr;
recpack : regpack;
begin
handle := memw [seg(thefile):ofs(thefile)];
recpack.al := 0;
recpack.AH := $57;
recpack.bx := handle;
msdos(recpack);
sortofdate := recpack.dx;
str(((sortofdate shr 9) + 1980):4,year);
str(((sortofdate shr 5) and $000F):2,month);
str((sortofdate and $001F):2,day);
date:= month + '/' + day + '/' + year;
for i:= 1 to 10 do if date[i] = ' ' then date[i]:= '0';
filedate := date
end; {WhenCreated}
procedure newpage(var fname : filstring;title:titletype);
var date : datestr;
date_stuff : string[40];
begin
pageno := pageno+1;
date_stuff := 'Created '+filedate(fv)+' '+'Listed '+currdate;
If (not ('S' in switches)) and (not ('F' in switches))
then write(outf,#12) else writeln(outf);
write(outf,title,': ',fname,' ':6,date_stuff,' ':6,'Page ',pageno:3);
writeln(outf);
writeln(outf);
end {newpage};
procedure writeid;
type
rsrv_key = (endcase,enddo,endif,aif,ado,acase,aelse,none);
var
chek_indent : rsrv_key;
function rsvdword: boolean;
const
wordlist: array[1..reserved_count] of string[14] =
('.AND.','.F.','.NOT.','.OR.','.T.','ABS','ACCE','ACCEPT','ADDI','ADDITIVE',
'ALL','ALTE','ALTERNATE','AMERICAN','ANSI','APPE','APPEND','ASC','AT','AVER',
'AVERAGE','BELL','BLAN','BLANK','BOF','BRITISH','BROW','BROWSE','CALL','CANC',
'CANCEL','CARR','CARRY','CASE','CATALOG','CDOW','CENTURY','CHR','CLEA',
'CLEAR','CLOS','CLOSE','CMON','CMONTH','COL','COLO','COLOR','CONF','CONFIRM',
'CONS','CONSOLE','CONT','CONTINUE','COPY','COUN','COUNT','CREA','CREATE',
'CTOD','DATA','DATABASES','DATE','DAY','DEBU','DEBUG','DECI','DECIMALS',
'DEFA','DEFAULT','DELE','DELETE','DELETED','DELI','DELIMITER','DELIMITERS',
'DEVI','DEVICE','DIR','DIR','DISK','DISKSPACE','DISP','DISPLAY','DO',
'DOHISTORY','DOW','DTOC','ECHO','EDIT','EJEC','EJECT','ELSE','ENDC','ENDCASE',
'ENDD','ENDDO','ENDI','ENDIF','ENDTEXT','EOF','ERAS','ERASE','ERROR','ESCA',
'ESCAPE','EXAC','EXACT','EXIT','EXP','EXPORT','EXTE','EXTENDED','FIELD',
'FIELDS','FILE','FILT','FILTER','FIND','FIXE','FIXED','FKLABEL','FKMAX','FORM',
'FORMAT','FOUND','FRENCH','FROM','FUNC','FUNCTION','GERMAN','GET','GETENV',
'GETS','GO','GOTO','HEAD','HEADING','HISTORY','IF','IIF','IMPORT','INDE',
'INDEX','INKEY','INPU','INPUT','INSE','INSERT','INT','INTE','INTENSITY',
'ISALPHA','ISCOLOR','ISLOWER','ISUPPER','ITALIAN','KEY','LABE','LABEL','LEFT',
'LEN','LIST','LOAD','LOCA','LOCATE','LOG','LOOP','LOWE','LOWER','LTRIM',
'LUPDATE','MARG','MARGIN','MASTER','MAX','MEMO','MEMORY','MEMOWIDTH','MENU',
'MENUS','MESSAGE','MIN','MOD','MODU','MODULE','MONT','MONTH','NDX','NOEJECT',
'OFF','ON','ORDER','OS','PACK','PARA','PARAMETER','PATH','PCOL','PICT',
'PICTURE','PLAIN','PRIN','PRINT','PRINTER','PRIV','PRIVATE','PROC','PROCEDURE',
'PROW','PUBL','PUBLIC','QUERY','QUIT','RANDOM','READ','READKEY','RECA',
'RECALL','RECCOUNT','RECN','RECNO','RECSIZE','REIN','REINDEX','RELA',
'RELATION','RELE','RELEASE','RENAME','REPL','REPLACE','REPLICATE','REPO',
'REPORT','REST','RESTORE','RESUME','RETRY','RETU','RETURN','RIGHT','ROUN',
'ROUND','ROW','RTRIM','RUN','SAFE','SAFETY','SAVE','SAY','SCOR','SCOREBOARD',
'SCREEN','SEEK','SELE','SELECT','SET','SKIP','SORT','SPAC','SPACE','SQRT',
'STAT','STATUS','STEP','STOR','STORE','STR','STRU','STRUCTURE','STUFF','SUBS',
'SUBSTR','SUM','SUMMARY','TALK','TEXT','TIME','TITLE','TO','TOTA','TOTAL',
'TRAN','TRANSFORM','TRIM','TYPE','TYPEAHEAD','UNIQ','UNIQUE','UPDA','UPDATE',
'UPPE','UPPER','USE','VAL','VERSION','VIEW','WAIT','WHIL','WHILE','WITH',
'YEAR','ZAP');
var
i, j, k: integer;
begin
upid := '';
for i := 1 to length(id) do
upid := upid + upcase(copy(id,i,1));
i := 1;
j := reserved_count - 1;
repeat
k := (i+j) div 2;
if upid > wordlist[k] then
i := k+1
else
j := k
until i = j;
rsvdword := (upid = wordlist[i])
end {rsvdword};
procedure search (var w1: wordref);
var
w: wordref;
x: itemref;
begin
w := w1;
if w = nil then
begin
new(w);
new(x);
with w^ do
begin
key := id;
left := nil;
right := nil;
first := x;
last := x
end ;
x^.lno := n;
x^.next := nil;
w1 := w
end
else
if id < w^.key then
search(w^.left)
else
if id > w^.key then
search(w^.right)
else
begin
new(x);
x^.lno := n;
x^.next := nil;
w^.last^.next := x;
w^.last := x
end
end {search} ;
Procedure Regular_video;
begin
TextBackground(black);
TextColor(white);
end;
Procedure Reverse_video;
begin
TextBackground(white);
TextColor(black);
end;
function locase(ch:char) : char;
begin
If ch in ['A'..'Z'] then
locase := chr(ord(ch) or $20)
else
locase := ch
end;
procedure rsvd_write;
begin
if lead then
begin
write(outf,ind_string);
lead := FALSE
end;
if 'F' in switches then
write(outf,upid)
else
if 'S' in switches then
begin
reverse_video;
write(outf,upid);
regular_video
end
else
{put in a page break when a procedure starts}
if ((upid='PROCEDURE') and (n>10)) then
begin { report at end of procedure same as end of file }
if (curr_if > 0) or (next_if > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDIF STATEMENT IN PROCEDURE ***');
writeln(outf,'*** MISSING ENDIF STATEMENT IN PROCEDURE ***')
end;
if (curr_do > 0) or (next_do > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDDO STATEMENT IN PROCEDURE ***');
writeln(outf,'*** MISSING ENDDO STATEMENT IN PROCEDURE ***')
end;
if (curr_case > 0) or (next_case > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDCASE STATEMENT IN PROCEDURE ***');
writeln(outf,'*** MISSING ENDCASE STATEMENT IN PROCEDURE ***')
end;
{ reset counters for next proc }
curr_case := 0;
curr_do := 0;
curr_if := 0;
next_case := 0;
next_do := 0;
next_if := 0;
ind_string := '';
st_err_tot := st_err_tot + st_err_page;
blk_err_tot := blk_err_tot + blk_err_page;
st_err_page := 0;
blk_err_page := 0;
newpage(filename,title);
cutoff := n;
write(outf,boldface_on,upid,boldface_off)
end
else
write(outf,boldface_on,upid,boldface_off)
end {rsvd_write};
procedure indentset;
begin
chek_indent := none; {reset it for next pass}
if lead then
begin
if upid ='IF' then chek_indent := aif;
if upid ='DO' then chek_indent := ado;
if upid = 'CASE' then chek_indent := acase;
if upid = 'ELSE' then chek_indent := aelse;
if upid = 'ENDCASE' then chek_indent :=endcase;
if upid = 'ENDDO' then chek_indent := enddo;
if upid = 'ENDIF' then chek_indent := endif;
case chek_indent of
endcase: begin
if curr_case >0 then
curr_case := curr_case - 2
else
begin
blk_err_page := blk_err_page + 1;
writeln(outf,'*** ENDCASE WITHOUT CASE ***');
if not ('S' in switches) then
writeln('*** ENDCASE WITHOUT CASE ***')
end
end;
enddo: begin
if curr_do>0 then
curr_do := curr_do - 1
else
begin
blk_err_page := blk_err_page + 1;
writeln(outf,'*** ENDDO WITHOUT DO ***');
if not ('S' in switches) then
writeln('*** ENDDO WITHOUT DO ***')
end
end;
endif: if curr_if>0 then
curr_if := curr_if - 1
else
begin
blk_err_page := blk_err_page + 1;
writeln(outf,'*** ENDIF WITHOUT IF ***');
if not ('S' in switches) then
writeln('*** ENDIF WITHOUT IF ***')
end;
aif: begin
next_if := next_if + 1
end;
ado: begin
test_sec_key := TRUE;
end;
acase: begin
temp_adjust := 1
end;
aelse: begin
if curr_if > 0 then
temp_adjust := 1
else
begin
blk_err_page := blk_err_page + 1;
writeln(outf,'*** ELSE WITHOUT IF ***');
if not ('S' in switches) then
writeln('*** ELSE WITHOUT IF ***')
end
end;
end { endcase};
end
else
begin
if upid = 'CASE' then
next_case := next_case + 2;
if (upid ='WHIL') or (upid='WHILE') then
next_do := next_do + 1;
test_sec_key := FALSE
end; {lead or test_sec_key }
{ this is one of two places that changes in indent level occur
but the only place that temp changes occur }
ind_cnt :=(curr_case + curr_do + curr_if - temp_adjust) * indent_amt;
ind_string := copy(blanks,1,ind_cnt);
rsvd_write;
temp_adjust := 0
end; {indentset}
begin {writeid}
if rsvdword then
if lead or test_sec_key then
indentset
else
rsvd_write
else
begin
{upid :='';}
if test_sec_key then
test_sec_key := FALSE;
for xx := 1 to length(id) do
id[xx] := locase(id[xx]);
if lead then
begin
write(outf,ind_string);
lead := FALSE
end;
write(outf,id);
If not ('N' in switches) then
begin
search(root)
end
end
end;{writeid}
procedure scrn_update(indent : boolean);
const
mainx = 18;
incx = 20;
begin
if indent
then
gotoxy(incx,wherey)
else
gotoxy(mainx,wherey);
write(n:1)
end;
procedure printtree (w:wordref);
procedure printword (w:word);
var l: integer;
x: itemref;
begin
if (n mod 58) = 0 then
newpage(filename,'xref');
write(outf,' ',w.key:ch_per_word);
x := w.first;
l:= 0;
repeat
if l = linenums then
begin
writeln(outf);
n := n+1;
scrn_update(false);
if (n mod 58) = 0 then
newpage(filename,'xref');
write(outf,' ':ch_per_word+1);
l := 0
end ;
l := l+1;
write(outf,x^.lno:linenum_size);
x := x^.next
until x = nil;
writeln(outf);
n := n+1;
scrn_update(false)
end {printword} ;
begin
if w <> nil then
begin
printtree(w^.left);
printword(w^);
printtree(w^.right)
end ;
end {printtree} ;
function get_answer;
var ch : char;
begin
repeat
read(kbd,ch)
until ch in [opt1,opt2,upcase(opt1),upcase(opt2)];
writeln(ch);
get_answer := upcase(ch)
end;
function get_choices(opt1,opt2,opt3 : option_type) : option_type;
var ch : char;
begin
repeat
read(kbd,ch)
until ch in [opt1,opt2,opt3,upcase(opt1),upcase(opt2),upcase(opt3)];
writeln(ch);
get_choices := upcase(ch)
end;
procedure empty_keyboard;
var
c : char;
begin
while keypressed do
read(kbd,c)
end;
Procedure do_listing(var fv : text;title:titletype ;
fn : filstring ; mode : state);
var
lead_white : Boolean;
procedure dealwithuser;
var
oldx,oldy : integer;
c : char;
begin
empty_keyboard;
oldx:=wherex; oldy:=wherey;
writeln;
write('Press space to continue, Esc to abort ...');
answer := get_answer( #32,#27);
if answer=#27 then
halt
else
begin
gotoxy(wherex,wherey-1);
delline;
if (oldy=25) or (oldy=23) then
oldy := 23;
gotoxy(oldx,oldy)
end
end;
begin
st_err_page := 0;
st_err_tot := 0;
blk_err_page := 0;
blk_err_tot := 0;
curr_case := 0;
curr_do := 0;
curr_if := 0;
temp_adjust := 0;
next_case := 0;
next_do := 0;
next_if := 0;
ind_string := '';
cutoff := n;
scan := mode;
lead := TRUE;
in_quotes := FALSE;
reset(fv);
if ((title='Filename') and(('C' in switches) or ( 'D' in switches) or ('L' in switches))) then
newpage(fn,title);
while not eof(fv) do
begin
if auto_ind then
lead_white := TRUE
else
lead_white := FALSE;
lead := TRUE;
{ update the indent counters with next line info }
curr_case := curr_case + next_case;
curr_do := curr_do + next_do;
curr_if := curr_if + next_if;
{ adjust the length of the indent string }
ind_cnt :=(curr_case + curr_do + curr_if - temp_adjust) * indent_amt;
ind_string := copy(blanks,1,ind_cnt);
{ reset the next-line counters }
next_case := 0;
next_do := 0;
next_if := 0;
if ((((n + st_err_page + blk_err_page)-(58+cutoff)) = 0)
and (('C' in switches) or ('D' in switches) or ('L' in switches)))
then
begin
st_err_tot := st_err_tot + st_err_page;
blk_err_tot := blk_err_tot + blk_err_page;
st_err_page := 0;
blk_err_page := 0;
cutoff := cutoff+58;
if not taken_careof then
newpage(fn,title)
end;
taken_careof := false;
n := n+1;
if not ('S' in switches) then
scrn_update(title='Include');
if ((not ('F' in switches)) or ( 'L' in switches)) then
write(outf,n:linenum_size,' ');
while not eoln(fv) do
begin
if keypressed then
dealwithuser;
read(fv,f);
if lead_white then
begin
while ((ord(f)<33) and not eoln(fv)) do read(fv,f); {drop leading white space}
lead_white := False
end;
case scan of
none: begin
if f in['.','a'..'z','A'..'Z','_'] then
begin
id := f;
scan := symbol
end
else
begin
if lead then
begin
write(outf,ind_string);
lead := FALSE
end;
write(outf,f);
if f ='''' then
begin
scan := quote1;
in_quotes := TRUE {starting a quoted string }
end
else
if f = '*' then
scan := com1
else
if f = '"' then
begin
scan := quote2;
in_quotes := TRUE
end
else
if f = '&' then { possible beginning of dB+ }
scan := com2 { end-of-line comment }
end
end;
symbol: begin
if f in['.','a'..'z','A'..'Z','0'..'9','_'] then
begin
id := id + f;
end
else
begin
writeid;
write(outf,f);
if f = '''' then
begin
scan := quote1;
in_quotes := TRUE { starting a quoted string }
end
else
if f = '"' then
begin
scan := quote2;
in_quotes := TRUE
end
else
scan := none
end
end;
quote1: begin
write(outf,f);
if f = '''' then
begin
scan := none;
in_quotes := FALSE {the quote is properly terminated}
end
end;
quote2: begin
write(outf,f);
if f = '"' then
begin
scan := none;
in_quotes := FALSE
end
end;
com1: begin
write(outf,f)
end;
com2: begin
if f = '&' then { two ampersands start e-o-l comment so }
scan := com1 { treat successive char as regular com }
else { it's probably a macro so treat it like }
scan := none;
{ an unknown for further testing }
write(outf,f)
end;
end;
end;
if scan = symbol then
begin
writeid;
scan := none
end;
scan := none;
writeln(outf);
if in_quotes then { a quoted string is NOT properly terminated }
begin
if not ('S' in switches) then
writeln('*** STRING ABOVE NOT TERMINATED ***');
writeln(outf,'*** STRING ABOVE NOT TERMINATED ***');
st_err_page := st_err_page + 1;
in_quotes := FALSE { reset the error-flag }
end;
readln(fv);
end;
if (curr_if > 0) or (next_if > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDIF STATEMENT IN FILE ***');
writeln(outf,'*** MISSING ENDIF STATEMENT IN FILE ***')
end;
if (curr_do > 0) or (next_do > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDDO STATEMENT IN FILE ***');
writeln(outf,'*** MISSING ENDDO STATEMENT IN FILE ***')
end;
if (curr_case > 0) or (next_case > 0) then
begin
blk_err_page := blk_err_page + 1;
if not ('S' in switches) then
writeln('*** MISSING ENDCASE STATEMENT IN FILE ***');
writeln(outf,'*** MISSING ENDCASE STATEMENT IN FILE ***')
end;
writeln(outf)
end;
procedure get_info;
var
i : integer;
parameters : string[127] absolute cseg:$0080;
workparams : string[127];
procedure get_filename;
begin
M := 0;
repeat
M := M+1
until (M > length(workparams)) or (workparams[M] <> ' ');
N:=M;
REPEAT
N:=N+1
UNTIL (N>length(workparams)) OR (workparams[N]='/');
filename := copy(workparams,m,(n-m));
if pos('.',filename)=0 { the extension was left out }
then filename := filename + '.PRG' { so add a default extension }
end;
procedure waytogo_user; {* filename and switches on command line *}
begin
n := pos('/',workparams) + 1;
While n<=length(workparams) do
begin
if upcase(workparams[n]) in ['A','C','D','F','L','N','S']
then switches := switches + [upcase(workparams[n])];
if workparams[n] in ['0'..'9'] then
indent_amt := (ord(workparams[n]) - ord('0')); {convert to integer}
n:=n+1
end;
if 'A' in switches then
auto_ind := TRUE
else
auto_ind := FALSE;
if 'F' in switches then
outname := copy(filename,1,pos('.',filename)-1)+'.'+'LST'
end;
procedure query_filename;
begin
write('C/R to quit or enter name of file to be listed [.PRG] : ');
readln(filename);
if pos('.',filename)=0
then filename := filename + '.PRG';
if pos('.',filename) < 2 then
halt
end;
procedure switch_menu;
var
ok : boolean;
indanswer, answer : char;
begin
write('Output to file, screen, or printer (F,S,P) ? ');
answer := get_choices('f','s','p');
If answer = 'P'
then
begin
write('Printer output in compressed or default mode (C,D) ? ');
if get_answer('c','d') = 'C'
then switches := switches + ['C']
else switches := switches + ['D']
end
else
if answer='S'
then switches := switches + ['S']
else
begin
switches := switches + ['F'];
write('Enter name of output file [',copy(filename,1,
pos('.',filename)-1),'.','LST]');
readln(outname);
if outname=''
then outname := copy(filename,1,pos('.',filename)-1)+'.'+'LST';
write('Include line numbers in output file (Y,N) ? ');
if get_answer('y','n') = 'Y'
then switches := switches + ['L']
end;
write('Generate auto-indentation of output (Y,N) ? ');
if get_answer('y','n') = 'Y' then
begin
write('C/R for indent = 3 or enter value to indent ');
{$I-} {turn off i/i chek until good answer}
ok := FALSE;
repeat
begin
read(indent_amt);
ok := (IoResult = 0);
if not ok then
begin
gotoxy(wherex-1,wherey);
write(' ')
end;
auto_ind := TRUE;
end
until ok;
writeln
end
else {indenting not wanted }
begin
indent_amt := 0;
auto_ind := FALSE
end;
{$I+}
write('Produce cross reference of user-defined identifiers (Y,N) ? ');
if get_answer('y','n') = 'N'
then switches := switches + ['N'];
end;
begin
workparams := parameters;
{ while workparams[LENGTH(workparams)]=#0 DO
delete(workparams,length(workparams),1);}
If pos('/',workparams)>0 then
If pos('/',workparams)<=length(workparams) then
begin
get_filename;
if not file_exists(filename)
then
begin
writeln('File ',filename,' not found.');
repeat
query_filename;
if not file_exists(filename)
then writeln('File ',filename,' not found.');
until file_exists(filename);
switch_menu
end
else
waytogo_user
end
else
begin
get_filename;
if not file_exists(filename)
then
begin
writeln('File ',filename,' not found.');
repeat
query_filename
until file_exists(filename);
end;
switch_menu
end
else
begin
if length(workparams)=0
then query_filename
else get_filename;
if not file_exists(filename)
then
begin
writeln('File ',filename,' not found.');
repeat
query_filename;
if not file_exists(filename)
then writeln('File ',filename,' not found.')
until file_exists(filename);
end;
switch_menu
end;
while filename[LENGTH(filename)]=#0 DO
delete(filename,length(filename),1)
end;
begin {*** main ***}
indent_amt := 3;
switches := [];
blanks :=' ';
test_sec_key := FALSE;
clrscr;
gotoxy(0,10);
get_info;
empty_keyboard;
if (not ('F' in switches)) and (not ('S' in switches))
then
begin
If 'C' in switches
then writeln(lst,compressed_on);
If 'D' in switches
then writeln(lst,default_on)
end;
if 'S' in switches
then
begin
assign(outf,'CON:');
rewrite(outf)
end
else
if 'F' in switches
then
begin
assign(outf,outname);
rewrite(outf)
end
else
begin
assign(outf,'LST:');
rewrite(outf)
end;
root := nil;
n := 0;
cutoff := 0;
scan := none;
pageno := 0;
title := 'Filename';
if not ('S' in switches)
then
begin
writeln;
write('Listing main file ',filename);
if 'F' in switches
then writeln(' to file ',outname)
else writeln;
write('Processing line #')
end;
assign(fv,filename);
do_listing(fv,title,filename,none);
if not ('N' in switches)
THEN
BEGIN
if not ('S' in switches)
then
begin
writeln;
write('Listing cross reference of ',filename);
if 'F' in switches
then writeln(' to file ',outname)
else writeln;
write('Processing line #')
end;
n := 0;
pageno := 0;
title := 'xref';
printtree(root);
If (not ('S' in switches)) and (not ('F' in switches))
then write(outf,#12);
END;
if ('F' in switches) then
close(outf);
st_err_tot := st_err_tot + st_err_page; {last update of total errors}
blk_err_tot := blk_err_tot + blk_err_page;
writeln(' ');
writeln('File processing completed for ',filename);
if not ((st_err_tot > 0) or (blk_err_tot > 0)) then
writeln('No errors were detected.')
else
begin
if blk_err_tot > 0 then
writeln('There were ',blk_err_tot,' block errors found.');
if st_err_tot > 0 then
writeln('There were ',st_err_tot,' unterminated strings found.')
end
end.