reduce-historical/r38/packages/mathpr/fortpri.red

module fortpri; % FORTRAN output package for expressions.

% Author: Anthony C. Hearn.

% Modified by: James Davenport after Francoise Richard, April 1988.
%              Herbert Melenk (introducing C output style), October 1994

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

fluid  '(!*fort
	 !*fortupper
	 !*period
	 scountr
         explis
         fbrkt
         fvar
         nchars
         svar
         posn!*
         fortlang!*);

switch fortupper;

global '(card_no
	 charassoc!*
	 fort_width
         fort_lang
         spare!*
         varnam!*);

%   The global fort_exponent is defined in the module arith/smlbflot.

% Global variables initialized in this section.

% SPARE!* should be set in the system dependent code module.

card_no:=20;
charassoc!* :=
	 '((!A . !a) (!B . !b) (!C . !c) (!D . !d) (!E . !e) (!F . !f)
	   (!G . !g) (!H . !h) (!I . !i) (!J . !j) (!K . !k) (!L . !l)
	   (!M . !m) (!N . !n) (!O . !o) (!P . !p) (!Q . !q) (!R . !r)
	   (!S . !s) (!T . !t) (!U . !u) (!V . !v) (!W . !w) (!X . !x)
	   (!Y . !y) (!Z . !z));
fort_width := 70;
posn!* := 0;
varnam!* := 'ans;
fort_lang := 'fort;

flag ('(card_no fort_width fort_lang),'share);

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

flag('(fort_array),'flagop);

symbolic procedure varname u;
   % Sets the default variable assignment name.
   if not idp car u then typerr(car u,"identifier")
    else varnam!* := car u;

rlistat '(varname);

symbolic procedure flength(u,chars);
   if chars<0 then chars
    else if atom u
     then chars-if numberp u then if fixp u then flatsizec u+1
                                   else flatsizec u
                 else flatsizec((lambda x; if x then x else u)
                                   get(u,'prtch))
    else flength(car u,flenlis(cdr u,chars)-2);

symbolic procedure flenlis(u,chars);
   if null u then chars
    else if chars<0 then chars
    else if atom u then flength(u,chars)
    else flenlis(cdr u,flength(car u,chars));

symbolic procedure fmprint(l,p);
   begin scalar x,w;
        if null l then return nil
         else if atom l then <<
	   if l eq 'e then return
%            if fortlang!*='c then "exp(1.0)" else "EXP(1.0)";
	     fprin2!* "EXP(1.0)";
           if fixp l and !*period then return fmprint(i2rd!* l,p);
           if not numberp l or
	      not(l<0) then return fprin2!* l;
	   fprin2!* "(";
           fbrkt := nil . fbrkt;
	   fprin2!* l;
	   fprin2!* ")";
           return fbrkt := cdr fbrkt >>
	 else if stringp l then return fprin2!* l
         else if not atom car l then fmprint(car l,p)
         else if x := get(car l,'fort)
          then return apply2(x,l,p)
         else if ((x := get(car l,'pprifn))
             and not((x := apply2(x,l,p)) eq 'failed)) or
                 ((x := get(car l,'prifn))
             and not((x := apply1(x,l)) eq 'failed))
          then return x
         else if x := get(car l,'infix) then <<
	    p := not(x>p);
	    if p then <<fprin2!* "("; fbrkt := nil . fbrkt>>;
            fnprint(car l,x,cdr l);
	    if p then <<fprin2!* ")"; fbrkt := cdr fbrkt>>;
            return >>
	 else fprin2!* car l;
        w:= fortlang!* = 'c and flagp(car l,'fort_array);
	fprin2!* if w then "[" else "(";
        fbrkt := nil . fbrkt;
	x := !*period;
	% Assume no period printing for non-operators (e.g., matrices).
	if gettype car l neq 'operator or flagp(car l,'fort_array) 
                   then !*period := nil;
        if cdr l then fnprint(if w then "][" else '!*comma!*,0,cdr l);
	!*period := x;
	fprin2!* if w then "]" else ")";
        return fbrkt := cdr fbrkt
   end;

symbolic procedure fnprint(op,p,l);
   begin
        if op eq 'expt then return fexppri(p,l)
         else if not get(op,'alt) then <<
           fmprint(car l,p);
           l := cdr l >>;
        for each v in l do <<
	  if atom v or not (op eq get(car v,'alt)) then foprin op;
          fmprint(v,p) >>
   end;

symbolic procedure fexppri(p,l);
   % Next line added by James Davenport after Francoise Richard.
   if car l eq 'e then fmprint('exp . cdr l,p)
   % C entry by Herbert Melenk.
    else if fortlang!*='c then
       if fixp cadr l and cadr l >0 and cadr l<4 then
           fmprint('times . for i:=1:cadr l collect car l,p)
       else fmprint('pow.l,p) 
    else begin scalar pperiod;
      fmprint(car l,p);
      foprin 'expt;
      pperiod := !*period;
      if numberp cadr l then !*period := nil else !*period := t;
      fmprint(cadr l,p);
      !*period := pperiod
   end;

put('pow,'simpfn,'simpiden);

symbolic procedure foprin op;
   (if null x then fprin2!* op else fprin2!* x) where x=get(op,'prtch);

symbolic procedure fvarpri(u,v,w);
   %prints an assignment in FORTRAN notation;
   begin integer scountr,llength,nchars; scalar explis,fvar,svar;
        fortlang!* := reval fort_lang;
        if not(fortlang!* memq '(fort c)) then
           typerr(fortlang!*,"target language");
        if not posintegerp card_no
          then typerr(card_no,"FORTRAN card number");
        if not posintegerp fort_width
          then typerr(fort_width,"FORTRAN line width");
        llength := linelength fort_width;
        if stringp u
          then return <<fprin2!* u;
                        if w eq 'only then fterpri(t);
                        linelength llength>>;
        if eqcar(u,'!*sq) then u := prepsq!* sqhorner!* cadr u;
        scountr := 0;
        nchars := if fortlang!* = 'c then 999999
            else ((linelength nil-spare!*)-12)*card_no;
           %12 is to allow for indentation and end of line effects;
        svar := varnam!*;
        fvar := if null v then (if fortlang!*='fort then svar else nil)
                 else car v;
        if posn!*=0 and w then fortpri(fvar,u,w)
         else fortpri(nil,u,w);
                % should mean expression preceded by a string.
        linelength llength
   end;

symbolic procedure fortpri(fvar,xexp,w);
   begin scalar fbrkt;
      if eqcar(xexp,'list)
	then <<posn!* := 0;
	       fprin2!* "C ***** INVALID FORTRAN CONSTRUCT (";
	       fprin2!* car xexp;
	       return fprin2!* ") NOT PRINTED">>;
        if flength(xexp,nchars)<0
          then xexp := car xexp . fout(cdr xexp,car xexp,w);
        if fvar
          then <<posn!* := 0;
		 fprin2!* "      ";
                 fmprint(fvar,0);
		 fprin2!* "=">>;
        fmprint(xexp,0);
        if fortlang!*='fort and w or w='last then fterpri(w)
   end;

symbolic procedure fout(args,op,w);
   begin integer ncharsl; scalar distop,x,z;
        ncharsl := nchars;
        if op memq '(plus times) then distop := op;
        while args do
         <<x := car args;
           if atom x and (ncharsl := flength(x,ncharsl))
              or (null cdr args or distop)
                and (ncharsl := flength(x,ncharsl))>0
             then z := x . z
            else if distop and flength(x,nchars)>0
             then <<z := fout1(distop . args,w) . z;
                    args := list nil>>
            else <<z := fout1(x,w) . z;
                   ncharsl := flength(op,ncharsl)>>;
           ncharsl := flength(op,ncharsl);
           args := cdr args>>;
        return reversip!* z
   end;

symbolic procedure fout1(xexp,w);
   begin scalar fvar;
      fvar := genvar();
      explis := (xexp . fvar) . explis;
      fortpri(fvar,xexp,w);
      return fvar
   end;

% If we are in a comment, we want to continue to stay in one,
% Even if there's a formula. That's the purpose of this flag
% Added by James Davenport after Francoise Richard.

global '(comment!*);

symbolic procedure fprin2!* u;
   % FORTRAN output of U.
   begin integer m,n;
	if posn!*=0 then comment!* :=
                stringp u and cadr(explode u) eq 'C;
        n := flatsizec u;
        m := posn!*+n;
	if fixp u and !*period then m := m+1;
        if m<(linelength nil-spare!*) then posn!* := m
          else <<terpri(); 
		if comment!* then << fprin2 "C"; spaces 4 >>
                             else spaces 5;
                prin2 if fortlang!*='c then "  " else ". "; 
                posn!* := n+7>>;
	fprin2 u;
	if fixp u and !*period then prin2 "."
   end;

symbolic procedure prin2!-downcase u;
   for each c in explode2 u do
      if liter c then prin2 red!-char!-downcase c else prin2 c;

symbolic procedure prin2!-upcase u;
   for each c in explode2 u do
      if liter c then prin2 red!-char!-upcase c else prin2 c;

symbolic procedure fprin2 u;
   % Prints id or string u so that case of all characters depends on
   % !*fortupper. Note !*lower setting only relevant here for PSL.
   (if !*fortupper then prin2!-upcase u else prin2!-downcase u)
    where !*lower = nil;

symbolic procedure red!-char!-downcase u;
   (if x then cdr x else u) where x = atsoc(u,charassoc!*);

symbolic procedure red!-char!-upcase u;
   (if x then car x else u) where x = rassoc(u,charassoc!*);

symbolic procedure fterpri(u);
   <<if not(posn!*=0) and u then terpri();
     posn!* := 0>>;

symbolic procedure genvar;
   intern compress append(explode svar,explode(scountr := scountr + 1));

mkop 'no_period;  % for printing of expressions with period locally off.

put('no_period,'fort,'fo_no_period);

symbolic procedure fo_no_period(u,p);
   begin scalar !*period; fmprint(cadr u,p) end;

endmodule;

end;