Artifact a94df0ade9cae610896c25e7f53831eb30769851904980eacab3a9420e5fcffd:
- Executable file
r37/packages/gentran/pre.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: 5121) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/gentran/pre.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: 5121) [annotate] [blame] [check-ins using]
module pre; %% GENTRAN Preprocessing Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: Preproc symbolic$ procedure preproc exp; begin scalar r; r := preproc1 exp; if r then return car r else return r end$ % This switch causes gentran to attempt to automatically generate type % declarations, without use of the 'declare' statement. mcd 12/11/87. fluid '(!*getdecs)$ !*getdecs := nil$ switch getdecs$ % This global variable is the default type given when 'getdecs' is on: global '(deftype!*)$ share deftype!*$ deftype!* := 'real$ % Bfloat defined in arith.red. % symbolic procedure bfloat x; if floatp x then fl2bf x else % normbf(if atom x then read!:num x else x); symbolic procedure preproc1 exp; % Amended mcd 12/11/87,13/11/87,14/10/91. if atom exp then list exp else if car exp = '!:rd!: then list if smallfloatp cdr exp then bfloat cdr exp else exp else if car exp = '!:dn!: then preproc1 decimal2internal(cadr exp,cddr exp) else if car exp eq '!*sq then % (!*SQ dpexp) --> (PREPSQ dpexp) % preproc1 prepsq cadr exp else if car exp eq 'procedure then << % Store subprogram name & parameters in symbol table % symtabput(cadr exp, '!*params!*, car cddddr exp); % Store subprogram type and parameters types in symbol table % if !*getdecs switch is on. Use default type unless % procedure is declared as either: % INTEGER PROCEDURE ... or REAL PROCEDURE ... if !*getdecs then if caddr exp memq '(real integer) then << symtabput(cadr exp,cadr exp,list caddr exp); for each v in car cddddr exp do symtabput(cadr exp,v,list caddr exp); list nconc(list ('procedure,cadr exp,'nil), for each e in cdddr exp conc preproc1 e) >> else << for each v in car cddddr exp do symtabput(cadr exp,v,list deftype!*); list for each e in exp conc preproc1 e >> else list for each e in exp conc preproc1 e >> else if car exp eq 'declare then << % Store type declarations in symbol table % exp := car preproc1 cdr exp; exp := preprocdec exp; for each dec in exp do for each var in cdr dec do if car dec memq '(subroutine function) then symtabput(var, '!*type!*, car dec) else symtabput(nil, if atom var then var else car var, if atom var then list car dec else (car dec . cdr var)); nil >> else if car exp eq 'setq and pairp caddr exp and memq(caaddr exp,'(cond progn) ) then migrate!-setqs exp else if memq(car exp, '(plus times difference quotient minus) ) then begin scalar simp_exp; return if pairp numr (simp_exp:=simp!* exp) and memq(car numr simp_exp,'(!:cr!: !:crn!: !:gi!:)) then if onep denr simp_exp then list numr simp_exp else list list('quotient,numr simp_exp, car preproc1 prepsq !*f2q denr simp_exp) else list for each e in exp conc preproc1 e; end else << % The next statement stores the index of a for loop in the symbol % table, assigning them the type integer, % if the switch 'getdecs' is on. if !*getdecs and (car exp memq '(!~FOR for)) then symtabput(nil,cadr exp, '(integer)); list for each e in exp conc preproc1 e >>$ symbolic procedure preprocdec arg; % (TIMES type int) --> type!*int % % (IMPLICIT type) --> IMPLICIT! type % % (DIFFERENCE v1 v2) --> v1!-v2 % if atom arg then arg else if car arg eq 'times then if equal(length arg,3) and fixp(caddr arg) then intern compress append( append( explode cadr arg, explode '!* ), explode caddr arg ) else begin scalar result; for i:=1:length(arg) do result := append(result, if equal(nth(arg,i),'times) then '(!*) else explode nth(arg,i)); return intern compress result; end else if car arg eq 'implicit then intern compress append( explode 'implicit! , explode preprocdec cadr arg ) else if car arg eq 'difference then intern compress append( append( explode cadr arg, explode '!- ), explode caddr arg ) else for each a in arg collect preprocdec a$ symbolic procedure migrate!-setqs exp; % Move setq's within a progn or cond so that we can translate things % like gentran x := if ... then ... list migrate!-setqs1(cadr exp,caddr exp)$ symbolic procedure migrate!-setqs1(var,exp); if atom exp then preproc list('setq,var,exp) else if eqcar(exp,'cond) then ('cond . for each u in cdr exp collect list (preproc car u,migrate!-setqs1(var,cadr u)) ) else if eqcar(exp,'progn) then reverse rplaca(exp := reverse exp,migrate!-setqs1(var,car exp)) else preproc list('setq,var,exp)$ endmodule; end;