reduce-historical/r37/packages/gentran/lspfor.red

module lspfor;    %%  GENTRAN LISP-to-FORTRAN Translation Module  %%
 
%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%
 
% Updates:
 
% M. Warns 7 Oct 89 Patch in FORTEXP1 for negative constant exponents
%                   and integer arguments of functions like SQRT added.
 
% M.C. Dewar and J.H. Davenport 8 Jan 88 Double precision etc. added.
 
% Entry Point:  FortCode
 
symbolic$
 
 
% To allow Fortran-90 Extensions:
fluid '(!*f90)$
switch f90$

fluid '(!*gendecs)$
switch gendecs$
fluid '(!*getdecs)$
 
fluid '(!*makecalls)$
switch makecalls$
!*makecalls := t$
 
% User-Accessible Global Variables %
global '(gentranlang!* fortlinelen!* minfortlinelen!*
         fortcurrind!* !*fortcurrind!* tablen!*)$
share fortcurrind!*, fortlinelen!*, minfortlinelen!*, tablen!*$
fortcurrind!* := 0$
!*fortcurrind!* := 6$     %current level of indentation for FORTRAN code
fortlinelen!*    := 72$
minfortlinelen!* := 40$
 
% Double Precision Switch (defaults to OFF) - mcd 13/1/88 %
fluid '(!*double);
% !*double := t;
switch double;
 
 
% GENTRAN Global Variables %
 
global '(!*notfortranfuns!* !*endofloopstack!* !*subprogname!*)$
!*notfortranfuns!*:= '(acosh asinh atanh cot dilog ei erf sec)$
                        %mcd 10/11/87
!*endofloopstack!* := nil$
!*subprogname!*    := nil$  %name of subprogram being generated
 
global '(!*do!* deftype!*)$
 
% The following ought to be all the legal Fortran types mcd 19/11/87.
global '(!*legalforttypes!*);
!*legalforttypes!* := '(real integer complex real!*8 complex!*16 logical
                        implicit! integer implicit! real
                        implicit! complex implicit! real!*8
                        implicit! complex!*16 implicit! logical)$
 
global '(!*stdout!*)$
global '(!*posn!* !$!#);
%%                                       %%
%% LISP-to-FORTRAN Translation Functions %%
%%                                       %%
 
put('fortran,'formatter,'formatfort);
put('fortran,'codegen,'fortcode);
put('fortran,'proctem,'procforttem);
put('fortran,'gendecs,'fortdecs);
put('fortran,'assigner,'mkffortassign);
put('fortran,'boolean!-type,'logical);
 
%% Control Function %%
 
 
symbolic procedure fortcode forms;
for each f in forms conc
    if atom f then
        fortexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
	fortexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(fortdecs symtabget('!*main!*, '!*decs!*),
                        fortstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            fortstmt f
    else if lispdefp f then
        fortsubprog f
    else
        fortexp f$
 
 
%% Subprogram Translation %%
 
 
symbolic procedure fortsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := !*subprogname!* := cadr deff;
if onep length (body := cdddr deff) and lispstmtgpp car body then
<<  body := cdar body;  if null car body then body := cdr body  >>;
if lispreturnp (lastst := car reverse body) then
    body := append(body, list '(end))
else if not lispendp lastst then
    body := append(body, list('(return), '(end)));
type :=  symtabget(name, name);
if type then type := cadr type;
stype := symtabget(name, '!*type!*) or
         (    if type or functionformp(body, name)
                 then 'function
                 else 'subroutine    );
symtabrem(name, '!*type!*);
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
if !*getdecs and null type and stype eq 'function
   then type := deftype!*;
if type then
<<  symtabrem(name, name);
    % Generate the correct double precision type name - mcd 28/1/88 %
    if !*double then
        if type memq '(real real*8) then
		type := 'double! precision
        else if type eq 'complex then
                type := 'complex!*16;
>>;
r := mkffortsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, fortdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc fortstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$
 
 
%% Generation of Declarations %%
 
 
symbolic procedure fortdecs decs;
for each tl in formtypelists decs
    conc mkffortdec(car tl, cdr tl)$
 
 
%% Expression Translation %%
 
 
procedure fortexp exp;
fortexp1(exp, 0)$
 
symbolic procedure fortexp1(exp, wtin);
if atom exp then
    list fortranname exp
else
    if listp exp and onep length exp then
        fortranname exp
    else if optype car exp then
        begin
	scalar wt, op, res;
	wt := fortranprecedence car exp;
	op := fortranop car exp;
	exp := cdr exp;
        if onep length exp then
            res := op . fortexp1(car exp, wt)
        else
        <<
	    res := fortexp1(car exp, wt);
            if op eq '!+ then
                while exp := cdr exp do
                <<
                    if atom car exp or caar exp neq 'minus then
			res := append(res, list op);
                    res := append(res, fortexp1(car exp, wt))
                >>
            else if op eq '!*!*  then
                while exp := cdr exp do
                  begin
                   if numberp car exp and lessp(car exp, 0) then
                    res := append(append(res, list op),
                   insertparens fortexp1(car exp, wt))
                   else
                    res := append(append(res, list op),
                                  fortexp1(car exp, wt))
                  end
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  fortexp1(car exp, wt))
	>>;
	if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        fortliteral exp
    else if car exp eq 'range
        then append(fortexp cadr exp,'!: . fortexp caddr exp)
    else if car exp eq '!:rd!: then
        if smallfloatp cdr exp then
            list cdr exp
	else
        begin scalar mt; % Print bigfloats more naturally. MCD 26/2/90
	    integer dotpos,!:lower!-sci!:,!:upper!-sci!:;
		    % This forces most numbers to exponential format.
            mt := rd!:explode exp;
            exp := car mt;
            mt  := cadr mt + caddr mt - 1;
            exp := append(list('literal,car exp, '!.),cdr exp);
            if null (mt = 0) then
                exp := append(exp,
                              list(if !*double then '!D else '!E,mt))
            else if !*double then
                exp := append(exp,'(!D 0));

	    return fortliteral exp;
	end
    else if car exp eq '!:crn!: then
	fortexp1(!*crn2cr exp,wtin)
    else if car exp eq '!:gi!: then
	fortexp1(!*gi2cr exp,wtin)
    else if car exp eq '!:cr!: then
        if !*double and !*f90 then
	    ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin),
	      ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin),
              list( '!, , 'KIND!(!1!.!0!D!0!) , '!) ))
            )
        else
	    ('CMPLX!().append(fortexp1(cons('!:rd!:,cadr exp),wtin),
	      ('!,).append(fortexp1(cons('!:rd!:,cddr exp),wtin),
			   list '!)))
               % We must make this list up at run time, since there's
               % a CONC loop that relies on being able to RPLAC into it.
               % Yuck. JHD/MCD 19.6.89
    else
        begin scalar op, res, intrinsic;
	intrinsic := get(car exp, '!*fortranname!*);
	op := fortranname car exp;
	exp := cdr exp;
        % Make the arguments of intrinsic functions real if we aren't
	% sure.  Note that we can't simply evaluate the argument and
	% test that, unless it is a constant.  MCD 7/11/89.
        res := cdr foreach u in exp conc
            '!, . if not intrinsic then
              fortexp1(u,0)
            else if fixp u then
              list float u 
            else if isfloat u or memq(op,'(real dble)) then
              fortexp1(u,0) 
            else
	      (fortranname 'real . insertparens fortexp1(u,0));
	return op . insertparens res
	end;


symbolic procedure isfloat u;
   % Returns T if u is a float or a list whose car is an intrinsic
   % function name.  MCD 7/11/89.
   floatp(u) or (idp u and declared!-as!-float(u) ) or
   pairp(u) and (car u eq '!:rd!: or 
                 get(car u,'!*fortranname!*) or
                 declared!-as!-float(car u) );
 
 
procedure fortranop op;
get(op, '!*fortranop!*) or op$
 
put('or,       '!*fortranop!*, '!.or!. )$
put('and,      '!*fortranop!*, '!.and!.)$
put('not,      '!*fortranop!*, '!.not!.)$
put('equal,    '!*fortranop!*, '!.eq!. )$
put('neq,      '!*fortranop!*, '!.ne!. )$
put('greaterp, '!*fortranop!*, '!.gt!. )$
put('geq,      '!*fortranop!*, '!.ge!. )$
put('lessp,    '!*fortranop!*, '!.lt!. )$
put('leq,      '!*fortranop!*, '!.le!. )$
put('plus,     '!*fortranop!*, '!+     )$
put('times,    '!*fortranop!*, '!*     )$
put('quotient, '!*fortranop!*, '/      )$
put('minus,    '!*fortranop!*, '!-     )$
put('expt,     '!*fortranop!*, '!*!*   )$
 
% This procedure (and FORTRANNAME, RATFORNAME properties, and
% the DOUBLE flag) are shared between FORTRAN and RATFOR
procedure fortranname a; % Amended mcd 10/11/87
if stringp a then
    	stringtoatom a    %  convert a to atom containing "'s
else
<<	if a memq !*notfortranfuns!* then
	<<	wrs cdr !*stdout!*;
		prin2 "*** WARNING: ";
		prin1 a;
		prin2t " is not an intrinsic Fortran function";
	>>$
 
	if !*double then
		get(a, '!*doublename!*) or a
	else
    		get(a, '!*fortranname!*) or a
>>$
 
put('true,   '!*fortranname!*, '!.true!. )$
put('false, '!*fortranname!*, '!.false!.)$
 
%% mcd 10/11/87
%% Reduce functions' equivalent Fortran 77 real function names
 
put('abs,'!*fortranname!*, 'abs)$
put('sqrt,'!*fortranname!*, 'sqrt)$
put('exp,'!*fortranname!*, 'exp)$
put('log,'!*fortranname!*, 'alog)$
put('ln,'!*fortranname!*, 'alog)$
put('sin,'!*fortranname!*, 'sin)$
put('cos,'!*fortranname!*, 'cos)$
put('tan,'!*fortranname!*, 'tan)$
put('acos,'!*fortranname!*, 'acos)$
put('asin,'!*fortranname!*, 'asin)$
put('atan,'!*fortranname!*, 'atan)$
put('sinh,'!*fortranname!*, 'sinh)$
put('cosh,'!*fortranname!*, 'cosh)$
put('tanh,'!*fortranname!*, 'tanh)$
put('real,'!*fortranname!*, 'real)$
put('max,'!*fortranname!*, 'amax1)$
put('min,'!*fortranname!*, 'amin1)$
 
%% Reduce function's equivalent Fortran 77 double-precision names
 
put('abs,'!*doublename!*, 'dabs)$
put('sqrt,'!*doublename!*, 'dsqrt)$
put('exp,'!*doublename!*, 'dexp)$
put('log,'!*doublename!*, 'dlog)$
put('ln,'!*doublename!*, 'dlog)$
put('sin,'!*doublename!*, 'dsin)$
put('cos,'!*doublename!*, 'dcos)$
put('tan,'!*doublename!*, 'dtan)$
put('acos,'!*doublename!*, 'dacos)$
put('asin,'!*doublename!*, 'dasin)$
put('atan,'!*doublename!*, 'datan)$
put('sinh,'!*doublename!*, 'dsinh)$
put('cosh,'!*doublename!*, 'dcosh)$
put('tanh,'!*doublename!*, 'dtanh)$
put('true,    '!*doublename!*, '!.true!. )$
put('false,  '!*doublename!*, '!.false!.)$
put('real,'!*doublename!*, 'dble)$
put('max,' !*doublename!*, 'dmax1)$
put('min, '!*doublename!*, 'dmin1)$
 
%% end of mcd
 
 
procedure fortranprecedence op;
get(op, '!*fortranprecedence!*) or 9$
 
put('or,       '!*fortranprecedence!*, 1)$
put('and,      '!*fortranprecedence!*, 2)$
put('not,      '!*fortranprecedence!*, 3)$
put('equal,    '!*fortranprecedence!*, 4)$
put('neq,      '!*fortranprecedence!*, 4)$
put('greaterp, '!*fortranprecedence!*, 4)$
put('geq,      '!*fortranprecedence!*, 4)$
put('lessp,    '!*fortranprecedence!*, 4)$
put('leq,      '!*fortranprecedence!*, 4)$
put('plus,     '!*fortranprecedence!*, 5)$
put('times,    '!*fortranprecedence!*, 6)$
put('quotient, '!*fortranprecedence!*, 6)$
put('minus,    '!*fortranprecedence!*, 7)$
put('expt,     '!*fortranprecedence!*, 8)$
 
 
%% Statement Translation %%
 
 
procedure fortstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    fortstmtnum stmt
else if car stmt eq 'literal then
    fortliteral stmt
else if lispreadp stmt then
    fortread stmt
else if lispassignp stmt then
    fortassign stmt
else if lispprintp stmt then
    fortwrite stmt
else if lispcondp stmt then
    fortif stmt
else if lispbreakp stmt then
    fortbreak stmt
else if lispgop stmt then
    fortgoto stmt
else if lispreturnp stmt then
    fortreturn stmt
else if lispstopp stmt then
    fortstop stmt
else if lispendp stmt then
    fortend stmt
else if lispwhilep stmt then
    fortwhile stmt
else if lisprepeatp stmt then
    fortrepeat stmt
else if lispforp stmt then
    fortfor stmt
else if lispstmtgpp stmt then
    fortstmtgp stmt
else if lispdefp stmt then
    fortsubprog stmt
else if lispcallp stmt then
    fortcall stmt$
 
 
procedure fortassign stmt;
mkffortassign(cadr stmt, caddr stmt)$
 
procedure fortbreak stmt;
if null !*endofloopstack!* then
    gentranerr('e, nil, "BREAK NOT INSIDE LOOP - CANNOT BE TRANSLATED",
               nil)
else if atom car !*endofloopstack!* then
    begin
    scalar n1;
    n1 := genstmtnum();
    rplaca(!*endofloopstack!*, list(car !*endofloopstack!*, n1));
    return mkffortgo n1
    end
else
    mkffortgo cadar !*endofloopstack!*$
 
procedure fortcall stmt;
mkffortcall(car stmt, cdr stmt)$
 
procedure fortfor stmt;
begin
scalar n1, result, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
!*endofloopstack!* := n1 . !*endofloopstack!*;
result := mkffortdo(n1, var, loexp, hiexp, stepexp);
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortcontinue n1);
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$
 
procedure fortend stmt;
mkffortend()$
 
procedure fortgoto stmt;
begin
scalar stmtnum;
if not ( stmtnum := get(cadr stmt, '!*stmtnum!*) ) then
    stmtnum := put(cadr stmt, '!*stmtnum!*, genstmtnum());
return mkffortgo stmtnum
end$
 
symbolic procedure fortif stmt;
begin scalar r, st;
    r := mkffortif caadr stmt;
    indentfortlevel(+1);
    st := seqtogp cdadr stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, fortstmt st);
    indentfortlevel(-1);
    stmt := cdr stmt;
    while (stmt := cdr stmt) and caar stmt neq t do
    <<
        r := append(r, mkffortelseif caar stmt);
        indentfortlevel(+1);
        st := seqtogp cdar stmt;
        if eqcar(st, 'cond) and length st=2 then
            st := mkstmtgp(0, list st);
        r := append(r, fortstmt st);
        indentfortlevel(-1)
    >>;
    if stmt then
    <<
        r := append(r, mkffortelse());
        indentfortlevel(+1);
        st := seqtogp cdar stmt;
        if eqcar(st, 'cond) and length st=2 then
            st := mkstmtgp(0, list st);
        r := append(r, fortstmt st);
        indentfortlevel(-1)
    >>;
    return append(r,mkffortendif());
end$


symbolic procedure mkffortif exp;
append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp),
              list('!),'! , 'then , mkfortterpri()))$

symbolic procedure mkffortelseif exp;
append(append(list(mkforttab(), 'else, '! , 'if, '! , '!(), 
              fortexp exp),
       list('!), 'then,  mkcterpri()))$

symbolic procedure mkffortelse();
list(mkforttab(), 'else, mkfortterpri())$

symbolic procedure mkffortendif();
list(mkforttab(), 'endif, mkfortterpri())$
 
procedure fortliteral stmt;
mkffortliteral cdr stmt$
 
procedure fortread stmt;
mkffortread cadr stmt$
 
procedure fortrepeat stmt;
begin
scalar n, result, stmtlst, logexp;
stmtlst := reverse cdr stmt;
logexp := car stmtlst;
stmtlst := reverse cdr stmtlst;
n := genstmtnum();
!*endofloopstack!* := 'dummy . !*endofloopstack!*;
result := mkffortcontinue n;
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
indentfortlevel(-1);
result := append(result, mkffortifgo(list('not, logexp), n));
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$
 
procedure fortreturn stmt;
if onep length stmt then
    mkffortreturn()
else if !*subprogname!* then
    append(mkffortassign(!*subprogname!*, cadr stmt), mkffortreturn())
else
    gentranerr('e, nil,
               "RETURN NOT INSIDE FUNCTION - CANNOT BE TRANSLATED",
               nil)$
 
procedure fortstmtgp stmtgp;
<<
    if car stmtgp eq 'progn then
        stmtgp := cdr stmtgp
    else
        stmtgp := cddr stmtgp;
    for each stmt in stmtgp conc fortstmt stmt
>>$
 
procedure fortstmtnum label;
begin
scalar stmtnum;
if not ( stmtnum := get(label, '!*stmtnum!*) ) then
    stmtnum := put(label, '!*stmtnum!*, genstmtnum());
return mkffortcontinue stmtnum
end$
 
procedure fortstop stmt;
mkffortstop()$
 
procedure fortwhile stmt;
begin
scalar n1, n2, result, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
n1 := genstmtnum();
n2 := genstmtnum();
!*endofloopstack!* := n2 . !*endofloopstack!*;
result := append(list(n1, '! ), mkffortifgo(list('not, logexp), n2));
indentfortlevel(+1);
result := append(result, for each st in stmtlst conc fortstmt st);
result := append(result, mkffortgo n1);
indentfortlevel(-1);
result := append(result, mkffortcontinue n2);
if pairp car !*endofloopstack!* then
    result := append(result, mkffortcontinue cadar !*endofloopstack!*);
!*endofloopstack!* := cdr !*endofloopstack!*;
return result
end$
 
procedure fortwrite stmt;
mkffortwrite cdr stmt$
 
 
%%                                   %%
%% FORTRAN Code Formatting Functions %%
%%                                   %%
 
 
%% Statement Formatting %%
 
 
% A macro used to prevent things with *fortranname* or *doublename*
% properties being evaluated in certain circumstances.  MCD 28.3.94
symbolic smacro procedure fortexp_name(u);
   if atom u then list(u)
    else rplaca(fortexp ('dummyArrayToken . cdr u), car u)$

symbolic procedure mkffortassign(lhs, rhs);
append(append(mkforttab() . fortexp_name lhs, '!= . fortexp rhs),
       list mkfortterpri())$
 
symbolic procedure mkffortcall(fname, params);
% Installed the switch makecalls 18/11/88 mcd.
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc fortexp p),
                         list '!));
    % If we want to generate bits of statements, then what might
    % appear a subroutine call may in fact be a function reference.
    if !*makecalls then
    	append(append(list(mkforttab(), 'call, '! ), fortexp fname),
           append(params, list mkfortterpri()))
    else
        append(fortexp fname,params)
>>$
 
procedure mkffortcontinue stmtnum;
list(stmtnum, '! , mkforttab(), 'continue, mkfortterpri())$
 
symbolic procedure mkffortdec(type, varlist); %Ammended mcd 13/11/87
<<
    if type equal 'scalar then type := deftype!*;
    if type and null (type memq !*legalforttypes!*) then
	gentranerr('e,type,"Illegal Fortran type. ",nil);
    type := type or 'dimension;
 
    % Generate the correct double precision type name - mcd 14/1/88 %
    if !*double then
	if type memq '(real real*8) then
		type := 'double! precision
	else if type memq '(implicit! real implicit! real*8) then
		type := 'implicit! double! precision
	else if type eq 'complex then
		type := 'complex!*16
	else if type eq 'implicit! complex then
		type := 'implicit! complex!*16;
 
    varlist := for each v in insertcommas varlist
                   conc fortexp_name v;
    if implicitp type then
        append(list(mkforttab(), type, '! , '!(),
               append(varlist, list('!), mkfortterpri())))
    else
        append(list(mkforttab(), type, '! ),
               append(varlist,list mkfortterpri()))
>>$
 
procedure mkffortdo(stmtnum, var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . fortexp incr;
    append(append(append(list(mkforttab(), !*do!*, '! , stmtnum, '! ),
                         fortexp var),
                  append('!= . fortexp lo, '!, . fortexp hi)),
           append(incr, list mkfortterpri()))
>>$
 
procedure mkffortend;
list(mkforttab(), 'end, mkfortterpri())$
 
procedure mkffortgo stmtnum;
list(mkforttab(), 'goto, '! , stmtnum, mkfortterpri())$
 
procedure mkffortifgo(exp, stmtnum);
append(append(list(mkforttab(), 'if, '! , '!(), fortexp exp),
       list('!), '! , 'goto, '! , stmtnum, mkfortterpri()))$
 
symbolic procedure mkffortliteral args;
   begin scalar !*lower;
      return for each a in args conc
	 if a eq 'tab!* then list mkforttab()
	  else if a eq 'cr!* then list mkfortterpri()
	  else if pairp a then fortexp a
	  else list stripquotes a
   end$
 
procedure mkffortread var;
append(list(mkforttab(), 'read, '!(!*!,!*!), '! ),
       append(fortexp var, list mkfortterpri()))$
 
procedure mkffortreturn;
list(mkforttab(), 'return, mkfortterpri())$
 
procedure mkffortstop;
list(mkforttab(), 'stop, mkfortterpri())$
 
procedure mkffortsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                   conc fortexp p,
                          list '!));
    if type then
        type := list(mkforttab(), type, '! , stype, '! )
    else
        type := list(mkforttab(), stype, '! );
    append(append(type, fortexp name),
           append(params, list mkfortterpri()))
>>$
 
procedure mkffortwrite arglist;
append(append(list(mkforttab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc fortexp arg),
       list mkfortterpri())$
 
 
%% Indentation Control %%
 
 
procedure mkforttab;
list('forttab, fortcurrind!* + 6)$
 
 
procedure indentfortlevel n;
fortcurrind!* := fortcurrind!* + n * tablen!*$
 
 
procedure mkfortterpri;
list 'fortterpri$
 
%% FORTRAN Code Formatting & Printing Functions %%
 
fluid '(maxint);

maxint := 2**31-1;

symbolic procedure formatfort lst;
begin scalar linelen,str,!*lower;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if pairp elt then lispeval elt
    else
    << 
        if fixp elt and (elt>maxint or elt<-maxint) then
           elt := cdr i2rd!* elt;
        str:=explode2 elt;
	if floatp elt then
           if !*double then
              if memq('!e,str)
		 then str:=subst('!D,'!e,str)
		 else if memq('!E,str) % some LISPs use E not e
		      then str:=subst('!D,'!E,str)
                      else str:=append(str,'(D !0))
           else if memq('!e,str) then
		   str:=subst('!E,'!e,str);
           % get the casing conventions correct
        if !*posn!* + length str > fortlinelen!* then
            fortcontline();
        for each u in str do pprin2 u
    >>;
linelength linelen
end$
 
procedure fortcontline;
<<
    fortterpri();
    pprin2 "     .";
    forttab !*fortcurrind!*;
    pprin2 " "
>>$
 
procedure fortterpri;
pterpri()$
 
procedure forttab n;
<<
    !*fortcurrind!* := max(min0(n, fortlinelen!* - minfortlinelen!*),6);
    if (n := !*fortcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$
 
 
 
%% FORTRAN Template routines%%
 
 
symbolic procedure procforttem;
   begin scalar c, linelen, !*lower;
      linelen := linelength 150;
      c := procfortcomm();
      while c neq !$eof!$ do
	 if c memq '(!F !f !S !s)
	   then <<pprin2 c; c := procsubprogheading c>>
	  else if c eq !$eol!$
	   then <<pterpri(); c := procfortcomm()>>
	 else if c eq '!; then c := procactive()
	 else <<pprin2 c; c := readch()>>;
      linelength linelen
   end$
 
procedure procfortcomm;
% <col 1>C ... <cr> %
% <col 1>c ... <cr> %
begin
scalar c;
while (c := readch()) memq '(!C !c) do
<<
    pprin2 c;
    repeat
        if (c := readch()) neq !$eol!$ then
           pprin2 c
    until c eq !$eol!$;
    pterpri()
>>;
return c
end$
 
 
 
%% This function is shared between FORTRAN and RATFOR %%
 
procedure procsubprogheading c;
% Altered to allow an active statement to be included in a subprogram
% heading.  This is more flexible than forbidding it as in the previous
% version, although it does mean that where such a statement occurs the
% value of !$!# may be incorrect.   MCD 21/11/90
begin
scalar lst, name, i, propname;
lst := if c memq '(!F !f)
          then '((!U !u) (!N !n) (!C !c) (!T !t) (!I !i) (!O !o)
                 (!N !n))
          else '((!U !u) (!B !b) (!R !r) (!O !o) (!U !u)
                 (!T !t) (!I !i) (!N !n) (!E !e));
while lst and (c := readch()) memq car lst do
<<  pprin2 c;  lst := cdr lst  >>;
if lst then return c;
c:=flushspaces readch();
while not(seprp c or c eq '!() do
<<  name := aconc(name, c);  pprin2 c;  c := readch()  >>;
name := intern compress name;
if not !*gendecs then
    symtabput(name, nil, nil);
propname := if gentranlang!* eq 'fortran
               then '!*fortranname!*
               else '!*ratforname!*;
put('!$0, propname, name);
c:=flushspaces c;
if c neq '!( then return c;
i := 1;
pprin2 c;
c := readch();
while c neq '!) and c neq '!; do
<<
    while c neq '!; and (seprp c or c eq '!,) do
    <<
        if c eq !$eol!$
            then pterpri()
            else pprin2 c;
        c := readch()
    >>;
    if c neq '!; then
    <<
        name := list c;
        pprin2 c;
        while not (seprp (c := readch()) 
              or c memq list('!,,'!;, '!))) do
        <<  name := aconc(name, c);  pprin2 c  >>;
        put(intern compress append(explode2 '!$, explode2 i),
            propname,
            intern compress name);
        i := add1 i;
        c:=flushspaces c;
    >>;
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
          propname) do
    remprop(name, propname);
return c
end$
 
endmodule;
 
 
end;