File r37/packages/scope/codpri.red from the latest check-in


module  codpri;  % Support for visualizing output.

% -------------------------------------------------------------------- ;
% Copyright : J.A. Van Hulzen, Twente University, Dept. of Computer    ;
%             Science, P.O.Box 217, 7500 AE Enschede, the Netherlands. ;
% Authors :   J.A. van Hulzen, B.J.A. Hulshof, M.C. van Heerwaarden,   ;
%             J.B. van Veelen                                          ;
% -------------------------------------------------------------------- ;

symbolic$

% -------------------------------------------------------------------- ;
% The module CODPRI consists of three parts:                           ;
%  1 - Facilities to vizualize the data structures on user request,i.e.;
%      when ON PRIMAT or ON PRIALL is set(see CODCTL.RED).             ;
%  2 - Routines for constructing PREFIXLIST. The value of this variable;
%      is an association list,consisting of pairs (name.value),where   ;
%      name is the (sub)expression name and where value stands for the ;
%      prefixform of the corresponding (sub)expression. Its construc-  ;
%      tion is activated via the procedure MAKEPREFIXL used in CALC    ;
%      (see the module CODCTL).                                        ;
%  3 - Functions for improving the final layout of the output. These   ;
%      functions are applied on the final form of Codmat before the    ;
%      preparations for the printing process start.Calling the function;
%      ImproveFinalLayout suffices.                                    ;
% -------------------------------------------------------------------- ;

% -------------------------------------------------------------------- ;
% Global identifiers needed in this module are :                       ;
% -------------------------------------------------------------------- ;

fluid '(preprefixlist);

global '(codbexl!* rowmax rowmin lintlst kvarlst endmat rhsaliases
	 avarlst min!-expr!-length!* !*vectorc)$

global '(codmat maxvar)$

% -------------------------------------------------------------------- ;
% LINTLST is a list of integers which are too long to be included in   ;
% the schemes directly.LINTLST is built up in the procedure PRINUMB and;
% used in the procedure PRISCHEME via the procedure PRILINT.           ;
% The globals ROWMAX,ROWMIN and ENDMAT are defined in CODCTL.RED. The  ;
% global KVARLST is introduced in CODMAT.RED.                          ;
% -------------------------------------------------------------------- ;

% -------------------------------------------------------------------- ;
% PART 1 : PROCEDURES FOR VIZUALIZING THE DATA STRUCTURES              ;
% -------------------------------------------------------------------- ;
% These print facilities are mainly designed as debugging tool.They are;
% usable via an ON PRIMAT or an ON PRIALL setting.The governing routine;
% is PRIMAT,called in the procedure CALC to vizualize the result of    ;
% parsing a set of input expressions and to show the results of optimi-;
% zing this set.                                                       ;
% In PRIMAT the linelength is temporarily reset to 120,thus limiting   ;
% the size of the matrix schemes produced by PRISCHEME('PLUS) and      ;
% PRISCHEME('TIMES) in PRIMAT.                                         ;
% In PRISCHEME(Operator) a message is generated when the linelength is ;
% not sufficient telling that printing is impossible.In all other cases;
% the procedure PRISCHEME produces a compact version of reality.It uses;
% the routines PRI(nt)NUMB(er),PRI(nt)ROW,PRI(nt)VAR(iable) and PRI(nt);
% L(ong)INT(eger). The procedures TESTPROW and MEMPQ are used for test-;
% ing details in PRISCHEME and PRIROW,resp. To simplify explaining the ;
% code we give a simple example :                                      ;
%                                                                      ;
% Assume we have :                                                     ;
%                                       8  2                   8       ;
% U := ((A + 2*B)*SIN(A + 2*B)*A*B + 2*A *B  + 2*A + 4*B - 677)  + 1234;
%                                                                      ;
% Then PRIMAT produces via PRISCHEME :                                 ;
%                                                                      ;
% Sumscheme :                                                          ;
%                                                                      ;
%    |  3  4  5| EC|Far                                                ;
% ---------------------                                                ;
%   0|        X|  1| U                                                 ;
%   2|  2  4  X|  8| 1                                                 ;
%   4|  1  2   |  1! 3                                                 ;
%   5|  1  2   |  1| S0                                                ;
% ---------------------                                                ;
% The following integers ought to replace the X-entries of the matrix  ;
% in a left-to-right-and-top-down order : 1234  -677                   ;
% 3 : A                                                                ;
% 4 : B                                                                ;
% 5 : +ONE                                                             ;
%                                                                      ;
% Productscheme :                                                      ;
%                                                                      ;
%    |  0  1  2| EC|Far                                                ;
% ---------------------                                                ;
%   1|         |  1| 0                                                 ;
%   3|  1  1  1|  1| 2                                                 ;
%   6|     8  2|  2| 2                                                 ;
% ---------------------                                                ;
% 0 : S1=SIN(S0)                                                       ;
% 1 : A                                                                ;
% 2 : B                                                                ;
%                                                                      ;
% If Far has a name (U,S0) as value its row defines the prim.part of   ;
% the expression assigned to this name.Its composite parts can be found;
% in those rows of the other scheme,which have the index of the present;
% row in their Far-field( i.e. their father). The EC-field shows the   ;
% E(xponent of a sum) or the C(oefficient of a product).               ;
% The column numbers in the schemes correspondent with the CODMAT co-  ;
% lumn indices. These numbers are used to give a (vertical) list of    ;
% pairs (number : varname),where varname is either a variable name,the ;
% special symbol !+ONE( for the constants in a sum) or an assignment   ;
% like S1=SIN(S0),indicating that function applications are replaced by;
% system selected names.                                               ;
% When exponents or coefficients are too long to be printed,i.e. when  ;
% entry>999 or when entry<-99 an X is printed instead. A sequence of   ;
% integers corresponding with these X's in the scheme is given directly;
% below it in a left-to-right-and-top-down order. Hence :              ;
%                                                                      ;
% U     := 1234 + prod1(= product defined in row 1)                    ;
% prod1 := 1 * sum2(= sum defined in row 2)                            ;
% sum2  := (2*A + 4*B -677 + prod3 + prod6)^8                          ;
% prod3 := S1 * A * B * sum4                                           ;
% sum4  := A + 2*B                                                     ;
% S1    := SIN(S0)                                                     ;
% S0    := A + 2*B                                                     ;
% prod6 := 2 * A^8 * B^2                                               ;
% -------------------------------------------------------------------- ;

symbolic smacro procedure testprow(y,opv);
% -------------------------------------------------------------------- ;
% arg : Column index Y. Operator value Opv.                            ;
% res : T if the column Y is part of the Opv-scheme,NIL otherwise.     ;
% -------------------------------------------------------------------- ;
free(y) and opval(y) eq opv;


symbolic procedure primat;
% -------------------------------------------------------------------- ;
% res : A reflection is produced of the state of the matrix CODMAT     ;
% -------------------------------------------------------------------- ;
   begin scalar l;
     l:=linelength 120;
     terpri();
     prin2 "Sumscheme :";
     prischeme('plus);
     terpri();
     terpri();
     terpri();
     prin2 "Productscheme :";
     prischeme('times);
     linelength(l);
   end;

% -------------------------------------------------------------------- ;
% The procedure Primat1 can be used for testing new features.          ;
% -------------------------------------------------------------------- ;
global '(freevec freetest)$
freetest:=nil;

symbolic procedure primat1;
begin scalar freevec1,rmin,rmax; 
 rmin:=rowmin; rmax:=rowmax;
 if null freetest or freetest<maxvar
  then <<freetest:=maxvar;
         freevec1:=mkvect(2*maxvar);
         freevec:=freevec1
       >>;
 for j:=rmin:rmax do <<putv(freevec,j+maxvar,free(j));setfree(j)>>;
 primat();
 for j:=rmin:rmax do
  << if not getv(freevec,j+maxvar) then setoccup(j);
     terpri();
     if j<0 then write "col(",j,")=",getv(codmat,maxvar+j)
     else write "row(",j,")=",getv(codmat,maxvar+j)
  >>;
 terpri()
end;
 
symbolic procedure prischeme(opv);
% -------------------------------------------------------------------- ;
% arg : The value of Opv is either 'TIMES or 'PLUS.                    ;
% eff : The Opv-scheme is printed                                      ;
% -------------------------------------------------------------------- ;
begin scalar n,yl;
  n:=0;
  lintlst:=nil;
  terpri();
  terpri();
  prin2 "   |";
  for y:=rowmin:(-1) do
  if testprow(y,opv)
  then <<prinumb(y+abs(rowmin)); yl:=y.yl; n:=n+1>>;
  prin2 "| EC|Far";
  terpri();
  n:=3*n+12;
  if n>120 then <<prin2 "Scheme to large to be printed"; return>>;
  for j:=1:n do prin2 "-";
  yl:=reverse(yl);
  for x:=0:rowmax do
  if testprow(x,opv)
  then prirow(x,opv,yl);
  terpri();
  for j:=1:n do prin2 "-";
  prilint();
  terpri();
  for y:=rowmin:(-1) do
  if testprow(y,opv)
  then
  <<prin2(yl:=y+abs(rowmin));
    if yl < 10 then prin2 "  : " else prin2 " : ";
    privar(farvar y);
    if n:=assoc(farvar y,kvarlst)
    then <<prin2 "="; privar(cdr n)>>;
    terpri()
  >>;
end;

symbolic procedure prirow(x,opv,yl);
% -------------------------------------------------------------------- ;
% arg : Index X of a row of the Opv-scheme. Y1 is the list of column   ;
%       indices which occur in the Opv-scheme.                         ;
% eff : Row X of the Opv-scheme is printed in the above discussed way. ;
% -------------------------------------------------------------------- ;
   begin
     terpri();
     prinumb(x);
     prin2 "|";
     foreach z in zstrt(x) do
     if testprow(yind z,opv)
     then
     <<yl:=memqp(yind z,yl);
       prinumb(ival z)>>;
     for j:=1:length(yl) do prin2 "   ";
     prin2 "|";
     prinumb(expcof x);
     prin2 "| ";
     privar(farvar x);
   end;

symbolic procedure memqp(y,yl);
% -------------------------------------------------------------------- ;
% arg : Y is the index of the column of which the exponent/coefficient ;
%       of the corresponding variable has to be printed. Y1 is the list;
%       of indices of columns which can also contribute to the row     ;
%       which is now in the process of being printed.                  ;
% eff : If Y=Car(Y1) the calling routine,PRIROW,can continue its prin- ;
%       ting activities directly with the exp./coeff. in question. If  ;
%       not we have to print blanks to indicate that the column and row;
%       have nothing in common. We continue with the Cdr of the list Y1;
% -------------------------------------------------------------------- ;
if y=car(yl)
then cdr(yl)
else
<<prin2 "   ";
  memqp(y,cdr yl)>>;

symbolic procedure prinumb(n);
% -------------------------------------------------------------------- ;
% arg : A number N.                                                    ;
% eff : N is printed using atmost three positions if possible.In case  ;
%       the size of the number is to large or the number is a float,   ;
%       we print "  X" and add N to then list LINTLST of long numbers, ;
%       which are printed once the scheme is completed.                ;
% -------------------------------------------------------------------- ;
<<if pairp(n) and memq(car n, domainlist!*)
  then <<lintlst:=n.lintlst; n:="  X">>
  else
  if minusp(n)
  then
    (if n>-10
     then prin2 " "
     else
      if n<=-100
      then <<lintlst:=n.lintlst; n:="  X">>)
  else
   (if n<10
    then prin2 "  "
    else
      if n<100
      then prin2 " "
      else
        if n>=1000
        then <<lintlst:=n.lintlst; n:="  X">>);
  prin2 n;
>>;

symbolic procedure prilint;
% -------------------------------------------------------------------- ;
% eff : The list of "long" numbers LINTLST,produced in the procedure   ;
%       PRINUMB,is printed.                                            ;
% -------------------------------------------------------------------- ;
if lintlst
then
<<terpri();
  prin2
  "The following numbers ought to replace the X-entries of the matrix";
  terpri();
  prin2 "in a left-to-right-and top-down order : ";
  foreach n in reverse(lintlst) do <<dm!-print n; prin2 "  ">>;
>>;

symbolic procedure privar(var);
% -------------------------------------------------------------------- ;
% arg : The template VAR  for a variable,a list defining a kernel in   ;
%       prefix notation,i.e.(a b c) in stead of a(b,c) or a constant.  ;
% eff : VAR is printed.                                                ;
% -------------------------------------------------------------------- ;
if atom(var)
then prin2 var
else
<<prin2(car var);
  prin2 "(";
  var:=cdr var;
  while var do
  <<dm!-print(car var);
   if var:=cdr(var) then prin2 ",">>;
  prin2 ")";
>>;

 
% -------------------------------------------------------------------- ;
% PART 2 : PRODUCTION OF PREFIXLIST - THE FINAL RESULT                 ;
% -------------------------------------------------------------------- ;
% Given :                                                              ;
%                                       8  2                   8       ;
% U := ((A + 2*B)*SIN(A + 2*B)*A*B + 2*A *B  + 2*A + 4*B - 677)  + 1234;
%                                                                      ;
% The optimizer produces the sequence of assignment statements :       ;
%                                                                      ;
%    S0 := A + 2*B                                                     ;
%    S1 := SIN(S0)                                                     ;
%    S3 := A*B                                                         ;
%    S9 := A*A                                                         ;
%    S8 := A*S9                                                        ;
%    S7 := S8*S8                                                       ;
%    S5 := 2*S0 - 677 + S3*(S0*S1 + 2*S3*S7)                           ;
%    S9 := S5*S5                                                       ;
%    S8 := S9*S9                                                       ;
%    S6 := S8*S8                                                       ;
%    U := 1234 + S6                                                    ;
%                                                                      ;
% The above given REDUCE infix notation can be replaced by FORTRAN or a;
% prefix form. This depends on the current flag settings. But for prin-;
% ting we always use the value of PREFIXLIST,which is in this particu- ;
% lar case :                                                           ;
%                                                                      ;
%   ((S0 PLUS A (TIMES 2 B))                                           ;
%    (S1 SIN S0)                                                       ;
%    (S3 TIMES A B)                                                    ;
%    (S9 TIMES A A)                                                    ;
%    (S8 TIMES A S9)                                                   ;
%    (S7 TIMES S8 S8)                                                  ;
%    (S5                                                               ;
%       PLUS                                                           ;
%       (TIMES 2 S0)                                                   ;
%       (MINUS 677)                                                    ;
%       (TIMES S3 (PLUS (TIMES S0 S1) (TIMES 2 S3 S7))))               ;
%    (S9 TIMES S5 S5)                                                  ;
%    (S8 TIMES S9 S9)                                                  ;
%    (S6 TIMES S8 S8)                                                  ;
%    (U PLUS 1234 (TIMES S6)))                                         ;
%                                                                      ;
% PREFIXLIST is iteratively constructed by the procedure MAKEPREFIXL   ;
% (see CODCTL.RED),by successively using the items of the (global) list;
% CodBexl!* via a ForEach-statement. Such an item is either an index of;
% a row,where the description of the corresponding assignment statement;
% starts(in the above example U) or of a system generated cse-name.    ;
% These alternatives demand for either a call of PRFEXP(rowindex) or of;
% PRFKVAR(cse-name).The routines PR(epare pre)F(ix form of an )EXP(res-;
% sion) and PR(epare pre)F(ix form of an element of)KVAR(lst) call each;
% other and the procedures CONSTR(uct an)EXP(ression),PR(epare the list;
% of operands in pre)F(ix form of the pri)M(.part of an)EX(pression),  ;
% (prepare the list of operands in prefix form of the)COMP(osite part  ;
% of an)EX(pression) and PR(epare in pre)F(ix form a redefinition of a);
% POW(er into a)L(ist of multiplications(i.d. an addition chain mecha- ;
% nism)). The last routine uses the additional procedures PREPPOWLS    ;
% and INSEXPLST. For further comment : see below.                      ;
% -------------------------------------------------------------------- ;

global '(!*prefix !*again)$
fluid '(prefixlist);
prefixlist:=nil;

% -------------------------------------------------------------------- ;
% These globals are already introduced in CODCTL.RED.                  ;
% -------------------------------------------------------------------- ;

symbolic procedure prfexp(x,prefixlist);
% -------------------------------------------------------------------- ;
% arg : X is the CODMAT-index of the row where the description of a top;
%       level sum or product starts.                                   ;
% eff : The prefix definition of this expression ,a dotted pair (name. ;
%       value) is added to PREFIXLIST,in combination with all its cse's;
%       which have to precede the expression when printing the result. ;
%       Since "consing" is used for the construction of PREFIXLIST it  ;
%       ought to be reversed before it can be used for the actual prin-;
%       ting.The cse-ordering is defined by the value of the ORDR-field;
%       of row X of CODMAT,a list built up during input parsing (see   ;
%       CODMAT.RED) and optimization(see CODOPT.RED) using the procedu-;
%       re SETPREV(see CODMAT.RED,part 2).                             ;
% -------------------------------------------------------------------- ;
begin scalar xx,nex;
 if free(x)
 then % Start with cse's.;
 <<foreach y in reverse(ordr x) do
   if constp(y)
   then prefixlist:=prfexp(y,prefixlist)
   else
   <<prefixlist:=prfkvar(y,prefixlist);
     if get(y,'nvarlst)
     then <<prefixlist:=prfpowl(y,prefixlist); remprop(y,'nvarlst)>>
   >>;
    % ---------------------------------------------------------------- ;
    % Continue with expression itself if it has not yet been printed as;
    % part of an addition chain ('Bexl:=T,see PREPPOWLS).              ;
    % ---------------------------------------------------------------- ;
   if not( get(farvar x,'bexl) = x)
    then if nex:=get(farvar x,'nex)
          then << foreach arg in cdr nex do
                   if xx := get(arg, 'rowindex)
                     then prefixlist:=prfexp(xx,prefixlist)
                     else prefixlist:=prfkvar(arg,prefixlist);
                  remprop(car nex, 'kvarlst);
                  % remprop(farvar x,'nex); Needed in cleanupprefixl to
                  %                         handle arrays
                  prefixlist:=(nex.constrexp(x)).prefixlist;
                  symtabrem(nil, farvar x)
               >>
          else prefixlist:=(farvar(x).constrexp(x)).prefixlist
     else remprop(farvar x,'bexl);
   setoccup(x)
 >>;
 return prefixlist
end;

 
symbolic procedure constrexp(x);
% -------------------------------------------------------------------- ;
% arg : X is the CODMAT-index of the row where the description starts  ;
%       of the expression to be added to PREFIXLIST.                   ;
% res : Construction of the expression in prefix form. The result is   ;
%       used in PRFEXP.                                                ;
% -------------------------------------------------------------------- ;
begin scalar s,ec,opv,ch,ls;
  if (opv:=opval x) eq 'times
  then
  <<s:=append(prfmex(zstrt x,'times),compex chrow x);
    if null(s) then s:=list 0;
    ec:=expcof(x);ls:=length(s);
    if !:onep(ec)
     then if ls>1 then s:='times.s else s:=car(s)
     else
       if !:onep(dm!-minus ec)
        then s:=(if ls>1 then list('minus,'times.s)
                                              else list('minus,car s))
        else
         if !:minusp(ec)
          then s:=list('minus,'times.((dm!-minus ec).s))
          else s:='times.(ec.s)
  >>
  else
    if opv eq 'plus
    then
    <<s:=append(prfmex(zstrt x,'plus),compex chrow x);
      if null(s) then s:=list 0;
      if length(s)>1 then s:='plus.shiftminus(s) else s:=car(s);
      if (ec:=expcof(x))>1 then s:=list('expt,s,ec)
    >>
    else
    <<ch:=chrow(x);
      foreach z in zstrt(x) do
      if null(z)
      then <<s:=constrexp(car ch).s; ch:=cdr(ch)>>
      else s:=z.s;
      s:=car(opv).reverse(s);
      foreach op in cdr(opv) do
      s:=list(op,s);
      if (ec:=expcof x)>1
      then s:=list('expt,s,ec)
    >>;
  return s
end;

symbolic procedure shiftminus(s);
begin scalar ts,head;
 ts:=s; head:=nil;
 while ts and (pairp(car ts) and caar(ts) eq 'minus) do
  << head:=car(ts).head; ts:=cdr ts>>;
 return if ts then append(ts,reverse head) else s
end;

symbolic procedure prfmex(zz,op);
% -------------------------------------------------------------------- ;
% arg : ZZ is a Zstrt and Op an element of {'PLUS,'TIMES}.             ;
% res : List of operands in prefix form,i.e. a list of multiples or a  ;
%       list of powers of variables.                                   ;
% -------------------------------------------------------------------- ;
foreach z in zz collect
begin scalar var,nex;
  var:=farvar(yind z);
  if nex:=get(var,'nex) then << var:=nex; symtabrem(nil,var)>>;
  if var eq '!+one
  then % A constant.;
    if !:minusp(ival(z))
    then return list('minus,dm!-minus(ival(z)))
    else return ival(z);
  if not(!:onep dm!-abs(ival z))
  then
    if op eq 'plus
    then var:=list('times,dm!-abs ival z,var)
    else
      if bval(z)
      then var:=bval(z)
      else var:=list('expt,var,ival z);
  if !:minusp(ival z)
  then var:=list('minus,var);
  return var;
end;

symbolic procedure compex(chr);
% -------------------------------------------------------------------- ;
% arg : Chr is a list of indices of rows where the description starts  ;
%       of (sub)expressions,being composite terms or factors.          ;
% res : A list of these (sub)expressions in prefix form.               ;
% -------------------------------------------------------------------- ;
foreach ch in chr collect
constrexp(ch);

symbolic procedure prfkvar(kv,prefixlist);
% -------------------------------------------------------------------- ;
% arg : Kv is the Car-part of an element (Var.F) of the Kvarlst,where F;
%       is a list of the form (function-name (list of arguments)),if   ;
%       not already added to PREFIXLIST                                ;
% eff : The occurence of Kv in Kvarlst is tested. If Kv is still there ;
%       the corresponding dotted pair is used for extending PREFIXLIST ;
%       before it is removed from Kvarlst.                             ;
% -------------------------------------------------------------------- ;
begin scalar kvl,x,kvl1,nex;
  while kvarlst and not (kv=caar(kvarlst)) do
  <<kvl:=car(kvarlst).kvl;
    kvarlst:=cdr(kvarlst)
  >>;
  if null(kvarlst)
  then 
  <<% KVar already printed or redefined as a lhs.;
    kvarlst:=kvl;
    if nex:=get(kv,'nex)
     then prefixlist:=(kv.nex).nexcheck(kv,nex,prefixlist)
  >>
  else
  <<kvl1:=car(kvarlst);
    kvarlst:=append(kvl,cdr kvarlst);
     % Restore Kvarlst before next recursive check;
    foreach var in cddr(kvl1) do
    % ---------------------------------------------------------------- ;
    % Add argument description,if composite,to Prefixlist before func. ;
    % application itself.                                              ;
    % ---------------------------------------------------------------- ;
    if x:=get(var,'rowindex) 
       then prefixlist:=prfexp(x,prefixlist) 
       else prefixlist:=prfkvar(var,prefixlist);  
    if nex:=get(kv,'nex)
     then << prefixlist:=nexcheck(kv,nex,prefixlist);
             kv := nex
         >>;
    prefixlist:=(kv.cdr(kvl1)).prefixlist;
    flag (list (kv),'done)
  >>;
  return prefixlist
end;

symbolic procedure nexcheck(kv,nex,prefixlist);
begin scalar x;
if not (flagp (kv, 'done) or (!*vectorc and subscriptedvarp (car nex)))
  then for each arg in cdr nex do
          if x:=get(arg,'rowindex)
             then prefixlist:=prfexp(x,prefixlist)
             else prefixlist:=prfkvar(arg,prefixlist);
  symtabrem(nil,kv);
  %--------------------------------------------------------------------;
  % Otherwise, this further non-used temporary variable will also be   ;
  % declared.                                                          ;
  %--------------------------------------------------------------------;
  remprop(kv,'nex);
  return prefixlist
end;

symbolic procedure evalpartprefixlist(prefixlist);
% ------------------------------------------------------------------- ;
% Evaluate partially the elements of Prefixlist leading to a list of  ;
% (sub)expressions, which have either PLUS or MINUS as their leading  ;
% operator.                                                           ;
% ------------------------------------------------------------------- ;
begin scalar newprefixlist,pair,temp;
 while not null prefixlist do
  <<if pair:=evalpart1 car prefixlist
     then newprefixlist:=pair.newprefixlist;
    prefixlist:=cdr prefixlist
  >>;
 foreach item in get('evalpart1,'setklist) do 
  << remprop(item,'avalue);
     if (temp:=get(item,'taval)) 
      then <<setk(item,mk!*sq simp!* temp); remprop(item,'taval) >>
  >>;
 remprop('evalpart1,'setklist);
 return reverse(newprefixlist)
end;

symbolic procedure evalpart1 pair;
begin scalar carpair,exp,res,x;
 exp:=!*exp; !*exp:=t;
 carpair:= car pair;
 x:=reval cdr pair;
 if not (atom(x) or (car x memq '(plus difference))) and
    flagp(carpair,'newsym)
  then << if (get(carpair,'avalue)) and not(get(carpair,'taval)) 
           then  put(carpair,'taval,prepsq cadadr get(carpair,'avalue));
          setk(carpair,aeval(x))
       >> 
  else res:=(carpair).x;
 if null res 
  then put('evalpart1,'setklist,(carpair).get('evalpart1,'setklist));
 !*exp:=exp;
 return res
end;

symbolic procedure removearraysubstitutes(prefixlist);
% ------------------------------------------------------------------- ;
% When arrayelements form rhs's in pairs of prefixlist, used to       ;
% produce output, the cse-names, used to denote them in the rest of   ;
% prefixlist, are replaced by these arrayelements if the arrayname    ;
% occurs in the GENTRAN symboltable, used for making declarations.    ;
% ------------------------------------------------------------------- ;
begin scalar newprefixlist,pair;
 while not null prefixlist do
  << pair:= car prefixlist; prefixlist:=cdr prefixlist;
     if flagp(car pair,'newsym)
         and
        (pairp(cdr pair) and subscriptedvarp(cadr pair))
      then
       prefixlist:=(foreach item in prefixlist collect
                                     subst(cdr pair,car pair,item))
    %subst(cdr pair,car pair,car item).subst(cdr pair,car pair,cdr item)
      else
       newprefixlist:=pair.newprefixlist;
  >>;
 return reverse newprefixlist
end;


% -------------------------------------------------------------------- ;
% COMPUTATION RULES FOR POWERS : AN ADDITION CHAIN MECHANISM           ;
%                                                                      ;
% The above given Optimizer output contains the following subsequences ;
%  ................                                                    ;
%  S9 := A * A          A ^ 2   ( 2 = 1 + 1 )                          ;
%  S8 := A * S9         A ^ 3   ( 3 = 2 + 1 )                          ;
%  S7 := S8 * S8        A ^ 6   ( 6 = 3 + 3 )                          ;
%  ................                                                    ;
%  S9 := S5 * S5       S5 ^ 2   ( 2 = 1 + 1 )                          ;
%  S8 := S9 * S9       S5 ^ 4   ( 4 = 2 + 2 )    S9 is re used         ;
%  S6 := S8 * S8       S5 ^ 8   ( 8 = 4 + 4 )    S8 is re used         ;
%                                                                      ;
% Printing a view on CODMAT (after the above given output is produced) ;
% using the procedure PRIMAT (see part 1 of this module) shows:        ;
%                                                                      ;
%  Sumscheme :                                                         ;
%                                                                      ;
%     |  7 11 12 13| EC|Far                                            ;
%  ------------------------                                            ;
%    0|          X |  1| U                                             ;
%    5|     1  2   |  1| S0                                            ;
%   10|            |  1| 9                                             ;
%   12|  2       X |  1| S5                                            ;
%  ------------------------                                            ;
%  The following integers ought tp replace the X-entries of the matrix ;
%  in a left-to-right-and-top-down order : 1234  -677                  ;
%  7  : S0                                                             ;
%  11 : A                                                              ;
%  12 : B                                                              ;
%  13 : +ONE                                                           ;
%                                                                      ;
%  Productscheme :                                                     ;
%                                                                      ;
%     |  1  3  4  8  9 10| EC|Far                                      ;
%  ------------------------------                                      ;
%    1|  8               |  1| 0                                       ;
%    3|     1     1      |  1| 10                                      ;
%    6|        1     6   |  2| 10                                      ;
%    8|              1  1|  1| S3                                      ;
%    9|        1         |  1| 12                                      ;
%  ------------------------------                                      ;
%  1  : S5                                                             ;
%  3  : S0                                                             ;
%  4  : S3                                                             ;
%  8  : S1=SIN(S0)                                                     ;
%  9  : A                                                              ;
%  10 : B                                                              ;
%                                                                      ;
% S5 ^ 8 and A ^ 6 are still there,in contrast to S6,S7,S8 and S9, be- ;
% cause the latter group is produced in a different way. S6 and S7 are ;
% generated via PREPPOWLS,called in PREPFINALPLST(see CODCTL.RED),acti-;
% vated in MAKEPREFIXL, assuming OFF AGAIN holds.                      ;
% In PREPPOWLS the Nvarlst's ((8.S6)(1.S5)) and ((6.S7)(1.A)) are made ;
% and via their property lists associated with S5 and A,respectively.  ;
% These lists are used in PRFPOWL to produce the above given chains.   ;
% The addition chain-like algorithm used is reflected by the structure ;
% of PRFPOWL : Given a list of at least two exponents(integers),being  ;
% the Car's of the elements of Nvarlst,produce an intuitively minimal  ;
% number of additions by halving even numbers and by making odd numbers;
% even by substracting 1. Hence (63 1) leads to :                      ;
% 63=62+1,62=31+31,31=30+1,30=15+15,15=14+1,14=7+7,7=6+1,6=3+3,3=2+1,  ;
% 2=1+1. Since the Nvarlst might be longer,for instance (63 28 15 1),  ;
% PRFPOWL allows a more general approach,which for example leads to :  ;
% 63=62+1,62=31+31,31=28+3,28=15+13,15=13+2,13=12+1,12=6+6,6=3+3,3=2+1,;
% 2=1+1.                                                               ;
% -------------------------------------------------------------------- ;

symbolic procedure preppowls;
% -------------------------------------------------------------------- ;
% eff : This procedure is called before the actual printing starts,i.e.;
%       before PREFIXLIST is made. This allows to refer to results     ;
%       produced by this routine in PRFEXP at two different places. The;
%       value of the indicators 'Nvarlst(i.e. exists such a list?) and ;
%       'Bexl(=T if the corresponding (sub)expression name is part of a;
%       chain) are used in PRFEXP.                                     ;
%       The Zstrt's of all relevant 'TIMES-columns are analysed. If non;
%       one elements occur they are stored in a so called Nvarlst,asso-;
%       ciated with these relevant columns as value of the indicator   ;
%       'Nvarlst,which is put on the property list of the variable gi- ;
%       ving the column its identity via its FarVar-value. Nvarlst is a;
%       list of pairs (exponent=IVal(Zstrt-element) . associated name).;
%       This name can be newly generated(such as S6 and S7 in the above;
%       example) or already exist if,for instance, FarVar^exponent is  ;
%       itself an expression.This is marked with the indicator 'Bexl=T.;
%       The incorporation of this expression in PREFIXLIST is now done ;
%       via the production of the addition chain,implying that it is no;
%       longer necessary to treat it seperately.                       ;
% -------------------------------------------------------------------- ;
begin scalar var,nvar,nvarlst,rindx;
  for y:=rowmin:(-1) do
  if not numberp(var:=farvar y) and opval(y) eq 'times
  then
  <<foreach z in zstrt(y) do
    if ival(z)=1
    then setbval(z,var)
    else
    <<rindx:=xind(z);
      setprev(rindx,var);
      if not nvarlst then nvarlst:=list(1 . var);
      if numberp(nvar:=farvar rindx) or pairp(nvar) or
         not (null(cdr zstrt rindx) and null(chrow rindx)
         and expcof(rindx)=1)
       then nvar:=fnewsym()
       else put(nvar,'bexl,rindx);
      setbval(z,nvar);
      setzstrt(rindx,inszzzr(mkzel(y,ival(z).nvar),
			     delyzz(y,zstrt rindx)));
      nvarlst:=insexplst(ival(z).nvar,nvarlst);
    >>;
    if nvarlst then <<put(var,'nvarlst,nvarlst);
                      nvarlst:=nil>>
  >>;
terpri()
end$

symbolic procedure prfpowl(y,prefixlist);
% -------------------------------------------------------------------- ;
% arg : Y is a variable with an NVarlst in its property list.          ;
% res : The NVarlst is used to produce an addition chain in the above  ;
%       suggested way.Its is produced in the form of a list Powlst of  ;
%       dotted pairs which can be included in PREFIXLIST directly. So  ;
%       the pairs have a name as Car-part and a product of 2 variables ;
%       as Cdr-part.                                                   ;
% -------------------------------------------------------------------- ;
begin scalar nvarlst,explst,first,cfirst,csecond,diff,var,
             powlst,var1,var2;
  nvarlst:=explst:=get(y,'nvarlst);
  repeat
  <<first:=car(explst);
    cfirst:=car(first);
    csecond:=caar(explst:=cdr explst);
    diff:=cfirst-csecond;
    if diff>csecond
    then
    <<if remainder(cfirst,2)=1
      then
      <<cfirst:=cfirst-1;
        var:=fnewsym();
        powlst:=(cdr(first).list('times,y,var)).powlst;
        first:=(cfirst.var);
        nvarlst:=first.nvarlst
      >>;
      diff:=csecond:=cfirst/2;
    >>;
    if null(assoc(diff,nvarlst))
    then
    <<var:=fnewsym();
      nvarlst:=(diff.var).nvarlst
    >>;
    var1:=cdr(assoc(diff,nvarlst));
    var2:=cdr(assoc(csecond,nvarlst));
    powlst:=(cdr(first).list('times,var1,var2)).powlst;
    explst:=insexplst((diff.var1),explst);
  >>
  until diff=csecond and csecond=1;
  prefixlist:=append(reverse(powlst),prefixlist);
  return prefixlist
end;

symbolic procedure insexplst(el,explst);
% -------------------------------------------------------------------- ;
% arg : EL is a dotted pair (integer . name). Explst is a list of such ;
%       dotted pairs . The car-parts of the list elements define a de- ;
%       cending order for the elements of Explst.                      ;
% res : EL is inserted in Explst,but only if the Car-part was not yet  ;
%       available.                                                     ;
% -------------------------------------------------------------------- ;
if null(explst) or car(el)>caar(explst)
then el.explst
else 
  if car(el)=caar(explst)
  then explst
  else car(explst).insexplst(el,cdr explst);


% -------------------------------------------------------------------- ;
% PART 3 : IMPROVEMENT OF THE FINAL FORM OF PREFIXLIST                 ;
% -------------------------------------------------------------------- ;
% The function CleanupPrefixlist is used in MakePrefixlist, defined in ;
% CODCTL.RED, for back substitution of identifiers, which occur only   ;
% once in  the set of right hand sides, defining the optimized version ;
% of the input.                                                        ;
% -------------------------------------------------------------------- ;

global '(codbexl!*);

symbolic procedure aliasbacksubst(pfl);
%--------------------------------------------------------------------
% pfl : list of (lhsides . rhsides) in reverse order.
% ret : new pfl with no more superfluous aliases in correct order.
%--------------------------------------------------------------------
begin 
  scalar backsubstlist,original,lhs,npfl;
  backsubstlist := rhsaliases;
  foreach stat in reverse pfl do
  <<if (original:=get((lhs:=car stat),'alias))
     then % lhs is an alias.
          % Should it be backsubstituted ?
          if (atom original)
                       % lhs was a dependence-alias.
                       % Backsubstitute !
             or 
             eq(lhs,cadr assoc(original,get(car original,'finalalias)))
                       % Output-occurence of original.
                       % Backsubstitute !
             or 
             vectorvarp(car original)
                       % User wants backsubstitution.
                       % Backsubstitute !
             then backsubstlist:= (lhs . original) . backsubstlist
             else original := nil;
     npfl:=((if original then original else lhs) 
           .
           recaliasbacksubst(cdr stat,backsubstlist)) . npfl;
   >>;
   return reverse npfl;
   end;

symbolic procedure recaliasbacksubst(ex, al);
%---------------------------------------------------------------
% Commit the actual backsubstitution.
%---------------------------------------------------------------
if atom ex or constp(ex)
   then if assoc(ex,al)
           then cdr assoc(ex,al)
           else ex
   else foreach el in ex collect recaliasbacksubst(el,al);     
     
symbolic procedure reinsertratexps (ppl,pfl);
% ----------------------------------------------------------------
% All rational exponents, collected in the preprefixlist, are
% reinserted in the prefixlist, in a position defining them just 
% before their use.
% ----------------------------------------------------------------
begin
  scalar keys,npfl;
  keys:= foreach re in ppl collect car re;
  for each stat in pfl do
           << foreach k in keys do
                      if not freeof(cdr stat, k)
                         then << npfl:=assoc(k,ppl) . npfl;
                                 keys:=delete(k,keys)
                              >>;
              npfl:=stat . npfl
            >>;
  return reverse npfl
  end;

symbolic procedure cleanupvars (p,pfl);
% ----------------------------------------------------------------
% Remove all generated flags and properties w.r.t. aliases.
% ----------------------------------------------------------------
begin scalar csenow,lp,dp,pn,sv;
  csenow:=fnewsym();
  lp:=letterpart csenow;
  dp:=digitpart csenow;
  pn:=for idx:=0:dp collect mkid(lp,idx);
  if !*again and not !*vectorc
     then <<foreach f in pfl do
             if atom(car f) and flagp(car f,'inalias)
                then<< remflag(list car f,'inalias);
                       remflag(list car f, 'newsym) >>
          >>
     else if not !*again
             then <<foreach v in pn do
                       if (sv:=get(v,'alias))
                           then <<if pairp(sv) then sv:=car sv;
                                  remprop(sv,'finalalias);
                                  foreach a in get(sv,'aliaslist) do
                                   << remprop(a,'alias);
                                      foreach a2 in get(a,'aliaslist)
                                        do remprop(a2,'alias);
                                      remprop(a,'finalalias);
                                   >>;
                                 remprop(sv,'aliaslist);
                                >>;
                     % remove all garbage from variables.
                     pn := append(pn,p);
%                           foreach el in p collect
%                              if atom el then el else car el);
                     remflag(pn,'subscripted);
                   % remflag(pn,'vectorvar); % This is user-controlled 
                                             % JB 16/3/94
                     remflag(pn,'inalias);
                     remflag(pn,'aliasnewsym);
                  >>;
  end;

symbolic procedure listeq(a,b);
if atom a
   then eq(a,b)
   else if atom b
           then nil
           else listeq(car a, car b)
                and listeq(cdr a, cdr b);

symbolic smacro procedure protected(a,pn);
member((if atom a then a else car a), pn);

symbolic smacro procedure protect(n,pn);
if member((if atom n then n else car n),pn)
   then pn
   else (if atom n then n else car n). pn;

symbolic procedure cleanupprefixlist(prefixlist);
% -------------------------------------------------------------------- ;
% This procedure is used for making the final version of the prefix-   ;
% list. The prefixlist is made shorter by substituting some assign-    ;
% ments occuring in the prefixlist in expressions in the other assign- ;
% ments in the list.                                                   ;
% The following cases are considered:                                  ;
%                                                                      ;
% 1)    :                                                              ;
%    a := (-)constant     a is not protected i.e. not an output var.   ;
%    . := ...a...      T  a -> (-)constant (old -> new) is substituted ;
%       :              v                in this part of the prefixlist ;
%                                                                      ;
% 2)    :                                                              ;
%    a := expression      a not protected, this assignment is removed  ;
%    . := ...a...      T  this is the only place where a is used       ;
%       :              v  a -> expression substituted in this part     ;
%                                                                      ;
% 3)    :                                                              ;
%    b := ...                                                          ;
%    . := ...b...                                                      ;
%    a := (-)b            a not protected, this assignment is removed  ;
%    . := ...b...      T  a -> (-)b substituted in this part of the    ;
%    . := ...a...      |            prefixlist                         ;
%       :              v                                               ;
%                                                                      ;
% 4)    :                                                              ;
%    b := ...          T  b not protected, changed to a := ...         ;
%    . := ...b...      |                                               ;
%    a := b            |  a protected, this assignment is removed      ;
%    . := ...b...      |  b -> a substituted in this part of the       ;
%    . := ...a...      |         prefixlist                            ;
%       :              v                                               ;
%                                                                      ;
% 5)    :                                                              ;
%    b := ...          T  b not protected, changed to a:= ...          ;
%    . := ...b...      |                                               ;
%    a := -b           |  a protected, this assignment is removed      ;
%    . := ...b...      |  b -> a and a -> -a substituted in this part  ;
%    . := ...a...      |                     of the prefixlist         ;
%       :              v                                               ;
%                                                                      ;
% Substitution-rules are collected in a list called SUBSTLST.          ;
% All assignments in the prefixlist are treated one by one.            ;
% First, all substitutions are made in the assignment. Second, the     ;
% resulting assignment is checked if it leads to a new substitution as ;
% described in 1) - 3). If so, the new substitution is added to the    ;
% substitutionlist.                                                    ;
% Note that substitutions of kind 4) and 5) require substitutions in   ;
% assignments prior to the one that is treated (a := (-)b). Therefore  ;
% these substitutions are collected before the actual cleaning-up.     ;
% These backward-substitutions may not contain subscripted variables.  ;
% This constraint is made because of the following reasons:            ;
%  - Substitution of b -> a[i] can introduce an assignment at a point  ;
%    where i is not yet calculated.                                    ;
%  - As substitutions are not applied to the substitutes, b -> a[expr] ;
%    can become invalid by a substitution of/in expr.                  ;
%  - The second reason also applies to b[i] -> a.                      ;
%  - b -> a[i] introduces more accesses of a[i] which are slower than  ;
%    accesses of b.                                                    ;
%  - b[i] -> a cannot occur because subscripted variables are output-  ;
%    variables and therefore protected.                                ;
% When, during the cleanup, a substitution is formed concerning a      ;
% variable already involved in a backward-substitution this backward-  ;
% substitution is overrided (i.e. removed) and the new substitution is ;
% added to the substitutionlist.                                       ;
% Variables:                                                           ;
%    protectednames  : output variables                                ;
%    defvarlst       : list of variables defined in the prefixlist     ;
%    rhsocc          : ((var . #) ...) where # = number of times that  ;
%                      var occurs in the rhs or in a subscript of a    ;
%                      lhs in an assignment in the prefixlist          ;
%    substlst        : ((old . new) ...), substitutionlist             ;
%    dellst          : list of indices of assignments in the prefixlist;
%                      which must be removed because of a backward-    ;
%                      substitution                                    ;
% -------------------------------------------------------------------- ;
begin scalar lpl,protectednames,j,item,substlst,dellst,se,ose,
	     r,defvarlst,rhsocc,occ,var,sgn,lhs,rhs;
  % -------------------------------------------------------------------
  %  Add rational exponentexpressions to prefixlist.
  % -------------------------------------------------------------------
  if preprefixlist
     then prefixlist:=reinsertratexps(preprefixlist, prefixlist);
  % -------------------------------------------------------------------
  %  Ensure backsubstitution of `aliased' output-variables.
  % -------------------------------------------------------------------
  prefixlist := aliasbacksubst(reverse prefixlist);
  lpl:=length(prefixlist);
  lhs:=mkvect(lpl); rhs:=mkvect(lpl);
  % -------------------------------------------------------------------
  %  Determine protected names.
  % -------------------------------------------------------------------
  foreach indx in codbexl!* do
    if numberp(indx) then 
       <<if var:=get(farvar indx,'nex)
          then protectednames:= protect(var,protectednames)
          else if not flagp(farvar indx,'aliasnewsym) 
	       then protectednames:=protect(farvar(indx),protectednames)
                else if (var:=get(farvar(indx),'alias))
                      then protectednames := protect(var,protectednames)
        >>
       else if idp(indx) then 
               if not flagp(indx,'aliasnewsym) 
                  then protectednames:=protect(indx, protectednames)
                  else if (var:=get(indx,'alias))
			  then protectednames
				  := protect(var, protectednames);
  % -------------------------------------------------------------------
  % Preliminaries.
  % -------------------------------------------------------------------
  j:=0;
  foreach item in prefixlist do
     <<  % Build lhs and rhs vectors
       putv(lhs,j:=j+1,car item);
       putv(rhs,j,cdr item);
         % Remove now redundant information.
       se := nil;
       if pairp(cdr item) and get (se := cadr item, 'kvarlst)
          then remprop (se ,'kvarlst);
       if flagp (se,'done)
          then remflag (list(se),'done);
         % Build defvarlst
       defvarlst:=(car(item) . j) . defvarlst;
         % Build variable occurences lists
       if pairp car(item)
          then rhsocc:=insoccs(car(item),rhsocc);
       rhsocc:=insoccs(cdr(item),rhsocc);
         % Determine backward substitutions
       sgn:=nil;
       if eqcar(cdr item,'minus) then
       << sgn:=t;
          item:=car(item).caddr(item)>>;
       if idp(cdr item) and 
          (protected(car item, protectednames) and
              not protected(cdr item,protectednames)) and 
          not(get(car item,'finalalias) and pairp(car item)) and
          (r:= assoc(cdr item, defvarlst)) and
          not(assoc(cdr item,substlst)) and 
          movable(item,defvarlst)
          then << dellst:=car(item).dellst;
                  substlst:=substel(cdr(item).car(item),sgn).substlst;
                  if sgn and r then 
                     <<% We 've found : S0 := blah
                       %                A  := - S0
                       % This becomes : A  := - blah,
                       % and further occurences of S0 will be replaced
                       % by: - A
                       % The actual substitution takes now place.
                       % We also create a nonsense-statement at here,
                       % to be deleted later on.
                       putv(rhs,cdr r,('minus . list getv(rhs,cdr r)));
                       putv(lhs,cdr r,getv(lhs,j));
                       putv(rhs,j,(getv(lhs,j)))>>
               >>;
     >>;
  % -------------------------------------------------------------------
  % Do the cleaning up!
  % -------------------------------------------------------------------
  for j:=1:lpl do
     <<if member(getv(lhs,j),dellst)
          and (not protected(getv(lhs,j),protectednames)
          or eq(getv(lhs,j),getv(rhs,j)))
          then % line j is deleted by a backward substitution
               <<putv(lhs,j,nil);
                 putv(rhs,j,nil)
               >>
          else % Do the substitutions
               <<if pairp(getv(lhs,j))
                    then putv(lhs,j,replacein(getv(lhs,j),substlst));
                 putv(rhs,j,replacein(getv(rhs,j),substlst));
                 % Determine a substitution
                 item:=getv(lhs,j).getv(rhs,j);
                 sgn:=nil;
                 if eqcar(cdr item,'minus)
                    then <<sgn:=t;
                           item:=car(item).caddr(item)>>;
                 se:=nil;
                 if listeq(car item,cdr item)
                    then % We created nonsense like ( a . a )
                         <<putv(lhs,j,nil);
                           putv(rhs,j,nil)>>
                    else 
                    <<if constp(cdr item) and
                         not protected(car item,protectednames)
                         then % a := (-)constant
                           se:=substel(item,sgn)
                         else if (if atom(cdr item) 
                                   then idp(cdr item)
                                   else subscriptedvarp(cadr item))
                              and not protected(car item,protectednames)
                              then % a := (-)b, a not protected
                                se:=substel(item,sgn)
                              else 
                               if not protected(car item,protectednames)
                                  and (occ:=assoc(car item,rhsocc))
                                  and cdr(occ)=1
                                  then % a:=(-)b,a not protected
                                       % and used once
                                       se:=substel(item,sgn);
                     >>;
                 % Add the substitution
                 if se
                 then <<if ose:=assoc(car se,substlst) then 
                           % remove backward-substitution
                           << substlst:=delete(ose,substlst);
                              substlst:=
                                delete(substel(cdr(ose).cdr(ose), t),
                                               substlst);
                              dellst:=delete(cdr ose,dellst)
                           >>;
                        substlst:=se.substlst;
                        putv(lhs,j,nil); % delete current assignment
                        putv(rhs,j,nil)
                      >>
                 else if (se:=assoc(car item,substlst)) and
                         not(protected(car item, protectednames) and
                             eq(j,cdr assoc(car item,defvarlst)))
                         then % backward-substitution of lhs
                              putv(lhs,j,cdr se)
                         else if se 
                                 then % This is an output occurrence 
                                      substlst:=delete(se,substlst);
               >>
     >>;
  % -------------------------------------------------------------------
  % Determine new prefixlist
  % -------------------------------------------------------------------
  prefixlist:=nil;
  for j:=1:lpl do
     if getv(lhs,j)
        then prefixlist:=(getv(lhs,j).getv(rhs,j)).prefixlist;
  % -------------------------------------------------------------------
  % Check on minimumlength requirements.
  % -------------------------------------------------------------------
  if min!-expr!-length!*
     then prefixlist:=
                     make_min_length(reverse prefixlist,protectednames)
     else prefixlist:=reverse prefixlist;
  % -------------------------------------------------------------------
  % Undo temporary value-backup and remove rubbish.
  % -------------------------------------------------------------------
  apply1('arestore,avarlst);   % For bootstrapping.
  cleanupvars(protectednames,prefixlist);
  % -------------------------------------------------------------------
  % Finish.
  % -------------------------------------------------------------------
  return prefixlist
  end$

symbolic procedure movable(v,defl);
%---------------------------------------------------------------------;
% We have to avoid that a subscripted variable is moved outside the  
% scope of a cse-definition it depends upon. We can check this by 
% comparing the new position and the position of the cse in the defl.
% ------------------------------------------------------------------- ;
  if pairp car(v)
     then 
       not(nil member foreach idx in cdar v collect
                (numberp(idx) or 
                if assoc(idx, defl)
                   then (cdr assoc(idx,defl) < cdr assoc(cdr v,defl))
		   else t))
     else t$

symbolic procedure insoccs(x,occlst);
begin
   if idp(x) or subscriptedvarp(x) or
      ((pairp x) and (subscriptedvarp car x))
      then occlst:=insertocc(occlst,x);
   if not(idp x) and not(constp x) then
      foreach arg in cdr x do
         occlst:=insoccs(arg,occlst);
   return occlst
end;


symbolic procedure insertocc(occlst,var);
begin scalar oldel;
   if oldel:=assoc(var,occlst) then
      occlst:=subst((var.(cdr(oldel)+1)),oldel,occlst)
   else
      occlst:=(var.1).occlst;
   return occlst
end;

symbolic procedure substel(oldnew,sign);
   car(oldnew).(if sign then list('minus,cdr oldnew) else cdr oldnew);

symbolic procedure replacein(expr1,sl);
% -------------------------------------------------------------------- ;
% All substitutions in sl are applied to expr1.                        ;
% In the resulting expression,                                         ;
%    (times 1 rest)        is replaced by (times rest)                 ;
%    (plus 0 rest)                     by (plus rest)                  ;
%    (minus (minus expr))              by expr                         ;
%    (minus 0)                         by 0                            ;
%    (times 1)                         by 1                            ;
%    (plus 0)                          by 0                            ;
%    (expt expr 0)                     by 1                            ;
%    (expt expr 1)                     by expr                         ;
%    (quotient expr 1)                 by expr                         ;
% -------------------------------------------------------------------- ;
begin scalar nexpr,iszero;
   return
      if idp(expr1) or subscriptedvarp(expr1) then
         if (nexpr:=assoc(expr1,sl)) then cdr(nexpr) else expr1
      else if constp expr1 then
         expr1
      else
      << nexpr:=foreach el in cdr(expr1) collect replacein(el,sl);
         expr1:=append(list(car expr1),nexpr);
         if eqcar(expr1,'minus) and eqcar(cadr expr1,'minus) then
            expr1:=cadadr expr1;
         if eqcar(expr1,'plus) then 
         << nexpr:='(plus);
            foreach el in cdr(expr1) do
               if not(constp(el) and !:zerop(el)) then
                  nexpr:=append(nexpr,
                       (if eqcar(el,'plus) then cdr(el) else list(el)));
            expr1:=nexpr
         >>
         else if eqcar(expr1,'times) then
         << iszero:=nil;
            nexpr:='(times);
            foreach el in cdr(expr1) do
            << if not(constp(el) and !:onep(el)) then
                  nexpr:=append(nexpr,
                      (if eqcar(el,'times) then cdr(el) else list(el)));
               if constp(el) and !:zerop(el) then iszero:=t
            >>;
            expr1:=if iszero then 0 else nexpr
         >>
         else if eqcar(expr1,'quotient) and constp(caddr expr1) and
                    !:onep(caddr expr1) then 
            expr1:=cadr(expr1)
         else if eqcar(expr1,'quotient) then
            expr1:=qqstr!?(expr1)
         else if eqcar(expr1,'minus) and constp(cadr expr1) and 
                    !:zerop(cadr expr1) then 
            expr1:=0
         else if eqcar(expr1,'expt) and constp(caddr expr1) then
            if !:zerop(caddr expr1) then
               expr1:=1
            else if !:onep(caddr expr1) then
               expr1:=cadr expr1;
         if pairp(expr1) and memq(car expr1,'(times plus)) then
            if length(expr1)=2 then
               expr1:=cadr expr1
            else
               if length(expr1)=1 then
                  expr1:=if expr1='plus then 0 else 1;
         expr1
      >>
end$

symbolic procedure qqstr!?(expr1);
 begin scalar nr,dm,nr2,dm2;
  nr:=cadr expr1; dm:=caddr expr1;
  if eqcar(nr,'quotient)
   then << dm2:=caddr nr; nr:=cadr nr>>
  else if eqcar(nr,'times)
   then nr:=foreach fct in nr collect
             if eqcar(fct,'quotient) 
              then << dm2:=caddr fct; cadr fct>> 
              else fct; 
  if eqcar(dm,'quotient)
   then <<nr2:=caddr dm; dm:=cadr dm>>
  else if eqcar(dm,'times)
   then dm:=foreach fct in dm collect
             if eqcar(fct,'quotient) 
              then << nr2:=caddr fct; cadr fct>> 
              else fct;
  if dm2 then dm:=append(list('times,dm2),
                         if eqcar(dm,'times) then cdr dm else list dm); 
  if nr2 then nr:=append(list('times,nr2),
                         if eqcar(nr,'times) then cdr nr else list nr); 
  return(list('quotient,nr,dm))
end;

endmodule;
end;


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