newentry(register Namep v, int substmsg) #endif { register Extsym *p; char buf[128], badname[64]; static int nbad = 0; static char already[] = "external name already used"; p = mkext(v->fvarname, addunder(v->cvarname)); if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) ) { sprintf(badname, "%s_bad%d", v->fvarname, ++nbad); if (substmsg) { sprintf(buf,"%s\n\tsubstituting \"%s\"", already, badname); dclerr(buf, v); } else dclerr(already, v); p = mkext(v->fvarname, badname); } v->vstg = STGAUTO; v->vprocclass = PTHISPROC; v->vclass = CLPROC; if (p->extstg == STGEXT) prev_proc = 1; else p->extstg = STGEXT; p->extinit = YES; v->vardesc.varno = p - extsymtab; return(p); }
namelist(Namep np) #endif { register chainp q; register Namep v; int y; if (!np->visused) return; y = 0; for(q = np->varxptr.namelist ; q ; q = q->nextp) { vardcl( v = (Namep) (q->datap) ); if( !ONEOF(v->vstg, MSKSTATIC) ) dclerr("may not appear in namelist", v); else { v->vnamelist = 1; v->visused = 1; v->vsave = 1; y = 1; } np->visused = y; } }
oneof_stg(Namep name, int stg, int mask) #endif { if (stg == STGCOMMON && name) { if ((mask & M(STGEQUIV))) return name->vcommequiv; if ((mask & M(STGCOMMON))) return !name->vcommequiv; } return ONEOF(stg, mask); }
dim_check(Namep q) #endif { register struct Dimblock *vdim = q->vdim; register expptr nelt; if(!(nelt = vdim->nelt) || !ISCONST(nelt)) dclerr("adjustable dimension on non-argument", q); else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL)) bad_dimtype(q); else if (ISINT(nelt->headblock.vtype) ? nelt->constblock.Const.ci <= 0 : nelt->constblock.Const.cd[0] <= 0.) dclerr("nonpositive dimension", q); }
mktmpn(int nelt, register int type, expptr lengp) #endif { ftnint leng; chainp p, oldp; register Addrp q; extern int krparens; if(type==TYUNKNOWN || type==TYERROR) badtype("mktmpn", type); if(type==TYCHAR) if(lengp && ISICON(lengp) ) leng = lengp->constblock.Const.ci; else { err("adjustable length"); return( (Addrp) errnode() ); } else if (type > TYCHAR || type < TYADDR) { erri("mktmpn: unexpected type %d", type); exit(1); } /* * if a temporary of appropriate shape is on the templist, * remove it from the list and return it */ if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX))) type++; for(oldp=CHNULL, p=templist[type]; p ; oldp=p, p=p->nextp) { q = (Addrp) (p->datap); if(q->ntempelt==nelt && (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) ) { if(oldp) oldp->nextp = p->nextp; else templist[type] = p->nextp; free( (charptr) p); return(q); } } q = autovar(nelt, type, lengp, ""); return(q); }
isstatic(register expptr p) #endif { extern int useauto; if(p->headblock.vleng && !ISCONST(p->headblock.vleng)) return(NO); switch(p->tag) { case TCONST: return(YES); case TADDR: if(ONEOF(p->addrblock.vstg,MSKSTATIC) && ISCONST(p->addrblock.memoffset) && !useauto) return(YES); default: return(NO); } }
dim_finish(Namep v) #endif { register struct Dimblock *p; register expptr q; register int i, nd; p = v->vdim; v->vdimfinish = 0; nd = p->ndim; doin_setbound = 1; for(i = 0; i < nd; i++) if (q = p->dims[i].dimexpr) { q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q))); if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL)) bad_dimtype(v); } if (q = p->basexpr) p->basexpr = make_int_expr(putx(fixtype(q))); doin_setbound = 0; }
LOCAL NODE * putop(bigptr q) { NODE *p; int k; bigptr lp, tp; int pt, lt; #ifdef PCC_DEBUG if (tflag) { printf("putop %p\n", q); fprint(q, 0); } #endif switch(q->b_expr.opcode) { /* check for special cases and rewrite */ case OPCONV: pt = q->vtype; lp = q->b_expr.leftp; lt = lp->vtype; while(q->tag==TEXPR && q->b_expr.opcode==OPCONV && ((ISREAL(pt)&&ISREAL(lt)) || (XINT(pt)&&(ONEOF(lt,MSKINT|MSKADDR))) )) { if(lp->tag != TEXPR) { if(pt==TYINT && lt==TYLONG) break; if(lt==TYINT && pt==TYLONG) break; } ckfree(q); q = lp; pt = lt; lp = q->b_expr.leftp; lt = lp->vtype; } if(q->tag==TEXPR && q->b_expr.opcode==OPCONV) break; p = putx(q); return p; case OPADDR: lp = q->b_expr.leftp; if(lp->tag != TADDR) { tp = fmktemp(lp->vtype, lp->vleng); p = putx(mkexpr(OPASSIGN, cpexpr(tp), lp)); sendp2(p); lp = tp; } p = putaddr(lp, NO); ckfree(q); return p; } if ((k = ops2[q->b_expr.opcode]) <= 0) fatal1("putop: invalid opcode %d (%d)", q->b_expr.opcode, k); p = putx(q->b_expr.leftp); if(q->b_expr.rightp) p = mkbinode(k, p, putx(q->b_expr.rightp), types2[q->vtype]); else p = mkunode(k, p, 0, types2[q->vtype]); if(q->vleng) frexpr(q->vleng); ckfree(q); return p; }
p1_addr(register struct Addrblock *addrp) #endif { int stg; if (addrp == (struct Addrblock *) NULL) return; stg = addrp -> vstg; if (ONEOF(stg, M(STGINIT)|M(STGREG)) || ONEOF(stg, M(STGCOMMON)|M(STGEQUIV)) && (!ISICON(addrp->memoffset) || (addrp->uname_tag == UNAM_NAME ? addrp->memoffset->constblock.Const.ci != addrp->user.name->voffset : addrp->memoffset->constblock.Const.ci)) || ONEOF(stg, M(STGBSS)|M(STGINIT)|M(STGAUTO)|M(STGARG)) && (!ISICON(addrp->memoffset) || addrp->memoffset->constblock.Const.ci) || addrp->Field || addrp->isarray || addrp->vstg == STGLENG) { p1_big_addr (addrp); return; } /* Write out a level of indirection for non-array arguments, which have addrp -> memoffset set and are handled by p1_big_addr(). Lengths are passed by value, so don't check STGLENG 28-Jun-89 (dmg) Added the check for != TYCHAR */ if (oneof_stg ( addrp -> uname_tag == UNAM_NAME ? addrp -> user.name : NULL, stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) { p1putdd (P1_EXPR, OPWHATSIN, addrp -> vtype); p1_expr (ENULL); /* Put dummy vleng */ } /* if stg == STGARG */ switch (addrp -> uname_tag) { case UNAM_NAME: p1_name (addrp -> user.name); break; case UNAM_IDENT: p1putdds(P1_IDENT, addrp->vtype, addrp->vstg, addrp->user.ident); break; case UNAM_CHARP: p1putdds(P1_CHARP, addrp->vtype, addrp->vstg, addrp->user.Charp); break; case UNAM_EXTERN: p1putd (P1_EXTERN, (long) addrp -> memno); if (addrp->vclass == CLPROC) extsymtab[addrp->memno].extype = addrp->vtype; break; case UNAM_CONST: if (addrp -> memno != BAD_MEMNO) p1_literal (addrp -> memno); else p1_const((struct Constblock *)addrp); break; case UNAM_UNKNOWN: default: erri ("p1_addr: unknown uname_tag '%d'", addrp -> uname_tag); break; } /* switch */ } /* p1_addr */
wr_globals(FILE *outfile) #endif { struct Literal *litp, *lastlit; extern int hsize; char *litname; int did_one, t; struct Constblock cb; ftnint x, y; if (nliterals == 0) return; lastlit = litpool + nliterals; did_one = 0; for (litp = litpool; litp < lastlit; litp++) { if (!litp->lituse) continue; litname = lit_name(litp); if (!did_one) { margin_printf(outfile, "/* Table of constant values */\n\n"); did_one = 1; } cb.vtype = litp->littype; if (litp->littype == TYCHAR) { x = litp->litval.litival2[0] + litp->litval.litival2[1]; if (y = x % hsize) x += y = hsize - y; nice_printf(outfile, "static struct { %s fill; char val[%ld+1];", halign, x); nice_printf(outfile, " char fill2[%ld];", hsize - 1); nice_printf(outfile, " } %s_st = { 0,", litname); cb.vleng = ICON(litp->litval.litival2[0]); cb.Const.ccp = litp->cds[0]; cb.Const.ccp1.blanks = litp->litval.litival2[1] + y; cb.vtype = TYCHAR; out_const(outfile, &cb); frexpr(cb.vleng); nice_printf(outfile, " };\n"); nice_printf(outfile, "#define %s %s_st.val\n", litname, litname); continue; } nice_printf(outfile, "static %s %s = ", c_type_decl(litp->littype,0), litname); t = litp->littype; if (ONEOF(t, MSKREAL|MSKCOMPLEX)) { cb.vstg = 1; cb.Const.cds[0] = litp->cds[0]; cb.Const.cds[1] = litp->cds[1]; } else { memcpy((char *)&cb.Const, (char *)&litp->litval, sizeof(cb.Const)); cb.vstg = 0; } out_const(outfile, &cb); nice_printf (outfile, ";\n"); } /* for */ if (did_one) nice_printf (outfile, "\n"); } /* wr_globals */
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() ); }
settype(register Namep v, register int type, register ftnint length) #endif { int type1; if(type == TYUNKNOWN) return; if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG) { v->vtype = TYSUBR; frexpr(v->vleng); v->vleng = 0; v->vimpltype = 0; } else if(type < 0) /* storage class set */ { if(v->vstg == STGUNKNOWN) v->vstg = - type; else if(v->vstg != -type) dclerr("incompatible storage declarations", v); } else if(v->vtype == TYUNKNOWN || v->vtype != type && (v->vimpltype || v->vinftype || v->vinfproc)) { if( (v->vtype = lengtype(type, length))==TYCHAR ) if (length>=0) v->vleng = ICON(length); else if (parstate >= INDATA) v->vleng = ICON(1); /* avoid a memory fault */ v->vimpltype = 0; v->vinftype = 0; /* 19960709 */ v->vinfproc = 0; /* 19960709 */ if (v->vclass == CLPROC) { if (v->vstg == STGEXT && (type1 = extsymtab[v->vardesc.varno].extype) && type1 != v->vtype) changedtype(v); else if (v->vprocclass == PTHISPROC && (parstate >= INDATA || procclass == CLMAIN) && !xretslot[type]) { xretslot[type] = autovar(ONEOF(type, MSKCOMPLEX|MSKCHAR) ? 0 : 1, type, v->vleng, " ret_val"); if (procclass == CLMAIN) errstr( "illegal use of %.60s (main program name)", v->fvarname); /* not completely right, but enough to */ /* avoid memory faults; we won't */ /* emit any C as we have illegal Fortran */ } } } else if(v->vtype != type && v->vtype != lengtype(type, length)) { incompat: dclerr("incompatible type declarations", v); } else if (type==TYCHAR) if (v->vleng && v->vleng->constblock.Const.ci != length) goto incompat; else if (parstate >= INDATA) v->vleng = ICON(1); /* avoid a memory fault */ }
bool is_list(cell_t const *c) { return c && is_value(c) && !is_var(c) && ONEOF(c->value.type, T_LIST, T_RETURN); }