module lspc; %% GENTRAN LISP-to-C Translation Module %%
%% Author: Barbara L. Gates %%
%% December 1986 %%
% Entry Point: CCode
symbolic$
fluid '(!*double !*gendecs)$
switch gendecs$
% User-Accessible Global Variables %
global '(clinelen!* minclinelen!* !*ccurrind!* ccurrind!* tablen!*)$
share clinelen!*, minclinelen!*, ccurrind!*, tablen!*$
ccurrind!* := 0$
clinelen!* := 80$
minclinelen!* := 40$
!*ccurrind!* := 0$ %current level of indentation for C code
global '(deftype!* !*c!-functions!*)$
global '(!*posn!* !$!#);
!*c!-functions!* := '(sin cos tan asin acos atan atan2 sinh cosh tanh
asinh acosh atanh sincos sinpi cospi tanpi asinpi
acospi atanpi exp expm1 exp2 exp10 log log1p log2
log10 pow compound annuity abs fabs fmod sqrt
cbrt)$
flag( '(abs),'!*int!-args!*)$ % Intrinsic function with integer arg.
%% %%
%% LISP-to-C Translation Functions %%
%% %%
put('c,'formatter,'formatc);
put('c,'codegen,'ccode);
put('c,'proctem,'procctem);
put('c,'gendecs,'cdecs);
put('c,'assigner,'mkfcassign);
put('c,'boolean!-type,'!i!n!t);
%% Control Function %%
symbolic procedure ccode forms;
for each f in forms conc
if atom f then
cexp f
else if car f memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then
cexp f
else if lispstmtp f or lispstmtgpp f then
if !*gendecs then
begin
scalar r;
r := append(cdecs symtabget('!*main!*, '!*decs!*),
cstmt f);
symtabrem('!*main!*, '!*decs!*);
return r
end
else
cstmt f
else if lispdefp f then
cproc f
else
cexp f$
%% Procedure Translation %%
symbolic procedure cproc deff; % Type details amended mcd 3/3/88
begin
scalar type, name, params, paramtypes, vartypes, body, 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 (type := symtabget(name, name)) then
<< type := cadr type;
% Convert reduce types to c types
if type equal 'real then
type := '!f!l!o!a!t
else if type equal 'integer then
type := '!i!n!t;
if !*double then
if type equal '!f!l!o!a!t then
type := '!d!o!u!b!l!e
else if type equal '!i!n!t then
type := '!l!o!n!g;
symtabrem(name, name)
>>;
params := symtabget(name, '!*params!*) or caddr deff;
symtabrem(name, '!*params!*);
for each dec in symtabget(name, '!*decs!*) do
if car dec memq params
then paramtypes := append(paramtypes, list dec)
else vartypes := append(vartypes, list dec);
r := append( append( mkfcprocdec(type, name, params),
cdecs paramtypes ),
mkfcbegingp() );
indentclevel(+1);
if !*gendecs then
r := append(r, cdecs vartypes);
r := append(r, for each s in body
conc cstmt s);
indentclevel(-1);
r := append(r, mkfcendgp());
if !*gendecs then
<< symtabrem(name, nil); symtabrem(name, '!*decs!*) >>;
return r
end$
%% Generation of Declarations %%
symbolic procedure cdecs decs;
for each tl in formtypelists decs
conc mkfcdec(car tl, cdr tl)$
%% Expression Translation %%
symbolic procedure cexp exp;
cexp1(exp, 0)$
symbolic procedure cexp1(exp, wtin);
if atom exp then
list cname exp
else
if onep length exp then
append(cname exp, insertparens(()))
else if car exp eq 'expt then
if caddr exp = 2 then
cexp1 (list('times, cadr exp, cadr exp), wtin)
else if caddr exp = 3 then
cexp1 (list('times, cadr exp, cadr exp, cadr exp), wtin)
else if caddr exp = 4 then
cexp1(list('times,cadr exp,cadr exp,cadr exp,cadr exp),wtin)
else if caddr exp = '(quotient 1 2) then
cexp1 (list('sqrt, cadr exp), wtin)
else
cexp1 ('pow . cdr exp,wtin)
else if optype car exp then
begin
scalar wt, op, res;
wt := cprecedence car exp;
op := cop car exp;
exp := cdr exp;
if onep length exp then
res := op . cexp1(car exp, wt)
else
<<
res := cexp1(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, cexp1(car exp, wt))
>>
else
while exp := cdr exp do
res := append(append(res, list op),
cexp1(car exp, wt))
>>;
if wtin >= wt then res := insertparens res;
return res
end
else if car exp eq 'literal then
cliteral exp
else if car exp eq 'range then
if cadr exp = 0 then cexp caddr exp
else gentranerr('e,exp,
"C does not support non-zero lower bounds",nil)
else if car exp eq '!:rd!: then
if smallfloatp cdr exp then
list cdr exp
else
begin scalar mt; % Print bigfloats more naturally.
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('!e,mt));
return cliteral exp;
end
else if car exp memq '(!:cr!: !:crn!: !:gi!:) then
gentranerr('e,exp,"C doesn't support complex data type",nil)
else if arrayeltp exp then
cname car exp . foreach s in cdr exp conc
insertbrackets cexp1(s, 0)
else if memq(car exp,!*c!-functions!*) then
begin scalar op,res,dblp;
dblp := not get(car exp,'!*int!-args!*);
op := cname car exp;
res := '!( . list op ;
while exp := cdr exp do
<<
op := cexp1(car exp, 0);
if dblp and not
(is!-c!-float(op) or is!-c!-float(car exp)) then
op := if fixp car op then
(float car op) . (cdr op)
else
append(list('!(,'!d!o!u!b!l!e,'!),'!(),
append(op,list '!)));
res := if cdr exp then
append('!, . reversip op,res)
else
append(reversip op,res);
>>;
return reversip ( '!) . res )
end
else if cfunctcallp exp then
begin
scalar op, res;
op := cname car exp;
exp := cdr exp;
res := '!( . cexp1(car exp, 0);
while exp := cdr exp do
res := append(res, '!, . cexp1(car exp, 0));
return op . append(res, list('!)) )
end
else
begin
scalar op, res;
op := cname car exp;
exp := cdr exp;
res := append( '![ . cexp1(car exp, 0),list('!]) );
% Changed to generate proper C arrays - mcd 25/9/89
while exp := cdr exp do
res := append(res, append('![ . cexp1(car exp, 0)
,list('!]) ) );
return op . res
end$
symbolic procedure string2id str;
intern compress reversip cdr reversip cdr explode str$
symbolic procedure is!-c!-float u;
% Returns T if u is a float or a list whose car is an intrinsic
% function name with a floating point result.
floatp(u) or (idp u and declared!-as!-float(u) ) or
pairp(u) and (car u eq '!:rd!: or
stringp car u and memq(string2id car u,!*c!-functions!*) and
not flagp(string2id car u, '!*int!-args!*) or
declared!-as!-float(car u) )$
symbolic procedure cfunctcallp exp;
symtabget(car exp,'!*type!*)$
symbolic procedure cop op;
get(op, '!*cop!*) or op$
put('or, '!*cop!*, '!|!|)$
put('and, '!*cop!*, '!&!&)$
put('not, '!*cop!*, '!! )$
put('equal, '!*cop!*, '!=!=)$
put('neq, '!*cop!*, '!!!=)$
put('greaterp, '!*cop!*, '> )$
put('geq, '!*cop!*, '!>!=)$
put('lessp, '!*cop!*, '< )$
put('leq, '!*cop!*, '!<!=)$
put('plus, '!*cop!*, '!+ )$
put('times, '!*cop!*, '* )$
put('quotient, '!*cop!*, '/ )$
put('minus, '!*cop!*, '!- )$
symbolic procedure cname a;
if stringp a then
stringtoatom a % convert a to atom containing "'s
else if memq(a,!*c!-functions!*) then
string!-downcase a
else
get(a, '!*cname!*) or a$
symbolic procedure cprecedence op;
get(op, '!*cprecedence!*) or 8$
put('or, '!*cprecedence!*, 1)$
put('and, '!*cprecedence!*, 2)$
put('equal, '!*cprecedence!*, 3)$
put('neq, '!*cprecedence!*, 3)$
put('greaterp, '!*cprecedence!*, 4)$
put('geq, '!*cprecedence!*, 4)$
put('lessp, '!*cprecedence!*, 4)$
put('leq, '!*cprecedence!*, 4)$
put('plus, '!*cprecedence!*, 5)$
put('times, '!*cprecedence!*, 6)$
put('quotient, '!*cprecedence!*, 6)$
put('not, '!*cprecedence!*, 7)$
put('minus, '!*cprecedence!*, 7)$
%% Statement Translation %%
symbolic procedure cstmt stmt;
if null stmt then
nil
else if lisplabelp stmt then
clabel stmt
else if car stmt eq 'literal then
cliteral stmt
else if lispassignp stmt then
cassign stmt
else if lispcondp stmt then
cif stmt
else if lispbreakp stmt then
cbreak stmt
else if lispgop stmt then
cgoto stmt
else if lispreturnp stmt then
creturn stmt
else if lispstopp stmt then
cexit stmt
else if lisprepeatp stmt then
crepeat stmt
else if lispwhilep stmt then
cwhile stmt
else if lispforp stmt then
cfor stmt
else if lispstmtgpp stmt then
cstmtgp stmt
else if lispdefp stmt then
cproc stmt
else
cexpstmt stmt$
symbolic procedure cassign stmt;
mkfcassign(cadr stmt, caddr stmt)$
symbolic procedure cbreak stmt;
mkfcbreak()$
symbolic procedure cexit stmt;
mkfcexit()$
symbolic procedure cexpstmt exp;
append(mkctab() . cexp exp, list('!;, mkcterpri()))$
symbolic procedure cfor 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 := mkfcfor(var, loexp,
list(if (numberp stepexp and stepexp < 0) or
eqcar(stepexp,'minus) then 'geq else 'leq,
var, hiexp),
var,
list('plus, var, stepexp));
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return r
end$
symbolic procedure cgoto stmt;
mkfcgo cadr stmt$
symbolic procedure cif stmt;
begin
scalar r, st;
r := mkfcif caadr stmt;
indentclevel(+1);
st := seqtogp cdadr stmt;
if eqcar(st, 'cond) and length st=2 then
st := mkstmtgp(0, list st);
r := append(r, cstmt st);
indentclevel(-1);
stmt := cdr stmt;
while (stmt := cdr stmt) and caar stmt neq t do
<<
r := append(r, mkfcelseif caar stmt);
indentclevel(+1);
st := seqtogp cdar stmt;
if eqcar(st, 'cond) and length st=2 then
st := mkstmtgp(0, list st);
r := append(r, cstmt st);
indentclevel(-1)
>>;
if stmt then
<<
r := append(r, mkfcelse());
indentclevel(+1);
st := seqtogp cdar stmt;
if eqcar(st, 'cond) and length st=2 then
st := mkstmtgp(0, list st);
r := append(r, cstmt st);
indentclevel(-1)
>>;
return r
end$
symbolic procedure clabel label;
mkfclabel label$
symbolic procedure cliteral stmt;
mkfcliteral cdr stmt$
symbolic procedure crepeat stmt;
begin
scalar r, stmtlst, logexp;
stmt := reverse cdr stmt;
logexp := car stmt;
stmtlst := reverse cdr stmt;
r := mkfcdo();
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return append(r, mkfcdowhile list('not, logexp))
end$
symbolic procedure creturn stmt;
if cdr stmt then
mkfcreturn cadr stmt
else
mkfcreturn nil$
symbolic procedure cstmtgp stmtgp;
begin
scalar r;
if car stmtgp eq 'progn then
stmtgp := cdr stmtgp
else
stmtgp :=cddr stmtgp;
r := mkfcbegingp();
indentclevel(+1);
r := append(r, for each stmt in stmtgp conc cstmt stmt);
indentclevel(-1);
return append(r, mkfcendgp())
end$
symbolic procedure cwhile stmt;
begin
scalar r, logexp, stmtlst;
logexp := cadr stmt;
stmtlst := cddr stmt;
r := mkfcwhile logexp;
indentclevel(+1);
r := append(r, foreach st in stmtlst conc cstmt st);
indentclevel(-1);
return r
end$
%% %%
%% C Code Formatting Functions %%
%% %%
%% Statement Formatting %%
% A macro used to prevent things with *cname*
% properties being evaluated in certain circumstances. MCD 28.3.94
symbolic smacro procedure cexp_name(u);
if atom u then list(u)
else rplaca(cexp ('dummyArrayToken . cdr u), car u)$
symbolic procedure mkfcassign(lhs, rhs);
begin
scalar st;
if length rhs = 3 and lhs member rhs then
begin
scalar op, exp1, exp2;
op := car rhs;
exp1 := cadr rhs;
exp2 := caddr rhs;
if op = 'plus then
if onep exp1 or onep exp2 then
st := ('!+!+ . cexp_name lhs)
else if exp1 member '(-1 (minus 1))
or exp2 member '(-1 (minus 1)) then
st := ('!-!- . cexp_name lhs)
else if eqcar(exp1, 'minus) then
st := append(cexp_name lhs, '!-!= . cexp cadr exp1)
else if eqcar(exp2, 'minus) then
st := append(cexp_name lhs, '!-!= . cexp cadr exp2)
else if exp1 = lhs then
st := append(cexp_name lhs, '!+!= . cexp exp2)
else
st := append(cexp_name lhs, '!+!= . cexp exp1)
else if op = 'difference and onep exp2 then
st := ('!-!- . cexp_name lhs)
else if op = 'difference and exp1 = lhs then
st := append(cexp_name lhs, '!-!= . cexp exp2)
else if op = 'times and exp1 = lhs then
st := append(cexp_name lhs, '!*!= . cexp exp2)
else if op = 'times then
st := append(cexp_name lhs, '!*!= . cexp exp1)
else if op = 'quotient and exp1 = lhs then
st := append(cexp_name lhs, '!/!= . cexp exp2)
else
st := append(cexp_name lhs, '!= . cexp rhs)
end
else
st := append(cexp_name lhs, '!= . cexp rhs);
return append(mkctab() . st, list('!;, mkcterpri()))
end$
symbolic procedure mkfcbegingp;
list(mkctab(), '!{, mkcterpri())$
symbolic procedure mkfcbreak;
list(mkctab(), '!b!r!e!a!k, '!;, mkcterpri())$
symbolic procedure mkfcdec(type, varlist); %Amended mcd 13/11/87,3/3/88
<<
if type equal 'scalar then
type := deftype!*;
% Convert Reduce types to C types.
if type equal 'real then
type := '!f!l!o!a!t
else if type equal 'integer then
type := '!i!n!t;
% Deal with precision.
if !*double then
if type equal '!f!l!o!a!t then
type := '!d!o!u!b!l!e
else if type equal '!i!n!t then
type := '!l!o!n!g;
varlist := for each v in varlist collect
if atom v then
v
else
car v . for each dim in cdr v collect
if dim eq 'times then '! %
else if numberp dim then add1 dim
else if eqcar (dim, 'range) and cadr dim = 0
then add1 caddr dim
else gentranerr('e,dim,"Not C dimension",nil);
append(mkctab() . type . '! . for each v in insertcommas varlist
conc cexp_name v,
list('!;, mkcterpri()))
>>$
symbolic procedure mkfcdo;
list(mkctab(), '!d!o, mkcterpri())$
symbolic procedure mkfcdowhile exp;
append(append(list(mkctab(), '!w!h!i!l!e, '! , '!(), cexp exp),
list('!), '!;, mkcterpri()))$
symbolic procedure mkfcelse;
list(mkctab(), '!e!l!s!e, mkcterpri())$
symbolic procedure mkfcelseif exp;
append(append(list(mkctab(), '!e!l!s!e, '! , '!i!f, '! , '!(),
cexp exp),
list('!), mkcterpri()))$
symbolic procedure mkfcendgp;
list(mkctab(), '!}, mkcterpri())$
symbolic procedure mkfcexit;
list(mkctab(), '!e!x!i!t, '!(, 0, '!), '!;, mkcterpri())$
symbolic procedure mkfcfor(var1, lo, cond, var2, nextexp);
<<
if var1 then
var1 := append(cexp var1, '!= . cexp lo);
if cond then
cond := cexp cond;
if var2 then
<<
var2 := cdr mkfcassign(var2, nextexp);
var2 := reverse cddr reverse var2
>>;
append(append(append(list(mkctab(), '!f!o!r! , '! , '!(), var1),
'!; . cond),
append('!; . var2, list('!), mkcterpri())))
>>$
symbolic procedure mkfcgo label;
list(mkctab(), '!g!o!t!o, '! , label, '!;, mkcterpri())$
symbolic procedure mkfcif exp;
append(append(list(mkctab(), '!i!f, '! , '!(), cexp exp),
list('!), mkcterpri()))$
symbolic procedure mkfclabel label;
list(label, '!:, mkcterpri())$
symbolic procedure mkfcliteral args;
for each a in args conc
if a eq 'tab!* then
list mkctab()
else if a eq 'cr!* then
list mkcterpri()
else if pairp a then
cexp a
else
list stripquotes a$
symbolic procedure mkfcprocdec(type, name, params);
<<
params := append('!( . for each p in insertcommas params
conc cexp p,
list '!));
if type then
append(mkctab() . type . '! . cexp name,
append(params,list mkcterpri()))
else
append(mkctab() . cexp name, append(params, list mkcterpri()))
>>$
symbolic procedure mkfcreturn exp;
if exp then
append(append(list(mkctab(), '!r!e!t!u!r!n, '!(), cexp exp),
list('!), '!;, mkcterpri()))
else
list(mkctab(), '!r!e!t!u!r!n, '!;, mkcterpri())$
symbolic procedure mkfcwhile exp;
append(append(list(mkctab(), '!w!h!i!l!e, '! , '!(), cexp exp),
list('!), mkcterpri()))$
%% Indentation Control %%
symbolic procedure mkctab;
list('ctab, ccurrind!*)$
symbolic procedure indentclevel n;
ccurrind!* := ccurrind!* + n * tablen!*$
symbolic procedure mkcterpri;
list 'cterpri$
%% %%
%% Misc. Functions %%
%% %%
symbolic procedure insertbrackets exp;
'![ . append(exp, list '!])$
%% C Code Formatting & Printing Functions %%
symbolic procedure formatc lst;
begin
scalar linelen;
linelen := linelength 300;
!*posn!* := 0;
for each elt in lst do
if pairp elt then lispeval elt
else
<<
if !*posn!* + length explode2 elt > clinelen!* then
ccontline();
pprin2 elt
>>;
linelength linelen
end$
symbolic procedure ccontline;
<<
cterpri();
ctab !*ccurrind!*;
pprin2 " "
>>$
symbolic procedure cterpri;
pterpri()$
symbolic procedure ctab n;
<<
!*ccurrind!* := min0(n, clinelen!* - minclinelen!*);
if (n := !*ccurrind!* - !*posn!*) > 0 then pprin2 nspaces n
>>$
%% C template processing %%
symbolic procedure procctem;
begin
scalar c, linelen;
linelen := linelength 150;
c := readch();
if c eq '!# then c := procc!#line c;
while c neq !$eof!$ do
if c eq !$eol!$ then
c := procc!#line c
else if c eq '!/ then
c := procccomm()
else if c eq '!; then
c := procactive()
else
c := proccheader(c);
linelength linelen
end$
symbolic procedure procc!#line c;
% # ... <cr> %
begin
if c eq !$eol!$ then
<< pterpri(); c := readch() >>;
if c eq '!# then
repeat
<< pprin2 c; c := readch() >>
until c eq !$eol!$;
return c
end$
symbolic procedure procccomm;
% /* ... */ %
begin
scalar c;
pprin2 '!/;
c := readch();
if c eq '!* then
<<
pprin2 c;
c := readch();
repeat
<<
while c neq '!* do
<<
if c eq !$eol!$
then pterpri()
else pprin2 c;
c := readch()
>>;
pprin2 c;
c := readch()
>>
until c eq '!/;
pprin2 c;
c := readch()
>>;
return c
end$
symbolic procedure proccheader c;
begin
scalar name, i;
while seprp c and c neq !$eol!$ do
<< pprin2 c; c := readch() >>;
while not(seprp c or c memq list('!/, '!;, '!()) do
<< name := aconc(name, c); pprin2 c; c := readch() >>;
if c memq list(!$eol!$, '!/, '!;) then return c;
while seprp c and c neq !$eol!$ do
<< pprin2 c; c := readch() >>;
if c neq '!( then return c;
name := intern compress name;
if not !*gendecs then
symtabput(name, nil, nil);
put('!$0, '!*cname!*, name);
pprin2 c;
i := 1;
c := readch();
while c neq '!) do
<<
while seprp c or c eq '!, do
<<
if c eq !$eol!$
then pterpri()
else pprin2 c;
c := readch()
>>;
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),
'!*cname!*,
intern compress name);
i := add1 i;
c:=flushspaces c
>>;
!$!# := sub1 i;
while get(name := intern compress append(explode2 '!$, explode2 i),
'!*cname!*) do
remprop(name, '!*cname!*);
return proccfunction c
end$
symbolic procedure proccfunction c;
begin
scalar !{!}count;
while c neq '!{ do
if c eq '!/ then
c := procccomm()
else if c eq '!; then
c := procactive()
else if c eq !$eol!$ then
<< pterpri(); c := readch() >>
else
<< pprin2 c; c := readch() >>;
pprin2 c;
!{!}count := 1;
c := readch();
while !{!}count > 0 do
if c eq '!{ then
<< !{!}count := add1 !{!}count; pprin2 c; c := readch() >>
else if c eq '!} then
<< !{!}count := sub1 !{!}count; pprin2 c; c := readch() >>
else if c eq '!/ then
c := procccomm()
else if c eq '!; then
c := procactive()
else if c eq !$eol!$ then
<< pterpri(); c := readch() >>
else
<< pprin2 c; c := readch() >>;
return c
end$
endmodule;
end;