reduce-historical/r38/packages/misc/rcref.red

module rcref; % Cross reference program.

% Author: Martin L. Griss, with modifications by Anthony C. Hearn.

% Requires REDIO and SORT support.

create!-package('(rcref redio),'(util));

fluid '(!*backtrace !*cref !*defn !*mode !*nocrefpri calls!* curfun!*
        dfprint!* globs!* locls!* toplv!*);

global '(undefg!* gseen!* btime!* expand!* haveargs!* notuse!* nolist!*
	dclglb!* entpts!* undefns!* seen!* tseen!* xseen!* op!*!* cloc!*
        pfiles!* curlin!* pretitl!* !*creftime !*saveprops maxarg!*
        !*crefsummary !*comp !*raise !*rlisp !*globals !*algebraics);

switch cref;

!*algebraics:='t; % Default is normal parse of algebraic.
!*globals:='t;  % Do analyze globals.
% !*rlisp:=nil;   % REDUCE as default.
maxarg!*:=15;   % Maximum args in Standard Lisp.


deflist('((anlfn procstat) (crflapo procstat)),'stat);

flag('(anlfn crflapo),'compile);

comment  EXPAND flag on these forces expansion of MACROS;

expand!* := '(for foreach repeat while);

nolist!* := nconc(for each j in slfns!* collect car j,nolist!*);

nolist!* := append('(and cond endmodule lambda list max min module or
                     plus prog prog2 progn putc switch times),
                   nolist!*);

flag ('(plus times and or lambda progn max min cond prog case list),
       'naryargs);

dclglb!*:='(!*comp emsg!* !*raise);

if not getd 'begin then
  flag('(rds deflist flag fluid global remprop remflag unfluid
           setq crefoff),'eval);

symbolic procedure crefon;
  begin btime!*:=time();
        dfprint!* := 'refprint;
        !*defn := t;
        if not !*algebraics then put('algebraic,'newnam,'symbolic);
        flag(nolist!*,'nolist);
        flag(expand!*,'expand);
        flag(dclglb!*,'dclglb);
%  Global lists.
        entpts!*:=nil;  % Entry points to package.
        undefns!*:=nil; % Functions undefined in package.
        seen!*:=nil;    % List of all encountered functions.
        tseen!*:=nil;   % List of all encountered types not flagged
                        % FUNCTION.
        gseen!*:=nil;   % All encountered globals.
        pfiles!*:=nil;  % Processed files.
        undefg!*:=nil;  % Undeclared globals encountered.
        curlin!*:=nil;  % Position in file(s) of current command.
        pretitl!*:=nil; % T if error or questionables found.
% Usages in specific function under analysis.
        globs!*:=nil;   % Globals refered to in this.
        calls!*:=nil;   % Functions called by this.
        locls!*:=nil;   % Defined local variables in this.
        toplv!*:=t;     % NIL if inside function body.
        curfun!*:=nil;  % Current function beeing analyzed.
        op!*!*:=nil;    % Current op. in LAP code.
        if not !*nocrefpri
          then setpage("  Errors or questionables",nil);
        if not getd 'begin then crefonlsp()   % In Lisp.
   end;

symbolic procedure undefdchk fn;
 if not flagp(fn,'defd) then undefns!* := fn . undefns!*;

symbolic procedure princng u;
   princn getes u;

symbolic procedure crefoff;
   % Main call, sets up, alphabetizes and prints.
   begin scalar tim,x;
        crefoff1();
        tim:=time()-btime!*;
        setpage("  Summary",nil);
        newpage();
        pfiles!*:=punused("Crossreference listing for files:",
                          for each z in pfiles!* collect cdr z);
        entpts!*:=punused("Entry Points:",entpts!*);
        undefns!*:=punused("Undefined Functions:",undefns!*);
        undefg!*:=punused("Undeclared Global Variables:",undefg!*);
        gseen!*:=punused("Global variables:",gseen!*);
        seen!*:=punused("Functions:",seen!*);
        for each z in tseen!* do
          <<rplacd(z,punused(list(car z," procedures:"),cdr z));
            x:='!( . nconc(explode car z,list '!));
            for each fn in cdr z do
             <<fn:=getes fn; rplacd(fn,append(x,cdr fn));
               rplaca(fn,length cdr fn)>> >>;
        if !*crefsummary then goto xy;
        if !*globals and gseen!* then
              <<setpage("  Global Variable Usage",1);
                newpage();
                for each z in gseen!* do cref6 z>>;
        if seen!* then cref52("  Function Usage",seen!*);
        for each z in tseen!* do
           cref52(list("  ",car z," procedures"),cdr z);
        setpage("  Toplevel calls:",nil);
        x:=t;
        for each z in pfiles!* do
         if get(z,'calls) or get(z,'globs) then
           <<if x then <<newpage(); x:=nil>>;
             newline 0; newline 0; princng z;
             spaces!-to 15; underline2 (linelength(nil)-10);
             cref51(z,'calls,"Calls:");
             if !*globals then cref51(z,'globs,"Globals:")>>;
  xy:   if !*saveprops then goto xx;
        rempropss(seen!*,'(gall calls globs calledby alsois sameas));
        remflagss(seen!*,'(seen cinthis defd));
        rempropss(gseen!*,'(usedby usedunby boundby setby));
        remflagss(gseen!*,'(dclglb gseen glb2rf glb2bd glb2st));
        for each z in tseen!* do remprop(car z,'funs);
%       for each z in haveargs!* do remprop(z,'number!-of!-args);
        haveargs!* := gseen!* := seen!* := tseen!* := nil;
  xx:   newline 2;
        if not !*creftime then return;
        btime!*:=time()-btime!*;
        setpage(" Timing Information",nil);
        newpage(); newline 0;
        prtatm " Total Time="; prtnum btime!*;
        prtatm " (ms)";
        newline 0;
        prtatm " Analysis Time="; prtnum tim;
        newline 0;
        prtatm " Sorting Time="; prtnum (btime!*-tim);
        newline 0; newline 0
  end;

symbolic procedure crefoff1;
   begin scalar x;
        dfprint!* := nil;
        !*defn := nil;
        if not !*algebraics
          then remprop('algebraic,'newnam);     % Back to normal.
         for each fn in seen!* do
         <<if null get(fn,'calledby) then entpts!*:=fn . entpts!*;
           undefdchk fn>>;
        tseen!*:=for each z in idsort tseen!* collect
         <<remprop(z,'tseen);
           for each fn in (x:=get(z,'funs)) do
            <<undefdchk fn; remprop(fn,'rccnam)>>;
           z.x>>;
        for each z in gseen!* do
         if get(z,'usedunby) then undefg!*:=z . undefg!*;
   end;

symbolic procedure punused(x,y);
 if y then
  <<newline 2; prtlst x; newline 0;
    lprint(y := idsort y,8); newline 0; y>>;

symbolic procedure cref52(x,y);
 <<setpage(x,1); newpage(); for each z in y do cref5 z>>;

symbolic procedure cref5 fn;
   % Print single entry.
   begin scalar x,y;
        newline 0; newline 0;
        prin1 fn; spaces!-to 15;
        y:=get(fn,'gall);
        if y then <<prin1 cdr y; x:=car y>>
         else prin2 "Undefined";
        spaces!-to 25;
        if flagp(fn,'naryargs) then prin2 "  Nary Args  "
         else if (y:=get(fn,'number!-of!-args)) then
          <<prin2 "  "; prin2 y; prin2 " Args  ">>;
        underline2 (linelength(nil)-10);
        if x then
          <<newline 15; prtatm "Line:"; spaces!-to 27;
            prtnum cddr x; prtatm '!/; prtnum cadr x;
            prtatm " in "; prtatm car x>>;
        cref51(fn,'calledby,"Called by:");
        cref51(fn,'calls,"Calls:");
        cref51(fn,'alsois,"Is also:");
        cref51(fn,'sameas,"Same as:");
        if !*globals then cref51(fn,'globs,"Globals:")
   end;

symbolic procedure cref51(x,y,z);
 if (x:=get(x,y)) then <<newline 15; prtatm z; lprint(idsort x,27)>>;

symbolic procedure cref6 glb;
   % Print single global usage entry.
      <<newline 0; prin1 glb; spaces!-to 15;
        notuse!*:=t;
        cref61(glb,'usedby,"Global in:");
        cref61(glb,'usedunby,"Undeclared:");
        cref61(glb,'boundby,"Bound in:");
        cref61(glb,'setby,"Set by:");
        if notuse!* then prtatm "*** Not Used ***">>;

symbolic procedure cref61(x,y,z);
   if (x:=get(x,y)) then
     <<if not notuse!* then newline 15 else notuse!*:=nil;
       prtatm z; lprint(idsort x,27)>>;

% Analyze bodies of LISP functions for functions called, and globals
% used, undefined.

smacro procedure flag1(u,v); flag(list u,v);

smacro procedure remflag1(u,v); remflag(list u,v);

smacro procedure isglob u;
 flagp(u,'dclglb);

smacro procedure chkseen s;
   % Has this name been encountered already?
        if not flagp(s,'seen) then
          <<flag1(s,'seen); seen!*:=s . seen!*>>;

smacro procedure globref u;
  if not flagp(u,'glb2rf)
   then <<flag1(u,'glb2rf); globs!*:=u . globs!*>>;

smacro procedure anatom u;
   % Global seen before local..ie detect extended from this.
   if !*globals and u and not(u eq 't)
      and idp u and not assoc(u,locls!*)
     then globref u;

smacro procedure chkgseen g;
 if not flagp(g,'gseen) then <<gseen!*:=g . gseen!*;
                            flag1(g,'gseen)>>;

symbolic procedure do!-global l;
  % Catch global defns.
  % Distinguish FLUID from GLOBAL later.
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <<for each v in l do chkgseen v; flag(l,'dclglb)>>;

put('global,'anlfn,'do!-global);

put('fluid,'anlfn,'do!-global);

symbolic anlfn procedure unfluid l;
   if pairp(l:=qcrf car l) and !*globals and toplv!* then
     <<for each v in l do chkgseen v; remflag(l,'dclglb)>>;

symbolic procedure add2locs ll;
  begin scalar oldloc;
   if !*globals then for each gg in ll do
      <<oldloc:=assoc(gg,locls!*);
        if not null oldloc then <<
           qerline 0;
           prin2 "*** Variable ";
           prin1 gg;
           prin2 " nested declaration in ";
           princng curfun!*;
           newline 0;
           rplacd(oldloc,nil.oldloc)>>
         else locls!*:=(gg . list nil) . locls!*;
        if isglob(gg) or flagp(gg,'glb2rf) then globind gg;
        if flagp(gg,'seen) then
          <<qerline 0;
            prin2 "*** Function ";
            princng gg;
            prin2 " used as variable in ";
            princng curfun!*;
            newline 0>> >>
  end;

symbolic procedure qerline u;
   if !*nocrefpri then nil
    else if pretitl!* then newline u
    else <<pretitl!*:=t; newpage()>>;

symbolic procedure globind gg;
  <<flag1(gg,'glb2bd); globref gg>>;

symbolic procedure remlocs lln;
   begin scalar oldloc;
    if !*globals then for each ll in lln do
      <<oldloc:=assoc(ll,locls!*);
        if null oldloc then
          if getd 'begin then rederr list(" Lvar confused",ll)
           else error(0,list(" Lvar confused",ll));
        if cddr oldloc then rplacd(oldloc,cddr oldloc)
         else locls!*:=efface1(oldloc,locls!*)>>
   end;

symbolic procedure efface1(u,v);
 if null v then nil
  else if u eq car v then cdr v
  else rplacd(v,efface1(u,cdr v));

symbolic procedure add2calls fn;
   % Update local CALLS!*.
   not flagp(fn,'cinthis) and
      <<if flagp(fn,'nolist) then xseen!* := fn . xseen!*
	 else calls!* := fn . calls!*;
	flag1(fn,'cinthis)>>;

symbolic procedure anform u;
   if atom u then anatom u else anform1 u;

symbolic procedure anforml l;
   begin
        while not atom l do <<anform car l; l:=cdr l>>;
        if l then anatom l
   end;

symbolic procedure anform1 u;
   begin scalar fn,x;
        fn:=car u; u:=cdr u;
        if not atom fn then return <<anform1 fn; anforml u>>;
        if not idp fn then return nil
         else if isglob fn then <<globref fn; return anforml u>>
         else if assoc(fn,locls!*) then return anforml u;
        add2calls fn;
        checkargcount(fn,length u);
        if flagp(fn,'noanl) then nil
         else if x:=get(fn,'anlfn) then apply1(x,u)
         else anforml u
   end;

symbolic anlfn procedure lambda u;
 <<add2locs car u; anforml cdr u; remlocs car u>>;

symbolic procedure anlsetq u;
 <<anforml u;
   if !*globals and flagp(u:=car u,'glb2rf) then flag1(u,'glb2st)>>;

put('setq,'anlfn,'anlsetq);

symbolic anlfn procedure cond u;
 for each x in u do anforml x;

symbolic anlfn procedure prog u;
 <<add2locs car u;
   for each x in cdr u do
    if not atom x then anform1 x;
   remlocs car u>>;

symbolic anlfn procedure function u;
 if pairp(u:=car u) then anform1 u
  else if isglob u then globref u
  else if null assoc(u,locls!*) then add2calls u;

flag('(quote go),'noanl);

symbolic anlfn procedure errorset u;
 begin scalar fn,x;
  anforml cdr u;
  if eqcar(u:=car u,'quote) then return ersanform cadr u
   else if not((eqcar(u,'cons) or (x:=eqcar(u,'list)))
               and quotp(fn:=cadr u))
    then return anform u;
  anforml cddr u;
  if pairp(fn:=cadr fn) then anform1 fn
   else if flagp(fn,'glb2rf) then nil
   else if isglob fn then globref fn
   else <<add2calls fn; if x then checkargcount(fn,length cddr u)>>
 end;

symbolic procedure ersanform u;
 begin scalar locls!*;
  return anform u
 end;

symbolic procedure anlmap u;
 <<anforml u;
   if quotp(u:=cadr u) and idp(u:=cadr u)
      and not isglob u and not assoc(u,locls!*)
     then checkargcount(u,1)>>;

for each x in '(map mapc maplist mapcar mapcon mapcan) do
 put(x,'anlfn,'anlmap);

symbolic anlfn procedure lispapply u;
 begin scalar fn;
  anforml cdr u;
  if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list)
    then checkargcount(fn,length cdr u)
 end;

symbolic anlfn procedure apply u;
 begin scalar fn;
  anforml cdr u;
  if quotp(fn:=cadr u) and idp(fn:=cadr fn) and eqcar(u:=caddr u,'list)
    then checkargcount(fn,length cdr u)
 end;

symbolic procedure quotp u; eqcar(u,'quote) or eqcar(u,'function);

put('cref ,'simpfg ,'((t (crefon)) (nil (crefoff))));

symbolic procedure outref(s,varlis,body,type);
 begin scalar curfun!*,calls!*,globs!*,locls!*,toplv!*,a;
  a:=if varlis memq '(anp!!atom anp!!idb anp!!eq anp!!unknown)
       then nil
      else length varlis;
  s := outrdefun(s,type,if a then a else get(body,'number!-of!-args));
  if a then <<add2locs varlis; anform(body); remlocs varlis>>
   else if null body or not idp body then nil
   else if varlis eq 'anp!!eq
    then <<put(s,'sameas,list body); traput(body,'alsois,s)>>
   else add2calls body;
  outrefend s
 end;

symbolic procedure traput(u,v,w);
 begin scalar a;
  if a:=get(u,v) then
    (if not(toplv!* or w memq a) then rplacd(a,w . cdr a))
   else put(u,v,list w)
 end;

smacro procedure toput(u,v,w);
 if w then put(u,v,if toplv!* then union(w,get(u,v)) else w);

symbolic procedure outrefend s;
  <<toput(s,'calls,calls!*);
    for each x in calls!* do
     <<remflag1(x,'cinthis);
        if not(x eq s) then <<chkseen x; traput(x,'calledby,s)>> >>;
    toput(s,'globs,globs!*);
    for each x in globs!* do
        <<traput(x,if isglob x then 'usedby
                    else <<chkgseen x; 'usedunby>>,s);
          remflag1(x,'glb2rf);
          if flagp(x,'glb2bd)
            then <<remflag1(x,'glb2bd); traput(x,'boundby,s)>>;
          if flagp(x,'glb2st)
            then <<remflag1(x,'glb2st); traput(x,'setby,s)>> >> >>;

symbolic procedure recref(s,type);
          <<qerline 2;
            prtatm "*** Redefinition to ";
            prin1 type;
            prtatm " procedure, of:";
            cref5 s;
            rempropss(list s,'(calls globs sameas));
            newline 2>>;

symbolic procedure outrdefun(s,type,v);
  begin
    s:=qtypnm(s,type);
    if flagp(s,'defd) then recref(s,type)
     else flag1(s,'defd);
    if flagp(type,'function) and (isglob s or assoc(s,locls!*)) then
      <<qerline 0;
        prin2 "**** Variable ";
        princng s;
        prin2 " defined as function";
        newline 0>>;
    if v and not flagp(type,'naryarg) then defineargs(s,v)
     else if flagp(type,'naryarg) and not flagp(s,'naryargs)
      then flag1(s,'naryargs);
    put(s,'gall,curlin!* . type);
    globs!*:=nil;
    calls!*:=nil;
    return curfun!*:=s
  end;

flag('(macro fexpr),'naryarg);

symbolic procedure qtypnm(s,type);
 if flagp(type,'function) then <<chkseen s; s>>
  else begin scalar x,y,z;
        if (y:=get(type,'tseen)) and (x:=atsoc(s,cdr y))
          then return cdr x;
        if null y then
          <<y:=list ('!( . nconc(explode type,list '!)));
            put(type,'tseen,y); tseen!* := type . tseen!*>>;
        x := compress (z := explode s);
        rplacd(y,(s . x) . cdr y);
        y := append(car y,z);
        put(x,'rccnam,length y . y);
        traput(type,'funs,x);
        return x
       end;

symbolic procedure defineargs(name,n);
  begin scalar calledwith,x;
    calledwith:=get(name,'number!-of!-args);
    if null calledwith then return hasarg(name,n);
    if n=calledwith then return nil;
    if x := get(name,'calledby) then instdof(name,n,calledwith,x);
    hasarg(name,n)
  end;

symbolic procedure instdof(name,n,m,fnlst);
  <<qerline 0;
    prin2 "***** ";
    prin1 name;
    prin2 " called with ";
    prin2 m;
    prin2 " instead of ";
    prin2 n;
    prin2 " arguments in:";
    lprint(idsort fnlst,posn()+1);
    newline 0>>;

symbolic procedure hasarg(name,n);
  <<haveargs!*:=name . haveargs!*;
    if n>maxarg!* then
           <<qerline 0;
             prin2 "**** "; prin1 name;
             prin2 " has "; prin2 n;
             prin2 " arguments";
             newline 0 >>;
    put(name,'number!-of!-args,n)>>;

symbolic procedure checkargcount(name,n);
  begin scalar correctn;
    if flagp(name,'naryargs) then return nil;
    correctn:=get(name,'number!-of!-args);
    if null correctn then return hasarg(name,n);
    if not(correctn=n) then instdof(name,correctn,n,list curfun!*)
  end;

symbolic procedure refprint u;
 begin scalar x,y;
% x:=if cloc!* then filemk car cloc!* else "*ttyinput*";
  x:=if cloc!* then car cloc!* else "*TTYINPUT*";
  if (curfun!*:=assoc(x,pfiles!*)) then
    <<x:=car curfun!*; curfun!*:=cdr curfun!*>>
   else <<pfiles!*:=(x.(curfun!*:=gensym())).pfiles!*;
          y:=reversip cdr reversip cdr explode x;
          put(curfun!*,'rccnam,length y . y)>>;
  curlin!*:=if cloc!* and cdr cloc!* then x . cdr cloc!* else nil;
  calls!*:=globs!*:=locls!*:=nil;
  anform u;
  outrefend curfun!*
 end;

symbolic procedure filemk u;
   % Convert a file specification from lisp format to a string.
   % This is essentially the inverse of MKFILE.
 begin scalar dev,name,flg,flg2;
  if null u then return nil
   else if atom u then name := explode2 u
   else for each x in u do
    if x eq 'dir!: then flg := t
     else if atom x then
      if flg then dev := '!< . nconc(explode2 x,list '!>)
       else if x eq 'dsk!: then dev:=nil
       else if !%devp x then dev := explode2 x
       else name := explode2 x
     else if atom cdr x then
      name := nconc(explode2 car x,'!. . explode2 cdr x)
     else <<flg2 := t;
            dev := '![ . nconc(explode2 car x,
                               '!, . nconc(explode2 cadr x,list '!]))>>;
  u := if flg2 then nconc(name,dev)
        else nconc(dev,name);
  return compress('!" . nconc(u,'(!")))
 end;

flag('(smacro nmacro),'cref);

symbolic anlfn procedure put u;
 if toplv!* and qcputx cadr u then anputx u
  else anforml u;

put('putc,'anlfn,get('put,'anlfn));

symbolic procedure qcputx u;
 eqcar(u,'quote) and (flagp(cadr u,'cref) or flagp(cadr u,'compile));

symbolic procedure anputx u;
 begin scalar nam,typ,body;
  nam:=qcrf car u;
  typ:=qcrf cadr u;
  u:=caddr u;
  if atom u then <<body:=qcrf u; u:='anp!!atom>>
   else if car u memq '(quote function) then
    if eqcar(u:=cadr u,'lambda) then <<body:=caddr u; u:=cadr u>>
     else if idp u then <<body:=u; u:='anp!!idb>>
     else return nil
   else if car u eq 'cdr and eqcar(cadr u,'getd) then
    <<body:=qcrf cadadr u; u:='anp!!eq>>
   else if car u eq 'get and qcputx caddr u then
    <<body:=qtypnm(qcrf cadr u,cadr caddr u); u:='anp!!eq>>
   else if car u eq 'mkcode then
    <<anform cadr u; u:=qcrf caddr u; body:=nil>>
   else <<body:=qcrf u; u:='anp!!unknown>>;
  outref(nam,u,body,typ)
 end;

symbolic anlfn procedure putd u;
 if toplv!* then anputx u else anforml u;

symbolic anlfn procedure de u;
 outdefr(u,'expr);

symbolic anlfn procedure df u;
 outdefr(u,'fexpr);

symbolic anlfn procedure dm u;
 outdefr(u,'macro);

symbolic anlfn procedure dn u;   % PSL function.
 outdefr(u,'macro);

symbolic anlfn procedure ds u;   % PSL function.
 outdefr(u,'smacro);

symbolic procedure outdefr(u,type);
 outref(car u,cadr u,caddr u,type);

symbolic procedure qcrf u;
 if null u or u eq t then u
  else if eqcar(u,'quote) then cadr u
  else <<anform u; compress explode '!?value!?!?>>;

flag('(expr fexpr macro smacro nmacro),'function);

endmodule;

end;