void hashclear(Void) /* clear hash table */ { register struct Hashentry *hp; register Namep p; register struct Dimblock *q; register int i; for(hp = hashtab ; hp < lasthash ; ++hp) if(p = hp->varp) { frexpr(p->vleng); if(q = p->vdim) { for(i = 0 ; i < q->ndim ; ++i) { frexpr(q->dims[i].dimsize); frexpr(q->dims[i].dimexpr); } frexpr(q->nelt); frexpr(q->baseoffset); frexpr(q->basexpr); free( (charptr) q); } if(p->vclass == CLNAMELIST) frchain( &(p->varxptr.namelist) ); free( (charptr) p); hp->varp = NULL; } }
p1_expr(expptr expr) #endif { /* An opcode of 0 means a null entry */ if (expr == ENULL) { p1putdd (P1_EXPR, 0, TYUNKNOWN); /* Should this be TYERROR? */ return; } /* if (expr == ENULL) */ switch (expr -> tag) { case TNAME: p1_name ((Namep) expr); return; case TCONST: p1_const(&expr->constblock); return; case TEXPR: /* Fall through the switch */ break; case TADDR: p1_addr (&(expr -> addrblock)); goto freeup; case TPRIM: warn ("p1_expr: got TPRIM"); return; case TLIST: p1_list (&(expr->listblock)); frchain( &(expr->listblock.listp) ); return; case TERROR: return; default: erri ("p1_expr: bad tag '%d'", (int) (expr -> tag)); return; } /* Now we know that the tag is TEXPR */ if (is_unary_op (expr -> exprblock.opcode)) p1_unary (&(expr -> exprblock)); else if (is_binary_op (expr -> exprblock.opcode)) p1_binary (&(expr -> exprblock)); else erri ("p1_expr: bad opcode '%d'", (int) expr -> exprblock.opcode); freeup: free((char *)expr); } /* p1_expr */
static void zap_changes(Void) { register chainp cp; register Argtypes *at; /* arrange to get correct count of prototypes that would change by running f2c again */ if (prev_proc && proc_argchanges) proc_protochanges++; prev_proc = proc_argchanges = 0; for(cp = new_procs; cp; cp = cp->nextp) if (at = ((Namep)cp->datap)->arginfo) at->changes &= ~1; frchain(&new_procs); }
void enddcl(Void) { register struct Entrypoint *ep; struct Entrypoint *ep0; chainp cp; extern char *err_proc; static char comblks[] = "common blocks"; err_proc = comblks; docommon(); /* Now the hash table entries for fields of common blocks have STGCOMMON, vdcldone, voffset, and varno. And the common blocks themselves have their full sizes in extleng. */ err_proc = "equivalences"; doequiv(); err_proc = comblks; docomleng(); /* This implies that entry points in the declarations are buffered in entries but not written out */ err_proc = "entries"; if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) { /* entries could be 0 in case of an error */ do doentry(ep); while(ep = ep->entnextp); entries = (struct Entrypoint *)revchain((chainp)ep0); } err_proc = 0; parstate = INEXEC; p1put(P1_PROCODE); freetemps(); if (earlylabs) { for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp) p1_label((long)cp->datap); frchain(&earlylabs); } p1_line_number(lineno); /* for files that start with a MAIN program */ /* that starts with an executable statement */ }
frdata(chainp p0) #endif { register struct Chain *p; register tagptr q; for(p = p0 ; p ; p = p->nextp) { q = (tagptr)p->datap; if(q->tag == TIMPLDO) { if(q->impldoblock.isbusy) return; /* circular chain completed */ q->impldoblock.isbusy = YES; frdata(q->impldoblock.datalist); free( (charptr) q); } else frexpr(q); } frchain( &p0); }
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 */ }
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() ); }
putentries(FILE *outfile) #endif /* put out wrappers for multiple entries */ { char base[IDENT_LEN]; struct Entrypoint *e; Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np; chainp args, lengths; int i, k, mt, nL, type; extern char *dfltarg[], **dfltproc; e = entries; if (!e->enamep) /* only possible with erroneous input */ return; nL = (nallargs + nallchargs) * sizeof(Namep *); A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **)); Ae = A + nallargs; Alp = (Namep **)(Ae1 = Ae + nallchargs); i = k = 0; for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) { np = (Namep)args->datap; if (np->vtype == TYCHAR && np->vclass != CLPROC) *a1 = &Ae[i++]; } mt = multitype; multitype = 0; sprintf(base, "%s0_", e->enamep->cvarname); do { np = e->enamep; lengths = length_comp(e, 0); proctype = type = np->vtype; if (protofile) protowrite(protofile, type, np->cvarname, e, lengths); nice_printf(outfile, "\n%s ", c_type_decl(type, 1)); nice_printf(outfile, "%s", np->cvarname); if (!Ansi) { listargs(outfile, e, 0, lengths); nice_printf(outfile, "\n"); } list_arg_types(outfile, e, lengths, 0, "\n"); nice_printf(outfile, "{\n"); frchain(&lengths); next_tab(outfile); if (mt) nice_printf(outfile, "Multitype ret_val;\n%s(%d, &ret_val", base, k); /*)*/ else if (ISCOMPLEX(type)) nice_printf(outfile, "%s(%d,%s", base, k, xretslot[type]->user.ident); /*)*/ else if (type == TYCHAR) nice_printf(outfile, "%s(%d, ret_val, ret_val_len", base, k); /*)*/ else nice_printf(outfile, "return %s(%d", base, k); /*)*/ k++; memset((char *)A, 0, nL); for(args = e->arglist; args; args = args->nextp) { np = (Namep)args->datap; A[np->argno] = np; if (np->vtype == TYCHAR && np->vclass != CLPROC) *Alp[np->argno] = np; } args = allargs; for(a = A; a < Ae; a++, args = args->nextp) nice_printf(outfile, ", %s", (np = *a) ? np->cvarname : ((Namep)args->datap)->vclass == CLPROC ? dfltproc[((Namep)args->datap)->vtype] : dfltarg[((Namep)args->datap)->vtype]); for(; a < Ae1; a++) if (np = *a) nice_printf(outfile, ", %s_len", np->fvarname); else nice_printf(outfile, ", (ftnint)0"); nice_printf(outfile, /*(*/ ");\n"); if (mt) { if (type == TYCOMPLEX) nice_printf(outfile, "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n"); else if (type == TYDCOMPLEX) nice_printf(outfile, "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n"); else if (type <= TYLOGICAL) nice_printf(outfile, "return ret_val.%s;\n", postfix[type-TYINT1]); } nice_printf(outfile, "}\n"); prev_tab(outfile); } while(e = e->entnextp); free((char *)A); }
dclgen() { register ptr p, q; ptr q1; chainp *y, z; register struct stentry *s; struct stentry **hp; int first; int i, j; extern char *types[]; char *sp; /* print procedure statement and argument list */ for(p = prevcomments ; p ; p = p->nextp) { sp = p->datap; fprintf(codefile, "%s\n", sp+1); cfree(sp); } frchain(&prevcomments); if(tailor.procheader) fprintf(codefile, "%s\n", tailor.procheader); if(procname) { p2str(" "); if(procname->vtype==TYSUBR || procname->vtype==TYUNDEFINED) p2key(FSUBROUTINE); else { p2str(types[procname->vtype]); p2key(FFUNCTION); } p2str(procname->sthead->namep); } else if(procclass == PRBLOCK) { p2stmt(0); p2key(FBLOCKDATA); } else { p2str("c main program"); if(tailor.ftnsys == CRAY) { p2stmt(0); p2key(FPROGRAM); } } if(thisargs) { p2str( "(" ); first = 1; for(p = thisargs ; p ; p = p->nextp) if( (q=p->datap)->vextbase) { if(first) first = 0; else p2str(", "); p2str(ftnames[q->vextbase]); } else for(i=0 ; i<NFTNTYPES ; ++i) if(j = q->vbase[i]) { if(first) first = 0; else p2str( ", " ); p2str(ftnames[j]); } p2str( ")" ); } /* first put out declarations of variables that are used as adjustable dimensions */ y = 0; z = & y; for(hp = hashtab ; hp<hashend; ++hp) if( *hp && (q = (*hp)->varp) ) if(q->tag==TNAME && q->vadjdim && q!=procname) z = z->nextp = mkchain(q,CHNULL); dclchain(y, NOCOMMON); frchain(&y); /* then declare the rest of the arguments */ z = & y; for(p = thisargs ; p ; p = p->nextp) if(p->datap->vadjdim == 0) z = z->nextp = mkchain(p->datap,CHNULL); dclchain(y, NOCOMMON); frchain(&y); frchain(&thisargs); /* now put out declarations for common blocks */ for(p = commonlist ; p ; p = p->nextp) prcomm(p->datap); TEST fprintf(diagfile, "\nend of common declarations"); z = &y; /* next the other variables that are in the symbol table */ for(hp = hashtab ; hp<hashend ; ++hp) if( *hp && (q = (*hp)->varp) ) if(q->tag==TNAME && q->vadjdim==0 && q->vclass!=CLCOMMON && q->vclass!=CLARG && q!=procname && (tailor.dclintrinsics || q->vproc!=PROCINTRINSIC) ) z = z->nextp = mkchain(q,CHNULL); dclchain(y, NOCOMMON); frchain(&y); TEST fprintf(diagfile, "\nend of symbol table, start of gonelist"); /* now declare variables that are no longer in the symbol table */ dclchain(gonelist, NOCOMMON); TEST fprintf(diagfile, "\nbeginning of hidlist"); dclchain(hidlist, NOCOMMON); dclchain(tempvarlist, NOCOMMON); /* finally put out equivalence statements that are generated because of structure and character variables */ for(p = genequivs; p ; p = p->nextp) { q = p->datap; p2stmt(0); first = 1; p2key(FEQUIVALENCE); p2str( "(" ); for(i=0; i<NFTNTYPES; ++i) if(q->vbase[i]) { if(first) first = 0; else p2str( ", " ); p2str(ftnames[ q->vbase[i] ]); p2str( "(1" ); if(q1 = q->vdim) for(q1 = q1->datap; q1 ; q1 = q1->nextp) p2str( ",1" ); p2str( ")" ); } p2str( ")" ); } frchain(&genequivs); }
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 */
argsort(chainp p0) #endif { Namep *args, q, *stack; int i, nargs, nout, nst; chainp *d, *da, p, rv, *rvp; struct Dimblock *dp; if (!p0) return p0; for(nargs = 0, p = p0; p; p = p->nextp) nargs++; args = (Namep *)ckalloc(i = nargs*(sizeof(Namep) + 2*sizeof(chainp) + 2*sizeof(int))); memset((char *)args, 0, i); stack = args + nargs; d = (chainp *)(stack + nargs); refs = (int *)(d + nargs); used = refs + nargs; for(p = p0; p; p = p->nextp) { q = (Namep) p->datap; args[q->argno] = q; } for(p = p0; p; p = p->nextp) { q = (Namep) p->datap; if (!(dp = q->vdim)) continue; i = dp->ndim; while(--i >= 0) awalk(dp->dims[i].dimexpr); awalk(dp->basexpr); while(nu > 0) { refs[i = used[--nu]] = 0; d[i] = mkchain((char *)q, d[i]); } } for(i = nst = 0; i < nargs; i++) for(p = d[i]; p; p = p->nextp) refs[((Namep)p->datap)->argno]++; while(--i >= 0) if (!refs[i]) stack[nst++] = args[i]; if (nst == nargs) { rv = p0; goto done; } nout = 0; rv = 0; rvp = &rv; while(nst > 0) { nout++; q = stack[--nst]; *rvp = p = mkchain((char *)q, CHNULL); rvp = &p->nextp; da = d + q->argno; for(p = *da; p; p = p->nextp) if (!--refs[(q = (Namep)p->datap)->argno]) stack[nst++] = q; frchain(da); } if (nout < nargs) for(i = 0; i < nargs; i++) if (refs[i]) { q = args[i]; errstr("Can't adjust %.38s correctly\n\ due to dependencies among arguments.", q->fvarname); *rvp = p = mkchain((char *)q, CHNULL); rvp = &p->nextp; frchain(d+i); } done: free((char *)args); return rv; }