{Produce a listing of procedure calls -- who calls whom} program procref; type wordtype = string[8]; itemp = ^item; item = record w: wordtype; left, right: itemp; end; strptr = ^string; var idstart, idset: set of char; word: wordtype; line: string[132]; lptr: integer; fin, fout: text; t: itemp; strp: strptr; lower: array [char] of char; done: boolean; fresult: integer; external function g2text(var str: string; var inf, outf: text): boolean; external function @cmd: strptr; procedure getword; var wlen: integer; ch: char; begin {get a word from input line} wlen := 0; word := ''; while (lptr <= length(line)) and (not (line[lptr] in idstart)) do lptr := lptr + 1; {scan to first identifier} while (lptr <= length(line)) and (line[lptr] in idset) do begin {copy identifier} ch := lower[line[lptr]]; {uniform case} if (ch <> '_') and (wlen < 8) then begin {omit underscore, stop at 8 chars} wlen := wlen + 1; word[wlen] := ch end; lptr := lptr + 1; end; word[0] := chr(wlen); {update word length} end; {getword} procedure init; var i: char; begin {initialize variables} idstart := ['A'..'Z', 'a'..'z', '@', '_']; idset := idstart + ['0'..'9']; for i := chr(0) to chr(127) do lower[i] := i; for i := 'A' to 'Z' do lower[i] := chr(ord(i) + $20); t := nil; end; {init} procedure saveword; var x, y: itemp; found, less: boolean; begin {search for word in binary tree, add it if not already there} if t = nil then begin {first entry} new(t); t^.w := word; t^.left := nil; t^.right := nil; end else begin {all subsequent entries} x := t; found := false; while (x <> nil) and (not found) do begin y := x; {previous entry} if word < x^.w then {search left subtree} begin x := x^.left; less := true end else if word > x^.w then {search right subtree} begin x := x^.right; less := false end else {got it} found := true end; if not found then begin new(x); if less then y^.left := x else y^.right := x; x^.w := word; x^.left := nil; x^.right := nil; end; end; end; {saveword} function is_saved: boolean; var x: itemp; found: boolean; begin {determine whether word is in binary tree} found := false; x := t; while (x <> nil) and (not found) do if word < x^.w then x := x^.left else if word > x^.w then x := x^.right else found := true; is_saved := found end; {is_saved} begin {procref} strp := @cmd; {get commmand line} line := strp^; if not g2text(line, fin, fout) then exit; {open files if possible} init; while not eof(fin) do begin readln(fin, line); lptr := 1; getword; if word = 'external' then getword; if (word = 'procedur') or (word = 'function') or (word = 'program') then begin getword; saveword end; end; writeln('End of pass 1'); reset(fin); if ioresult = 255 then begin writeln('Unable to reset input file'); exit end; while not eof(fin) do begin readln(fin, line); lptr := 1; getword; done := false; while (length(word) > 0) and (not done) do begin if is_saved then begin writeln(fout, line); done := true end else getword end end; close(fout, fresult); if fresult = 255 then writeln('Unable to close output file'); end {procref} .