{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}  .
