(***************************************************) (*-------> 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 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 }; end; { WHILE Cpos> 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); } (*----------------------------------------------------------------------*)