Artifact a8304d4de7b6ee164e4c3e7e9dc988c0148875a484f13eba0d28c519854b17b2:
- Executable file
r38/packages/gentran/lsprat.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 18714) [annotate] [blame] [check-ins using] [more...]
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;