Check-ins Using Download Hex

Artifact a3cac14af651256562151cd104b792dbf4abea6f7ee02854fc689fe37c9226c8:

module redio; % General Purpose I/O package, sorting and positioning.

% Author: Martin L. Griss.

% Modified by: Anthony C. Hearn.

global '(!*formfeed lnnum!* maxln!* orig!* pgnum!* title!*);

% This module is functionally equivalent to the PSL file PSL-CREFIO.RED.

% FORMFEED (ON)  controls ^L or spacer of ====;

symbolic procedure initio();
% Set-up common defaults;
   begin
        !*formfeed:=t;
        orig!*:=0;
        lnnum!*:=0;
        linelength(75);
        maxln!*:=55;
        title!*:=nil;
        pgnum!*:=1;
   end;

symbolic procedure lposn();
   lnnum!*;

initio();

symbolic procedure setpgln(p,l);
  begin if p then maxln!*:=p;
        if l then linelength(l);
  end;

% We use EXPLODE to produce a list of chars from atomname,
% and TERPRI() to terminate a buffer..all else
% done in package..spaces,tabs,etc. ;

comment Character lists are (length . chars), for FITS;


symbolic  procedure getes u;
% Returns for U , EE=(Length . List of char);
   begin scalar ee;
        if not idp u then return<<ee:=explode u;length(ee).ee>>;
        if not(ee:=get(u,'rccnam)) then <<ee:=explode(u);
                                   ee:=length(ee) . ee;
                                   put(u,'rccnam,ee)>>;
        return ee;
   end;

% symbolic smacro procedure prtwrd u;
%   if numberp u then prtnum u else prtatm u;

symbolic procedure prtatm u;
        prin2 u;        % For a nice print;

symbolic procedure prtlst u;
 if atom u then prin2 u else for each x in u do prin2 x;

symbolic procedure prtnum n;
   % We use this kludge to defeat the new line that several LISPs
   % including PSL like to insert when printing a number near the line
   % boundary.
   for each x in explode2 n do prin2 x;

symbolic procedure princn ee;
% output a list of chars, update POSN();
         while (ee:=cdr ee) do prin2 car ee;

symbolic procedure spaces n; for i:=1:n do prin2 '!  ;

symbolic procedure spaces!-to n;
   begin scalar x;
        x := n - posn();
        if x<1 then newline n
         else spaces x;
   end;

symbolic procedure setpage(title,page);
% Initialise current page and title;
   begin
        title!*:= title ;
        pgnum!*:=page;
   end;

symbolic procedure newline n;
% Begins a fresh line at posn N;
   begin
        lnnum!*:=lnnum!*+1;
        if lnnum!*>=maxln!* then newpage()
         else terpri();
        spaces(orig!*+n);
   end;

symbolic procedure newpage();
% Start a fresh page, with PGNUM and TITLE, if needed;
   begin scalar a;
        a:=lposn();
        lnnum!*:=0;
        if posn() neq 0 then newline 0;
        if a neq 0 then formfeed();
        if title!* then
          <<spaces!-to 5; prtlst title!*>>;
        spaces!-to (linelength(nil)-4);
        if pgnum!* then <<prtnum pgnum!*; pgnum!*:=pgnum!*+1>>
         else pgnum!*:=2;
        newline 10;
        newline 0;
   end;

symbolic procedure underline2 n;
        if n>=linelength(nil) then
          <<n:=linelength(nil)-posn();
            for i:=0:n do prin2 '!- ;
            newline(0)>>
         else begin scalar j;
                j:=n-posn();
                for i:=0:j do prin2 '!-;
              end;

symbolic procedure lprint(u,n);
% prints a list of atoms within block LINELENGTH(NIL)-n;
   begin scalar ee; integer l,m;
        spaces!-to n;
        l := linelength nil-posn();
        if l<=0 then error(13,"WINDOW TOO SMALL FOR LPRINT");
        while u do
           <<ee:=getes car u; u:=cdr u;
            if linelength nil<posn() then newline n;
             if car ee<(m := linelength nil-posn()) then princn ee
              else if car ee<l then <<newline n; princn ee>>
              else begin
                 ee := cdr ee;
              a: for i := 1:m do <<prin2 car ee; ee := cdr ee>>;
                 newline n;
                 if null ee then nil
                  else if length ee<(m := l) then princn(nil . ee)
                  else go to a
                end;
             if posn()<linelength nil then prin2 '! >>
   end;

symbolic procedure rempropss(atmlst,lst);
   for each x in atmlst do
      for each y in lst do remprop(x,y);


symbolic procedure remflagss(atmlst,lst);
   for each x in lst do remflag(atmlst,x);

symbolic procedure formfeed;
        if !*formfeed then eject()
         else <<terpri();
                prin2 " ========================================= ";
                terpri()>>;

endmodule;


module rcref; % Cross reference program.

% Author: Martin L. Griss.

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

global '(undefg!* gseen!* btime!* expand!* haveargs!* notuse!* nolist!*
        dclglb!* entpts!* undefns!* seen!* tseen!* 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;

% Requires REDIO and SORT support.

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(deflist(slfns!*,'number!-of!-args),nolist!*)$

nolist!* := append('(and cond endmodule lambda list max min module or
                     plus prog prog2 progn 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 scalar a,ocrfil,crfil;
        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 analysed;
        op!*!*:=nil;    % Current op. in LAP code;
        setpage("  Errors or questionables",nil);
        if getd 'begin then return nil; % In REDUCE;
% The following loop is used when running in bare LISP;
  ndf:  if not (a eq !$eof!$) then go lop;
        crfil:=nil;
        if null ocrfil then go lop;
        crfil:=caar ocrfil;
        rds cdar ocrfil;
        ocrfil:=cdr ocrfil;
  lop:  a:=errorset('(!%nexttyi),t,!*backtrace);
        if atom a then go ndf;
        cloc!*:=if crfil then crfil . pgline() else nil;
        a:=errorset('(read),t,!*backtrace);
        if atom a then go ndf;
        a:=car a;
        if not pairp a then go lop;
        if car a eq 'dskin then
           <<ocrfil:=(crfil.rds open(cdr a,'input)).ocrfil;
             crfil:=cdr a; go lop>>;
        errorset(list('refprint,mkquote a),t,!*backtrace);
        if flagp(car a,'eval) and
           (car a neq 'setq or caddr a memq '(t nil) or
            constantp caddr a or eqcar(caddr a,'quote))
          then errorset(a,t,!*backtrace);
        if !*defn then go lop
  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;
        dfprint!* := nil;
        !*defn:=nil;
        if not !*algebraics
          then remprop('algebraic,'newnam);     %back to normal;
        tim:=time()-btime!*;
        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!*;
        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 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)>>;

%  Analyse 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 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 add2calls fn;
% Update local CALLS!*;
   if not(flagp(fn,'nolist) or flagp(fn,'cinthis))
    then <<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 apply(x,list 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 cdr u;
   if quotp(u:=caddr u) and idp(u:=cadr u)
      and not isglobl 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 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 union(x,y);
   if null x then y
    else union(cdr x,if car x member y then y else car x . y);

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);
    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);

symbolic anlfn procedure lap u;
   if pairp(u:=qcrf car u) then
    begin scalar globs!*,locls!*,calls!*,curfun!*,toplv!*,x;
     while u do
      <<if pairp car u then
          if x:=get(op!*!*:=caar u,'crflapo) then apply(x,list u)
           else if !*globals then for each y in cdar u do anlapev y;
        u:=cdr u>>;
     qoutrefe()
    end;

symbolic crflapo procedure !*entry u;
 <<qoutrefe(); u:=cdar u; outrdefun(car u,cadr u,caddr u)>>;

symbolic procedure qoutrefe;
 begin
  if null curfun!* then
    if globs!* or calls!* then
      <<curfun!*:=compress explode '!?lap!?!?; chkseen curfun!*>>
     else return;
  outrefend curfun!*
 end;

symbolic crflapo procedure !*lambind u;
 for each x in caddar u do globind car x;

symbolic crflapo procedure !*progbind u;
 for each x in cadar u do globind car x;

symbolic procedure lincall u;
 <<add2calls car (u:=cdar u); checkargcount(car u,caddr u)>>;

put('!*link,'crflapo,'lincall);

put('!*linke,'crflapo,'lincall);

symbolic procedure anlapev u;
 if pairp u then
   if car u memq '(global fluid) then
     <<u:=cadr u; globref u;
       if flagp(op!*!*,'store) then put(u,'glb2st,'t)>>
    else <<anlapev car u; anlapev cdr u>>;

flag('(!*store),'store);

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

% These functions defined to be able to run in bare LISP;

symbolic procedure eqcar(u,v);
 pairp u and car u eq v;

symbolic procedure mkquote u; list('quote,u);

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));


% DECSystem 10/20 dependent part;

flag('(pop movem setzm hrrzm),'store);

symbolic procedure lapcallf u;
 begin scalar fn;
  return
   if eqcar(cadr (u:=cdar u),'e) then
     <<add2calls(fn:=cadadr u); checkargcount(fn,car u)>>
    else if !*globals then anlapev cadr u
 end;

put('jcall,'crflapo,'lapcallf);

put('callf,'crflapo,'lapcallf);

put('jcallf,'crflapo,'lapcallf);

symbolic crflapo procedure call u;
 if not(caddar u = '(e !*lambind!*)) then lapcallf u
  else while ((u:=cdr u) and pairp car u and caar u = 0) do
        globind cadr caddar u;

endmodule;


end;
REDUCE Historical
[ REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]