  program tree (input,output,rfile,trefile);


CONST

  b6='      ';
  delimiter='-';

TYPE

  linetype=PACKED ARRAY [1..132] OF char;
  stringtype=PACKED ARRAY [1..6] OF char;
  nametype=PACKED ARRAY [1..30] OF char;

VAR

  separator:linetype;
  inname,outname:nametype;
  line:linetype;
  title,string0,string1,string2:stringtype;
  rfile,trefile,odlfile:text;
  okay,done,odlflag:boolean;
  pagecount,linecount,lindex,index,i,count,j,k:integer;


  PROCEDURE detach;FORTRAN;



  PROCEDURE treeprint;

  CONST

    maxnumtable=18   (*  270 FLAGS  *);
    maxnumsymbols=270;
    tab3='   ';

  TYPE

    symboltype=RECORD
		 name:stringtype;
		 flag,level:integer;
		 table:ARRAY [1..maxnumtable] OF integer;
	       END;
    link=^symbollist;
    symbollist=RECORD
		 number:integer;
		 up,cross,bud:link;
	       END;


  VAR

    sympointer:ARRAY [1..maxnumsymbols] OF link;
    symbol:ARRAY [1..maxnumsymbols] OF symboltype;
    tabcount,k,symcount:integer;
    newsym,first:boolean;
    laststring:stringtype;
    start,leaf,tip,branch,root:link;
    l,p,q,maxlevel:integer;
    tally:ARRAY [1..maxnumsymbols] OF integer;
    bit:ARRAY [1..15] OF integer;
    saveflag:ARRAY [1..maxnumsymbols] OF integer;
    tab:ARRAY [1..3] OF char;


    (*$D-*)
    PROCEDURE getbitflag (i,j:integer;  VAR q:integer);

    VAR

      n,m:integer;

     BEGIN
       WITH symbol[j] DO
	BEGIN
	  n:=( (i-1) DIV 15 ) + 1;
	  m:=i - 15*(n - 1);
	  q:=table[n] AND bit[m];
	  IF q<>0
	   THEN q:=1;
	END;
     END;




    PROCEDURE grow (k:integer; root:link);

      (*  extend tips and branches of tree  *)

    VAR

      tip:link;
      i,j:integer;

     BEGIN  (*  grow  *)
       IF symbol[k].level>0
	THEN
	 BEGIN
	   tip:=NIL;
	   FOR i:=1 TO symcount DO
	    BEGIN
	      getbitflag(i,k,q);
	      IF q=1
	       THEN
	       IF symbol[i].level=(symbol[k].level + 1)
		THEN
		 BEGIN
		   IF sympointer[i]=NIL
		    THEN new(leaf)
		    ELSE leaf:=sympointer[i];
		   leaf^.number:=i;
		   leaf^.cross:=NIL;
		   leaf^.up:=NIL;
		   leaf^.bud:=NIL;
		   sympointer[i]:=leaf;
		   IF tip=NIL
		    THEN root^.up:=leaf
		    ELSE tip^.cross:=leaf;
		   tip:=leaf;
		   grow(i,tip);
		 END;
	    END;
	 END;
     END(*   grow   *);




    PROCEDURE getposition (string:stringtype; VAR k:integer);

     BEGIN  (*   GETPOSITION   *)
       k:=0;
	REPEAT
	 k:=k + 1;
	UNTIL string=symbol[k].name;
     END(*   GETPOSITION   *);




    (*$D+*)
    PROCEDURE placebud (i,k:integer);

      (*  put floators into tree  *)

    VAR

      j,n:integer;
      done:boolean;

     BEGIN (*  placebud  *)
       root:=sympointer[k];
       leaf:=sympointer[i];
       tip:=root^.up;
       IF tip=NIL
	THEN
	root^.up:=leaf
	ELSE
	 BEGIN
	   branch:=tip^.cross;
	   IF branch=NIL
	    THEN
	     BEGIN
	       j:=tip^.number;
	       getbitflag(i,j,q);
	       IF q=1
		THEN placebud(i,j)
		ELSE tip^.cross:=leaf;
	     END
	    ELSE
	     BEGIN
	       p:=0;
	       done:=false;
	       WHILE NOT done DO
		BEGIN
		  j:=tip^.number;
		  getbitflag(i,j,q);
		  IF q=1
		   THEN
		    BEGIN
		      p:=p + 1;
		      n:=tip^.number;
		    END;
		  IF tip^.cross=NIL
		   THEN done:=true
		   ELSE
		    BEGIN
		      branch:=tip^.cross;
		      tip:=branch;
		    END;
		END;

	       IF p>1
		THEN
		IF root^.bud=NIL
		 THEN root^.bud:=leaf
		 ELSE
		  BEGIN
		    tip:=root^.bud;
		    root^.bud:=leaf;
		    leaf^.bud:=tip;
		  END;
	       IF p=0
		THEN
		 BEGIN
		   tip:=root^.up;
		   branch:=tip^.cross;
		   tip^.cross:=leaf;
		   leaf^.cross:=branch;
		 END;
	       IF p=1
		THEN placebud(i,n);
	     END;
	 END;
     END(*  placebud  *);





    (*$D-*)
    PROCEDURE setbitflag (i,j:integer);

    VAR

      n,m:integer;

     BEGIN
       WITH symbol[j] DO
	BEGIN
	  n:=( (i-1) DIV 15 ) + 1;
	  m:=i - 15*(n - 1);
	  table[n]:=table[n] OR bit[m];
	END;
     END;




    PROCEDURE buildtable;


     BEGIN  (*   buildtable   *)

       (*   set bit flags=1 for all routines referenced by each routine   *)

       reset(rfile);
       readln(rfile,string1,string2);

	REPEAT

	 IF string1<>string2
	  THEN
	   BEGIN
	     getposition(string1,i);
	     getposition(string2,j);
	     setbitflag(j,i);
	   END;
	 readln(rfile,string1,string2);

	UNTIL eof(rfile);



       FOR i:=1 TO symcount DO
	BEGIN
	  tally[i]:=0;
	  FOR j:=1 TO symcount DO
	   BEGIN
	     getbitflag(i,j,q);
	     tally[i]:=tally[i] + q;
	   END;
	END;

       FOR i:=1 TO symcount DO
       IF tally[i]=0
	THEN
	 BEGIN
	   symbol[i].flag:=1;
	   symbol[i].level:=1;
	 END;


       FOR l:=1 TO 14 DO  (*  for each level  *)
       FOR i:=1 TO symcount DO  (*  for each symbol  *)
       IF (symbol[i].flag AND bit[l])=bit[l]
	THEN
	FOR j:=1 TO symcount DO  (*  for each flag  *)
	 BEGIN
	   getbitflag(j,i,q);
	   IF q=1
	    THEN WITH symbol[j] DO
	    IF (flag AND bit[l+1])=bit[l+1]
	     THEN level:=level OR bit[l+1]
	     ELSE flag:=flag OR bit[l+1];
	 END;


        (*  convert flag bit patterns to integer level numbers
         and set level=-1 if more than one bit is set or if
	 the same bit was flagged more than once  *)

       FOR i:=1 TO symcount DO
       IF (symbol[i].level=0) OR (symbol[i].level=2)
	THEN
	 BEGIN
	   IF symbol[i].flag<>0
	    THEN WITH symbol[i] DO
	     BEGIN
	       p:=0;
	       FOR j:=1 TO 15 DO
	       IF (flag AND bit[j])=bit[j]
		THEN p:=p + 1;
	       IF p=1
		THEN
		 BEGIN
		   FOR j:=1 TO 15 DO
		   IF (flag AND bit[j])=bit[j]
		    THEN level:=j;
		 END
		ELSE level:=-1;
	     END;
	 END
	ELSE
	IF symbol[i].level<>1
	 THEN
	 symbol[i].level:=-1;


	 (*  set flags for routines that are ultimately called by each routine  *)

       FOR i:=1 TO 15 DO
	BEGIN
	  l:=15 - i + 1  (*  high to low order  *);
	  FOR j:=1 TO symcount DO
	  IF (symbol[j].flag AND bit[l])=bit[l]
	   THEN
	    BEGIN
	      FOR p:=1 TO symcount DO
	       BEGIN
		 getbitflag(p,j,q);
		 IF q=1
		  THEN
		  FOR q:=1 TO maxnumtable DO
		  WITH symbol[j] DO
		  table[q]:=table[q] OR symbol[p].table[q];
	       END;
	    END;
	END;
       (*  define floators as routines that don't call anything  *)

       FOR i:=1 TO symcount DO
       IF symbol[i].level<>1
	THEN
	 BEGIN
	   p:=0;
	   FOR j:=1 TO symcount DO
	    BEGIN
	      getbitflag(j,i,q);
	      IF q=1
	       THEN p:=p + 1;
	    END;
	   IF p=0
	    THEN symbol[i].level:=-2;
	 END;



     END(*   buildtable  *);




    PROCEDURE printtree (tip:link);

    VAR

      next:link;

     BEGIN  (*  printtree  *)
       tabcount:=tabcount + 1;
       i:=tip^.number;
       write(trefile,(tabcount-2):2);
       FOR j:=1 TO (tabcount - 2) DO write(trefile,tab3);
       IF symbol[i].level=1
	THEN write(trefile,tab3)
	ELSE write(trefile,tab);
       IF symbol[i].level=-2
	THEN write(trefile,'- *')
	ELSE write(trefile,'-  ');
       write(trefile,symbol[i].name);

       (*  print buds  *)

       next:=tip^.bud;
       j:=0;
       WHILE next<>NIL DO
	BEGIN
	  i:=next^.number;
	  IF (3*tabcount + 9*j + 6)>121
	   THEN
	    BEGIN
	      writeln(trefile);
	      FOR j:=1 TO (tabcount + 2) DO write(trefile,tab3);
	      write(trefile,'  ');
	      j:=0;
	    END;
	  IF symbol[i].level=-2
	   THEN write(trefile,'- *')
	   ELSE write(trefile,'-  ');
	  write(trefile,symbol[i].name);
	  j:=j + 1;
	  next:=next^.bud;
	END(*  while next  *);

       writeln(trefile);



       (*  print upward branch  *)

       next:=tip^.up;
       IF next<>NIL
	THEN printtree(next);

	(*  print cross branch  *)

       next:=tip^.cross;
       IF next<>NIL
	THEN
	 BEGIN
	   tabcount:=tabcount - 1;
	   printtree(next);
	   tabcount:=tabcount + 1;
	 END;
       tabcount:=tabcount - 1;
     END(*  printtree  *);



    PROCEDURE printodl (tip:link);

    VAR

      start,next:link;
      first:boolean;

     BEGIN  (*  printODL  *)
       i:=tip^.number;
       write(odlfile,'Y',i:1,':',chr(9),'.FCTR',chr(9),'Z',i:1);

       (*  print buds  *)

       next:=tip^.bud;
       j:=0;
       WHILE next<>NIL DO
	BEGIN
	  i:=next^.number;
	  IF (5*j + 20)>70
	   THEN
	    BEGIN
	      writeln(odlfile,'-Y',(i+300):1);
	      write(odlfile,'Y',(i+300):1,':',chr(9),'.FCTR',chr(9),'Z',i:1);
	      j:=0;
	    END
	   ELSE
	   write(odlfile,'-Z',i:1);
	  j:=j + 1;
	  next:=next^.bud;
	END(*  while next  *);


       (*  print upward overlays  *)

       next:=tip^.up;
       IF next<>NIL
	THEN
	 BEGIN
	   start:=next;
	   first:=true;
	   i:=next^.number;
	   IF symbol[tip^.number].level=1
	    THEN
	     BEGIN
	       write(odlfile,'-F4P-SYS');
	       j:=j + 2;
	     END;
	   write(odlfile,'-*(Y',i:1);
	   j:=j + 1;
	   next:=next^.cross;
	   WHILE next<>NIL DO
	    BEGIN
	      i:=next^.number;
	      IF (5*j + 20)>70
	       THEN
		BEGIN
		  write(odlfile,',Y',(i+300):1);
		  IF first
		   THEN writeln(odlfile,')')
		   ELSE writeln(odlfile);
		  first:=false;
		  write(odlfile,'Y',(i+300):1,':',chr(9),'.FCTR',chr(9),'Y',i:1);
		  j:=0;
		END
	       ELSE
	       write(odlfile,',Y',i:1);
	      j:=j + 1;
	      next:=next^.cross;
	    END;
	   IF first
	    THEN
	    writeln(odlfile,')')
	    ELSE writeln(odlfile);
	   j:=0;
	   next:=start;
	   WHILE next<>NIL DO
	    BEGIN
	      printodl(next);
	      next:=next^.cross;
	    END;
	 END
	ELSE
	IF symbol[tip^.number].level=1
	 THEN writeln(odlfile,'-F4P-SYS')
	 ELSE writeln(odlfile);

     END(*  printODL  *);



   BEGIN (*  treeprint  *)

     FOR i:=1 TO 132 DO separator[i]:=delimiter;
     writeln(trefile,'LEVEL      SYMBOLS');
     writeln(trefile,separator);
     tab[1]:=' ';
     tab[2]:=' ';
     tab[3]:=chr(124);
     FOR i:=1 TO maxnumsymbols DO sympointer[i]:=NIL;
     symcount:=0;
     j:=1;
     FOR i:=1 TO 15 DO
      BEGIN
	bit[i]:=j;
	j:=j*2;
      END;

     (*   INITIALIZE SYMBOL TABLE   *)

     FOR i:=1 TO maxnumsymbols DO
      BEGIN
	WITH symbol[i] DO
	 BEGIN
	   name:=b6;
	   level:=0;
	   flag:=0;
	   FOR j:=1 TO maxnumtable DO  table[j]:=0;
	 END;
      END;

     (*   BUILD SYMBOL.NAMES   *)

     readln(rfile,string1,string2);
      REPEAT
       FOR j:=1 TO 2 DO
	BEGIN
	  string0:=string1;
	  IF j=2
	   THEN string0:=string2;
	  newsym:=true;
	  IF symcount<>0
	   THEN
	   FOR i:=1 TO symcount DO
	   IF string0=symbol[i].name
	    THEN newsym:=false;
	  IF newsym
	   THEN
	    BEGIN
	      symcount:=symcount + 1;
	      symbol[symcount].name:=string0;
	    END;

	END;
       readln(rfile,string1,string2);

      UNTIL eof(rfile);

       (*   BUILD TABLE   *)

     buildtable;


     (*
      writeln('NAME  LEVEL  FLAG  TABLE');
      FOR i:=1 TO symcount DO
      WITH symbol[i] DO
      BEGIN
      write(name,level,flag);
      FOR j:=1 TO 5 DO write(table[j]:5);
      writeln;
      END;
      *)


     FOR i:=1 TO symcount DO saveflag[i]:=symbol[i].flag;


     (*   LOCATE UNREFERENCED SYMBOLS AND BUILD A TREE WITH EACH ONE   *)

     IF odlflag
      THEN
       BEGIN
	 j:=0;
	 first:=true;
	 write(odlfile,chr(9),'.ROOT',chr(9));
	 FOR i:=1 TO symcount DO
	 IF symbol[i].level=1
	  THEN
	   BEGIN
	     IF (5*j + 20)>70
	      THEN
	       BEGIN
		 writeln(odlfile,',Y',(i+300):1);
		 write(odlfile,'Y',(i+300):1,':',chr(9),'.FCTR',chr(9),'Y',i:1);
		 j:=0;
	       END
	      ELSE
	      IF first
	       THEN
		BEGIN
		  first:=false;
		  write(odlfile,'Y',i:1);
		END
	       ELSE
	       write(odlfile,',Y',i:1);
	     j:=j + 1;
	   END;
	 writeln(odlfile);
       END;


     FOR k:=1 TO symcount DO  (*  for each root  *)
     IF symbol[k].level=1
      THEN
       BEGIN
	 (*  define root  *)

	 new(leaf);
	 start:=leaf;
	 root:=leaf;
	 root^.number:=k;
	 sympointer[k]:=root;

	 (*  DELETE PREVIOUS TREE CONNECTIONS  *)

	 FOR i:=1 TO symcount DO
	 IF sympointer[i]<>NIL
	  THEN WITH sympointer[i]^ DO
	   BEGIN
	     tip:=NIL;
	     bud:=NIL;
	     cross:=NIL;
	   END;



	  (*  recursively define all branches of co-tree  *)

	 grow(k,root);


	 (*   PLACE ALL FLOATORS IN TREE AT OPTIMUM POINT   *)

	 maxlevel:=0;
	 FOR i:=1 TO symcount DO
	  BEGIN
	    FOR l:=1 TO 15 DO
	    IF (symbol[i].flag AND bit[l])=bit[l]
	     THEN
	     IF l>maxlevel
	      THEN maxlevel:=l;
	  END;


	 FOR l:=2 TO maxlevel DO
	  BEGIN
	    FOR i:=1 TO symcount DO
	     BEGIN
	       getbitflag(i,k,q);
	       IF q=1
		THEN
		IF (symbol[i].level<=0) AND ( (symbol[i].flag AND bit[l])=bit[l] )
		 THEN
		  BEGIN
		    IF sympointer[i]=NIL
		     THEN new(leaf)
		     ELSE leaf:=sympointer[i];
		    leaf^.number:=i;
		    leaf^.cross:=NIL;
		    leaf^.up:=NIL;
		    leaf^.bud:=NIL;
		    symbol[i].flag:=0;
		    sympointer[i]:=leaf;
		    placebud(i,k);
		  END;
	     END;
	  END;


	 FOR i:=1 TO symcount DO symbol[i].flag:=saveflag[i];





	 (*   RECURSIVELY PRINT THE WHOLE TREE   *)

	 tip:=start;
	 tabcount:=2;
	 printtree(tip);
	 writeln(trefile);
	 writeln(trefile,separator);
	 writeln(trefile);
	 writeln(trefile);
	 IF odlflag
	  THEN
	  printodl(tip);



       END;

     writeln(trefile);
     writeln(trefile);
     writeln(trefile,'* - routine has no external calls');
     FOR i:=1 TO symcount DO
      BEGIN
	IF odlflag
	 THEN
	 writeln(odlfile,'Z',i:1,':',chr(9),'.FCTR',chr(9),'ULIB/LB:',symbol[i].name);
	IF sympointer[i]=NIL
	 THEN
	  BEGIN
	    writeln('symbol  ',symbol[i].name,'  not placed.');
	    writeln(trefile,'symbol  ',symbol[i].name,'  not placed.');
	  END;
      END;

     IF odlflag
      THEN
       BEGIN
	 writeln(odlfile,'SYS:',chr(9),'.FCTR',chr(9),'F4P-LB:[1,1]SYSLIB/DL');
	 writeln(odlfile,'F4P:',chr(9),'.FCTR',chr(9),'LB:[1,1]F4POTS/LB');
	 writeln(odlfile,chr(9),'.END');
       END;
   END
    (*   TREEPRINT   *);



 BEGIN  (*   TREE   *)
   detach;
   reset(rfile,'SY:ZZREF.RTP');
   rewrite(trefile,'SY:ZZREF.TRE');
   odlflag:=true;
   IF odlflag
    THEN rewrite(odlfile,'SY:ZZREF.ODL');
   treeprint;
   close(trefile);
   IF odlflag
    THEN close(odlfile);
 END.
