LOCAL struct bigblock * putcx1(bigptr qq) { struct bigblock *q, *lp, *rp; register struct bigblock *resp; NODE *p; int opcode; int ltype, rtype; ltype = rtype = 0; /* XXX gcc */ if(qq == NULL) return(NULL); switch(qq->tag) { case TCONST: if( ISCOMPLEX(qq->vtype) ) qq = putconst(qq); return( qq ); case TADDR: if( ! addressable(qq) ) { resp = fmktemp(tyint, NULL); p = putassign( cpexpr(resp), qq->b_addr.memoffset ); sendp2(p); qq->b_addr.memoffset = resp; } return( qq ); case TEXPR: if( ISCOMPLEX(qq->vtype) ) break; resp = fmktemp(TYDREAL, NO); p = putassign( cpexpr(resp), qq); sendp2(p); return(resp); default: fatal1("putcx1: bad tag %d", qq->tag); } opcode = qq->b_expr.opcode; if(opcode==OPCALL || opcode==OPCCALL) { q = putcall(qq); sendp2(callval); return(q); } else if(opcode == OPASSIGN) { return( putcxeq(qq) ); } resp = fmktemp(qq->vtype, NULL); if((lp = putcx1(qq->b_expr.leftp) )) ltype = lp->vtype; if((rp = putcx1(qq->b_expr.rightp) )) rtype = rp->vtype; switch(opcode) { case OPCOMMA: frexpr(resp); resp = rp; rp = NULL; break; case OPNEG: p = putassign(realpart(resp), mkexpr(OPNEG, realpart(lp), NULL)); sendp2(p); p = putassign(imagpart(resp), mkexpr(OPNEG, imagpart(lp), NULL)); sendp2(p); break; case OPPLUS: case OPMINUS: p = putassign( realpart(resp), mkexpr(opcode, realpart(lp), realpart(rp) )); sendp2(p); if(rtype < TYCOMPLEX) { p = putassign(imagpart(resp), imagpart(lp) ); } else if(ltype < TYCOMPLEX) { if(opcode == OPPLUS) p = putassign( imagpart(resp), imagpart(rp) ); else p = putassign( imagpart(resp), mkexpr(OPNEG, imagpart(rp), NULL) ); } else p = putassign( imagpart(resp), mkexpr(opcode, imagpart(lp), imagpart(rp) )); sendp2(p); break; case OPSTAR: if(ltype < TYCOMPLEX) { if( ISINT(ltype) ) lp = intdouble(lp); p = putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(lp), realpart(rp) )); sendp2(p); p = putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(lp), imagpart(rp) )); } else if(rtype < TYCOMPLEX) { if( ISINT(rtype) ) rp = intdouble(rp); p = putassign( realpart(resp), mkexpr(OPSTAR, cpexpr(rp), realpart(lp) )); sendp2(p); p = putassign( imagpart(resp), mkexpr(OPSTAR, cpexpr(rp), imagpart(lp) )); } else { p = putassign( realpart(resp), mkexpr(OPMINUS, mkexpr(OPSTAR, realpart(lp), realpart(rp)), mkexpr(OPSTAR, imagpart(lp), imagpart(rp)) )); sendp2(p); p = putassign( imagpart(resp), mkexpr(OPPLUS, mkexpr(OPSTAR, realpart(lp), imagpart(rp)), mkexpr(OPSTAR, imagpart(lp), realpart(rp)) )); } sendp2(p); break; case OPSLASH: /* fixexpr has already replaced all divisions * by a complex by a function call */ if( ISINT(rtype) ) rp = intdouble(rp); p = putassign( realpart(resp), mkexpr(OPSLASH, realpart(lp), cpexpr(rp)) ); sendp2(p); p = putassign( imagpart(resp), mkexpr(OPSLASH, imagpart(lp), cpexpr(rp)) ); sendp2(p); break; case OPCONV: p = putassign( realpart(resp), realpart(lp) ); if( ISCOMPLEX(lp->vtype) ) q = imagpart(lp); else if(rp != NULL) q = realpart(rp); else q = mkrealcon(TYDREAL, 0.0); sendp2(p); p = putassign( imagpart(resp), q); sendp2(p); break; default: fatal1("putcx1 of invalid opcode %d", opcode); } frexpr(lp); frexpr(rp); ckfree(qq); return(resp); }
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 */
/* * 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; }
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; }
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; }
void procinit(Void) { register struct Labelblock *lp; struct Chain *cp; int i; struct memblock; extern struct memblock *curmemblock, *firstmemblock; extern char *mem_first, *mem_next, *mem_last, *mem0_last; curmemblock = firstmemblock; mem_next = mem_first; mem_last = mem0_last; ei_next = ei_first = ei_last = 0; wh_next = wh_first = wh_last = 0; iob_list = 0; for(i = 0; i < 9; i++) io_structs[i] = 0; parstate = OUTSIDE; headerdone = NO; blklevel = 1; saveall = NO; substars = NO; nwarn = 0; thislabel = NULL; needkwd = 0; proctype = TYUNKNOWN; procname = "MAIN_"; procclass = CLUNKNOWN; nentry = 0; nallargs = nallchargs = 0; multitype = NO; retslot = NULL; for(i = 0; i < NTYPES0; i++) { frexpr((expptr)xretslot[i]); xretslot[i] = 0; } cxslot = -1; chslot = -1; chlgslot = -1; procleng = 0; blklevel = 1; lastargslot = 0; for(lp = labeltab ; lp < labtabend ; ++lp) lp->stateno = 0; hashclear(); /* Clear the list of newly generated identifiers from the previous function */ frexchain(&new_vars); frexchain(&used_builtins); frchain(&assigned_fmts); frchain(&allargs); frchain(&earlylabs); nintnames = 0; highlabtab = labeltab; ctlstack = ctls - 1; for(i = TYADDR; i < TYVOID; i++) { for(cp = templist[i]; cp ; cp = cp->nextp) free( (charptr) (cp->datap) ); frchain(templist + i); autonum[i] = 0; } holdtemps = NULL; dorange = 0; nregvar = 0; highregvar = 0; entries = NULL; rpllist = NULL; inioctl = NO; eqvstart += nequiv; nequiv = 0; dcomplex_seen = 0; for(i = 0 ; i<NTYPES0 ; ++i) rtvlabel[i] = 0; if(undeftype) setimpl(TYUNKNOWN, (ftnint) 0, 'a', 'z'); else { setimpl(tyreal, (ftnint) 0, 'a', 'z'); setimpl(tyint, (ftnint) 0, 'i', 'n'); } setimpl(-STGBSS, (ftnint) 0, 'a', 'z'); /* set class */ }
putconst(register Constp p) #endif { register Addrp q; struct Literal *litp, *lastlit; int k, len, type; int litflavor; double cd[2]; ftnint nblanks; char *strp; char cdsbuf0[64], cdsbuf1[64], *ds[2]; if (p->tag != TCONST) badtag("putconst", p->tag); q = ALLOC(Addrblock); q->tag = TADDR; type = p->vtype; q->vtype = ( type==TYADDR ? tyint : type ); q->vleng = (expptr) cpexpr(p->vleng); q->vstg = STGCONST; /* Create the new label for the constant. This is wasteful of labels because when the constant value already exists in the literal pool, this label gets thrown away and is never reclaimed. It might be cleaner to move this down past the first switch() statement below */ q->memno = newlabel(); q->memoffset = ICON(0); q -> uname_tag = UNAM_CONST; /* Copy the constant info into the Addrblock; do this by copying the largest storage elts */ q -> user.Const = p -> Const; q->user.kludge.vstg1 = p->vstg; /* distinguish string from binary fp */ /* check for value in literal pool, and update pool if necessary */ k = 1; switch(type) { case TYCHAR: if (halign) { strp = p->Const.ccp; nblanks = p->Const.ccp1.blanks; len = (int)p->vleng->constblock.Const.ci; litflavor = LIT_CHAR; goto loop; } else q->memno = BAD_MEMNO; break; case TYCOMPLEX: case TYDCOMPLEX: k = 2; if (p->vstg) cd[1] = atof(ds[1] = p->Const.cds[1]); else ds[1] = cds(dtos(cd[1] = p->Const.cd[1]), cdsbuf1); case TYREAL: case TYDREAL: litflavor = LIT_FLOAT; if (p->vstg) cd[0] = atof(ds[0] = p->Const.cds[0]); else ds[0] = cds(dtos(cd[0] = p->Const.cd[0]), cdsbuf0); goto loop; #ifndef NO_LONG_LONG case TYQUAD: litflavor = LIT_INTQ; goto loop; #endif case TYLOGICAL1: case TYLOGICAL2: case TYLOGICAL: case TYLONG: case TYSHORT: case TYINT1: #ifdef TYQUAD0 case TYQUAD: #endif litflavor = LIT_INT; /* Scan the literal pool for this constant value. If this same constant has been assigned before, use the same label. Note that this routine does NOT consider two differently-typed constants with the same bit pattern to be the same constant */ loop: lastlit = litpool + nliterals; for(litp = litpool ; litp<lastlit ; ++litp) /* Remove this type checking to ensure that all bit patterns are reused */ if(type == litp->littype) switch(litflavor) { case LIT_CHAR: if (len == (int)litp->litval.litival2[0] && nblanks == litp->litval.litival2[1] && !memcmp(strp, litp->cds[0], len)) { q->memno = litp->litnum; frexpr((expptr)p); q->user.Const.ccp1.ccp0 = litp->cds[0]; return(q); } break; case LIT_FLOAT: if(cd[0] == litp->litval.litdval[0] && !strcmp(ds[0], litp->cds[0]) && (k == 1 || cd[1] == litp->litval.litdval[1] && !strcmp(ds[1], litp->cds[1]))) { ret: q->memno = litp->litnum; frexpr((expptr)p); return(q); } break; case LIT_INT: if(p->Const.ci == litp->litval.litival) goto ret; break; #ifndef NO_LONG_LONG case LIT_INTQ: if(p->Const.cq == litp->litval.litqval) goto ret; break; #endif } /* If there's room in the literal pool, add this new value to the pool */ if(nliterals < maxliterals) { ++nliterals; /* litp now points to the next free elt */ litp->littype = type; litp->litnum = q->memno; switch(litflavor) { case LIT_CHAR: litp->litval.litival2[0] = len; litp->litval.litival2[1] = nblanks; q->user.Const.ccp = litp->cds[0] = (char*) memcpy(gmem(len,0), strp, len); break; case LIT_FLOAT: litp->litval.litdval[0] = cd[0]; litp->cds[0] = copys(ds[0]); if (k == 2) { litp->litval.litdval[1] = cd[1]; litp->cds[1] = copys(ds[1]); } break; case LIT_INT: litp->litval.litival = p->Const.ci; break; #ifndef NO_LONG_LONG case LIT_INTQ: litp->litval.litqval = p->Const.cq; break; #endif } /* switch (litflavor) */ } else many("literal constants", 'L', maxliterals); break; case TYADDR: break; default: badtype ("putconst", p -> vtype); break; } /* switch */ if (type != TYCHAR || halign) frexpr((expptr)p); return( q ); }
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; }
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 */ }