reduce-historical/r37/packages/alg/reval.red

module reval; % Functions for algebraic evaluation of prefix forms.

% Author: Anthony C. Hearn.

% Copyright (c) 1991 RAND.  All rights reserved.

fluid '(!*exp !*intstr !*listargs !*resimp alglist!* dmode!* subfg!*
	varstack!*);

switch listargs;

global '(!*resubs !*sqvar!* !*val);

symbolic procedure reval u;
   reval1(u,t);

symbolic procedure aeval u;
   reval1(u,nil);

symbolic procedure aeval!* u;
   % This version rebinds alglist!* to avoid invalid computation in
   % loops.
   begin scalar alglist!*;
      return reval1(u,nil)
   end;

symbolic procedure reval1(u,v);
   (begin scalar x,y;
      if null u then return nil   % this may give trouble
       else if stringp u then return u
       else if fixp u
        then return if flagp(dmode!*,'convert) then reval2(u,v) else u
       else if atom u
	then if null subfg!* then return u
	      else if idp u and (x := get(u,'avalue))
               then if u memq varstack!* then recursiveerror u
                     else <<varstack!* := u . varstack!*;
			    return if y := get(car x,'evfn)
				     then apply2(y,u,v)
				    else reval1(cadr x,v)>>
              else nil
       else if not idp car u % or car u eq '!*comma!*
        then errpri2(u,t)
       else if car u eq '!*sq
	then return if caddr u and null !*resimp
                      then if null v then u else prepsqxx cadr u
                     else reval2(u,v)
       else if flagp(car u,'remember) then return rmmbreval(u,v)
       else if flagp(car u,'opfn) then return reval1(opfneval u,v)
       else if x := get(car u,'psopfn)
	 then <<u := apply1(x,cdr u);
		if x := get(x,'cleanupfn) then u := apply2(x,u,v);
		return u>>
          % Note that we assume that the results of such functions are
          % always returned in evaluated form.
       else if arrayp car u then return reval1(getelv u,v);
       return if x := getrtype u then
		  if y := get(x,'evfn) then apply2(y,u,v)
		    else rerror(alg,101,
				list("Missing evaluation for type",x))
               else if not atom u
		     and not atom cdr u
		     and null cddr u      % Don't pass opr to list if
					  % there is more than one arg.
		     and (y := getrtype cadr u) eq 'list  % Only lists
		     and (x := get(y,'aggregatefn))       % for now.
		     and not flagp(car u,'boolean)
		     and not !*listargs and not flagp(car u,'listargp)
                then apply2(x,u,v)
               else reval2(u,v)
   end) where varstack!* := varstack!*;

flagop listargp;

symbolic procedure rmmbreval(u,v);
 % The leading operator of u is flagged 'remember.
  begin scalar fn,x,w,u1,u2;
   fn := car u;
   u1:={fn}; u2:={fn};
   for each y in cdr u do
   <<w:=reval1(y,nil); u2:=aconc(u2,w);
     if eqcar(w,'!*sq) then w:=!*q2a(cadr w);
     u1:=aconc(u1,w)>>;
   if (x:=assoc(u1,w:=get(fn,'kvalue))) then<<x:=cadr x; go to a>>;
     % Evaluate "algebraic procedure" and "algebraic operator" directly.
   if flagp(fn,'opfn) then x:= reval1(opfneval u2,v)
   else if get(fn,'simpfn) then x:=!*q2a1(simp!* u2,v)
   else % All others are passed to reval.
   << remflag({fn},'remember);
      x:=reval1(u2,v);
      flag({fn},'remember);
   >>;
   if not smember(u1,x) and not smember(u2,x)
        then put!-kvalue(fn,get(fn,'kvalue),(car u)
                . foreach uuu in cdr u collect reval uuu,x);
 a: return x;
  end;

symbolic procedure remember u;
  % Remember declaration for operator and procedure names.
 for each fn in u do
  <<if not flagp(fn,'opfn) and null get(fn,'simpfn)
        then <<redmsg(fn,"operator"); mkop fn>>;
    if flagp(fn,'noval) or flagp(fn,'listargp) 
        then typerr(fn,"remember operator");
    flag({fn},'remember);
  >>;

put('remember,'stat,'rlis);

symbolic procedure recursiveerror u;
   msgpri(nil,u,"improperly defined in terms of itself",nil,t);

put('quote,'psopfn,'car);    % Since we don't want this evaluated.

symbolic procedure opfneval u;
   if flagp(car u ,'remember) then
    begin scalar interm,resul,x;
             interm := for each j in
                  (if flagp(car u,'noval) then cdr u else revlis cdr u)
                  collect if fixp j then j else mkquote j;
              if (x:=assoc(car u . interm ,get(car u,'kvalue)))
                         then return cadr x;
              resul := lispeval(car u . interm);
              put!-kvalue(car u,get(car u,'kvalue), car u . interm, resul);
              return resul;
     end
       else
   lispeval(car u . for each j in
                  (if flagp(car u,'noval) then cdr u else revlis cdr u)
                  collect mkquote j);

flag('(reval),'opfn);   % to make it a symbolic operator.

symbolic procedure reval2(u,v);  !*q2a1(simp!* u,v);

symbolic procedure getrtype u;
   % Returns overall algebraic type of u (or NIL is expression is a
   % scalar). Analysis is incomplete for efficiency reasons.
   % Type conflicts will later be resolved when expression is evaluated.
   begin scalar x,y;
    return
    if null u then nil   % Suggested by P.K.H. Gragert to avoid the
                         % loop caused if NIL has a share flag.
     else if atom u
      then if not idp u then not numberp u and getrtype1 u
	    else if flagp(u,'share) % then getrtype lispeval u
	     then if (x := eval u) eq u then nil else getrtype x
	    else if (x := get(u,'avalue)) and
		       not(car x memq '(scalar generic))
		    or (x := get(u,'rtype)) and (x := list x)
                    then if y := get(car x,'rtypefn) then apply1(y,nil)
                          else car x
                  else nil
     else if not idp car u then nil
     else if (x := get(car u,'avalue)) and (x := get(car x,'rtypefn))
      then apply1(x,cdr u)
     else getrtype2 u
   end;

symbolic procedure getrtype1 u;
   % Placeholder for packages that use vectors.
   nil;

symbolic procedure getrtype2 u;
   % Placeholder for packages that key expression type to the operator.
   begin scalar x;
     % Next line is maybe only needed by EXCALC.
      return if (x := get(car u,'rtype)) and (x := get(x,'rtypefn))
	       then apply1(x,cdr u)
	      else if x := get(car u,'rtypefn) then apply1(x,cdr u)
	      else nil
   end;

remprop('rtypecar,'stat);

symbolic procedure rtypecar u;
   for each j in u do put(j,'rtypefn,'getrtypecar);

deflist('((rtypecar rlis)),'stat);

rtypecar difference,expt,minus,plus,recip;

deflist('
  ((quotient getrtypeor)
   (times getrtypeor)
   (!*sq (lambda (x) nil))
 ),'rtypefn);

symbolic procedure getrtypecar u; getrtype car u;

symbolic procedure getrtypeor u;
   u and (getrtype car u or getrtypeor cdr u);

symbolic procedure !*eqn2a u;
   % If u is an equation a=b, it is converted to an equivalent equation
   % a-b=0, or if a=0, b=0.  Otherwise u is returned converted to true
   % prefix form.
   if not eqexpr u then prepsqyy u
    else if null cdr u or null cddr u or cdddr u
     then typerr(u,"equation")
    else (if rh=0 then lh else if lh=0 then rh else{'difference,lh,rh})
	  where lh=prepsqyy cadr u,rh=prepsqyy caddr u;

symbolic procedure prepsqyy u;
   if eqcar(u,'!*sq) then prepsqxx cadr u else u;

symbolic procedure getelv u;
   % Returns the value of the array element U.
%  getel(car u . for each x in cdr u collect ieval x);
   getel(car u . for each x in cdr u collect reval_without_mod x);

symbolic procedure setelv(u,v);
%  setel(car u . for each x in cdr u collect ieval x,v);
   setel(car u . for each x in cdr u collect reval_without_mod x,v);

symbolic procedure reval_without_mod u;
   % Evaluate u without a modulus.
   if dmode!* eq '!:mod!: then (reval u where dmode!* = nil)
    else reval u;

symbolic procedure revlis u; for each j in u collect reval j;

symbolic procedure revop1 u;
   if !*val then car u . revlis cdr u else u;

symbolic procedure mk!*sq u;
   % Modified by Francis J. Wright to return a list correctly.
%  if null numr u then 0
%   else if atom numr u and denr u=1 then numr u
%   else '!*sq . expchk u . if !*resubs then !*sqvar!* else list nil;
  (if null numr u then 0
    else if atom numr u and denr u=1 then numr u
    else if kernp u and eqcar(mvar numr u,'list) then mvar numr u
    else '!*sq . u . if !*resubs then !*sqvar!* else list nil)
   where u=expchk u;

symbolic macro procedure !*sq u;
   % Provide an interface to symbolic mode.
   prepsq cadr u;

symbolic procedure expchk u; if !*exp then u else offexpchk u;

symbolic procedure lengthreval u;
   begin scalar v,w,x;
      if length u neq 1
	then rerror(alg,11,
		    "LENGTH called with wrong number of arguments");
      u := car u;
      if idp u and arrayp u then return 'list . get(u,'dimension);
      v := aeval u;
      if (w := getrtype v) and (x := get(w,'lengthfn))
	then return apply1(x,v)
       else if atom v then return 1
       else if not idp car v or not(x := get(car v,'lengthfn))
	then if w
	  then lprie list("LENGTH not defined for argument of type",w)
	 else typerr(u,"LENGTH argument")
       else return apply1(x,cdr v)
   end;

put('length,'psopfn,'lengthreval);


% Code for evaluation of expressions whose type can only be
% infered after partial evaluation.

symbolic procedure yetunknowntypeeval(u,v);
   % Assumes that only psopfn's can produce yet unknown types.
   reval1(eval!-yetunknowntypeexpr(u,v),v);

symbolic procedure eval!-yetunknowntypeexpr(u,v);
   if atom u 
      then ((if w then eval!-yetunknowntypeexpr(cadr w,v)
	      else u)
	    where w = get(u,'avalue))
    else if car u eq '!*sq or get(car u,'dname) or car u eq '!:dn!:
     then u
    else ((if x and (getrtype u eq 'yetunknowntype)
	      then apply1(x,cdr u)
	    else car u . for each j in cdr u collect
			     eval!-yetunknowntypeexpr(j,v))
	  where x = get(car u,'psopfn));

put('yetunknowntype,'evfn,'yetunknowntypeeval);

endmodule;

end;