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

module lsprat;    %%  GENTRAN LISP-to-RATFOR Translation Module  %%
 
%%  Author:  Barbara L. Gates  %%
%%  December 1986              %%
 
% Updates:
 
% M.C. Dewar and J.H. Davenport 8 Jan 88 Double precision check added.
 
% Entry Point:  RatCode
 
 
symbolic$
 
fluid '(!*double !*gendecs !*getdecs);
 
switch gendecs$
 
fluid '(!*makecalls)$
switch makecalls$
!*makecalls := t$
 
% User-Accessible Global Variables %
global '(minratlinelen!* ratlinelen!* !*ratcurrind!*
         ratcurrind!* tablen!*)$
share ratcurrind!*, minratlinelen!*, ratlinelen!*, tablen!*$
ratcurrind!* := 0$
minratlinelen!*  := 40$
ratlinelen!*     := 80$
!*ratcurrind!*  := 0$     %current level of indentation for RATFOR code
 
 
global '(deftype!* !*do!* !*notfortranfuns!* !*legalforttypes!*)$
 
global '(!*stdout!*)$
global '(!*posn!* !$!#)$
 
%%                                      %%
%% LISP-to-RATFOR Translation Functions %%
%%                                      %%
 
put('ratfor,'formatter,'formatrat);
put('ratfor,'codegen,'ratcode);
put('ratfor,'proctem,'procrattem);
put('ratfor,'gendecs,'ratdecs);
put('ratfor,'assigner,'mkfratassign);
put('ratfor,'boolean!-type,'logical);
 
%% Control Function %%
 
 
procedure ratcode forms;
for each f in forms conc
    if atom f then
        ratexp f
    else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
        ratexp f
    else if lispstmtp f or lispstmtgpp f then
        if !*gendecs then
            begin
            scalar r;
            r := append(ratdecs symtabget('!*main!*, '!*decs!*),
                        ratstmt f);
            symtabrem('!*main!*, '!*decs!*);
            return r
            end
        else
            ratstmt f
    else if lispdefp f then
        ratsubprog f
    else
        ratexp f$
 
 
%% Subprogram Translation %%
 
 
symbolic procedure ratsubprog deff;
begin
scalar type, stype, name, params, body, lastst, r;
name := 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 := cadr symtabget(name, name);
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 := mkfratsubprogdec(type, stype, name, params);
if !*gendecs then
    r := append(r, ratdecs symtabget(name, '!*decs!*));
r := append(r, for each s in body
                   conc ratstmt s);
if !*gendecs then
<<  symtabrem(name, nil);  symtabrem(name, '!*decs!*)  >>;
return r
end$
 
 
%% Generation of Declarations %%
 
 
procedure ratdecs decs;
for each tl in formtypelists decs
    conc mkfratdec(car tl, cdr tl)$
 
 
%% Expression Translation %%
 
 
procedure ratexp exp;
ratexp1(exp, 0)$
 
procedure ratexp1(exp, wtin);
if atom exp then
    list fortranname exp
else
    if onep length exp then
        fortranname exp
    else if optype car exp then
        begin
        scalar wt, op, res;
        wt := ratforprecedence car exp;
        op := ratforop car exp;
        exp := cdr exp;
        if onep length exp then
            res := op . ratexp1(car exp, wt)
        else
        <<
            res := ratexp1(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, ratexp1(car exp, wt))
                >>
            else
                while exp := cdr exp do
                    res := append(append(res, list op),
                                  ratexp1(car exp, wt))
        >>;
        if wtin >= wt then res := insertparens res;
        return res
        end
    else if car exp eq 'literal then
        ratliteral exp
    else if car exp eq 'range
        then append(fortexp cadr exp,'!: . fortexp caddr exp)
    else if car exp eq '!:rd!: then
    begin scalar mt;
        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,'(!e 0));

        return ratliteral exp;
    end
    else if car exp memq '(!:cr!: !:crn!: !:gi!:) then
    begin scalar re,im;
 
        re := explode if smallfloatp cadr exp then cadr exp
                                              else caadr exp;
        re := if memq ('!e, re) then
            subst('d,'!e,re)
        else if memq ('!e, re) then
            subst('d,'!e,re)
        else if !*double then
            append(re,'(d 0))
        else
            append(re,'(e 0));
 
        im := explode if smallfloatp cddr exp then cddr exp
                                              else caddr exp;
        im := if memq ('!e, im) then
            subst('d,'!e,im)
        else if memq ('!e, im) then
            subst('d,'!e,im)
        else if !*double then
            append(im,'(d 0))
        else
            append(im,'(e 0));
 
        return ('!().append(re,('!,).append(im,'(!))));
    end
    else
        begin
        scalar op, res;
        op := fortranname car exp;
        exp := cdr exp;
        res := ratexp1(car exp, 0);
        while exp := cdr exp do
            res := append(append(res, list '!,), ratexp1(car exp, 0));
        return op . insertparens res
        end$
 
 
procedure ratforop op;
get(op, '!*ratforop!*) or op$
 
put('or,       '!*ratforop!*, '|   )$
put('and,      '!*ratforop!*, '&   )$
put('not,      '!*ratforop!*, '!!  )$
put('equal,    '!*ratforop!*, '!=!=)$
put('neq,      '!*ratforop!*, '!!!=)$
put('greaterp, '!*ratforop!*, '>   )$
put('geq,      '!*ratforop!*, '!>!=)$
put('lessp,    '!*ratforop!*, '<   )$
put('leq,      '!*ratforop!*, '!<!=)$
put('plus,     '!*ratforop!*, '!+  )$
put('times,    '!*ratforop!*, '*   )$
put('quotient, '!*ratforop!*, '/   )$
put('minus,    '!*ratforop!*, '!-  )$
put('expt,     '!*ratforop!*, '!*!*)$
 
procedure ratforprecedence op;
get(op, '!*ratforprecedence!*) or 9$
 
put('or,       '!*ratforprecedence!*, 1)$
put('and,      '!*ratforprecedence!*, 2)$
put('not,      '!*ratforprecedence!*, 3)$
put('equal,    '!*ratforprecedence!*, 4)$
put('neq,      '!*ratforprecedence!*, 4)$
put('greaterp, '!*ratforprecedence!*, 4)$
put('geq,      '!*ratforprecedence!*, 4)$
put('lessp,    '!*ratforprecedence!*, 4)$
put('leq,      '!*ratforprecedence!*, 4)$
put('plus,     '!*ratforprecedence!*, 5)$
put('times,    '!*ratforprecedence!*, 6)$
put('quotient, '!*ratforprecedence!*, 6)$
put('minus,    '!*ratforprecedence!*, 7)$
put('expt,     '!*ratforprecedence!*, 8)$
 
 
%% Statement Translation %%
 
 
procedure ratstmt stmt;
if null stmt then
    nil
else if lisplabelp stmt then
    ratstmtnum stmt
else if car stmt eq 'literal then
    ratliteral stmt
else if lispreadp stmt then
    ratread stmt
else if lispassignp stmt then
    ratassign stmt
else if lispprintp stmt then
    ratwrite stmt
else if lispcondp stmt then
    ratif stmt
else if lispbreakp stmt then
    ratbreak stmt
else if lispgop stmt then
    ratgoto stmt
else if lispreturnp stmt then
    ratreturn stmt
else if lispstopp stmt then
    ratstop stmt
else if lispendp stmt then
    ratend stmt
else if lisprepeatp stmt then
    ratrepeat stmt
else if lispwhilep stmt then
    ratwhile stmt
else if lispforp stmt then
    ratforfor stmt
else if lispstmtgpp stmt then
    ratstmtgp stmt
else if lispdefp stmt then
    ratsubprog stmt
else if lispcallp stmt then
    ratcall stmt$
 
 
procedure ratassign stmt;
mkfratassign(cadr stmt, caddr stmt)$
 
procedure ratbreak stmt;
mkfratbreak()$
 
procedure ratcall stmt;
mkfratcall(car stmt, cdr stmt)$
 
procedure ratforfor stmt;
begin
scalar r, var, loexp, stepexp, hiexp, stmtlst;
var := cadr stmt;
stmt := cddr stmt;
loexp := caar stmt;
stepexp := cadar stmt;
hiexp := caddar stmt;
stmtlst := cddr stmt;
r := mkfratdo(var, loexp, hiexp, stepexp);
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return r
end$
 
procedure ratend stmt;
mkfratend()$
 
procedure ratgoto stmt;
begin
scalar stmtnum;
stmtnum := get(cadr stmt, '!*stmtnum!*) or
          put(cadr stmt, '!*stmtnum!*, genstmtnum());
return mkfratgo stmtnum
end$
 
procedure ratif stmt;
begin
scalar r, st;
r := mkfratif caadr stmt;
indentratlevel(+1);
st := seqtogp cdadr stmt;
if eqcar(st, 'cond) and length st=2 then
    st := mkstmtgp(0, list st);
r := append(r, ratstmt st);
indentratlevel(-1);
stmt := cdr stmt;
while (stmt := cdr stmt) and caar stmt neq t do
<<
    r := append(r, mkfratelseif caar stmt);
    indentratlevel(+1);
    st := seqtogp cdar stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, ratstmt st);
    indentratlevel(-1)
>>;
if stmt then
<<
    r := append(r, mkfratelse());
    indentratlevel(+1);
    st := seqtogp cdar stmt;
    if eqcar(st, 'cond) and length st=2 then
        st := mkstmtgp(0, list st);
    r := append(r, ratstmt st);
    indentratlevel(-1)
>>;
return r
end$
 
procedure ratliteral stmt;
mkfratliteral cdr stmt$
 
procedure ratread stmt;
mkfratread cadr stmt$
 
procedure ratrepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfratrepeat();
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return append(r, mkfratuntil logexp)
end$
 
procedure ratreturn stmt;
if cdr stmt then
    mkfratreturn cadr stmt
else
    mkfratreturn nil$
 
procedure ratstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
    stmtgp := cdr stmtgp
else
    stmtgp := cddr stmtgp;
r := mkfratbegingp();
indentratlevel(+1);
r := append(r, for each stmt in stmtgp conc ratstmt stmt);
indentratlevel(-1);
return append(r, mkfratendgp())
end$
 
procedure ratstmtnum label;
begin
scalar stmtnum;
stmtnum := get(label, '!*stmtnum!*) or
          put(label, '!*stmtnum!*, genstmtnum());
return mkfratcontinue stmtnum
end$
 
procedure ratstop stmt;
mkfratstop()$
 
procedure ratwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfratwhile logexp;
indentratlevel(+1);
r := append(r, foreach st in stmtlst conc ratstmt st);
indentratlevel(-1);
return r
end$
 
procedure ratwrite stmt;
mkfratwrite cdr stmt$
 
 
%%                                  %%
%% RATFOR 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 ratexp_name(u);
   if atom u then list(u)
    else rplaca(ratexp ('dummyArrayToken . cdr u), car u)$

procedure mkfratassign(lhs, rhs);
append(append(mkrattab() . ratexp_name lhs, '!= . ratexp rhs),
       list mkratterpri())$
 
procedure mkfratbegingp;
list(mkrattab(), '!{, mkratterpri())$
 
procedure mkfratbreak;
list(mkrattab(), 'break, mkratterpri())$
 
procedure mkfratcall(fname, params);
% Installed the switch makecalls 18/11/88 mcd.
<<
    if params then
        params := append(append(list '!(,
                                for each p in insertcommas params
                                              conc ratexp 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(mkrattab(), 'call, '! ), ratexp fname),
           append(params, list mkratterpri()))
    else
        append(ratexp fname,params)
>>$
 
procedure mkfratcontinue stmtnum;
list(stmtnum, '! , mkrattab(), 'continue, mkratterpri())$
 
 
symbolic procedure mkfratdec(type, varlist); %Ammended mcd 3/12/87
<<
    if type equal 'scalar then type := deftype!*;
    if type and null (type memq !*legalforttypes!*) then
        gentranerr('e,type,"Illegal Ratfor 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 ratexp_name v;
    if implicitp type then
        append(list(mkrattab(), type, '! , '!(),
               append(varlist, list('!), mkratterpri())))
    else
        append(list(mkrattab(), type, '! ),
               append(varlist, list mkratterpri()))
>>$
 
procedure mkfratdo(var, lo, hi, incr);
<<
    if onep incr then
        incr := nil
    else if incr then
        incr := '!, . ratexp incr;
    append(append(append(list(mkrattab(), !*do!*, '! ), ratexp var),
                  append('!= . ratexp lo, '!, . ratexp hi)),
           append(incr, list mkratterpri()))
>>$
 
procedure mkfratelse;
list(mkrattab(), 'else, mkratterpri())$
 
procedure mkfratelseif exp;
append(append(list(mkrattab(), 'else, '! , 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$
 
procedure mkfratend;
list(mkrattab(), 'end, mkratterpri())$
 
procedure mkfratendgp;
list(mkrattab(), '!}, mkratterpri())$
 
procedure mkfratgo stmtnum;
list(mkrattab(), 'goto, '! , stmtnum, mkratterpri())$
 
procedure mkfratif exp;
append(append(list(mkrattab(), 'if, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$
 
procedure mkfratliteral args;
for each a in args conc
    if a eq 'tab!* then
        list mkrattab()
    else if a eq 'cr!* then
        list mkratterpri()
    else if pairp a then
        ratexp a
    else
        list stripquotes a$
 
procedure mkfratread var;
append(list(mkrattab(), 'read, '!(!*!,!*!), '! ),
       append(ratexp var, list mkratterpri()))$
 
procedure mkfratrepeat;
list(mkrattab(), 'repeat, mkratterpri())$
 
procedure mkfratreturn exp;
if exp then
    append(append(list(mkrattab(), 'return, '!(), ratexp exp),
           list('!), mkratterpri()))
else
    list(mkrattab(), 'return, mkratterpri())$
 
procedure mkfratstop;
list(mkrattab(), 'stop, mkratterpri())$
 
procedure mkfratsubprogdec(type, stype, name, params);
<<
    if params then
        params := append('!( . for each p in insertcommas params
                                  conc ratexp p,
                         list '!));
    if type then
        type := list(mkrattab(), type, '! , stype, '! )
    else
        type := list(mkrattab(), stype, '! );
    append(append(type, ratexp name),
           append(params,list mkratterpri()))
>>$
 
procedure mkfratuntil logexp;
append(list(mkrattab(), 'until, '! , '!(),
       append(ratexp logexp, list('!), mkratterpri())))$
 
procedure mkfratwhile exp;
append(append(list(mkrattab(), 'while, '! , '!(), ratexp exp),
       list('!), mkratterpri()))$
 
procedure mkfratwrite arglist;
append(append(list(mkrattab(), 'write, '!(!*!,!*!), '! ),
              for each arg in insertcommas arglist conc ratexp arg),
       list mkratterpri())$
 
 
%% Indentation Control %%
 
 
procedure mkrattab;
list('rattab, ratcurrind!*)$
 
 
procedure indentratlevel n;
ratcurrind!* := ratcurrind!* + n * tablen!*$
 
 
procedure mkratterpri;
list 'ratterpri$
 
%% RATFOR Code Formatting & Printing Functions %%
 
 
procedure formatrat lst;
begin
scalar linelen,str;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
    if pairp elt then lispeval elt
    else
    <<  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 str:=subst('E,'!e,str);
                % get the casing conventions correct
        if !*posn!* + length str > ratlinelen!* then
            ratcontline();
        for each u in str do pprin2 u
    >>;
linelength linelen
end$
 
procedure ratcontline;
<<
    ratterpri();
    rattab !*ratcurrind!*;
    pprin2 " "
>>$
 
procedure ratterpri;
pterpri()$
 
procedure rattab n;
<<
    !*ratcurrind!* := min0(n, ratlinelen!* - minratlinelen!*);
    if (n := !*ratcurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$
 
%% RATFOR template processing %%
 
 
procedure procrattem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
while c neq !$eof!$ do
    if c memq '(!F !f !S !s) then
    <<
        pprin2 c;
        c := procsubprogheading c
    >>
    else if c eq '!# then
        c := procratcomm()
    else if c eq '!; then
        c := procactive()
    else if c eq !$eol!$ then
    <<
        pterpri();
        c := readch()
    >>
    else
    <<
        pprin2 c;
        c := readch()
    >>;
linelength linelen
end$
 
procedure procratcomm;
% # ... <cr> %
begin
scalar c;
pprin2 '!#;
while (c := readch()) neq !$eol!$ do
    pprin2 c;
pterpri();
return readch()
end$
 
 
endmodule;
 
end;