retval(register int t) #endif { register Addrp p; switch(t) { case TYCHAR: case TYCOMPLEX: case TYDCOMPLEX: break; case TYLOGICAL: t = tylogical; case TYINT1: case TYADDR: case TYSHORT: case TYLONG: #ifdef TYQUAD case TYQUAD: #endif case TYREAL: case TYDREAL: case TYLOGICAL1: case TYLOGICAL2: p = (Addrp) cpexpr((expptr)retslot); p->vtype = t; p1_subr_ret (mkconv (t, fixtype((expptr)p))); break; default: badtype("retval", t); } }
/* * Put return values into correct register. */ void putforce(int t, bigptr p) { NODE *p1; p = mkconv(t, fixtype(p)); p1 = putx(p); p1 = mkunode(FORCE, p1, 0, (t==TYSHORT ? SHORT : (t==TYLONG ? LONG : LDOUBLE))); sendp2(p1); }
cast_args(int maxtype, chainp args) #endif { for (; args; args = args -> nextp) { expptr e = (expptr) args->datap; if (e -> headblock.vtype != maxtype) if (e -> tag == TCONST) args->datap = (char *) mkconv(maxtype, e); else { Addrp temp = mktmp(maxtype, ENULL); puteq(cpexpr((expptr)temp), e); args->datap = (char *)temp; } /* else */ } /* for */ } /* cast_args */
Inline(int fno, int type, struct Chain *args) #endif { register expptr q, t, t1; switch(fno) { case 8: /* real abs */ case 9: /* short int abs */ case 10: /* long int abs */ case 11: /* double precision abs */ if( addressable(q = (expptr) args->datap) ) { t = q; q = NULL; } else t = (expptr) mktmp(type,ENULL); t1 = mkexpr(type == TYREAL && forcedouble ? OPDABS : OPABS, cpexpr(t), ENULL); if(q) t1 = mkexpr(OPCOMMA, mkexpr(OPASSIGN, cpexpr(t),q), t1); frexpr(t); return(t1); case 26: /* dprod */ q = mkexpr(OPSTAR, mkconv(TYDREAL,(expptr)args->datap), (expptr)args->nextp->datap); return(q); case 27: /* len of character string */ q = (expptr) cpexpr(((tagptr)args->datap)->headblock.vleng); frexpr((expptr)args->datap); return(q); case 14: /* half-integer mod */ case 15: /* mod */ return mkexpr(OPMOD, (expptr) args->datap, (expptr) args->nextp->datap); } return(NULL); }
make_param(register struct Paramblock *p, expptr e) #endif { register expptr q; struct Constblock qc; p->vclass = CLPARAM; impldcl((Namep)p); if (e->headblock.vtype != TYCHAR) e = putx(fixtype(e)); p->paramval = q = mkconv(p->vtype, e); if (p->vtype == TYCHAR) { if (q->tag == TEXPR) p->paramval = q = fixexpr((Exprp)q); if (q->tag == TADDR && q->addrblock.uname_tag == UNAM_CONST) { qc.Const = q->addrblock.user.Const; qc.tag = TCONST; qc.vtype = q->addrblock.vtype; qc.vleng = q->addrblock.vleng; q = (expptr)&qc; } if (!ISCONST(q) || q->constblock.vtype != TYCHAR) { errstr("invalid value for character parameter %s", p->fvarname); return; } if (!(e = p->vleng)) p->vleng = ICON(q->constblock.vleng->constblock.Const.ci + q->constblock.Const.ccp1.blanks); else if (q->constblock.vleng->constblock.Const.ci > e->constblock.Const.ci) { q->constblock.vleng->constblock.Const.ci = e->constblock.Const.ci; q->constblock.Const.ccp1.blanks = 0; } else q->constblock.Const.ccp1.blanks = e->constblock.Const.ci - q->constblock.vleng->constblock.Const.ci; } }
/* * Convert a f77 tree statement to something that looks like a * pcc expression tree. */ NODE * putx(bigptr q) { struct bigblock *x1; NODE *p = NULL; /* XXX */ int opc; int type, k; #ifdef PCC_DEBUG if (tflag) { printf("putx %p\n", q); fprint(q, 0); } #endif switch(q->tag) { case TERROR: ckfree(q); break; case TCONST: switch(type = q->vtype) { case TYLOGICAL: type = tyint; case TYLONG: case TYSHORT: p = mklnode(ICON, q->b_const.fconst.ci, 0, types2[type]); ckfree(q); break; case TYADDR: p = mklnode(ICON, 0, 0, types2[type]); p->n_name = copys(memname(STGCONST, (int)q->b_const.fconst.ci)); ckfree(q); break; default: p = putx(putconst(q)); break; } break; case TEXPR: switch(opc = q->b_expr.opcode) { case OPCALL: case OPCCALL: if( ISCOMPLEX(q->vtype) ) p = putcxop(q); else { putcall(q); p = callval; } break; case OPMIN: case OPMAX: p = putmnmx(q); break; case OPASSIGN: if (ISCOMPLEX(q->b_expr.leftp->vtype) || ISCOMPLEX(q->b_expr.rightp->vtype)) { frexpr(putcxeq(q)); } else if (ISCHAR(q)) p = putcheq(q); else goto putopp; break; case OPEQ: case OPNE: if (ISCOMPLEX(q->b_expr.leftp->vtype) || ISCOMPLEX(q->b_expr.rightp->vtype) ) { p = putcxcmp(q); break; } case OPLT: case OPLE: case OPGT: case OPGE: if(ISCHAR(q->b_expr.leftp)) p = putchcmp(q); else goto putopp; break; case OPPOWER: p = putpower(q); break; case OPSTAR: /* m * (2**k) -> m<<k */ if (XINT(q->b_expr.leftp->vtype) && ISICON(q->b_expr.rightp) && ((k = flog2(q->b_expr.rightp->b_const.fconst.ci))>0) ) { q->b_expr.opcode = OPLSHIFT; frexpr(q->b_expr.rightp); q->b_expr.rightp = MKICON(k); goto putopp; } case OPMOD: goto putopp; case OPPLUS: case OPMINUS: case OPSLASH: case OPNEG: if( ISCOMPLEX(q->vtype) ) p = putcxop(q); else goto putopp; break; case OPCONV: if( ISCOMPLEX(q->vtype) ) p = putcxop(q); else if (ISCOMPLEX(q->b_expr.leftp->vtype)) { p = putx(mkconv(q->vtype, realpart(putcx1(q->b_expr.leftp)))); ckfree(q); } else goto putopp; break; case OPAND: /* Create logical AND */ x1 = fmktemp(TYLOGICAL, NULL); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(0))); k = newlabel(); putif(q->b_expr.leftp, k); putif(q->b_expr.rightp, k); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(1))); putlabel(k); p = putx(x1); break; case OPNOT: /* Logical NOT */ x1 = fmktemp(TYLOGICAL, NULL); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(1))); k = newlabel(); putif(q->b_expr.leftp, k); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(0))); putlabel(k); p = putx(x1); break; case OPOR: /* Create logical OR */ x1 = fmktemp(TYLOGICAL, NULL); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(1))); k = newlabel(); putif(mkexpr(OPEQ, q->b_expr.leftp, mklogcon(0)), k); putif(mkexpr(OPEQ, q->b_expr.rightp, mklogcon(0)), k); putexpr(mkexpr(OPASSIGN, cpexpr(x1), mklogcon(0))); putlabel(k); p = putx(x1); break; case OPCOMMA: for (x1 = q; x1->b_expr.opcode == OPCOMMA; x1 = x1->b_expr.leftp) putexpr(x1->b_expr.rightp); p = putx(x1); break; case OPEQV: case OPNEQV: case OPADDR: case OPBITOR: case OPBITAND: case OPBITXOR: case OPBITNOT: case OPLSHIFT: case OPRSHIFT: putopp: p = putop(q); break; default: fatal1("putx: invalid opcode %d", opc); } break; case TADDR: p = putaddr(q, YES); break; default: fatal1("putx: impossible tag %d", q->tag); } return p; }
static NODE * putaddr(bigptr q, int indir) { int type, type2, funct; NODE *p, *p1, *p2; ftnint offset; bigptr offp; p = p1 = p2 = NULL; /* XXX */ type = q->vtype; type2 = types2[type]; funct = (q->vclass==CLPROC ? FTN<<TSHIFT : 0); offp = (q->b_addr.memoffset ? cpexpr(q->b_addr.memoffset) : NULL); offset = simoffset(&offp); if(offp) offp = mkconv(TYINT, offp); switch(q->vstg) { case STGAUTO: if(indir && !offp) { p = oregtree(offset, AUTOREG, type2); break; } if(!indir && !offp && !offset) { p = mklnode(REG, 0, AUTOREG, INCREF(type2)); break; } p = mklnode(REG, 0, AUTOREG, INCREF(type2)); if(offp) { p1 = putx(offp); if(offset) p2 = mklnode(ICON, offset, 0, INT); } else p1 = mklnode(ICON, offset, 0, INT); if (offp && offset) p1 = mkbinode(PLUS, p1, p2, INCREF(type2)); p = mkbinode(PLUS, p, p1, INCREF(type2)); if (indir) p = mkunode(UMUL, p, 0, type2); break; case STGARG: p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno), ARGREG, INCREF(type2)|funct); if (offp) p1 = putx(offp); if (offset) p2 = mklnode(ICON, offset, 0, INT); if (offp && offset) p1 = mkbinode(PLUS, p1, p2, INCREF(type2)); else if (offset) p1 = p2; if (offp || offset) p = mkbinode(PLUS, p, p1, INCREF(type2)); if (indir) p = mkunode(UMUL, p, 0, type2); break; case STGLENG: if(indir) { p = oregtree(ARGOFFSET + (ftnint)(q->b_addr.memno), ARGREG, INCREF(type2)|funct); } else { fatal1("faddrnode: STGLENG: fixme!"); #if 0 p2op(P2PLUS, types2[TYLENG] | P2PTR ); p2reg(ARGREG, types2[TYLENG] | P2PTR ); p2icon( ARGOFFSET + (ftnint) (FUDGEOFFSET*p->b_addr.memno), P2INT); #endif } break; case STGBSS: case STGINIT: case STGEXT: case STGCOMMON: case STGEQUIV: case STGCONST: if(offp) { p1 = putx(offp); p2 = putmem(q, ICON, offset); p = mkbinode(PLUS, p1, p2, INCREF(type2)); if(indir) p = mkunode(UMUL, p, 0, type2); } else p = putmem(q, (indir ? NAME : ICON), offset); break; case STGREG: if(indir) p = mklnode(REG, 0, q->b_addr.memno, type2); else fatal("attempt to take address of a register"); break; default: fatal1("putaddr: invalid vstg %d", q->vstg); } frexpr(q); return p; }
intrcall(Namep np, struct Listblock *argsp, int nargs) #endif { int i, rettype; Addrp ap; register struct Specblock *sp; register struct Chain *cp; expptr q, ep; int mtype; int op; int f1field, f2field, f3field; packed.ijunk = np->vardesc.varno; f1field = packed.bits.f1; f2field = packed.bits.f2; f3field = packed.bits.f3; if(nargs == 0) goto badnargs; mtype = 0; for(cp = argsp->listp ; cp ; cp = cp->nextp) { ep = (expptr)cp->datap; if( ISCONST(ep) && ep->headblock.vtype==TYSHORT ) cp->datap = (char *) mkconv(tyint, ep); mtype = maxtype(mtype, ep->headblock.vtype); } switch(f1field) { case INTRBOOL: op = f3field; if( ! ONEOF(mtype, MSKINT|MSKLOGICAL) ) goto badtype; if(op == OPBITNOT) { if(nargs != 1) goto badnargs; q = mkexpr(OPBITNOT, (expptr)argsp->listp->datap, ENULL); } else { if(nargs != 2) goto badnargs; q = mkexpr(op, (expptr)argsp->listp->datap, (expptr)argsp->listp->nextp->datap); } frchain( &(argsp->listp) ); free( (charptr) argsp); return(q); case INTRCONV: rettype = f2field; switch(rettype) { case TYLONG: rettype = tyint; break; case TYLOGICAL: rettype = tylog; } if( ISCOMPLEX(rettype) && nargs==2) { expptr qr, qi; qr = (expptr) argsp->listp->datap; qi = (expptr) argsp->listp->nextp->datap; if(ISCONST(qr) && ISCONST(qi)) q = mkcxcon(qr,qi); else q = mkexpr(OPCONV,mkconv(rettype-2,qr), mkconv(rettype-2,qi)); } else if(nargs == 1) { if (f3field && ((Exprp)argsp->listp->datap)->vtype == TYDCOMPLEX) rettype = TYDREAL; q = mkconv(rettype+100, (expptr)argsp->listp->datap); if (q->tag == TADDR) q->addrblock.parenused = 1; } else goto badnargs; q->headblock.vtype = rettype; frchain(&(argsp->listp)); free( (charptr) argsp); return(q); #if 0 case INTRCNST: /* Machine-dependent f77 stuff that f2c omits: intcon contains radix for short int radix for long int radix for single precision radix for double precision precision for short int precision for long int precision for single precision precision for double precision emin for single precision emin for double precision emax for single precision emax for double prcision largest short int largest long int realcon contains tiny for single precision tiny for double precision huge for single precision huge for double precision mrsp (epsilon) for single precision mrsp (epsilon) for double precision */ { register struct Incstblock *cstp; extern ftnint intcon[14]; extern double realcon[6]; cstp = consttab + f3field; for(i=0 ; i<f2field ; ++i) if(cstp->atype == mtype) goto foundconst; else ++cstp; goto badtype; foundconst: switch(cstp->rtype) { case TYLONG: return(mkintcon(intcon[cstp->constno])); case TYREAL: case TYDREAL: return(mkrealcon(cstp->rtype, realcon[cstp->constno]) ); default: Fatal("impossible intrinsic constant"); } } #endif case INTRGEN: sp = spectab + f3field; if(no66flag) if(sp->atype == mtype) goto specfunct; else err66("generic function"); for(i=0; i<f2field ; ++i) if(sp->atype == mtype) goto specfunct; else ++sp; warn1 ("bad argument type to intrinsic %s", np->fvarname); /* Made this a warning rather than an error so things like "log (5) ==> log (5.0)" can be accommodated. When none of these cases matches, the argument is cast up to the first type in the spectab list; this first type is assumed to be the "smallest" type, e.g. REAL before DREAL before COMPLEX, before DCOMPLEX */ sp = spectab + f3field; mtype = sp -> atype; goto specfunct; case INTRSPEC: sp = spectab + f3field; specfunct: if(tyint==TYLONG && ONEOF(sp->rtype,M(TYSHORT)|M(TYLOGICAL)) && (sp+1)->atype==sp->atype) ++sp; if(nargs != sp->nargs) goto badnargs; if(mtype != sp->atype) goto badtype; /* NOTE!! I moved fixargs (YES) into the ELSE branch so that constants in the inline expression wouldn't get put into the constant table */ fixargs (NO, argsp); cast_args (mtype, argsp -> listp); if(q = Inline((int)(sp-spectab), mtype, argsp->listp)) { frchain( &(argsp->listp) ); free( (charptr) argsp); } else { if(sp->othername) { /* C library routines that return double... */ /* sp->rtype might be TYREAL */ ap = builtin(sp->rtype, callbyvalue[sp->othername], 1); q = fixexpr((Exprp) mkexpr(OPCCALL, (expptr)ap, (expptr)argsp) ); } else { fixargs(YES, argsp); ap = builtin(sp->rtype, sp->spxname, 0); q = fixexpr((Exprp) mkexpr(OPCALL, (expptr)ap, (expptr)argsp) ); } /* else */ } /* else */ return(q); case INTRMIN: case INTRMAX: if(nargs < 2) goto badnargs; if( ! ONEOF(mtype, MSKINT|MSKREAL) ) goto badtype; argsp->vtype = mtype; q = mkexpr( (f1field==INTRMIN ? OPMIN : OPMAX), (expptr)argsp, ENULL); q->headblock.vtype = mtype; rettype = f2field; if(rettype == TYLONG) rettype = tyint; else if(rettype == TYUNKNOWN) rettype = mtype; return( mkconv(rettype, q) ); default: fatali("intrcall: bad intrgroup %d", f1field); } badnargs: errstr("bad number of arguments to intrinsic %s", np->fvarname); goto bad; badtype: errstr("bad argument type to intrinsic %s", np->fvarname); bad: return( errnode() ); }
prolog(FILE *outfile, register chainp p) #endif { int addif, addif0, i, nd; ftnint size; int *ac; register Namep q; register struct Dimblock *dp; chainp p0, p1; if(procclass == CLBLOCK) return; p0 = p; p1 = p = argsort(p); wrote_comment = 0; comment_file = outfile; ac = 0; /* Compute the base addresses and offsets for the array parameters, and assign these values to local variables */ addif = addif0 = nentry > 1; for(; p ; p = p->nextp) { q = (Namep) p->datap; if(dp = q->vdim) /* if this param is an array ... */ { expptr Q, expr; /* See whether to protect the following with an if. */ /* This only happens when there are multiple entries. */ nd = dp->ndim - 1; if (addif0) { if (!ac) ac = count_args(); if (ac[q->argno] == nentry) addif = 0; else if (dp->basexpr || dp->baseoffset->constblock.Const.ci) addif = 1; else for(addif = i = 0; i <= nd; i++) if (dp->dims[i].dimexpr && (i < nd || !q->vlastdim)) { addif = 1; break; } if (addif) { write_comment(); nice_printf(outfile, "if (%s) {\n", /*}*/ q->cvarname); next_tab(outfile); } } for(i = 0 ; i <= nd; ++i) /* Store the variable length of each dimension (which is fixed upon runtime procedure entry) into a local variable */ if ((Q = dp->dims[i].dimexpr) && (i < nd || !q->vlastdim)) { expr = (expptr)cpexpr(Q); write_comment(); out_and_free_statement (outfile, mkexpr (OPASSIGN, fixtype(cpexpr(dp->dims[i].dimsize)), expr)); } /* if dp -> dims[i].dimexpr */ /* size will equal the size of a single element, or -1 if the type is variable length character type */ size = typesize[ q->vtype ]; if(q->vtype == TYCHAR) if( ISICON(q->vleng) ) size *= q->vleng->constblock.Const.ci; else size = -1; /* Fudge the argument pointers for arrays so subscripts * are 0-based. Not done if array bounds are being checked. */ if(dp->basexpr) { /* Compute the base offset for this procedure */ write_comment(); out_and_free_statement (outfile, mkexpr (OPASSIGN, cpexpr(fixtype(dp->baseoffset)), cpexpr(fixtype(dp->basexpr)))); } /* if dp -> basexpr */ if(! checksubs) { if(dp->basexpr) { expptr tp; /* If the base of this array has a variable adjustment ... */ tp = (expptr) cpexpr (dp -> baseoffset); if(size < 0 || q -> vtype == TYCHAR) tp = mkexpr (OPSTAR, tp, cpexpr (q -> vleng)); write_comment(); tp = mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv(TYINT, fixtype (fixtype (tp)))); /* Avoid type clash by removing the type conversion */ tp = prune_left_conv (tp); out_and_free_statement (outfile, tp); } else if(dp->baseoffset->constblock.Const.ci != 0) { /* if the base of this array has a nonzero constant adjustment ... */ expptr tp; write_comment(); if(size > 0 && q -> vtype != TYCHAR) { tp = prune_left_conv (mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv (TYINT, fixtype (cpexpr (dp->baseoffset))))); out_and_free_statement (outfile, tp); } else { tp = prune_left_conv (mkexpr (OPMINUSEQ, mkconv (TYADDR, (expptr)p->datap), mkconv (TYINT, fixtype (mkexpr (OPSTAR, cpexpr (dp -> baseoffset), cpexpr (q -> vleng)))))); out_and_free_statement (outfile, tp); } /* else */ } /* if dp -> baseoffset -> const */ } /* if !checksubs */ if (addif) { nice_printf(outfile, /*{*/ "}\n"); prev_tab(outfile); } } } if (wrote_comment) nice_printf (outfile, "\n/* Function Body */\n"); if (ac) free((char *)ac); if (p0 != p1) frchain(&p1); } /* prolog */
setbound(Namep v, int nd, struct Dims *dims) #endif { expptr q, q0, t; struct Dimblock *p; int i; extern chainp new_vars; char buf[256]; if(v->vclass == CLUNKNOWN) v->vclass = CLVAR; else if(v->vclass != CLVAR) { dclerr("only variables may be arrays", v); return; } v->vdim = p = (struct Dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) ); p->ndim = nd--; p->nelt = ICON(1); doin_setbound = 1; if (noextflag) for(i = 0; i <= nd; i++) if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)) || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) { sprintf(buf, "dimension %d of %s is not an integer.", i+1, v->fvarname); errext(buf); break; } for(i = 0; i <= nd; i++) { if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))) dims[i].lb = mkconv(TYINT, q); if (((q = dims[i].ub) && !ISINT(q->headblock.vtype))) dims[i].ub = mkconv(TYINT, q); } for(i = 0; i <= nd; ++i) { if( (q = dims[i].ub) == NULL) { if(i == nd) { frexpr(p->nelt); p->nelt = NULL; } else err("only last bound may be asterisk"); p->dims[i].dimsize = ICON(1); p->dims[i].dimexpr = NULL; } else { if(dims[i].lb) { q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb)); q = mkexpr(OPPLUS, q, ICON(1) ); } if( ISCONST(q) ) { p->dims[i].dimsize = q; p->dims[i].dimexpr = (expptr) PNULL; } else { sprintf(buf, " %s_dim%d", v->fvarname, i+1); p->dims[i].dimsize = (expptr) autovar(1, tyint, EXNULL, buf); p->dims[i].dimexpr = q; if (i == nd) v->vlastdim = new_vars; v->vdimfinish = 1; } if(p->nelt) p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize) ); } } q = dims[nd].lb; q0 = 0; if(q == NULL) q = q0 = ICON(1); for(i = nd-1 ; i>=0 ; --i) { t = dims[i].lb; if(t == NULL) t = ICON(1); if(p->dims[i].dimsize) { if (q == q0) { q0 = 0; frexpr(q); q = cpexpr(p->dims[i].dimsize); } else q = mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q); q = mkexpr(OPPLUS, t, q); } } if( ISCONST(q) ) { p->baseoffset = q; p->basexpr = NULL; } else { sprintf(buf, " %s_offset", v->fvarname); p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf); p->basexpr = q; v->vdimfinish = 1; } doin_setbound = 0; }