/****************************************************************
Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
Permission to use, copy, modify, and distribute this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all
copies and that both that the copyright notice and this
permission notice and warranty disclaimer appear in supporting
documentation, and that the names of AT&T Bell Laboratories or
Bellcore or any of their entities not be used in advertising or
publicity pertaining to distribution of the software without
specific, written prior permission.
AT&T and Bellcore disclaim all warranties with regard to this
software, including all implied warranties of merchantability
and fitness. In no event shall AT&T or Bellcore be liable for
any special, indirect or consequential damages or any damages
whatsoever resulting from loss of use, data or profits, whether
in an action of contract, negligence or other tortious action,
arising out of or in connection with the use or performance of
****************************************************************/
/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
#include "output.h" /* for nice_printf */
LOCAL Addrp
intdouble(), putcx1(), putcxeq (), putch1 ();
LOCAL expptr
putcall (), putmnmx (), putcheq(), putcat ();
LOCAL expptr
putaddr(), putchcmp (), putpower(), putop();
LOCAL expptr
putcxcmp ();
extern int proc_argchanges
, proc_protochanges
;
/* Puthead -- output the header information about subroutines, functions
where
= ftell(pass1_file
);
if( !ISLOGICAL((k
= (p
= fixtype(p
))->headblock
.vtype
)) )
err("non-logical expression in IF statement");
memcpy(ei_next
, ei_first
, k
);
if (*ei_next
++ = ftell(pass1_file
) > where
) {
/* Used to make temporaries in holdtemps available here, but they */
/* may be reused too soon (e.g. when multiple **'s are involved). */
putcmgo(index
, nlab
, labs
)
struct Labelblock
*labs
[];
if(! ISINT(index
->headblock
.vtype
) )
execerr("computed goto index must be integer", CNULL
);
p1comp_goto (index
, nlab
, labs
);
int t
= krparens
== 2 ? TYDREAL
: p
->exprblock
.vtype
;
op
= p
->exprblock
.opcode
;
if (e
->tag
== TEXPR
&& e
->exprblock
.opcode
== op
) {
e1
= (expptr
)mktmp(t
, ENULL
);
putout(putassign(cpexpr(e1
), e
));
p
->exprblock
.leftp
= putx(e
);
if (e
->tag
== TEXPR
&& e
->exprblock
.opcode
== op
) {
e1
= (expptr
)mktmp(t
, ENULL
);
putout(putassign(cpexpr(e1
), e
));
p
->exprblock
.rightp
= e1
;
p
->exprblock
.rightp
= putx(e
);
switch(p
->constblock
.vtype
)
/* Don't write it out to the p2 file, since you'd need to call putconst,
which is just what we need to avoid in the translator */
p
= putx( (expptr
)putconst((Constp
)p
) );
switch(opc
= p
->exprblock
.opcode
)
if( ISCOMPLEX(p
->exprblock
.vtype
) )
else p
= putcall(p
, (Addrp
*)NULL
);
if(ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
)
|| ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
)) {
if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) ||
ISCOMPLEX(p
->exprblock
.rightp
->headblock
.vtype
) )
if(ISCHAR(p
->exprblock
.leftp
))
if(INT(p
->exprblock
.leftp
->headblock
.vtype
) &&
ISICON(p
->exprblock
.rightp
) &&
( (k
= log_2(p
->exprblock
.rightp
->constblock
.Const
.ci
))>0) )
p
->exprblock
.opcode
= OPLSHIFT
;
frexpr(p
->exprblock
.rightp
);
p
->exprblock
.rightp
= ICON(k
);
if (krparens
&& ISREAL(p
->exprblock
.vtype
))
if (krparens
&& ISREAL(p
->exprblock
.vtype
))
if( ISCOMPLEX(p
->exprblock
.vtype
) )
if( ISCOMPLEX(p
->exprblock
.vtype
) )
else if( ISCOMPLEX(p
->exprblock
.leftp
->headblock
.vtype
) )
p
= putx( mkconv(p
->exprblock
.vtype
,
(expptr
)realpart(putcx1(p
->exprblock
.leftp
))));
/* weird things like ichar(a//a) */
switch(p
->exprblock
.opcode
) /* check for special cases and rewrite */
lt
= lp
->headblock
.vtype
;
/* Simplify nested type casts */
while(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONV
&&
( (ISREAL(pt
)&&ONEOF(lt
,MSKREAL
|MSKCOMPLEX
)) ||
(INT(pt
)&&(ONEOF(lt
,MSKINT
|MSKADDR
|MSKCHAR
|M(TYSUBR
)))) ))
if(pt
==TYDREAL
&& lt
==TYREAL
)
&& lp
->exprblock
.opcode
== OPCONV
) {
lt1
= lp
->exprblock
.leftp
->headblock
.vtype
;
putx(lp
->exprblock
.leftp
);
lp
->exprblock
.leftp
= putx(
putcx1(lp
->exprblock
.leftp
)));
else if (ISREAL(pt
) && ISCOMPLEX(lt
)) {
p
->exprblock
.leftp
= putx(mkconv(pt
,
putcx1(p
->exprblock
.leftp
))));
if(lt
==TYCHAR
&& lp
->tag
==TEXPR
&&
lp
->exprblock
.opcode
==OPCALL
)
/* May want to make a comma expression here instead. I had one, but took
it out for my convenience, not for the convenience of the end user */
putout (putcall (lp
, (Addrp
*) &(p
->
p
->exprblock
.leftp
= putx(p
->exprblock
.leftp
);
frexpr(p
->exprblock
.vleng
);
lt
= lp
->headblock
.vtype
;
if(p
->tag
==TEXPR
&& p
->exprblock
.opcode
==OPCONV
)
mktmp(lp
->headblock
.vtype
,lp
->headblock
.vleng
);
p
= putx( mkexpr(OPASSIGN
, cpexpr(tp
), lp
) );
p
= mkexpr(OPCOMMA
, p
, putaddr(lp
));
if( ops2
[p
->exprblock
.opcode
] <= 0)
badop("putop", p
->exprblock
.opcode
);
p
-> exprblock
.leftp
= putx (p
-> exprblock
.leftp
);
if (p
-> exprblock
.rightp
)
p
-> exprblock
.rightp
= putx (p
-> exprblock
.rightp
);
char buf
[80]; /* buffer for text of comment */
if(!ISICON(p
->exprblock
.rightp
) ||
(k
= p
->exprblock
.rightp
->constblock
.Const
.ci
)<2)
Fatal("putpower: bad call");
base
= p
->exprblock
.leftp
;
type
= base
->headblock
.vtype
;
p
= putassign (cpexpr((expptr
) t1
), base
);
sprintf (buf
, "Computing %ld%s power", k
,
k
== 2 ? "nd" : k
== 3 ? "rd" : "th");
for( ; (k
&1)==0 && k
>2 ; k
>>=1 )
p
= mkexpr (OPCOMMA
, p
, putsteq(t1
, t1
));
/* Write the power computation out immediately */
p
= putx( mkexpr(OPSTAR
, cpexpr((expptr
)t1
), cpexpr((expptr
)t1
)));
p
= mkexpr (OPCOMMA
, p
, putassign(cpexpr((expptr
)t2
),
p
= mkexpr (OPCOMMA
, p
, putsteq(t1
, t1
));
p
= mkexpr (OPCOMMA
, p
, putsteq(t2
, t1
));
/* Write the power computation out immediately */
p
= putx( mkexpr(OPSTAR
, cpexpr((expptr
)t2
),
mkexpr(OPSTAR
, cpexpr((expptr
)t1
), cpexpr((expptr
)t1
))));
t
= mktmp(TYDREAL
, ENULL
);
putout (putassign(cpexpr((expptr
)t
), (expptr
)p
));
/* Complex-type variable assignment */
badtag("putcxeq", p
->tag
);
lp
= putcx1(p
->exprblock
.leftp
);
rp
= putcx1(p
->exprblock
.rightp
);
code
= putassign ( (expptr
)realpart(lp
), (expptr
)realpart(rp
));
if( ISCOMPLEX(p
->exprblock
.vtype
) )
code
= mkexpr (OPCOMMA
, code
, putassign
(imagpart(lp
), imagpart(rp
)));
/* putcxop -- used to write out embedded calls to complex functions, and
complex arguments to procedures */
return (expptr
)putaddr((expptr
)putcx1(p
));
#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
if( ISCOMPLEX(p
->constblock
.vtype
) )
p
= (expptr
) putconst((Constp
)p
);
if (q
= resp
->memoffset
) {
if (resp
->uname_tag
== UNAM_REF
) {
q
= cpexpr((tagptr
)resp
);
q
->addrblock
.vtype
= tyint
;
q
->addrblock
.cmplx_sub
= 1;
p
->addrblock
.skip_offset
= 1;
resp
->user
.name
->vsubscrused
= 1;
resp
->uname_tag
= UNAM_NAME
;
tskludge
= typesize
[resp
->vtype
]
&& resp
->vtype
!= TYCHAR
) {
if (ONEOF(resp
->vstg
, M(STGCOMMON
)|M(STGEQUIV
))
&& resp
->uname_tag
== UNAM_NAME
)
mkintcon(resp
->user
.name
->voffset
));
ts
= typesize
[resp
->vtype
]
q
= resp
->memoffset
= mkexpr(OPSLASH
, q
,
resp
= mktmp(tyint
, ENULL
);
putout(putassign(cpexpr((expptr
)resp
), q
));
p
->addrblock
.memoffset
= tskludge
? mkexpr(OPSTAR
, (expptr
)resp
, ICON(tskludge
))
q
= mkexpr(OPSTAR
, resp
->memoffset
, ICON(ts
));
if (ONEOF(resp
->vstg
, M(STGCOMMON
)|M(STGEQUIV
))
&& resp
->uname_tag
== UNAM_NAME
)
mkintcon(resp
->user
.name
->voffset
));
if( ISCOMPLEX(p
->exprblock
.vtype
) )
resp
= mktmp(TYDREAL
, ENULL
);
putout (putassign( cpexpr((expptr
)resp
), p
));
badtag("putcx1", p
->tag
);
opcode
= p
->exprblock
.opcode
;
if(opcode
==OPCALL
|| opcode
==OPCCALL
)
else if(opcode
== OPASSIGN
)
/* BUG (inefficient) Generates too many temporary variables */
resp
= mktmp(p
->exprblock
.vtype
, ENULL
);
if(lp
= putcx1(p
->exprblock
.leftp
) )
if(rp
= putcx1(p
->exprblock
.rightp
) )
putassign( (expptr
)realpart(resp
),
mkexpr(OPNEG
, (expptr
)realpart(lp
), ENULL
)),
putassign( imagpart(resp
),
mkexpr(OPNEG
, imagpart(lp
), ENULL
))));
case OPMINUS
: { expptr r
;
r
= putassign( (expptr
)realpart(resp
),
mkexpr(opcode
, (expptr
)realpart(lp
), (expptr
)realpart(rp
) ));
q
= putassign( imagpart(resp
), imagpart(lp
) );
else if(ltype
< TYCOMPLEX
)
q
= putassign( imagpart(resp
), imagpart(rp
) );
q
= putassign( imagpart(resp
),
mkexpr(OPNEG
, imagpart(rp
), ENULL
) );
q
= putassign( imagpart(resp
),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
) ));
} /* case OPPLUS, OPMINUS: */
putassign( (expptr
)realpart(resp
),
mkexpr(OPSTAR
, cpexpr((expptr
)lp
),
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr((expptr
)lp
), imagpart(rp
)))));
else if(rtype
< TYCOMPLEX
)
putassign( (expptr
)realpart(resp
),
mkexpr(OPSTAR
, cpexpr((expptr
)rp
),
putassign( imagpart(resp
),
mkexpr(OPSTAR
, cpexpr((expptr
)rp
), imagpart(lp
)))));
putassign( (expptr
)realpart(resp
), mkexpr(OPMINUS
,
mkexpr(OPSTAR
, (expptr
)realpart(lp
),
mkexpr(OPSTAR
, imagpart(lp
), imagpart(rp
)))),
putassign( imagpart(resp
), mkexpr(OPPLUS
,
mkexpr(OPSTAR
, (expptr
)realpart(lp
), imagpart(rp
)),
mkexpr(OPSTAR
, imagpart(lp
),
(expptr
)realpart(rp
))))));
/* fixexpr has already replaced all divisions
* by a complex by a function call
putassign( (expptr
)realpart(resp
),
mkexpr(OPSLASH
, (expptr
)realpart(lp
), cpexpr((expptr
)rp
))),
putassign( imagpart(resp
),
mkexpr(OPSLASH
, imagpart(lp
), cpexpr((expptr
)rp
)))));
if( ISCOMPLEX(lp
->vtype
) )
q
= (expptr
) realpart(rp
);
q
= mkrealcon(TYDREAL
, "0");
putassign( (expptr
)realpart(resp
), (expptr
)realpart(lp
)),
putassign( imagpart(resp
), q
)));
/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
badtag("putcxcmp", p
->tag
);
opcode
= p
->exprblock
.opcode
;
lp
= putcx1(p
->exprblock
.leftp
);
rp
= putcx1(p
->exprblock
.rightp
);
q
= mkexpr( opcode
==OPEQ
? OPAND
: OPOR
,
mkexpr(opcode
, (expptr
)realpart(lp
), (expptr
)realpart(rp
)),
mkexpr(opcode
, imagpart(lp
), imagpart(rp
)) );
return putx( fixexpr((Exprp
)q
) );
/* putch1 -- Forces constants into the literal pool, among other things */
return( putconst((Constp
)p
) );
switch(p
->exprblock
.opcode
)
t
= mktmp(TYCHAR
, ICON(lencat(p
)));
q
= (expptr
) cpexpr(p
->headblock
.vleng
);
p
= putcat( cpexpr((expptr
)t
), p
);
/* put the correct length on the block */
if(!ISICON(p
->exprblock
.vleng
)
|| p
->exprblock
.vleng
->constblock
.Const
.ci
!=1
|| ! INT(p
->exprblock
.leftp
->headblock
.vtype
) )
Fatal("putch1: bad character conversion");
t
= mktmp(TYCHAR
, ICON(1));
e
= mkexpr(OPCONV
, (expptr
)t
, ENULL
);
e
->headblock
.vtype
= TYCHAR
;
p
= putop( mkexpr(OPASSIGN
, cpexpr(e
), p
));
badop("putch1", p
->exprblock
.opcode
);
badtag("putch1", p
->tag
);
/* NOT REACHED */ return 0;
/* putchop -- Write out a character actual parameter; that is, this is
part of a procedure invocation */
p
= putaddr((expptr
)putch1(p
));
badtag("putcheq", p
->tag
);
rp
= p
->exprblock
.rightp
;
frexpr(p
->exprblock
.vleng
);
/* If s = t // u, don't bother copying the result, write it directly into
nbad
= badchleng(lp
) + badchleng(rp
);
if( rp
->tag
==TEXPR
&& rp
->exprblock
.opcode
==OPCONCAT
)
&& ISONE(lp
->headblock
.vleng
)
&& ISONE(rp
->headblock
.vleng
) ) {
lp
= mkexpr(OPCONV
, lp
, ENULL
);
rp
= mkexpr(OPCONV
, rp
, ENULL
);
lp
->headblock
.vtype
= rp
->headblock
.vtype
= TYCHAR
;
p
= putop(mkexpr(OPASSIGN
, lp
, rp
));
p
= putx( call2(TYSUBR
, "s_copy", lp
, rp
) );
badtag("putchcmp", p
->tag
);
rp
= p
->exprblock
.rightp
;
if(ISONE(lp
->headblock
.vleng
) && ISONE(rp
->headblock
.vleng
) ) {
lp
= mkexpr(OPCONV
, lp
, ENULL
);
rp
= mkexpr(OPCONV
, rp
, ENULL
);
lp
->headblock
.vtype
= rp
->headblock
.vtype
= TYCHAR
;
lp
= call2(TYINT
,"s_cmp", lp
, rp
);
p
->exprblock
.rightp
= rp
;
/* putcat -- Writes out a concatenation operation. Two temporary arrays
are allocated, putct1() is called to initialize them, and then a
call to runtime library routine s_cat() is inserted.
This routine generates code which will perform an (nconc lhs rhs)
at runtime. The runtime funciton does not return a value, the routine
that calls this putcat must remember the name of lhs.
LOCAL expptr
putcat(lhs0
, rhs
)
register Addrp lhs
= (Addrp
)lhs0
;
Addrp length_var
, string_var
;
static char Writing_concatenation
[] = "Writing concatenation";
/* Create the temporary arrays */
length_var
= mktmpn(n
, tyioint
, ENULL
);
string_var
= mktmpn(n
, TYADDR
, ENULL
);
frtemp((Addrp
)cpexpr((expptr
)length_var
));
frtemp((Addrp
)cpexpr((expptr
)string_var
));
/* Initialize the arrays */
/* p1_comment scribbles on its argument, so we
* cannot safely pass a string literal here. */
p1_comment(Writing_concatenation
);
putct1(rhs
, length_var
, string_var
, &n
);
/* Create the invocation */
tyint
= tyioint
; /* for -I2 */
p
= putx (call4 (TYSUBR
, "s_cat",
(expptr
)putconst((Constp
)ICON(n
))));
LOCAL
putct1(q
, length_var
, string_var
, ip
)
register Addrp length_var
, string_var
;
Addrp length_copy
, string_copy
;
if(q
->tag
==TEXPR
&& q
->exprblock
.opcode
==OPCONCAT
)
putct1(q
->exprblock
.leftp
, length_var
, string_var
,
putct1(q
->exprblock
.rightp
, length_var
, string_var
,
frexpr (q
-> exprblock
.vleng
);
e
= cpexpr(q
->headblock
.vleng
);
return; /* error -- character*(*) */
length_copy
= (Addrp
) cpexpr((expptr
)length_var
);
mkexpr(OPPLUS
,length_copy
->memoffset
, ICON(i
*szleng
));
string_copy
= (Addrp
) cpexpr((expptr
)string_var
);
mkexpr(OPPLUS
, string_copy
->memoffset
,
ICON(i
*typesize
[TYADDR
]));
putout (PAIR (putassign((expptr
)length_copy
, e
),
putassign((expptr
)string_copy
, addrof((expptr
)putch1(q
)))));
/* putaddr -- seems to write out function invocation actual parameters */
if( p
->tag
==TERROR
|| (p
->memoffset
!=NULL
&& ISERROR(p
->memoffset
)) )
if (p
->isarray
&& p
->memoffset
)
if (p
->uname_tag
== UNAM_REF
) {
cp
= p
->memoffset
->listblock
.listp
;
for(; cp
; cp
= cp
->nextp
)
cp
->datap
= (char *)fixtype((tagptr
)cp
->datap
);
p
->memoffset
= putx(p
->memoffset
);
addrfix(e
) /* fudge character string length if it's a TADDR */
return e
->tag
== TADDR
? mkexpr(OPIDENTITY
, e
, ENULL
) : e
;
typekludge(ccall
, q
, at
, j
)
int j
; /* alternate type */
* < 100 ==> Fortran arg (pointer to type)
* < 300 ==> procedure arg
* < 400 ==> external, no explicit type
* < 500 ==> arg that may turn out to be
* either a variable or a procedure
k
= TYDREAL
; /* force double for library routines */
if ((i
== TEXPR
&& q
->exprblock
.opcode
!= OPCOMMA_ARG
)
|| (i
== TADDR
&& q
->addrblock
.charleng
)
switch(q
->addrblock
.vclass
) {
if (q
->addrblock
.uname_tag
!= UNAM_NAME
)
else if ((np
= q
->addrblock
.user
.name
)->vprocclass
if (j
> 200 && infertypes
&& j
< 300) {
else k
= (np
->vstg
== STGEXT
? extsymtab
[np
->vardesc
.varno
].extype
at
->cp
= mkchain((char *)np
, at
->cp
);
if (q
->addrblock
.vstg
== STGARG
&& q
->addrblock
.uname_tag
== UNAM_NAME
) {
at
->cp
= mkchain((char *)q
->addrblock
.user
.name
,
else if (i
== TNAME
&& q
->nameblock
.vstg
== STGARG
) {
else if (j
<= 200 || !infertypes
|| j
>= 300)
/* argument may be a scalar variable or a function */
if (np
->vimpltype
&& j
&& infertypes
/* to handle procedure args only so far known to be
* external, save a pointer to the symbol table entry...
at
->cp
= mkchain((char *)np
, at
->cp
);
sprintf(buf
, "%s variable", ftn_types
[k
]);
return ftn_types
[TYSUBR
];
sprintf(buf
, "%s function", ftn_types
[k
]);
return "external argument";
sprintf(buf
, "%s argument", ftn_types
[k
]);
for(a
= at
->atypes
, ae
= a
+ at
->nargs
; a
< ae
; a
++)
if (at
->changes
& 2 && !at
->defined
)
static char inconsist
[] = "inconsistent calling sequences for ";
bad_atypes(at
, fname
, i
, j
, k
, here
, prev
)
char *fname
, *here
, *prev
;
char buf
[208], buf1
[32], buf2
[32];
sprintf(buf
, "%s%.90s,\n\targ %d: %s%s%s %s.",
inconsist
, fname
, i
, here
, Argtype(k
, buf1
),
register struct Entrypoint
*ep
;
for(ep
= entries
; ep
; ep
= ep
->entnextp
)
if (at
== ep
->entryname
->arginfo
) {
return proc_argchanges
= 1;
save_argtypes(arglist
, at0
, at1
, ccall
, fname
, stg
, nchargs
, type
, zap
)
int ccall
, stg
, nchargs
, type
, zap
;
int i
, i0
, j
, k
, nargs
, nbad
, *t
, *te
;
char buf
[208], buf1
[32], buf2
[32];
static int initargs
[4] = {TYCOMPLEX
, TYDCOMPLEX
, TYCHAR
, TYFTNLEN
+100};
static int *init_ap
[TYSUBR
+1] = {0,0,0,0,0,0,0,
initargs
, initargs
+1,0,0,0,initargs
+2};
extern int init_ac
[TYSUBR
+1];
if (nargs
< 0 && type
&& at
->changes
& 2 && !at
->defined
)
if (at
->dnargs
>= 0 && zap
!= 2)
if (nargs
< 0) { /* inconsistent usage seen */
for(nbad
= 0; t
< te
; atypes
++) {
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
case 1: if (at
->defined
& 4)
"%s%.90s:\n\there %d, previously %d args and string lengths.",
inconsist
, fname
, i
, nargs
);
for(cp
= arglist
; cp
; atypes
++, cp
= cp
->nextp
) {
if (!(q
= (expptr
)cp
->datap
))
k
= typekludge(ccall
, q
, atypes
, j
);
if (k
== TYUNKNOWN
+ 200)
&& !type_fixup(at
,atypes
,k
))
else if (j
% 100 % TYSUBR
!= k
% TYSUBR
&& !type_fixup(at
,atypes
,k
))
else if (k
< 200 || j
< 200)
&& q
->nameblock
.vinfproc
) {
q
->nameblock
.vdcldone
= 0;
else ; /* fall through to update */
else if (k
== TYUNKNOWN
+200)
else if (j
!= TYUNKNOWN
+200)
bad_atypes(at
, fname
, i
, j
, k
, "here ",
"\targ %d: here %s, previously %s.\n",
/* We've subsequently learned the right type,
as in the call on zoo below...
/* we're defining the procedure */
if (zap
== 1 && (at
->changes
& 5) != 5)
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
k
= sizeof(Argtypes
) + (i
-1)*sizeof(Atype
);
*at0
= *at1
= at
= stg
== STGEXT
? (Argtypes
*)gmem(k
,1)
at
->dnargs
= at
->nargs
= i
;
at
->changes
= type
? 0 : 4;
for(; t
< te
; atypes
++) {
for(cp
= arglist
; cp
; atypes
++, cp
= cp
->nextp
) {
atypes
->type
= (q
= (expptr
)cp
->datap
)
? typekludge(ccall
, q
, atypes
, 0)
for(; --nchargs
>= 0; atypes
++) {
atypes
->type
= TYFTNLEN
+ 100;
saveargtypes(p
) /* for writing prototypes */
case UNAM_EXTERN
: /* e.g., sqrt() */
e
= extsymtab
+ a
->memno
;
at0
= &extsymtab
[np
->vardesc
.varno
].arginfo
;
if (a
->uname_tag
!= UNAM_NAME
)
at0
= at1
= &np
->arginfo
;
Fatal("Confusion in saveargtypes");
arglist
= rp
&& rp
->tag
== TLIST
? rp
->listblock
.listp
: 0;
save_argtypes(arglist
, at0
, at1
, p
->opcode
== OPCCALL
,
fname
, a
->vstg
, 0, 0, 0);
/* putcall - fix up the argument list, and write out the invocation. p
is expected to be initialized and point to an OPCALL or OPCCALL
expression. The return value is a pointer to a temporary holding the
result of a COMPLEX or CHARACTER operation, or NULL. */
LOCAL expptr
putcall(p0
, temp
)
register Exprp p
= (Exprp
)p0
;
chainp arglist
; /* Pointer to actual arguments, if any */
chainp charsp
; /* List of copies of the variables which
hold the lengths of character
parameters (other than procedure
chainp cp
; /* Iterator over argument lists */
register expptr q
; /* Pointer to the current argument */
Addrp fval
; /* Function return value */
int type
; /* type of the call - presumably this was
int byvalue
; /* True iff we don't want to massage the
parameter list, since we're calling a C
extern struct Listblock
*mklist();
byvalue
= (p
->opcode
== OPCCALL
);
/* Verify the actual parameters */
err ("putcall: NULL call expression");
else if (p
-> tag
!= TEXPR
)
erri ("putcall: expected TEXPR, got '%d'", p
-> tag
);
/* Find the argument list */
if(p
->rightp
&& p
-> rightp
-> tag
== TLIST
)
arglist
= p
->rightp
->listblock
.listp
;
/* Count the number of explicit arguments, including lengths of character
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
/* Even constants are passed by reference, so we need to put them in the
q
= (expptr
) putconst((Constp
)q
);
/* Save the length expression of character variables (NOT character
procedures) for the end of the argument list */
(q
->headblock
.vclass
!= CLPROC
|| q
->headblock
.vstg
== STGARG
&& q
->addrblock
.uname_tag
== UNAM_NAME
&& q
->addrblock
.user
.name
->vprocclass
== PTHISPROC
))
p0
= cpexpr(q
->headblock
.vleng
);
charsp
= mkchain((char *)p0
, charsp
);
if (q
->headblock
.vclass
== CLUNKNOWN
&& q
->headblock
.vstg
== STGARG
)
q
->addrblock
.user
.name
->vpassed
= 1;
&& q
->addrblock
.uname_tag
== UNAM_CONST
)
+= q
->addrblock
.user
.Const
.ccp1
.blanks
;
charsp
= revchain(charsp
);
/* If the routine is a CHARACTER function ... */
/* Allocate a temporary to hold the return value of the function */
fval
= mktmp(TYCHAR
, p
->vleng
);
err("adjustable character function");
/* If the routine is a COMPLEX function ... */
else if( ISCOMPLEX(type
) )
fval
= mktmp(type
, ENULL
);
/* Write the function name, without taking its address */
p
-> leftp
= putx(fixtype(putaddr(p
->leftp
)));
/* Prepend a copy of the function return value buffer out as the first
prepend
= mkchain((char *)putx(putaddr(cpexpr((expptr
)fval
))), arglist
);
/* If it's a character function, also prepend the length of the result */
prepend
->nextp
= mkchain((char *)putx(mkconv(TYLENG
,
p
->rightp
= q
= (expptr
)mklist(CHNULL
);
q
->listblock
.listp
= prepend
;
/* Scan through the fortran argument list */
for(cp
= arglist
; cp
; cp
= cp
->nextp
)
q
= (expptr
) (cp
->datap
);
err ("putcall: NULL argument");
/* call putaddr only when we've got a parameter for a C routine or a
memory resident parameter */
if (q
-> tag
== TCONST
&& !byvalue
)
q
= (expptr
) putconst ((Constp
)q
);
if(q
->tag
==TADDR
&& (byvalue
|| q
->addrblock
.vstg
!=STGREG
) ) {
if (q
->addrblock
.parenused
&& !byvalue
&& q
->headblock
.vtype
!= TYCHAR
)
cp
->datap
= (char *)putaddr(q
);
else if( ISCOMPLEX(q
->headblock
.vtype
) )
cp
-> datap
= (char *) putx (fixtype(putcxop(q
)));
cp
-> datap
= (char *) putx (fixtype((expptr
)putchop(q
)));
|| q
->tag
== TEXPR
&& q
->exprblock
.opcode
== OPCHARCAST
)
cp
-> datap
= (char *) putx(q
);
/* If we've got a register parameter, or (maybe?) a constant, save it in a
t
= (expptr
) mktmp(q
->headblock
.vtype
, q
->headblock
.vleng
);
/* Assign to temporary variables before invoking the subroutine or
t1
= putassign( cpexpr(t
), q
);
t
= mkexpr(OPCOMMA_ARG
, t1
, t
);
cp
-> datap
= (char *) t
;
/* Now adjust the lengths of the CHARACTER parameters */
for(cp
= charsp
; cp
; cp
= cp
->nextp
)
cp
->datap
= (char *)addrfix(putx(
/* in case MAIN has a character*(*)... */
(s
= cp
->datap
) ? mkconv(TYLENG
,(expptr
)s
)
/* ... and add them to the end of the argument list */
hookup (arglist
, charsp
);
/* Return the name of the temporary used to hold the results, if any was
else frexpr ((expptr
)fval
);
/* putmnmx -- Put min or max. p must point to an EXPR, not just a
badtag("putmnmx", p
->tag
);
type
= p
->exprblock
.vtype
;
op
= p
->exprblock
.opcode
;
op2
= op
== OPMIN
? OPMIN2
: OPMAX2
;
p0
= p
->exprblock
.leftp
->listblock
.listp
;
free( (charptr
) (p
->exprblock
.leftp
) );
/* special case for two addressable operands */
if (addressable((expptr
)p0
->datap
)
&& addressable((expptr
)p1
->datap
)
if (type
== TYREAL
&& forcedouble
)
op2
= op
== OPMIN
? OPDMIN
: OPDMAX
;
p
= mkexpr(op2
, mkconv(type
, cpexpr((expptr
)p0
->datap
)),
mkconv(type
, cpexpr((expptr
)p1
->datap
)));
/* We only need a second temporary if the arg list has an unaddressable
for (p1
= p0
-> nextp
; p1
; p1
= p1
-> nextp
)
if (!addressable ((expptr
) p1
-> datap
)) {
qp
= mkexpr(op2
, cpexpr((expptr
)sp
), cpexpr((expptr
)tp
));
/* Now output the appropriate number of assignments and comparisons. Min
and max are implemented by the simple O(n) algorithm:
t2 = b; t1 = (t1 < t2) ? t1 : t2;
t2 = c; t1 = (t1 < t2) ? t1 : t2;
t2 = d; t1 = (t1 < t2) ? t1 : t2;
sprintf (comment_buf
, "Computing M%s", what
);
p1_comment (comment_buf
);
temp
= (expptr
)p0
->datap
;
if (addressable(temp
) && addressable((expptr
)p1
->datap
)) {
p
= mkconv(type
, cpexpr(temp
));
arg
= mkconv(type
, cpexpr((expptr
)p1
->datap
));
temp
= mkexpr(op2
, p
, arg
);
temp
= fixexpr((Exprp
)temp
);
p
= putassign (cpexpr((expptr
)sp
), temp
);
for(; p1
; p1
= p1
->nextp
)
if (addressable ((expptr
) p1
-> datap
)) {
arg
= mkconv(type
, cpexpr((expptr
)p1
->datap
));
temp
= mkexpr(op2
, cpexpr((expptr
)sp
), arg
);
temp
= fixexpr((Exprp
)temp
);
temp
= (expptr
) cpexpr (qp
);
putassign(cpexpr((expptr
)tp
), (expptr
)p1
->datap
));
putassign(cpexpr((expptr
)sp
), temp
));
if (type
== TYREAL
&& forcedouble
)
op
== OPMIN
? OPDMIN
: OPDMAX
;
p
= mkexpr(OPCOMMA
, p
, temp
);
memcpy(wh_next
, wh_first
, k
);
where
= ftell(pass1_file
);
if( !ISLOGICAL((k
= (p
= fixtype(p
))->headblock
.vtype
)))
err("non-logical expression in DO WHILE statement");
*wh_next
++ = ftell(pass1_file
) > where
;