/* little routines to create constant blocks */
struct constblock
*mkconst(t
)
register struct constblock
*p
;
struct constblock
*mklogcon(l
)
register struct constblock
* p
;
struct constblock
*mkintcon(l
)
register struct constblock
*p
;
if(l
>= -MAXSHORT
&& l
<= MAXSHORT
)
struct constblock
*mkaddcon(l
)
register struct constblock
*p
;
struct constblock
*mkrealcon(t
, d
)
register struct constblock
*p
;
struct constblock
*mkbitcon(shift
, leng
, s
)
register struct constblock
*p
;
p
->const.ci
= (p
->const.ci
<< shift
) | hextoi(*s
++);
struct constblock
*mkstrcon(l
,v
)
register struct constblock
*p
;
p
->const.ccp
= s
= (char *) ckalloc(l
);
struct constblock
*mkcxcon(realp
,imagp
)
register expptr realp
, imagp
;
register struct constblock
*p
;
if( ISCONST(realp
) && ISNUMERIC(rtype
) && ISCONST(imagp
) && ISNUMERIC(itype
) )
p
= mkconst( (rtype
==TYDREAL
||itype
==TYDREAL
) ? TYDCOMPLEX
: TYCOMPLEX
);
p
->const.cd
[0] = realp
->const.ci
;
else p
->const.cd
[0] = realp
->const.cd
[0];
p
->const.cd
[1] = imagp
->const.ci
;
else p
->const.cd
[1] = imagp
->const.cd
[0];
err("invalid complex constant");
struct errorblock
*errnode()
if(t
==TYUNKNOWN
|| t
==TYERROR
)
fatal1("mkconv of impossible type %d", t
);
else if( ISCONST(p
) && p
->vtype
!=TYADDR
)
consconv(t
, &(q
->const), p
->vtype
, &(p
->const));
q
= mkexpr(OPCONV
, p
, 0);
struct exprblock
*addrof(p
)
return( mkexpr(OPADDR
, p
, NULL
) );
static int blksize
[ ] = { 0, sizeof(struct nameblock
), sizeof(struct constblock
),
sizeof(struct exprblock
), sizeof(struct addrblock
),
sizeof(struct primblock
), sizeof(struct listblock
),
sizeof(struct errorblock
)
if( (tag
= p
->tag
) == TNAME
)
e
= cpblock( blksize
[p
->tag
] , p
);
e
->const.ccp
= copyn(1+strlen(e
->const.ccp
), e
->const.ccp
);
e
->vleng
= cpexpr(e
->vleng
);
e
->leftp
= cpexpr(p
->leftp
);
e
->rightp
= cpexpr(p
->rightp
);
ep
= e
->listp
= mkchain( cpexpr(pp
->datap
), NULL
);
for(pp
= pp
->nextp
; pp
; pp
= pp
->nextp
)
ep
= ep
->nextp
= mkchain( cpexpr(pp
->datap
), NULL
);
e
->vleng
= cpexpr(e
->vleng
);
e
->memoffset
= cpexpr(e
->memoffset
);
e
->argsp
= cpexpr(e
->argsp
);
e
->fcharp
= cpexpr(e
->fcharp
);
e
->lcharp
= cpexpr(e
->lcharp
);
fatal1("cpexpr: impossible tag %d", tag
);
for(q
= p
->listp
; q
; q
= q
->nextp
)
fatal1("frexpr: impossible tag %d", p
->tag
);
/* fix up types in expression; replace subtrees and convert
names to address blocks */
if( ! ONEOF(p
->vtype
, MSKINT
|MSKLOGICAL
|MSKADDR
) )
p
->memoffset
= fixtype(p
->memoffset
);
fatal1("fixtype: impossible tag %d", p
->tag
);
if(p
->argsp
&& p
->namep
->vclass
!=CLVAR
)
/* special case tree transformations and cleanups of expression trees */
register struct exprblock
*p
;
int opcode
, ltype
, rtype
, ptype
, mtype
;
fatal1("fixexpr: invalid tag %d", p
->tag
);
lp
= p
->leftp
= fixtype(p
->leftp
);
if(opcode
==OPASSIGN
&& lp
->tag
!=TADDR
)
err("left side of assignment must be variable");
rp
= p
->rightp
= fixtype(p
->rightp
);
/* force folding if possible */
if( ISCONST(lp
) && (rp
==NULL
|| ISCONST(rp
)) )
q
= mkexpr(opcode
, lp
, rp
);
free(q
); /* constants did not fold */
if( (ptype
= cktype(opcode
, ltype
, rtype
)) == TYERROR
)
p
->vleng
= mkexpr(OPPLUS
, cpexpr(lp
->vleng
),
if( ! ISCONST(rp
) && ISREAL(ltype
) && ISREAL(rtype
) )
if( ISCOMPLEX(ltype
) || ISCOMPLEX(rtype
) )
if( ONEOF(ltype
, MSKADDR
|MSKINT
) && ONEOF(rtype
, MSKADDR
|MSKINT
)
&& typesize
[ltype
]>=typesize
[rtype
] )
&& typesize
[ltype
]==typesize
[rtype
] )
p
->rightp
= fixtype( mkconv(ptype
, rp
) );
p
= call2(ptype
, ptype
==TYCOMPLEX
? "c_div" : "z_div",
mkconv(ptype
, lp
), mkconv(ptype
, rp
) );
if(ptype
==TYDREAL
&& ( (ltype
==TYREAL
&& ! ISCONST(lp
) ) ||
(rtype
==TYREAL
&& ! ISCONST(rp
) ) ))
p
->leftp
= fixtype(mkconv(ptype
,lp
));
p
->rightp
= fixtype(mkconv(ptype
,rp
));
mtype
= cktype(OPMINUS
, ltype
, rtype
);
if(mtype
==TYDREAL
&& ( (ltype
==TYREAL
&& ! ISCONST(lp
)) ||
(rtype
==TYREAL
&& ! ISCONST(rp
)) ))
p
->leftp
= fixtype(mkconv(mtype
,lp
));
p
->rightp
= fixtype(mkconv(mtype
,rp
));
ptype
= cktype(OPCONV
, p
->vtype
, ltype
);
if(lp
->tag
==TEXPR
&& lp
->opcode
==OPCOMMA
)
lp
->rightp
= fixtype( mkconv(ptype
, lp
->rightp
) );
if(lp
->tag
==TEXPR
&& lp
->opcode
==OPADDR
)
for efficient subscripting, replace long ints by shorts
return( mkconv(TYINT
,p
) );
fatal1("shorten: invalid tag %d", p
->tag
);
q
= shorten( cpexpr(p
->rightp
) );
p
->leftp
= shorten(p
->leftp
);
if(p
->leftp
->vtype
== TYLONG
)
p
->leftp
= shorten(p
->leftp
);
if(p
->leftp
->vtype
== TYINT
)
struct addrblock
*mkaddr();
for(p
= p0
->listp
; p
; p
= p
->nextp
)
else if(qtag
==TPRIM
&& q
->argsp
==0 && q
->namep
->vclass
==CLPROC
)
p
->datap
= mkaddr(q
->namep
);
else if(qtag
==TPRIM
&& q
->argsp
==0 && q
->namep
->vdim
!=NULL
)
p
->datap
= mkscalar(q
->namep
);
else if(qtag
==TPRIM
&& q
->argsp
==0 && q
->namep
->vdovar
&&
(t
= memversion(q
->namep
)) )
else p
->datap
= fixtype(q
);
register struct nameblock
*np
;
register struct addrblock
*ap
;
register struct dimblock
*dp
;
/* on the VAX, prolog causes array arguments
to point at the (0,...,0) element, except when
if( !checksubs
&& np
->vstg
==STGARG
)
ap
->memoffset
= mkexpr(OPSTAR
, ICON(typesize
[np
->vtype
]),
cpexpr(dp
->baseoffset
) );
register struct primblock
* p
;
struct extsym
*mkext(), *extp
;
register struct nameblock
*np
;
register struct exprblock
*q
;
struct exprblock
*intrcall(), *stfcall();
np
->vclass
= class = CLPROC
;
if(np
->vstg
== STGUNKNOWN
)
if(k
= intrfunct(np
->varname
))
np
->vprocclass
= PINTRINSIC
;
extp
= mkext( varunder(VL
,np
->varname
) );
np
->vardesc
.varno
= extp
- extsymtab
;
np
->vprocclass
= PEXTERNAL
;
else if(np
->vstg
==STGARG
)
if(np
->vtype
!=TYCHAR
&& !ftn66flag
)
warn("Dummy procedure not declared EXTERNAL. Code may be wrong.");
np
->vprocclass
= PEXTERNAL
;
fatal1("invalid class code for function", class);
if(p
->fcharp
|| p
->lcharp
)
err("no substring of function call");
nargs
= fixargs( np
->vprocclass
!=PINTRINSIC
, p
->argsp
);
q
= mkexpr(OPCALL
, ap
, p
->argsp
);
q
->vleng
= cpexpr(np
->vleng
);
q
= intrcall(np
, p
->argsp
, nargs
);
q
= stfcall(np
, p
->argsp
);
for(ep
= entries
; ep
; ep
= ep
->nextp
)
fatal("mkfunct: impossible recursion");
ap
= builtin(np
->vtype
, varstr(XL
, ep
->entryname
->extname
) );
fatal1("mkfunct: impossible vprocclass %d", np
->vprocclass
);
LOCAL
struct exprblock
*stfcall(np
, actlist
)
struct listblock
*actlist
;
struct exprblock
*q
, *rhs
;
register struct rplblock
*rp
;
actuals
= actlist
->listp
;
formals
= np
->vardesc
.vstfdesc
->datap
;
rhs
= np
->vardesc
.vstfdesc
->nextp
;
/* copy actual arguments into temporaries */
while(actuals
!=NULL
&& formals
!=NULL
)
rp
->rplnp
= q
= formals
->datap
;
ap
= fixtype(actuals
->datap
);
if(q
->vtype
==ap
->vtype
&& q
->vtype
!=TYCHAR
&& (ap
->tag
==TCONST
|| ap
->tag
==TADDR
) )
rp
->rplvp
= mktemp(q
->vtype
, q
->vleng
);
rp
->rplxp
= fixtype( mkexpr(OPASSIGN
, cpexpr(rp
->rplvp
), ap
) );
if( (rp
->rpltag
= rp
->rplxp
->tag
) == TERROR
)
err("disagreement of argument types in statement function call");
actuals
= actuals
->nextp
;
formals
= formals
->nextp
;
if(actuals
!=NULL
|| formals
!=NULL
)
err("statement function definition and argument list differ");
now push down names involved in formal argument list, then
evaluate rhs of statement function definition in this environment
rpllist
= hookup(tlist
, rpllist
);
q
= mkconv(type
, fixtype(cpexpr(rhs
)) );
/* now generate the tree ( t1=a1, (t2=a2,... , f))))) */
q
= mkexpr(OPCOMMA
, rpllist
->rplxp
, q
);
struct addrblock
*mklhs(p
)
register struct primblock
* p
;
register struct addrblock
*s
;
register struct rplblock
*rp
;
/* is name on the replace list? */
for(rp
= rpllist
; rp
; rp
= rp
->nextp
)
np
= p
->namep
= rp
->rplvp
;
else return( cpexpr(rp
->rplvp
) );
/* is variable a DO index in a register ? */
if(np
->vdovar
&& ( (regn
= inregister(np
)) >= 0) )
s
->memoffset
= mkexpr(OPPLUS
, s
->memoffset
, suboffset(p
) );
/* now do substring part */
if(p
->fcharp
|| p
->lcharp
)
err1("substring of noncharacter %s", varstr(VL
,np
->varname
));
p
->lcharp
= cpexpr(s
->vleng
);
s
->vleng
= mkexpr(OPMINUS
, p
->lcharp
,
mkexpr(OPMINUS
, p
->fcharp
, ICON(1) ));
s
->vleng
= fixtype( s
->vleng
);
s
->memoffset
= fixtype( s
->memoffset
);
if(nregvar
>0 && regnamep
[nregvar
-1]==np
)
struct addrblock
*memversion(np
)
register struct nameblock
*np
;
register struct addrblock
*s
;
if(np
->vdovar
==NO
|| (inregister(np
)<0) )
s
= mklhs( mkprim(np
, 0,0,0) );
register struct nameblock
*np
;
for(i
= 0 ; i
< nregvar
; ++i
)
if( ONEOF(np
->vtype
, MSKIREG
) )
regnamep
[nregvar
++] = np
;
register struct primblock
*p
;
register struct nameblock
*np
;
for(cp
= p
->argsp
->listp
; cp
; cp
= cp
->nextp
)
sub
[n
++] = fixtype(cpexpr(cp
->datap
));
err("more than 7 subscripts");
err("subscripts on scalar variable");
else if(dimp
&& dimp
->ndim
!=n
)
err1("wrong number of subscripts on %s",
varstr(VL
, np
->varname
) );
prod
= mkexpr(OPPLUS
, sub
[n
],
mkexpr(OPSTAR
, prod
, cpexpr(dimp
->dims
[n
].dimsize
)) );
if(checksubs
|| np
->vstg
!=STGARG
)
prod
= mkexpr(OPMINUS
, prod
, cpexpr(dimp
->baseoffset
));
prod
= mkexpr(OPMINUS
, prod
, cpexpr(dimp
->baseoffset
));
prod
= subcheck(np
, prod
);
size
= cpexpr(np
->vleng
);
else size
= ICON( typesize
[np
->vtype
] );
prod
= mkexpr(OPSTAR
, prod
, size
);
offp
= mkexpr(OPPLUS
, offp
, prod
);
if(p
->fcharp
&& np
->vtype
==TYCHAR
)
offp
= mkexpr(OPPLUS
, offp
, mkexpr(OPMINUS
, cpexpr(p
->fcharp
), ICON(1) ));
expptr t
, checkvar
, checkcond
, badcall
;
return(p
); /* don't check arrays with * bounds */
if(p
->const.ci
< dimp
->nelt
->const.ci
)
if(p
->tag
==TADDR
&& p
->vstg
==STGREG
)
checkvar
= mktemp(p
->vtype
, NULL
);
t
= mkexpr(OPASSIGN
, cpexpr(checkvar
), p
);
checkcond
= mkexpr(OPLT
, t
, cpexpr(dimp
->nelt
) );
checkcond
= mkexpr(OPAND
, checkcond
,
mkexpr(OPLE
, ICON(0), cpexpr(checkvar
)) );
badcall
= call4(p
->vtype
, "s_rnge", mkstrcon(VL
, np
->varname
),
mkconv(TYLONG
, cpexpr(checkvar
)),
mkstrcon(XL
, procname
), ICON(lineno
));
badcall
->opcode
= OPCCALL
;
p
= mkexpr(OPQUEST
, checkcond
,
mkexpr(OPCOLON
, checkvar
, badcall
));
err1("subscript on variable %s out of range", varstr(VL
,np
->varname
));
struct addrblock
*mkaddr(p
)
register struct nameblock
*p
;
struct extsym
*mkext(), *extp
;
register struct addrblock
*t
;
struct addrblock
*intraddr();
extp
= mkext( varunder(VL
, p
->varname
) );
p
->vardesc
.varno
= extp
- extsymtab
;
p
->vprocclass
= PEXTERNAL
;
t
->memno
= p
->vardesc
.varno
;
t
->memoffset
= ICON(p
->voffset
);
t
->vleng
= cpexpr(p
->vleng
);
/*debug*/ fprintf(diagfile
, "mkaddr. vtype=%d, vclass=%d\n", p
->vtype
, p
->vclass
);
fatal1("mkaddr: impossible storage tag %d", p
->vstg
);
register struct addrblock
*p
;
p
->vstg
= (type
==TYLENG
? STGLENG
: STGARG
);
tagptr
mkprim(v
, args
, lstr
, rstr
)
register union { struct paramblock
; struct nameblock
; } *v
;
register struct primblock
*p
;
err1("no qualifiers on parameter name", varstr(VL
,v
->varname
));
return( cpexpr(v
->paramval
) );
register struct nameblock
*v
;
if(v
->vtype
== TYUNKNOWN
)
if(v
->vclass
== CLUNKNOWN
)
else if(v
->vclass
!=CLVAR
&& v
->vprocclass
!=PTHISPROC
)
dclerr("used as variable", v
);
v
->vstg
= implstg
[ letter(v
->varname
[0]) ];
v
->vardesc
.varno
= ++lastvarno
;
if(v
->vclass
==CLPROC
&& v
->vprocclass
==PTHISPROC
)
if( (neltp
= t
->nelt
) && ISCONST(neltp
) )
dclerr("adjustable automatic array", v
);
p
= autovar(nelt
, v
->vtype
, v
->vleng
);
v
->voffset
= p
->memoffset
->const.ci
;
register struct nameblock
*p
;
if(p
->vdcldone
|| (p
->vclass
==CLPROC
&& p
->vprocclass
==PINTRINSIC
) )
if(p
->vtype
== TYUNKNOWN
)
k
= letter(p
->varname
[0]);
dclerr("attempt to use undefined variable", p
);
#define ICONEQ(z, c) (ISICON(z) && z->const.ci==c)
#define COMMUTE { e = lp; lp = rp; rp = e; }
expptr
mkexpr(opcode
, lp
, rp
)
register struct exprblock
*e
, *e1
;
if(rp
&& opcode
!=OPCALL
&& opcode
!=OPCCALL
)
etype
= cktype(opcode
, ltype
, rtype
);
/* check for multiplication by 0 and 1 and addition to 0 */
err("attempted division by zero");
return( mkexpr(OPNEG
, lp
, 0) );
if( ISSTAROP(lp
) && ISICON(lp
->rightp
) )
e
= mkexpr(OPSTAR
, lp
->rightp
, rp
);
else if(ISICON(rp
) && lp
->rightp
->const.ci
% rp
->const.ci
== 0)
e
= mkexpr(OPSLASH
, lp
->rightp
, rp
);
return( mkexpr(OPSTAR
, e1
, e
) );
return( mkexpr(OPNEG
, rp
, 0) );
if( ISPLUSOP(lp
) && ISICON(lp
->rightp
) )
e
= mkexpr(OPPLUS
, lp
->rightp
, rp
);
return( mkexpr(OPPLUS
, e1
, e
) );
if(ltag
==TEXPR
&& lp
->opcode
==OPNEG
)
if(ltag
==TEXPR
&& lp
->opcode
==OPNOT
)
if(rp
!=NULL
&& rp
->listp
==NULL
)
fatal1("mkexpr: impossible opcode %d", opcode
);
if(ltag
==TCONST
&& (rp
==0 || rtag
==TCONST
) )
if(rp
&& opcode
!=OPCALL
&& opcode
!=OPCCALL
)
#define ERR(s) { errs = s; goto error; }
if(lt
==TYERROR
|| rt
==TYERROR
)
if(op
!=OPNOT
&& op
!=OPBITNOT
&& op
!=OPNEG
&& op
!=OPCALL
&& op
!=OPCCALL
&& op
!=OPADDR
)
if( ISNUMERIC(lt
) && ISNUMERIC(rt
) )
return( maxtype(lt
, rt
) );
ERR("nonarithmetic operand of arithmetic operator")
ERR("nonarithmetic operand of negation")
if(lt
==TYLOGICAL
&& rt
==TYLOGICAL
)
ERR("nonlogical operand of logical operator")
if(lt
==TYCHAR
|| rt
==TYCHAR
|| lt
==TYLOGICAL
|| rt
==TYLOGICAL
)
ERR("illegal comparison")
else if( ISCOMPLEX(lt
) || ISCOMPLEX(rt
) )
ERR("order comparison of complex data")
else if( ! ISNUMERIC(lt
) || ! ISNUMERIC(rt
) )
ERR("comparison of nonarithmetic data")
if(lt
==TYCHAR
&& rt
==TYCHAR
)
ERR("concatenation of nonchar data")
if( ISINT(lt
) && rt
==TYCHAR
)
if(lt
==TYCHAR
|| rt
==TYCHAR
|| lt
==TYLOGICAL
|| rt
==TYLOGICAL
)
if(op
!=OPASSIGN
|| lt
!=rt
)
/* debug fprintf(diagfile, " lt=%d, rt=%d, op=%d\n", lt, rt, op); */
/* debug fatal("impossible conversion. possible compiler bug"); */
ERR("impossible conversion")
fatal1("cktype: impossible opcode %d", op
);
register struct exprblock
*e
;
int etype
, mtype
, ltype
, rtype
, opcode
;
union constant lcon
, rcon
;
lp
->const.ci
= ! lp
->const.ci
;
lp
->const.ci
= ~ lp
->const.ci
;
fatal1("fold: invalid unary operator %d", opcode
);
p
->const.ci
= lp
->const.ci
&& rp
->const.ci
;
p
->const.ci
= lp
->const.ci
|| rp
->const.ci
;
p
->const.ci
= lp
->const.ci
== rp
->const.ci
;
p
->const.ci
= lp
->const.ci
!= rp
->const.ci
;
p
->const.ci
= lp
->const.ci
& rp
->const.ci
;
p
->const.ci
= lp
->const.ci
| rp
->const.ci
;
p
->const.ci
= lp
->const.ci
^ rp
->const.ci
;
p
->const.ci
= lp
->const.ci
<< rp
->const.ci
;
p
->const.ci
= lp
->const.ci
>> rp
->const.ci
;
ll
= lp
->vleng
->const.ci
;
lr
= rp
->vleng
->const.ci
;
p
->const.ccp
= q
= (char *) ckalloc(ll
+lr
);
for(i
= 0 ; i
< ll
; ++i
)
conspower(&(p
->const), lp
, rp
->const.ci
);
lcon
.ci
= cmpstr(lp
->const.ccp
, rp
->const.ccp
,
lp
->vleng
->const.ci
, rp
->vleng
->const.ci
);
mtype
= maxtype(ltype
, rtype
);
consconv(mtype
, &lcon
, ltype
, &(lp
->const) );
consconv(mtype
, &rcon
, rtype
, &(rp
->const) );
consbinop(opcode
, mtype
, &(p
->const), &lcon
, &rcon
);
/* assign constant l = r , doing coercion */
register union constant
*lv
, *rv
;
/* fall through and do real assignment of
lv
->cd
[1] = rv
->cd
[1]; break;
else lv
->cd
[0] = rv
->cd
[0];
register struct constblock
*p
;
p
->const.ci
= - p
->const.ci
;
p
->const.cd
[1] = - p
->const.cd
[1];
/* fall through and do the real parts */
p
->const.cd
[0] = - p
->const.cd
[0];
fatal1("consnegop: impossible type %d", p
->vtype
);
LOCAL
conspower(powp
, ap
, n
)
register union constant
*powp
;
switch(type
= ap
->vtype
) /* pow = 1 */
fatal1("conspower: invalid type %d", type
);
err("integer ** negative power ");
consbinop(OPSLASH
, type
, &x
, powp
, &(ap
->const));
consbinop(OPSTAR
, type
, &x
, powp
, &(ap
->const));
consbinop(OPSTAR
, type
, powp
, powp
, &x
);
consbinop(OPSTAR
, type
, &x
, &x
, &x
);
/* do constant operation cp = a op b */
LOCAL
consbinop(opcode
, type
, cp
, ap
, bp
)
register union constant
*ap
, *bp
, *cp
;
cp
->ci
= ap
->ci
+ bp
->ci
;
cp
->cd
[1] = ap
->cd
[1] + bp
->cd
[1];
cp
->cd
[0] = ap
->cd
[0] + bp
->cd
[0];
cp
->ci
= ap
->ci
- bp
->ci
;
cp
->cd
[1] = ap
->cd
[1] - bp
->cd
[1];
cp
->cd
[0] = ap
->cd
[0] - bp
->cd
[0];
cp
->ci
= ap
->ci
* bp
->ci
;
cp
->cd
[0] = ap
->cd
[0] * bp
->cd
[0];
temp
= ap
->cd
[0] * bp
->cd
[0] -
cp
->cd
[1] = ap
->cd
[0] * bp
->cd
[1] +
cp
->ci
= ap
->ci
/ bp
->ci
;
cp
->cd
[0] = ap
->cd
[0] / bp
->cd
[0];
cp
->ci
= ap
->ci
% bp
->ci
;
fatal("inline mod of noninteger");
default: /* relational ops */
else if(ap
->ci
== bp
->ci
)
if(ap
->cd
[0] < bp
->cd
[0])
else if(ap
->cd
[0] == bp
->cd
[0])
if(ap
->cd
[0] == bp
->cd
[0] &&
fatal( "sgn(nonconstant)" );
if(p
->const.ci
> 0) return(1);
if(p
->const.ci
< 0) return(-1);
if(p
->const.cd
[0] > 0) return(1);
if(p
->const.cd
[0] < 0) return(-1);
return(p
->const.cd
[0]!=0 || p
->const.cd
[1]!=0);
fatal1( "conssgn(type %d)", p
->vtype
);
char *powint
[ ] = { "pow_ii", "pow_ri", "pow_di", "pow_ci", "pow_zi" };
register struct exprblock
*p
;
register expptr q
, lp
, rp
;
return( putconst( mkconv(ltype
, ICON(1))) );
err("integer**negative");
rp
->const.ci
= - rp
->const.ci
;
p
->leftp
= lp
= fixexpr(mkexpr(OPSLASH
, ICON(1), lp
));
if( ONEOF(ltype
, MSKINT
|MSKREAL
) )
if(ltype
==TYSHORT
&& rtype
==TYSHORT
)
q
= call2(TYSHORT
, "pow_hh", lp
, rp
);
q
= call2(ltype
, powint
[ltype
-TYLONG
], lp
, mkconv(TYLONG
, rp
));
else if( ISREAL( (mtype
= maxtype(ltype
,rtype
)) ))
q
= call2(mtype
, "pow_dd",
mkconv(TYDREAL
,lp
), mkconv(TYDREAL
,rp
));
q
= call2(TYDCOMPLEX
, "pow_zz",
mkconv(TYDCOMPLEX
,lp
), mkconv(TYDCOMPLEX
,rp
));
q
= mkconv(TYCOMPLEX
, q
);
/* Complex Division. Same code as in Runtime Library
struct dcomplex
{ double dreal
, dimag
; };
register struct dcomplex
*a
, *b
, *c
;
if( (abr
= b
->dreal
) < 0.)
if( (abi
= b
->dimag
) < 0.)
fatal("complex division by zero");
ratio
= b
->dreal
/ b
->dimag
;
den
= b
->dimag
* (1 + ratio
*ratio
);
c
->dreal
= (a
->dreal
*ratio
+ a
->dimag
) / den
;
c
->dimag
= (a
->dimag
*ratio
- a
->dreal
) / den
;
ratio
= b
->dimag
/ b
->dreal
;
den
= b
->dreal
* (1 + ratio
*ratio
);
c
->dreal
= (a
->dreal
+ a
->dimag
*ratio
) / den
;
c
->dimag
= (a
->dimag
- a
->dreal
*ratio
) / den
;