File r38/packages/scope/restore.red from the latest check-in


module restore;

fluid '(prefixlist);

global '(!*vectorc malst optlang!*);

symbolic procedure vectorcode list_of_names;
% ------------------------------------------------------------------- ;
% All names are assigned the flag subscripted               
% ------------------------------------------------------------------- ;
<< %!*vectorc:='t;                   % should NOT be set. JB 15/3/94
   flag(list_of_names,'subscripted);
   flag(list_of_names,'vectorvar); >>$

put('vectorcode,'stat,'rlis)$
symbolic operator vectorcode$

symbolic procedure vclear list_of_names;
% ------------------------------------------------------------------- ;
% All names are assigned the flag subscripted.
% ------------------------------------------------------------------- ;
<< remflag(list_of_names,'subscripted);
   remflag(list_of_names,'vectorvar); >>$

put('vclear,'stat,'rlis)$
symbolic operator vclear$

symbolic procedure vectorvarp u;
(!*vectorc and subscriptedvarp(u))
or 
flagp(u, 'vectorvar);

%global '(!*vectorc)$ switch vectorc$ !*vectorc:='nil$

symbolic procedure optlang u; 
if not member(car u, '(nil c fortran f90 pascal ratfor))
   then if eq(car(u), 'fortran90)
           then optlang!* := 'f90
           else rederr("No such targetlanguage available !!!")
   else optlang!* := car u$

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

global '(avarlst)$ malst:=avarlst:='nil$

symbolic procedure algresults;
algresults1 prefixlist;

symbolic procedure algresults1 prefixlist;
%-------------------------------------------------------------------- ;
% The algebraic mode facility aresults is used to produce an alg. mode;
% list, presenting the result of a previous optimize-run. All possibly;
% existing algebraic values, of both lhs and rhs variables in the     ;
% listed eq's are stored with the indicator-name a2value,             ;
% simply to avoid untimely backsubstitutions.                         ;
% The algebraic variables, having an avalue are collectedin the list  ;
% avarlst. This list is mainly produced with the procedure check_info.;
% ------------------------------------------------------------------- ;
begin
  scalar results;
  foreach item in prefixlist do
   << check_info car item;
      check_info cdr item;
      results:=list('equal,car item, reval cdr item).results;
   >>;
 if malst then foreach el in malst do put(car el,'simpfn,'simpiden);
 return append(list('list),reverse results)
end;

symbolic operator algresults$
algebraic operator aresults;
algebraic(let aresults=algresults());

symbolic procedure check_info info;
% ------------------------------------------------------------------- ;
% The list info is searched for algebraic variables having an avalue. ;
% This value is saved as value of the indicator a2value, before the   ;
% avalue itself is removed. The variable name is stored in the list   ;
% avarlst.                                                            ;
% ------------------------------------------------------------------- ;
begin scalar aval;
 if pairp(info)
  then
   if constp(info) % Could be some float...
     then info
     else foreach item in info do check_info item
  else
   if idp(info) and not(memq(info,avarlst)) and 
      (aval:=get(info,'avalue))
    then << put(info,'a2value,aval);
            remprop(info,'avalue);
            avarlst:=info.avarlst;
            if member(get(info,'rtype),'(array matrix))
               then <<malst := cons(info, get(info,'rtype)) . malst;
                      remprop(info,'rtype)
                    >>
         >>;
end;
symbolic expr procedure arestore(list_of_names);
% ------------------------------------------------------------------- ;
% All names in the list_of_names get their avalue back. 
% Their names are removed from the avarlst.             
% ------------------------------------------------------------------- ;
 foreach name in list_of_names do 
        << put(name,'avalue,get(name,'a2value));
           remprop(name,'a2value);
           avarlst:=delete(name,avarlst);
           if assoc(name,malst) 
              then <<put(name,'rtype,cdr assoc(name,malst));
                     remprop(name,'klist);
                     remprop(name,'simpfn);
                     malst:=delete(assoc(name,malst),malst)
                   >>
        >>;
put('arestore,'stat,'rlis)$
symbolic operator arestore$

symbolic procedure restoreall;
% ------------------------------------------------------------------- ;
% All names in the list avarlst get their avalue back. 
% Then avarlst is set to nil again.
% ------------------------------------------------------------------- ;
arestore avarlst;


remprop('restoreall,'stat)$   % So next line parses properly.
symbolic operator restoreall$
put('restoreall,'stat,'endstat)$

symbolic expr procedure ireval ex;
%----------------------------------------------------------------------
% `Symbolic-reval'; all variables known to the system by their avalue,
% are hidden by check_info. 
% This prevents expressions like x + 1  and 2x + 1  to evaluate to 1 
% when x has the avalue 0.
% After this `reval' is applied to obtain a canonical representation of
% ex.
%----------------------------------------------------------------------
begin
  check_info ex;
  if atom ex
     then return ex
     else return (car ex . foreach el in cdr ex collect reval el);
  end;


symbolic procedure ids_to_restore;
% ---------------------------------------------------------------------
% The present value of the fluid variable avarlst is printed.          
% ---------------------------------------------------------------------
append(list('list),avarlst)$

symbolic operator ids_to_restore$
algebraic operator restorables$
algebraic(let restorables=ids_to_restore())$

endmodule;

end;


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