module codgen;
% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ;
% Science, P.O.Box 217, 7500 AE Enschede, The Netherlands.;
% Author: J.A. van Hulzen. ;
% ------------------------------------------------------------------- ;
lisp$
global '(!*for!* !*do!*)$ % Gentran-globals used in makedecs.
global '(!*currout!*)$ % Gentran global used in redefinition
% of symbolic procedure gentran.
fluid '(!*gentranseg)$ % Gentran fluid introduced.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Patch 8 november 94 HvH.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
put('c,'preproc,'preproc)$
put('ratfor,'preproc,'preproc)$
put('fortran,'preproc,'preproc)$
put('pascal,'preproc,'preproc)$
put('c,'parser,'gentranparse)$
put('ratfor,'parser,'gentranparse)$
put('fortran,'parser,'gentranparse)$
put('pascal,'parser,'gentranparse)$
put('c,'lispcode,'lispcode)$
put('ratfor,'lispcode,'lispcode)$
put('fortran,'lispcode,'lispcode)$
put('pascal,'lispcode,'lispcode)$
global '(!*wrappers!*)$
!*wrappers!*:='(optimization segmentation)$
symbolic procedure optimization forms;
if !*gentranopt then opt forms else forms$
symbolic procedure segmentation forms;
if !*gentranseg then seg forms else forms$
symbolic procedure gentran!-wrappers!* forms;
begin
if !*wrappers!* then
foreach proc_name in !*wrappers!* do
forms:=apply1(proc_name,forms);
return forms
end$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%
%%%% Herbert's facility can now be added:
%%%%
%%%% !*wrappers!*:=append(list('differentiate),!*wrappers!*)$
%%%% symbolic procedure differentiate forms;
%%%% << load!-package adiff; adiff!-eval forms>>$
%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure gentran(forms, flist);
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%% Redefinition of the main gentran procedure %%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
begin scalar !:print!-prec!: ; % Gentran ignores print_precision
if flist then
lispeval list('gentranoutpush, list('quote, flist));
forms:=
apply1(get(gentranlang!*,'preproc) or get('fortran,'preproc),
list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
forms:=
apply1(get(gentranlang!*,'lispcode) or get('fortran,'lispcode),forms);
forms:=gentran!-wrappers!* forms;
apply1(get(gentranlang!*,'formatter) or get('fortran,'formatter),
apply1(get(gentranlang!*,'codegen) or get('fortran,'codegen),
forms));
if flist then
<<
flist := car !*currout!* or ('list . cdr !*currout!*);
lispeval '(gentranpop '(nil));
return flist
>>
else
return car !*currout!* or ('list . cdr !*currout!*)
end$
%=================================================================
%=== The codgen.red module itself!!!
%=================================================================
symbolic procedure interchange_defs(def1,def2);
begin scalar temp1,temp2;
temp1:=getd def1; remd def1;
temp2:=getd def2; remd def2;
putd(def1,car temp2,cdr temp2);
putd(def2,car temp1,cdr temp1);
end$
symbolic procedure strip_progn(lst);
if pairp lst
then if pairp(car lst) and caar(lst)='progn
then cdar(lst)
else if pairp(car lst) and
caar(lst)='prog and
cadar(lst)='nil
then cddar(lst)
else lst;
symbolic procedure add_progn(lst);
if pairp lst then append(list('progn),lst) else lst;
switch gentranopt$
!*gentranopt:=nil$
fluid '(delaylist!* delayoptlist!* delaydecs!* !*gendecs !*period!*)$
symbolic procedure delaydecs;
% ------------------------------------------------------------------- ;
% Effect: Redefinition of codegeneration functions. ;
% ------------------------------------------------------------------- ;
begin
!*period!*:=!*period; !*period:=nil;
delaydecs!*:=t; delaylist!*:=nil;
symtabrem('!*main!*,'!*decs!*);
symtabrem('!*main!*,'!*params!*);
symtabrem('!*main!*,'!*type!*);
!*wrappers!*:=
delete('optimization,delete('segmentation,!*wrappers!*));
interchange_defs('gentran,'gentran_delaydecs);
end;
put('delaydecs,'stat,'endstat)$
symbolic procedure gentran_delaydecs(forms,flist);
% ------------------------------------------------------------------- ;
% This procedure replaces the gentran-evaluator when production of ;
% delcarations has to be delayed. The results of all gentran eval.s ;
% are collected in the list delaylist!* and processed together by ;
% activating thre function make decs. ;
% ------------------------------------------------------------------- ;
begin
forms:= apply1(get(gentranlang!*,'preproc) or
get('fortran,'preproc),
list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
forms:= apply1(get(gentranlang!*,'lispcode) or
get('fortran,'lispcode),
forms);
forms:=gentran!-wrappers!* forms;
if !*gentranopt then forms:=opt strip_progn forms;
if !*gentranseg then forms:=seg forms;
forms:=strip_progn forms;
if delaylist!*
then delaylist!*:=append(delaylist!*,forms)
else delaylist!*:=forms
end;
symbolic procedure makedecs;
% ------------------------------------------------------------------- ;
% Effect: Original situation restored. Template processing performed. ;
% Symboltable cleaned up. ;
% ------------------------------------------------------------------- ;
begin scalar gentranopt,gentranseg;
if delayoptlist!*
then gentranerr(nil,nil,"DELAYOPT ACTIVE",nil)
else
<< !*period:=!*period!*;
!*gendecs:=t; delaydecs!*:=nil;
gentranopt:=!*gentranopt;!*gentranopt:=nil;
gentranseg:=!*gentranseg;!*gentranseg:=nil;
interchange_defs('gentran,'gentran_delaydecs);
delaylist!* := subst('for,!*for!*, delaylist!*); % JB 9/3/94
delaylist!* := subst('do, !*do!*, delaylist!*); % JB 9/3/94
apply('gentran,list(add_progn delaylist!*,nil));
delaylist!*:=nil;
!*wrappers!*:=
append(!*wrappers!*,list('optimization,'segmentation));
!*gentranopt:=gentranopt;!*gentranseg:=gentranseg;
>>
end;
put('makedecs,'stat,'endstat)$
symbolic procedure delayopts;
% ------------------------------------------------------------------- ;
% This procedure allows to avoid optimization until further notice, ;
% i.e. until the command makeopts is executed. ;
% All gentran evaluations are collected in the list delayoptlist!*. ;
% Through makeopts this colection is processed in one run. ;
% ------------------------------------------------------------------- ;
begin
if not delaydecs!*
then !*wrappers!*:=
delete('optimization,delete('segmentation,!*wrappers!*));
interchange_defs('gentran,'gentran_delayopt);
delayoptlist!*:=nil
end;
put('delayopts,'stat,'endstat)$
symbolic procedure gentran_delayopt(forms,flist);
% ------------------------------------------------------------------- ;
% This procedure replaces the current gentran evaluator when produc- ;
% tion of optimizwd code has to be delayed. We informally introduce a ;
% two-pass evaluation mechanism by doing so: one for gentran treatable;
% prefix statements and a second for optimization of this set of sta- ;
% tements. ;
% ------------------------------------------------------------------- ;
begin
forms:= apply1(get(gentranlang!*,'preproc) or
get('fortran,'preproc),
list forms);
apply1(get(gentranlang!*,'parser) or get('fortran,'parser),forms);
if delayoptlist!*
then delayoptlist!*:=
append(delayoptlist!*,
strip_progn(gentran!-wrappers!* lispcode forms))
else delayoptlist!*:=strip_progn(gentran!-wrappers!* lispcode forms);
end;
symbolic procedure makeopts;
% ------------------------------------------------------------------- ;
% The previous gentran environment is restored and the list of state- ;
% ments delayoptlist!* is treated in this environment. ;
% ------------------------------------------------------------------- ;
begin scalar gendecs,gentranopt;
interchange_defs('gentran,'gentran_delayopt);
gentranopt:=!*gentranopt;!*gentranopt:=t;
gendecs:=!*gendecs; !*gendecs:=nil;
if delaydecs!*
then
if delaylist!*
then delaylist!*:=
append(delaylist!*,strip_progn opt delayoptlist!*)
else delaylist!*:=strip_progn opt delayoptlist!*
else << !*wrappers!*:=
append(!*wrappers!*,list('optimization,'segmentation));
apply('gentran,list(add_progn delayoptlist!*,nil))
>>;
delayoptlist!*:=nil; !*gentranopt:=gentranopt ; !*gendecs:=gendecs;
end;
put('makeopts,'stat,'endstat)$
endmodule;
end;