d/freebsd-skq
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
0ac2ad320e
freebsd-skq/usr.bin/f2c/putpcc.c
Joerg Wunsch c3ad4b4583 Update to the most recent version. Among other things, this also solves 
the function naming problem for complex double function i've recently
aksed for in -committers.  (The recently committed rev 1.5 of proc.c
was actually also part of this update.)

Should the mailing lists come to an agreement that f2c better belongs
into the ports, this could be done nevertheless.  For the time being,
we've at least got a current version now.

Thanks, Steve!

Submitted by:	Steve Kargl <sgk@troutmask.apl.washington.edu>
1999-02-03 17:23:49 +00:00

2080 lines
43 KiB
C
Raw Blame History

/****************************************************************
Copyright 1990 - 1996 by AT&T, Lucent Technologies 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,
Lucent 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, Lucent and Bellcore disclaim all warranties with regard to
this software, including all implied warranties of
merchantability and fitness. In no event shall AT&T, Lucent 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 this software.
****************************************************************/
/* INTERMEDIATE CODE GENERATION FOR S. C. JOHNSON C COMPILERS */
/* NEW VERSION USING BINARY POLISH POSTFIX INTERMEDIATE */
#include "defs.h"
#include "pccdefs.h"
#include "output.h" /* for nice_printf */
#include "names.h"
#include "p1defs.h"
static Addrp intdouble Argdcl((Addrp));
static Addrp putcx1 Argdcl((tagptr));
static tagptr putaddr Argdcl((tagptr));
static tagptr putcall Argdcl((tagptr, Addrp*));
static tagptr putcat Argdcl((tagptr, tagptr));
static Addrp putch1 Argdcl((tagptr));
static tagptr putchcmp Argdcl((tagptr));
static tagptr putcheq Argdcl((tagptr));
static void putct1 Argdcl((tagptr, Addrp, Addrp, ptr));
static tagptr putcxcmp Argdcl((tagptr));
static Addrp putcxeq Argdcl((tagptr));
static tagptr putmnmx Argdcl((tagptr));
static tagptr putop Argdcl((tagptr));
static tagptr putpower Argdcl((tagptr));
extern int init_ac[TYSUBR+1];
extern int ops2[];
extern int proc_argchanges, proc_protochanges;
extern int krparens;
#define P2BUFFMAX 128
/* Puthead -- output the header information about subroutines, functions
and entry points */
void
#ifdef KR_headers
puthead(s, class)
char *s;
int class;
#else
puthead(char *s, int class)
#endif
{
if (headerdone == NO) {
if (class == CLMAIN)
s = "MAIN__";
p1_head (class, s);
headerdone = YES;
}
}
void
#ifdef KR_headers
putif(p, else_if_p)
register expptr p;
int else_if_p;
#else
putif(register expptr p, int else_if_p)
#endif
{
register int k;
int n;
long where;
if (else_if_p) {
p1put(P1_ELSEIFSTART);
where = ftell(pass1_file);
}
if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
{
if(k != TYERROR)
err("non-logical expression in IF statement");
}
else {
if (else_if_p) {
if (ei_next >= ei_last)
{
k = ei_last - ei_first;
n = k + 100;
ei_next = mem(n,0);
ei_last = ei_first + n;
if (k)
memcpy(ei_next, ei_first, k);
ei_first = ei_next;
ei_next += k;
ei_last = ei_first + n;
}
p = putx(p);
if (*ei_next++ = ftell(pass1_file) > where) {
p1_if(p);
new_endif();
}
else
p1_elif(p);
}
else {
p = putx(p);
p1_if(p);
}
}
}
void
#ifdef KR_headers
putout(p)
expptr p;
#else
putout(expptr p)
#endif
{
p1_expr (p);
/* Used to make temporaries in holdtemps available here, but they */
/* may be reused too soon (e.g. when multiple **'s are involved). */
}
void
#ifdef KR_headers
putcmgo(index, nlab, labs)
expptr index;
int nlab;
struct Labelblock **labs;
#else
putcmgo(expptr index, int nlab, struct Labelblock **labs)
#endif
{
if(! ISINT(index->headblock.vtype) )
{
execerr("computed goto index must be integer", CNULL);
return;
}
p1comp_goto (index, nlab, labs);
}
static expptr
#ifdef KR_headers
krput(p)
register expptr p;
#else
krput(register expptr p)
#endif
{
register expptr e, e1;
register unsigned op;
int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
op = p->exprblock.opcode;
e = p->exprblock.leftp;
if (e->tag == TEXPR && e->exprblock.opcode == op) {
e1 = (expptr)mktmp(t, ENULL);
putout(putassign(cpexpr(e1), e));
p->exprblock.leftp = e1;
}
else
p->exprblock.leftp = putx(e);
e = p->exprblock.rightp;
if (e->tag == TEXPR && e->exprblock.opcode == op) {
e1 = (expptr)mktmp(t, ENULL);
putout(putassign(cpexpr(e1), e));
p->exprblock.rightp = e1;
}
else
p->exprblock.rightp = putx(e);
return p;
}
expptr
#ifdef KR_headers
putx(p)
register expptr p;
#else
putx(register expptr p)
#endif
{
int opc;
int k;
if (p)
switch(p->tag)
{
case TERROR:
break;
case TCONST:
switch(p->constblock.vtype)
{
case TYLOGICAL1:
case TYLOGICAL2:
case TYLOGICAL:
#ifdef TYQUAD
case TYQUAD:
#endif
case TYLONG:
case TYSHORT:
case TYINT1:
break;
case TYADDR:
break;
case TYREAL:
case TYDREAL:
/* 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 */
break;
default:
p = putx( (expptr)putconst((Constp)p) );
break;
}
break;
case TEXPR:
switch(opc = p->exprblock.opcode)
{
case OPCALL:
case OPCCALL:
if( ISCOMPLEX(p->exprblock.vtype) )
p = putcxop(p);
else p = putcall(p, (Addrp *)NULL);
break;
case OPMIN:
case OPMAX:
p = putmnmx(p);
break;
case OPASSIGN:
if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
|| ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
(void) putcxeq(p);
p = ENULL;
} else if( ISCHAR(p) )
p = putcheq(p);
else
goto putopp;
break;
case OPEQ:
case OPNE:
if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
{
p = putcxcmp(p);
break;
}
case OPLT:
case OPLE:
case OPGT:
case OPGE:
if(ISCHAR(p->exprblock.leftp))
{
p = putchcmp(p);
break;
}
goto putopp;
case OPPOWER:
p = putpower(p);
break;
case OPSTAR:
/* m * (2**k) -> m<<k */
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);
goto putopp;
}
if (krparens && ISREAL(p->exprblock.vtype))
return krput(p);
case OPMOD:
goto putopp;
case OPPLUS:
if (krparens && ISREAL(p->exprblock.vtype))
return krput(p);
case OPMINUS:
case OPSLASH:
case OPNEG:
case OPNEG1:
case OPABS:
case OPDABS:
if( ISCOMPLEX(p->exprblock.vtype) )
p = putcxop(p);
else goto putopp;
break;
case OPCONV:
if( ISCOMPLEX(p->exprblock.vtype) )
p = putcxop(p);
else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
{
p = putx( mkconv(p->exprblock.vtype,
(expptr)realpart(putcx1(p->exprblock.leftp))));
}
else goto putopp;
break;
case OPNOT:
case OPOR:
case OPAND:
case OPEQV:
case OPNEQV:
case OPADDR:
case OPPLUSEQ:
case OPSTAREQ:
case OPCOMMA:
case OPQUEST:
case OPCOLON:
case OPBITOR:
case OPBITAND:
case OPBITXOR:
case OPBITNOT:
case OPLSHIFT:
case OPRSHIFT:
case OPASSIGNI:
case OPIDENTITY:
case OPCHARCAST:
case OPMIN2:
case OPMAX2:
case OPDMIN:
case OPDMAX:
case OPBITTEST:
case OPBITCLR:
case OPBITSET:
#ifdef TYQUAD
case OPQBITSET:
case OPQBITCLR:
#endif
putopp:
p = putop(p);
break;
case OPCONCAT:
/* weird things like ichar(a//a) */
p = (expptr)putch1(p);
break;
default:
badop("putx", opc);
p = errnode ();
}
break;
case TADDR:
p = putaddr(p);
break;
default:
badtag("putx", p->tag);
p = errnode ();
}
return p;
}
LOCAL expptr
#ifdef KR_headers
putop(p)
expptr p;
#else
putop(expptr p)
#endif
{
expptr lp, tp;
int pt, lt, lt1;
int comma;
char *hsave;
switch(p->exprblock.opcode) /* check for special cases and rewrite */
{
case OPCONV:
pt = p->exprblock.vtype;
lp = p->exprblock.leftp;
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)
{
if(lp->tag==TEXPR
&& lp->exprblock.opcode == OPCONV) {
lt1 = lp->exprblock.leftp->headblock.vtype;
if (lt1 == TYDREAL) {
lp->exprblock.leftp =
putx(lp->exprblock.leftp);
return p;
}
if (lt1 == TYDCOMPLEX) {
lp->exprblock.leftp = putx(
(expptr)realpart(
putcx1(lp->exprblock.leftp)));
return p;
}
}
break;
}
else if (ISREAL(pt) && ISCOMPLEX(lt)) {
p->exprblock.leftp = putx(mkconv(pt,
(expptr)realpart(
putcx1(p->exprblock.leftp))));
break;
}
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 ->
exprblock.leftp)));
return putop (p);
}
if (lt == TYCHAR) {
if (ISCONST(p->exprblock.leftp)
&& ISNUMERIC(p->exprblock.vtype)) {
hsave = halign;
halign = 0;
p->exprblock.leftp = putx((expptr)
putconst((Constp)
p->exprblock.leftp));
halign = hsave;
}
else
p->exprblock.leftp =
putx(p->exprblock.leftp);
return p;
}
if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
break;
frexpr(p->exprblock.vleng);
free( (charptr) p );
p = lp;
if (p->tag != TEXPR)
goto retputx;
pt = lt;
lp = p->exprblock.leftp;
lt = lp->headblock.vtype;
} /* while */
if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
break;
retputx:
return putx(p);
case OPADDR:
comma = NO;
lp = p->exprblock.leftp;
free( (charptr) p );
if(lp->tag != TADDR)
{
tp = (expptr)
mktmp(lp->headblock.vtype,lp->headblock.vleng);
p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
lp = tp;
comma = YES;
}
if(comma)
p = mkexpr(OPCOMMA, p, putaddr(lp));
else
p = (expptr)putaddr(lp);
return p;
case OPASSIGN:
case OPASSIGNI:
case OPLT:
case OPLE:
case OPGT:
case OPGE:
case OPEQ:
case OPNE:
;
}
if( ops2[p->exprblock.opcode] <= 0)
badop("putop", p->exprblock.opcode);
lp = p->exprblock.leftp = putx(p->exprblock.leftp);
if (p -> exprblock.rightp) {
tp = p->exprblock.rightp = putx(p->exprblock.rightp);
if (ISCONST(tp) && ISCONST(lp))
p = fold(p);
}
return p;
}
LOCAL expptr
#ifdef KR_headers
putpower(p)
expptr p;
#else
putpower(expptr p)
#endif
{
expptr base;
Addrp t1, t2;
ftnint k;
int type;
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;
t1 = mktmp(type, ENULL);
t2 = NULL;
free ((charptr) p);
p = putassign (cpexpr((expptr) t1), base);
sprintf (buf, "Computing %ld%s power", k,
k == 2 ? "nd" : k == 3 ? "rd" : "th");
p1_comment (buf);
for( ; (k&1)==0 && k>2 ; k>>=1 )
{
p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
}
if(k == 2) {
/* Write the power computation out immediately */
putout (p);
p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
} else if (k == 3) {
putout(p);
p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1),
mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
} else {
t2 = mktmp(type, ENULL);
p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
cpexpr((expptr)t1)));
for(k>>=1 ; k>1 ; k>>=1)
{
p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
if(k & 1)
{
p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
}
}
/* Write the power computation out immediately */
putout (p);
p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
}
frexpr((expptr)t1);
if(t2)
frexpr((expptr)t2);
return p;
}
LOCAL Addrp
#ifdef KR_headers
intdouble(p)
Addrp p;
#else
intdouble(Addrp p)
#endif
{
register Addrp t;
t = mktmp(TYDREAL, ENULL);
putout (putassign(cpexpr((expptr)t), (expptr)p));
return(t);
}
/* Complex-type variable assignment */
LOCAL Addrp
#ifdef KR_headers
putcxeq(p)
register expptr p;
#else
putcxeq(register expptr p)
#endif
{
register Addrp lp, rp;
expptr code;
if(p->tag != TEXPR)
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)));
}
putout (code);
frexpr((expptr)rp);
free ((charptr) p);
return lp;
}
/* putcxop -- used to write out embedded calls to complex functions, and
complex arguments to procedures */
expptr
#ifdef KR_headers
putcxop(p)
expptr p;
#else
putcxop(expptr p)
#endif
{
return (expptr)putaddr((expptr)putcx1(p));
}
#define PAIR(x,y) mkexpr (OPCOMMA, (x), (y))
LOCAL Addrp
#ifdef KR_headers
putcx1(p)
register expptr p;
#else
putcx1(register expptr p)
#endif
{
expptr q;
Addrp lp, rp;
register Addrp resp;
int opcode;
int ltype, rtype;
long ts, tskludge;
if(p == NULL)
return(NULL);
switch(p->tag)
{
case TCONST:
if( ISCOMPLEX(p->constblock.vtype) )
p = (expptr) putconst((Constp)p);
return( (Addrp) p );
case TADDR:
resp = &p->addrblock;
if (addressable(p))
return (Addrp) p;
ts = tskludge = 0;
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->Field ? 2 : 1);
}
else if (resp->isarray
&& resp->vtype != TYCHAR) {
if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
&& resp->uname_tag == UNAM_NAME)
q = mkexpr(OPMINUS, q,
mkintcon(resp->user.name->voffset));
ts = typesize[resp->vtype]
* (resp->Field ? 2 : 1);
q = resp->memoffset = mkexpr(OPSLASH, q,
ICON(ts));
}
}
resp = mktmp(tyint, ENULL);
putout(putassign(cpexpr((expptr)resp), q));
p->addrblock.memoffset = tskludge
? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
: (expptr)resp;
if (ts) {
resp = &p->addrblock;
q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
&& resp->uname_tag == UNAM_NAME)
q = mkexpr(OPPLUS, q,
mkintcon(resp->user.name->voffset));
resp->memoffset = q;
}
return (Addrp) p;
case TEXPR:
if( ISCOMPLEX(p->exprblock.vtype) )
break;
resp = mktmp(p->exprblock.vtype, ENULL);
/*first arg of above mktmp call was TYDREAL before 19950102 */
putout (putassign( cpexpr((expptr)resp), p));
return(resp);
case TERROR:
return NULL;
default:
badtag("putcx1", p->tag);
}
opcode = p->exprblock.opcode;
if(opcode==OPCALL || opcode==OPCCALL)
{
Addrp t;
p = putcall(p, &t);
putout(p);
return t;
}
else if(opcode == OPASSIGN)
{
return putcxeq (p);
}
/* BUG (inefficient) Generates too many temporary variables */
resp = mktmp(p->exprblock.vtype, ENULL);
if(lp = putcx1(p->exprblock.leftp) )
ltype = lp->vtype;
if(rp = putcx1(p->exprblock.rightp) )
rtype = rp->vtype;
switch(opcode)
{
case OPCOMMA:
frexpr((expptr)resp);
resp = rp;
rp = NULL;
break;
case OPNEG:
case OPNEG1:
putout (PAIR (
putassign( (expptr)realpart(resp),
mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
putassign( imagpart(resp),
mkexpr(OPNEG, imagpart(lp), ENULL))));
break;
case OPPLUS:
case OPMINUS: { expptr r;
r = putassign( (expptr)realpart(resp),
mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
if(rtype < TYCOMPLEX)
q = putassign( imagpart(resp), imagpart(lp) );
else if(ltype < TYCOMPLEX)
{
if(opcode == OPPLUS)
q = putassign( imagpart(resp), imagpart(rp) );
else
q = putassign( imagpart(resp),
mkexpr(OPNEG, imagpart(rp), ENULL) );
}
else
q = putassign( imagpart(resp),
mkexpr(opcode, imagpart(lp), imagpart(rp) ));
r = PAIR (r, q);
putout (r);
break;
} /* case OPPLUS, OPMINUS: */
case OPSTAR:
if(ltype < TYCOMPLEX)
{
if( ISINT(ltype) )
lp = intdouble(lp);
putout (PAIR (
putassign( (expptr)realpart(resp),
mkexpr(OPSTAR, cpexpr((expptr)lp),
(expptr)realpart(rp))),
putassign( imagpart(resp),
mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
}
else if(rtype < TYCOMPLEX)
{
if( ISINT(rtype) )
rp = intdouble(rp);
putout (PAIR (
putassign( (expptr)realpart(resp),
mkexpr(OPSTAR, cpexpr((expptr)rp),
(expptr)realpart(lp))),
putassign( imagpart(resp),
mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
}
else {
putout (PAIR (
putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
mkexpr(OPSTAR, (expptr)realpart(lp),
(expptr)realpart(rp)),
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))))));
}
break;
case OPSLASH:
/* fixexpr has already replaced all divisions
* by a complex by a function call
*/
if( ISINT(rtype) )
rp = intdouble(rp);
putout (PAIR (
putassign( (expptr)realpart(resp),
mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
putassign( imagpart(resp),
mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
break;
case OPCONV:
if (!lp)
break;
if(ISCOMPLEX(lp->vtype) )
q = imagpart(lp);
else if(rp != NULL)
q = (expptr) realpart(rp);
else
q = mkrealcon(TYDREAL, "0");
putout (PAIR (
putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
putassign( imagpart(resp), q)));
break;
default:
badop("putcx1", opcode);
}
frexpr((expptr)lp);
frexpr((expptr)rp);
free( (charptr) p );
return(resp);
}
/* Only .EQ. and .NE. may be performed on COMPLEX data, other relations
are not defined */
LOCAL expptr
#ifdef KR_headers
putcxcmp(p)
register expptr p;
#else
putcxcmp(register expptr p)
#endif
{
int opcode;
register Addrp lp, rp;
expptr q;
if(p->tag != TEXPR)
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)) );
free( (charptr) lp);
free( (charptr) rp);
free( (charptr) p );
if (ISCONST(q))
return q;
return putx( fixexpr((Exprp)q) );
}
/* putch1 -- Forces constants into the literal pool, among other things */
LOCAL Addrp
#ifdef KR_headers
putch1(p)
register expptr p;
#else
putch1(register expptr p)
#endif
{
Addrp t;
expptr e;
switch(p->tag)
{
case TCONST:
return( putconst((Constp)p) );
case TADDR:
return( (Addrp) p );
case TEXPR:
switch(p->exprblock.opcode)
{
expptr q;
case OPCALL:
case OPCCALL:
p = putcall(p, &t);
putout (p);
break;
case OPCONCAT:
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 */
frexpr(t->vleng);
t->vleng = q;
putout (p);
break;
case OPCONV:
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));
putout (p);
break;
default:
badop("putch1", p->exprblock.opcode);
}
return(t);
default:
badtag("putch1", p->tag);
}
/* NOT REACHED */ return 0;
}
/* putchop -- Write out a character actual parameter; that is, this is
part of a procedure invocation */
Addrp
#ifdef KR_headers
putchop(p)
expptr p;
#else
putchop(expptr p)
#endif
{
p = putaddr((expptr)putch1(p));
return (Addrp)p;
}
LOCAL expptr
#ifdef KR_headers
putcheq(p)
register expptr p;
#else
putcheq(register expptr p)
#endif
{
expptr lp, rp;
int nbad;
if(p->tag != TEXPR)
badtag("putcheq", p->tag);
lp = p->exprblock.leftp;
rp = p->exprblock.rightp;
frexpr(p->exprblock.vleng);
free( (charptr) p );
/* If s = t // u, don't bother copying the result, write it directly into
this buffer */
nbad = badchleng(lp) + badchleng(rp);
if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
p = putcat(lp, rp);
else if( !nbad
&& 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));
}
else
p = putx( call2(TYSUBR, "s_copy", lp, rp) );
return p;
}
LOCAL expptr
#ifdef KR_headers
putchcmp(p)
register expptr p;
#else
putchcmp(register expptr p)
#endif
{
expptr lp, rp;
if(p->tag != TEXPR)
badtag("putchcmp", p->tag);
lp = p->exprblock.leftp;
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;
}
else {
lp = call2(TYINT,"s_cmp", lp, rp);
rp = ICON(0);
}
p->exprblock.leftp = lp;
p->exprblock.rightp = rp;
p = putop(p);
return p;
}
/* 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
#ifdef KR_headers
putcat(lhs0, rhs)
expptr lhs0;
register expptr rhs;
#else
putcat(expptr lhs0, register expptr rhs)
#endif
{
register Addrp lhs = (Addrp)lhs0;
int n, tyi;
Addrp length_var, string_var;
expptr p;
static char Writing_concatenation[] = "Writing concatenation";
/* Create the temporary arrays */
n = ncat(rhs);
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 */
n = 0;
/* 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 */
tyi = tyint;
tyint = tyioint; /* for -I2 */
p = putx (call4 (TYSUBR, "s_cat",
(expptr)lhs,
(expptr)string_var,
(expptr)length_var,
(expptr)putconst((Constp)ICON(n))));
tyint = tyi;
return p;
}
LOCAL void
#ifdef KR_headers
putct1(q, length_var, string_var, ip)
register expptr q;
register Addrp length_var;
register Addrp string_var;
int *ip;
#else
putct1(register expptr q, register Addrp length_var, register Addrp string_var, int *ip)
#endif
{
int i;
Addrp length_copy, string_copy;
expptr e;
extern int szleng;
if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
{
putct1(q->exprblock.leftp, length_var, string_var,
ip);
putct1(q->exprblock.rightp, length_var, string_var,
ip);
frexpr (q -> exprblock.vleng);
free ((charptr) q);
}
else
{
i = (*ip)++;
e = cpexpr(q->headblock.vleng);
if (!e)
return; /* error -- character*(*) */
length_copy = (Addrp) cpexpr((expptr)length_var);
length_copy->memoffset =
mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
string_copy = (Addrp) cpexpr((expptr)string_var);
string_copy->memoffset =
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 */
LOCAL expptr
#ifdef KR_headers
putaddr(p0)
expptr p0;
#else
putaddr(expptr p0)
#endif
{
register Addrp p;
chainp cp;
if (!(p = (Addrp)p0))
return ENULL;
if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
{
frexpr((expptr)p);
return ENULL;
}
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);
}
else
p->memoffset = putx(p->memoffset);
return (expptr) p;
}
LOCAL expptr
#ifdef KR_headers
addrfix(e)
expptr e;
#else
addrfix(expptr e)
#endif
/* fudge character string length if it's a TADDR */
{
return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
}
LOCAL int
#ifdef KR_headers
typekludge(ccall, q, at, j)
int ccall;
register expptr q;
Atype *at;
int j;
#else
typekludge(int ccall, register expptr q, Atype *at, int j)
#endif
/* j = alternate type */
{
register int i, k;
extern int iocalladdr;
register Namep np;
/* Return value classes:
* < 100 ==> Fortran arg (pointer to type)
* < 200 ==> C arg
* < 300 ==> procedure arg
* < 400 ==> external, no explicit type
* < 500 ==> arg that may turn out to be
* either a variable or a procedure
*/
k = q->headblock.vtype;
if (ccall) {
if (k == TYREAL)
k = TYDREAL; /* force double for library routines */
return k + 100;
}
if (k == TYADDR)
return iocalladdr;
i = q->tag;
if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
|| (i == TADDR && q->addrblock.charleng)
|| i == TCONST)
k = TYFTNLEN + 100;
else if (i == TADDR)
switch(q->addrblock.vclass) {
case CLPROC:
if (q->addrblock.uname_tag != UNAM_NAME)
k += 200;
else if ((np = q->addrblock.user.name)->vprocclass
!= PTHISPROC) {
if (k && !np->vimpltype)
k += 200;
else {
if (j > 200 && infertypes && j < 300) {
k = j;
inferdcl(np, j-200);
}
else k = (np->vstg == STGEXT
? extsymtab[np->vardesc.varno].extype
: 0) + 200;
at->cp = mkchain((char *)np, at->cp);
}
}
else if (k == TYSUBR)
k += 200;
break;
case CLUNKNOWN:
if (q->addrblock.vstg == STGARG
&& q->addrblock.uname_tag == UNAM_NAME) {
k += 400;
at->cp = mkchain((char *)q->addrblock.user.name,
at->cp);
}
}
else if (i == TNAME && q->nameblock.vstg == STGARG) {
np = &q->nameblock;
switch(np->vclass) {
case CLPROC:
if (!np->vimpltype)
k += 200;
else if (j <= 200 || !infertypes || j >= 300)
k += 300;
else {
k = j;
inferdcl(np, j-200);
}
goto add2chain;
case CLUNKNOWN:
/* argument may be a scalar variable or a function */
if (np->vimpltype && j && infertypes
&& j < 300) {
inferdcl(np, j % 100);
k = j;
}
else
k += 400;
/* to handle procedure args only so far known to be
* external, save a pointer to the symbol table entry...
*/
add2chain:
at->cp = mkchain((char *)np, at->cp);
}
}
return k;
}
char *
#ifdef KR_headers
Argtype(k, buf)
int k;
char *buf;
#else
Argtype(int k, char *buf)
#endif
{
if (k < 100) {
sprintf(buf, "%s variable", ftn_types[k]);
return buf;
}
if (k < 200) {
k -= 100;
return ftn_types[k];
}
if (k < 300) {
k -= 200;
if (k == TYSUBR)
return ftn_types[TYSUBR];
sprintf(buf, "%s function", ftn_types[k]);
return buf;
}
if (k < 400)
return "external argument";
k -= 400;
sprintf(buf, "%s argument", ftn_types[k]);
return buf;
}
static void
#ifdef KR_headers
atype_squawk(at, msg)
Argtypes *at;
char *msg;
#else
atype_squawk(Argtypes *at, char *msg)
#endif
{
register Atype *a, *ae;
warn(msg);
for(a = at->atypes, ae = a + at->nargs; a < ae; a++)
frchain(&a->cp);
at->nargs = -1;
if (at->changes & 2 && !at->defined)
proc_protochanges++;
}
static char inconsist[] = "inconsistent calling sequences for ";
void
#ifdef KR_headers
bad_atypes(at, fname, i, j, k, here, prev)
Argtypes *at;
char *fname;
int i;
int j;
int k;
char *here;
char *prev;
#else
bad_atypes(Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev)
#endif
{
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),
prev, Argtype(j, buf2));
atype_squawk(at, buf);
}
int
#ifdef KR_headers
type_fixup(at, a, k)
Argtypes *at;
Atype *a;
int k;
#else
type_fixup(Argtypes *at, Atype *a, int k)
#endif
{
register struct Entrypoint *ep;
if (!infertypes)
return 0;
for(ep = entries; ep; ep = ep->entnextp)
if (ep->entryname && at == ep->entryname->arginfo) {
a->type = k % 100;
return proc_argchanges = 1;
}
return 0;
}
void
#ifdef KR_headers
save_argtypes(arglist, at0, at1, ccall, fname, stg, nchargs, type, zap)
chainp arglist;
Argtypes **at0;
Argtypes **at1;
int ccall;
char *fname;
int stg;
int nchargs;
int type;
int zap;
#else
save_argtypes(chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap)
#endif
{
Argtypes *at;
chainp cp;
int i, i0, j, k, nargs, nbad, *t, *te;
Atype *atypes;
expptr q;
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,
#ifdef TYQUAD
0,
#endif
initargs, initargs+1,0,0,0,initargs+2};
i0 = init_ac[type];
t = init_ap[type];
te = t + i0;
if (at = *at0) {
*at1 = at;
nargs = at->nargs;
if (nargs < 0 && type && at->changes & 2 && !at->defined)
--proc_protochanges;
if (at->dnargs >= 0 && zap != 2)
type = 0;
if (nargs < 0) { /* inconsistent usage seen */
if (type)
goto newlist;
return;
}
atypes = at->atypes;
i = nchargs;
for(nbad = 0; t < te; atypes++) {
if (++i > nargs) {
toomany:
i = nchargs + i0;
for(cp = arglist; cp; cp = cp->nextp)
i++;
toofew:
switch(zap) {
case 2: zap = 6; break;
case 1: if (at->defined & 4)
return;
}
sprintf(buf,
"%s%.90s:\n\there %d, previously %d args and string lengths.",
inconsist, fname, i, nargs);
atype_squawk(at, buf);
if (type) {
t = init_ap[type];
goto newlist;
}
return;
}
j = atypes->type;
k = *t++;
if (j != k && j-400 != k) {
cp = 0;
goto badtypes;
}
}
for(cp = arglist; cp; atypes++, cp = cp->nextp) {
if (++i > nargs)
goto toomany;
j = atypes->type;
if (!(q = (expptr)cp->datap))
continue;
k = typekludge(ccall, q, atypes, j);
if (k >= 300 || k == j)
continue;
if (j >= 300) {
if (k >= 200) {
if (k == TYUNKNOWN + 200)
continue;
if (j % 100 != k - 200
&& k != TYSUBR + 200
&& j != TYUNKNOWN + 300
&& !type_fixup(at,atypes,k))
goto badtypes;
}
else if (j % 100 % TYSUBR != k % TYSUBR
&& !type_fixup(at,atypes,k))
goto badtypes;
}
else if (k < 200 || j < 200)
if (j) {
if (k == TYUNKNOWN
&& q->tag == TNAME
&& q->nameblock.vinfproc) {
q->nameblock.vdcldone = 0;
impldcl((Namep)q);
}
goto badtypes;
}
else ; /* fall through to update */
else if (k == TYUNKNOWN+200)
continue;
else if (j != TYUNKNOWN+200)
{
badtypes:
if (++nbad == 1)
bad_atypes(at, fname, i - nchargs,
j, k, "here ", ", previously");
else
fprintf(stderr,
"\targ %d: here %s, previously %s.\n",
i - nchargs, Argtype(k,buf1),
Argtype(j,buf2));
if (!cp)
break;
continue;
}
/* We've subsequently learned the right type,
as in the call on zoo below...
subroutine foo(x, zap)
external zap
call goo(zap)
x = zap(3)
call zoo(zap)
end
*/
if (!nbad) {
atypes->type = k;
at->changes |= 1;
}
}
if (i < nargs)
goto toofew;
if (nbad) {
if (type) {
/* we're defining the procedure */
t = init_ap[type];
te = t + i0;
proc_argchanges = 1;
goto newlist;
}
return;
}
if (zap == 1 && (at->changes & 5) != 5)
at->changes = 0;
return;
}
newlist:
i = i0 + nchargs;
for(cp = arglist; cp; cp = cp->nextp)
i++;
k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
*at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
: (Argtypes *) mem(k,1);
at->dnargs = at->nargs = i;
at->defined = zap & 6;
at->changes = type ? 0 : 4;
atypes = at->atypes;
for(; t < te; atypes++) {
atypes->type = *t++;
atypes->cp = 0;
}
for(cp = arglist; cp; atypes++, cp = cp->nextp) {
atypes->cp = 0;
atypes->type = (q = (expptr)cp->datap)
? typekludge(ccall, q, atypes, 0)
: 0;
}
for(; --nchargs >= 0; atypes++) {
atypes->type = TYFTNLEN + 100;
atypes->cp = 0;
}
}
static char*
#ifdef KR_headers
get_argtypes(p, pat0, pat1) Exprp p; Argtypes ***pat0, ***pat1;
#else
get_argtypes(Exprp p, Argtypes ***pat0, Argtypes ***pat1)
#endif
{
Addrp a;
Argtypes **at0, **at1;
Namep np;
expptr rp;
Extsym *e;
char *fname;
a = (Addrp)p->leftp;
switch(a->vstg) {
case STGEXT:
switch(a->uname_tag) {
case UNAM_EXTERN: /* e.g., sqrt() */
e = extsymtab + a->memno;
at0 = at1 = &e->arginfo;
fname = e->fextname;
break;
case UNAM_NAME:
np = a->user.name;
at0 = &extsymtab[np->vardesc.varno].arginfo;
at1 = &np->arginfo;
fname = np->fvarname;
break;
default:
goto bug;
}
break;
case STGARG:
if (a->uname_tag != UNAM_NAME)
goto bug;
np = a->user.name;
at0 = at1 = &np->arginfo;
fname = np->fvarname;
break;
default:
bug:
Fatal("Confusion in saveargtypes");
}
*pat0 = at0;
*pat1 = at1;
return fname;
}
void
#ifdef KR_headers
saveargtypes(p)
register Exprp p;
#else
saveargtypes(register Exprp p)
#endif
/* for writing prototypes */
{
Argtypes **at0, **at1;
chainp arglist;
expptr rp;
char *fname;
fname = get_argtypes(p, &at0, &at1);
rp = p->rightp;
arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
fname, p->leftp->addrblock.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
#ifdef KR_headers
putcall(p0, temp)
expptr p0;
Addrp *temp;
#else
putcall(expptr p0, Addrp *temp)
#endif
{
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
parameters) */
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
set elsewhere */
int byvalue; /* True iff we don't want to massage the
parameter list, since we're calling a C
library routine */
char *s;
Argtypes *at, **at0, **at1;
Atype *At, *Ate;
type = p -> vtype;
charsp = NULL;
byvalue = (p->opcode == OPCCALL);
/* Verify the actual parameters */
if (p == (Exprp) NULL)
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;
else
arglist = NULL;
/* Count the number of explicit arguments, including lengths of character
variables */
if (!byvalue) {
get_argtypes(p, &at0, &at1);
At = Ate = 0;
if ((at = *at0) && at->nargs >= 0) {
At = at->atypes;
Ate = At + at->nargs;
At += init_ac[type];
}
for(cp = arglist ; cp ; cp = cp->nextp) {
q = (expptr) cp->datap;
if( ISCONST(q) ) {
/* Even constants are passed by reference, so we need to put them in the
literal table */
q = (expptr) putconst((Constp)q);
cp->datap = (char *) q;
}
/* Save the length expression of character variables (NOT character
procedures) for the end of the argument list */
if( ISCHAR(q) &&
(q->headblock.vclass != CLPROC
|| q->headblock.vstg == STGARG
&& q->tag == TADDR
&& q->addrblock.uname_tag == UNAM_NAME
&& q->addrblock.user.name->vprocclass == PTHISPROC)
&& (!At || At->type % 100 % TYSUBR == TYCHAR))
{
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;
else if (q->tag == TADDR
&& q->addrblock.uname_tag == UNAM_CONST)
p0->constblock.Const.ci
+= q->addrblock.user.Const.ccp1.blanks;
}
if (At && ++At == Ate)
At = 0;
}
}
charsp = revchain(charsp);
/* If the routine is a CHARACTER function ... */
if(type == TYCHAR)
{
if( ISICON(p->vleng) )
{
/* Allocate a temporary to hold the return value of the function */
fval = mktmp(TYCHAR, p->vleng);
}
else {
err("adjustable character function");
if (temp)
*temp = 0;
return 0;
}
}
/* If the routine is a COMPLEX function ... */
else if( ISCOMPLEX(type) )
fval = mktmp(type, ENULL);
else
fval = NULL;
/* Write the function name, without taking its address */
p -> leftp = putx(fixtype(putaddr(p->leftp)));
if(fval)
{
chainp prepend;
/* Prepend a copy of the function return value buffer out as the first
argument. */
prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
/* If it's a character function, also prepend the length of the result */
if(type==TYCHAR)
{
prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
p->vleng)), arglist);
}
if (!(q = p->rightp))
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);
if (q == ENULL)
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)
goto make_copy;
cp->datap = (char *)putaddr(q);
}
else if( ISCOMPLEX(q->headblock.vtype) )
cp -> datap = (char *) putx (fixtype(putcxop(q)));
else if (ISCHAR(q) )
cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
else if( ! ISERROR(q) )
{
if(byvalue) {
if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
&& q->exprblock.leftp->tag == TEXPR)
q->exprblock.leftp = putcxop(q->exprblock.leftp);
else
q->exprblock.leftp = putx(q->exprblock.leftp);
}
else
cp -> datap = (char *) putx(q);
}
else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
cp -> datap = (char *) putx(q);
else {
expptr t, t1;
/* If we've got a register parameter, or (maybe?) a constant, save it in a
temporary first */
make_copy:
t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
/* Assign to temporary variables before invoking the subroutine or
function */
t1 = putassign( cpexpr(t), q );
if (doin_setbound)
t = mkexpr(OPCOMMA_ARG, t1, t);
else
putout(t1);
cp -> datap = (char *) t;
} /* else */
} /* if !ISERROR(q) */
}
/* 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)
: ICON(0)));
/* ... 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
necessary. */
if (temp) *temp = fval;
else frexpr ((expptr)fval);
saveargtypes(p);
return (expptr) p;
}
/* putmnmx -- Put min or max. p must point to an EXPR, not just a
CONST */
LOCAL expptr
#ifdef KR_headers
putmnmx(p)
register expptr p;
#else
putmnmx(register expptr p)
#endif
{
int op, op2, type;
expptr arg, qp, temp;
chainp p0, p1;
Addrp sp, tp;
char comment_buf[80];
char *what;
if(p->tag != TEXPR)
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) );
free( (charptr) p );
/* special case for two addressable operands */
if (addressable((expptr)p0->datap)
&& (p1 = p0->nextp)
&& addressable((expptr)p1->datap)
&& !p1->nextp) {
if (type == TYREAL && forcedouble)
op2 = op == OPMIN ? OPDMIN : OPDMAX;
p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
mkconv(type, cpexpr((expptr)p1->datap)));
frchain(&p0);
return p;
}
/* general case */
sp = mktmp(type, ENULL);
/* We only need a second temporary if the arg list has an unaddressable
value */
tp = (Addrp) NULL;
qp = ENULL;
for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
if (!addressable ((expptr) p1 -> datap)) {
tp = mktmp(type, ENULL);
qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
qp = fixexpr((Exprp)qp);
break;
} /* if */
/* Now output the appropriate number of assignments and comparisons. Min
and max are implemented by the simple O(n) algorithm:
min (a, b, c, d) ==>
{ <type> t1, t2;
t1 = a;
t2 = b; t1 = (t1 < t2) ? t1 : t2;
t2 = c; t1 = (t1 < t2) ? t1 : t2;
t2 = d; t1 = (t1 < t2) ? t1 : t2;
}
*/
if (!doin_setbound) {
switch(op) {
case OPLT:
case OPMIN:
case OPDMIN:
case OPMIN2:
what = "IN";
break;
default:
what = "AX";
}
sprintf (comment_buf, "Computing M%s", what);
p1_comment (comment_buf);
}
p1 = p0->nextp;
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);
if (!ISCONST(temp))
temp = fixexpr((Exprp)temp);
p1 = p1->nextp;
}
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);
} else {
temp = (expptr) cpexpr (qp);
p = mkexpr(OPCOMMA, p,
putassign(cpexpr((expptr)tp), (expptr)p1->datap));
} /* else */
if(p1->nextp)
p = mkexpr(OPCOMMA, p,
putassign(cpexpr((expptr)sp), temp));
else {
if (type == TYREAL && forcedouble)
temp->exprblock.opcode =
op == OPMIN ? OPDMIN : OPDMAX;
if (doin_setbound)
p = mkexpr(OPCOMMA, p, temp);
else {
putout (p);
p = putx(temp);
}
if (qp)
frexpr (qp);
} /* else */
} /* for */
frchain( &p0 );
return p;
}
void
#ifdef KR_headers
putwhile(p)
expptr p;
#else
putwhile(expptr p)
#endif
{
long where;
int k, n;
if (wh_next >= wh_last)
{
k = wh_last - wh_first;
n = k + 100;
wh_next = mem(n,0);
wh_last = wh_first + n;
if (k)
memcpy(wh_next, wh_first, k);
wh_first = wh_next;
wh_next += k;
wh_last = wh_first + n;
}
p1put(P1_WHILE1START);
where = ftell(pass1_file);
if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
{
if(k != TYERROR)
err("non-logical expression in DO WHILE statement");
}
else {
p = putx(p);
*wh_next++ = ftell(pass1_file) > where;
p1put(P1_WHILE2START);
p1_expr(p);
}
}
Reference in New Issue View Git Blame Copy Permalink