home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
TURBOPAS
/
ZXREF.LBR
/
XREF2.IQC
/
XREF2.INC
Wrap
Text File
|
2000-06-30
|
15KB
|
593 lines
(***************************************************)
(*-------> Include file #2 for XREF.PAS <-------*)
(***************************************************)
(* v. 0200pm, sun, 28.Sep.86, Glen Ellis *)
(*-------> primary procedure is pBuildTree *)
(*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
(* *)
(* Primary procedure >> BuildTree << *)
(* *)
(*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
procedure pBuildTree
( var tree : treepointer; var InFile : GenStr; BTkeyModeChar : string1 );
var
CurrentWord : alfa;
fin : text; { local input file }
currchar, { Current operative character }
nextchar : charinfo; { Look-ahead character }
flushing : (KNOT, DBL, STD, LIT, SCANFN, SCANFN2);
fname : string[30];
doInclude : boolean; { true IF we discovered include file }
fbuffer : string[255]; { format buffer - before final Print }
LineIn : string[255];
LineInLast : string[255];
cp : 0..255;
xeof, { EOF status AFTER a read }
xeoln : BOOLEAN; { EOLN status after a read }
(*----------------------------*)
(* sub procedure of pReadWord *)
procedure pFindInReserve
(var fWord: alfa ;
var fFindInReserve : boolean ;
FRkeyModeChar : string1 ) ;
Label Return;
var
low, high, mid : integer;
KeyRefStr : string[20];
begin
low := 1;
high := NumKeys;
WHILE (low <= high)
do
begin
mid := (low+high) div 2;
IF (FRkeyModeChar <> 'T') and (FRkeyModeChar <> 'D')
then Halt; (* emergency trap sanity *)
(*---------------------*)
(* Turbo Pascal Search *)
if FRkeyModeChar = 'T' then
begin
IF fWord < key[mid] (**)
then
begin
high := mid - 1 ;
end
else
IF fWord > key[mid] (**)
then
begin
low := mid + 1;
end
else
begin
fFindInReserve := true;
goto Return; (* flakey exit ! *)
end;
end;
(* Turbo Pascal Search *)
(*--------------*)
(* dBASE search *)
if FRkeyModeChar = 'D' then
begin
(* prep reference string *) (* leftstring method *)
KeyRefStr := copy(Key[mid],1,length(fWord)); (**)
IF fWord < KeyRefStr (**) (* leftstring method *)
then
begin
high := mid - 1 ;
end
else
IF fWord > KeyRefStr (**) (* leftstring method *)
then
begin
low := mid + 1;
end
else
begin
fFindInReserve := true;
goto Return; (* flakey exit ! *)
end;
end;
(* dBASE search *)
end;
(* WHILE *)
fFindInReserve := false;
Return: (* label *)
End; (* procedure pFindInReserve *)
(*------------------------------*)
(* sub procedure of pBuildTree *)
procedure pEnterTree
(var subtree: treepointer; Word : alfa; line :counter);
var
nextitem : Queuepointer;
begin
IF subtree=nil then
begin {create a new entry}
new(subtree);
WITH subtree^ do
begin
left := nil;
right := nil;
WITH entry do
begin
Wordvalue := Word;
new(FirstInQueue);
LastinQueue := FirstInQueue;
WITH FirstInQueue^ do
begin
linenumber := line;
NextInQueue := nil;
end; {with FirstInQueue}
end; {with entry}
end; {with subtree}
end {create a new entry}
ELSE {append a list item}
WITH subtree^, entry do
IF Word=Wordvalue then
begin
IF lastinQueue^.linenumber <> line then
begin
new(nextitem);
WITH Nextitem^ do
begin
linenumber := line;
NextInQueue := nil;
end;{WITH}
lastinQueue^.NextInQueue := Nextitem;
lastinQueue := nextitem;
end;
end (* if *)
ELSE
IF Word < Wordvalue
then pEnterTree(left,Word,line)
ELSE
pEnterTree(right,Word,line);
end; {pEnterTree}
(*$W2*)
(*---------------------------*)
(* sub procedure of pGetLine *)
procedure pReadChar
({updating} var nextchar : charinfo; {returning}var currchar : charinfo );
var
Look : char; { Character read in from File }
RKeyModeChar : string1 ;
begin (*+++> File status module. <+++*)
(* Stores file status "AFTER" a read.
(* NOTE this play on words - after one char is
(* actually "PRIOR TO" the next character *)
IF xeoln then
begin
LineInLast := LineIn;
IF (not EOF(fin)) then
begin
readln(fin, LineIn);
cp := 0;
xeoln := false;
end
else
xeof := true;
end;
IF cp >= length(LineIn) then
begin
xeoln := true;
xeof := EOF(fin);
Look := ' ';
end
else
begin
cp := cp + 1;
Look := LineIn[cp];
End;
{+++ current operative character module +++}
currchar := nextchar;
{+++ ClassIFy the character just read +++}
WITH nextchar
do
begin { the Look-ahead character name module }
IF xeof
then name := FileMark
ELSE
IF xeoln
then name := EndofLine
ELSE
IF Look IN ['a'..'z']
then {lower case plus}
name := lletter
ELSE
IF Look IN ['^','$','y','A'..'Z']
then {upper case} name := uletter
ELSE
IF Look IN ['0'..'9']
then {digit} name := digit
ELSE
IF Look = ''''
then name := quote
ELSE
IF Look = TabChar
then name := aTabChar
ELSE
IF Look = space
then name := blank
ELSE
name := otherchar;
CASE name of{ store character value module } EndofLine,
FileMark:
Valu := space;
lletter:
Valu := upcase(look); { Cnvrt to uppcase }
ELSE
valu := look;
end { case name of };
End { Look-ahead character name module };
end; {of pReadChar}
(*-----------------------------*)
(* sub procedure of pBuildTree *)
procedure pGetLine( var fbuffer : GenStr );
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
{+ Get a line of text into users buffer. +}
{+ Flushes comment lines: +}
{+ Flushes lines of Literals: 'this is it' +}
{+ Ignores special characters & Tabs: +}
{+ Recognizes End of File and End of Line. +}
{+ +}
{+GLOBAL +}
{+ flushing : (KNOT, DBL, STD, LIT, SCANFN); +}
{+ LLmax = 0..Max Line length; +}
{++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
var
state : (scanning, terminal, overflow);
SawDot : boolean;
GKeyModeChar : string1;
begin { pGetLine }
fbuffer := '';
fname := '';
FatalErrorStatus := false;
state := scanning;
REPEAT
(* CALL *)
pReadChar(nextchar, currchar);
IF (length(fbuffer) >= LLmax) then { exceeded length of buffer }
begin{ reset EOLN }
FatalErrorStatus := true;
state := overflow;
fbuffer := '';
write(bell);
writeln('EXCEEDED LENGTH OF INPUT BUFFER');
end
ELSE
begin
IF (currchar.name IN [FileMark,EndofLine])
then state:=terminal { end of line or end of file };
CASE flushing of
KNOT:
CASE currchar.name of
lletter, uletter, digit, blank:
begin{ store }
fbuffer := concat(FBUFFER,CURRCHAR.VALU) ;
end;
aTabChar, quote, otherchar:
begin{ Flush comments -convert
TabChars & other chars to spaces }
IF (currchar.valu='(')
and (nextchar.valu='*')
then flushing := DBL
ELSE
IF (currchar.valu='{')
then flushing := STD
ELSE
IF currchar.name=quote
then flushing := LIT;
{ convert to a space }
fbuffer := concat(fbuffer,GapChar);
end;
ELSE { end of line -or- file mark }
fbuffer := concat(fbuffer,currchar.valu)
end{ case currchar name of };
DBL:
{ scanning for a closing - double comment }
IF (currchar.valu ='*')
and (nextchar.valu =')')
then flushing := KNOT;
STD:
begin { scanning for a closing curley }
IF currchar.valu = '}'
then flushing := KNOT;
{ Check IF incl }
IF (currchar.valu = '$')
and (nextchar.valu = 'I')
then flushing := SCANFN;
end;
LIT: { scanning for a closing quote }
IF currchar.name = quote
then flushing := KNOT;
SCANFN:
IF (nextchar.valu<>' ')
and (nextchar.valu<>TabChar) then
begin
flushing := SCANFN2;
SawDot := false;
end;
SCANFN2:
IF (currchar.valu in ['A'..'Z','0'..'9','.']) then
begin
fname := concat(fname, currchar.valu);
IF currchar.valu = '.'
then SawDot := true;
end
ELSE
begin
IF length(fname) = 0
then { Make sure we ignore $I-}
doInclude := false { compiler directive }
else
begin
IF not SawDot
then fname := Concat(fname, '.PAS');
doInclude := true;
end;
flushing := STD;
end;
end { flushing case }
end { ELSE }
UNTIL (state<>scanning);
end; {of pGetLine}
(*-----------------------------*)
(* sub procedure of pBuildTree *)
procedure pReadWord( RWkeyModeChar : string1 );
{++++++++++++++++++++++++++++++++++++++++++++++++}
{+ +}
{+ Analyze the Line into "words" +}
{+ +}
{++++++++++++++++++++++++++++++++++++++++++++++++}
LABEL 1;
var
ix, {temp indexer}
idlen, {length of the word}
Cpos : BYTE; { Current Position pointer }
FindInReserve : boolean; (* logic for Search *)
begin{ pReadWord }
Cpos := 1; { start at the beginning of a line }
WHILE Cpos < length(fbuffer) do
begin {Cpos<length(fbuffer)}
WHILE (Cpos < length(fbuffer))
and (fbuffer[Cpos]=space)
do
Cpos:=Cpos + 1; {--- skip spaces ---}
idlen := 0;
WHILE (Cpos < length(fbuffer))
and (fbuffer[Cpos ] <> space)
do
begin{ accept only non-spaces }
IF idlen < MaxWordlen then
begin
idlen := idlen + 1;
CurrentWord[idlen] := fbuffer[Cpos];
end;
Cpos := Cpos +1;
end { WHILE };
CurrentWord[0] := chr(idlen);
IF length(CurrentWord)=0 (* no word was found *)
then GOTO 1; (* label *)
(* function binary search for CurrentWord *)
(* returns logic FindInReserve for CurrentWord *)
(* uses string1 IKeyModeChar during search *)
pFindInReserve
( CurrentWord, FindInReserve, RWkeyModeChar );
IF ( not FindInReserve)
and (not (CurrentWord[1] in ['0'..'9'])) (* not num.const *)
then
begin
(* Glen Ellis utility tracer *)
IF XrefTrace then write(currentword,':'); (**)
(* Required by program ! *)
pEnterTree(tree,CurrentWord,Currentline);
end;
1: (* label *)
{Here is no word <length of word=0>};
end; { WHILE Cpos<length(fbuffer) }
end; { of pReadWord }
(*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
(* *)
(* Primary procedure >> BuildTree << *)
(* *)
(*++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
begin (* primary procedure BuildTree *)
flushing := KNOT { flushing } ;
doInclude := false;
xeoln := true;
xeof := false;
LineIn := '';
ASSIGN(fin,InFile);
RESET(fin);
IF IOresult <> 0 then
begin
write(BELL);
writeln('File ',InFile,' not found !!!!!!');
FatalErrorStatus := true;
end;
nextchar.name := blank; { Initialize next char to a space }
nextchar.valu := space;
pReadChar
({update} nextchar, { Initialize current char to space }
{returning} currchar);
{ First char from file in nextchar }
write ('.');
WHILE ((currchar.name<>filemark)
and (not FatalErrorStatus))
do
begin
Currentline := Currentline + 1;
pGetLine(fbuffer); (* Attempt to Read the First Line *)
(* currentline:4 will be truncated at 9,999 lines *)
writeln(Fout, Currentline,': ',LineInLast); (**)
IF listing
then
begin;
writeln; (**) (* closes print line of new xref words *)
writeln(Currentline,': ',LineInLast);
end
else
begin
IF (CurrentLine mod 50) = 0
then writeln(' ',Currentline:0,' lines read');
write ('.');
end;
(* else IF (Currentline mod 100) = 0 then *)
(* writeln('ON LINE : ',Currentline:0); *)
pReadWord(BTkeyModeChar);
(* Analyze the Text into single 'words' *)
IF doInclude then
begin
pBuildTree(tree, fname, BTkeyModeChar);
(* recursively do include *)
doInclude := false;
end;
end; {While}
close(fin);
writeln (' ',Currentline:0,' total lines read');
end; { of pBuildTree } { CLOSE(PRNyID); }
(*----------------------------------------------------------------------*)
