01227 {
01228         ftnint leng;
01229         register Addrp q;
01230         register int nelt = nelt0 > 0 ? nelt0 : 1;
01231         extern char *av_pfix[];
01232 
01233         if(t == TYCHAR)
01234                 if( ISICON(lengp) )
01235                         leng = lengp->constblock.Const.ci;
01236                 else    {
01237                         Fatal("automatic variable of nonconstant length");
01238                 }
01239         else
01240                 leng = typesize[t];
01241 
01242         q = ALLOC(Addrblock);
01243         q->tag = TADDR;
01244         q->vtype = t;
01245         if(t == TYCHAR)
01246         {
01247                 q->vleng = ICON(leng);
01248                 q->varleng = leng;
01249         }
01250         q->vstg = STGAUTO;
01251         q->ntempelt = nelt;
01252         q->isarray = (nelt > 1);
01253         q->memoffset = ICON(0);
01254 
01255         /* kludge for nls so we can have ret_val rather than ret_val_4 */
01256         if (*name == ' ')
01257                 unamstring(q, name);
01258         else {
01259                 q->uname_tag = UNAM_IDENT;
01260                 temp_name(av_pfix[t], ++autonum[t], q->user.ident);
01261                 }
01262         if (nelt0 > 0)
01263                 declare_new_addr (q);
01264         return(q);
01265 }

00666 {
00667         errstr("bad dimension type for %.70s", q->fvarname);
00668         }

00064 {
00065         char buf[200];
00066         int qtype, type1;
00067         register Extsym *e;
00068         Argtypes *at;
00069 
00070         if (q->vtypewarned)
00071                 return;
00072         q->vtypewarned = 1;
00073         qtype = q->vtype;
00074         e = &extsymtab[q->vardesc.varno];
00075         if (!(at = e->arginfo)) {
00076                 if (!e->exused)
00077                         return;
00078                 }
00079         else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
00080                 proc_protochanges++;
00081         type1 = e->extype;
00082         if (type1 == TYUNKNOWN)
00083                 return;
00084         if (qtype == TYUNKNOWN)
00085                 /* e.g.,
00086                         subroutine foo
00087                         end
00088                         external foo
00089                         call goo(foo)
00090                         end
00091                 */
00092                 return;
00093         sprintf(buf, "%.90s: inconsistent declarations:\n\
00094         here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
00095                 qtype == TYSUBR ? "" : " function",
00096                 ftn_types[type1], type1 == TYSUBR ? "" : " function");
00097         warn(buf);
00098         }

01377 {
01378         Extsym *p;
01379         register char *t;
01380         register int c, i;
01381         char cbuf[256], *s0;
01382 
01383 /* Give the unnamed common block a unique name */
01384 
01385         if(*s == 0)
01386                 p = mkext1(s0 = Blank, Blank);
01387         else {
01388                 s0 = s;
01389                 t = cbuf;
01390                 for(i = 0; c = *t = *s++; t++)
01391                         if (c == '_')
01392                                 i = 1;
01393                 if (i)
01394                         *t++ = '_';
01395                 t[0] = '_';
01396                 t[1] = 0;
01397                 p = mkext1(s0,cbuf);
01398                 }
01399         if(p->extstg == STGUNKNOWN)
01400                 p->extstg = STGCOMMON;
01401         else if(p->extstg != STGCOMMON)
01402         {
01403                 errstr("%.52s cannot be a common block: it is a subprogram.",
01404                         s0);
01405                 return(0);
01406         }
01407 
01408         return( p );
01409 }

01128 {
01129     for (; list; list = list -> nextp) {
01130         Namep namep = ALLOC (Nameblock);
01131         int size, nd, i;
01132         struct Dimblock *dp;
01133 
01134         cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
01135         namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
01136                 namep->fvarname);
01137         namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
01138                 ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
01139                 : namep->fvarname;
01140         if (namep -> vleng)
01141             namep -> vleng = (expptr) cpexpr (namep -> vleng);
01142         if (namep -> vdim) {
01143             nd = namep -> vdim -> ndim;
01144             size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
01145             dp = (struct Dimblock *) ckalloc (size);
01146             cpn(size, (char *)namep->vdim, (char *)dp);
01147             namep -> vdim = dp;
01148             dp->nelt = (expptr)cpexpr(dp->nelt);
01149             for (i = 0; i < nd; i++) {
01150                 dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
01151             } /* for */
01152         } /* if */
01153         list -> datap = (char *) namep;
01154     } /* for */
01155 } /* copy_data */

00906 {
00907         register struct Dimblock *vdim = q->vdim;
00908         register expptr nelt;
00909 
00910         if(!(nelt = vdim->nelt) || !ISCONST(nelt))
00911                 dclerr("adjustable dimension on non-argument", q);
00912         else if (!ONEOF(nelt->headblock.vtype, MSKINT|MSKREAL))
00913                 bad_dimtype(q);
00914         else if (ISINT(nelt->headblock.vtype)
00915                     && nelt->constblock.Const.ci <= 0
00916                  || nelt->constblock.Const.cd[0] <= 0)
00917                 dclerr("nonpositive dimension", q);
00918         }

00685 {
00686         register struct Dimblock *p;
00687         register expptr q;
00688         register int i, nd;
00689 
00690         p = v->vdim;
00691         v->vdimfinish = 0;
00692         nd = p->ndim;
00693         doin_setbound = 1;
00694         for(i = 0; i < nd; i++)
00695                 if (q = p->dims[i].dimexpr) {
00696                         q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
00697                         if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
00698                                 bad_dimtype(v);
00699                         }
00700         if (q = p->basexpr)
00701                 p->basexpr = make_int_expr(putx(fixtype(q)));
00702         doin_setbound = 0;
00703         }

00922 {
00923         register struct Hashentry *p;
00924         register Namep q;
00925         int qstg, qclass, qtype;
00926         Extsym *e;
00927 
00928         for(p = hashtab ; p<lasthash ; ++p)
00929                 if(q = p->varp)
00930                 {
00931                         qstg = q->vstg;
00932                         qtype = q->vtype;
00933                         qclass = q->vclass;
00934 
00935                         if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
00936                             (qclass==CLVAR && qstg==STGUNKNOWN) ) {
00937                                 if (!(q->vis_assigned | q->vimpldovar))
00938                                         warn1("local variable %s never used",
00939                                                 q->fvarname);
00940                                 }
00941                         else if(qclass==CLVAR && qstg==STGBSS)
00942                         { ; }
00943 
00944 /* Give external procedures the proper storage class */
00945 
00946                         else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
00947                                         && qstg!=STGARG) {
00948                                 e = mkext(q->fvarname,addunder(q->cvarname));
00949                                 e->extstg = STGEXT;
00950                                 q->vardesc.varno = e - extsymtab;
00951                                 if (e->extype != qtype)
00952                                         changedtype(q);
00953                                 }
00954                         if(qclass==CLVAR) {
00955                             if (qstg != STGARG && q->vdim)
00956                                 dim_check(q);
00957                         } /* if qclass == CLVAR */
00958                 }
00959 
00960 }

01161 {
01162         register Extsym *p;
01163 
01164         for(p = extsymtab ; p < nextext ; ++p)
01165                 if(p->extstg == STGCOMMON)
01166                 {
01167                         if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
01168                             && strcmp(Blank, p->cextname) )
01169                                 warn1("incompatible lengths for common block %.60s",
01170                                     p->fextname);
01171                         if(p->maxleng < p->extleng)
01172                                 p->maxleng = p->extleng;
01173                         p->extleng = 0;
01174                 }
01175 }

01037 {
01038     register Extsym *extptr;
01039     register chainp q, q1;
01040     struct Dimblock *t;
01041     expptr neltp;
01042     register Namep comvar;
01043     ftnint size;
01044     int i, k, pref, type;
01045     extern int type_pref[];
01046 
01047     for(extptr = extsymtab ; extptr<nextext ; ++extptr)
01048         if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
01049 
01050 /* If a common declaration also had a list of variables ... */
01051 
01052             q = extptr->extp = revchain(q);
01053             pref = 1;
01054             for(k = TYCHAR; q ; q = q->nextp)
01055             {
01056                 comvar = (Namep) (q->datap);
01057 
01058                 if(comvar->vdcldone == NO)
01059                     vardcl(comvar);
01060                 type = comvar->vtype;
01061                 if (pref < type_pref[type])
01062                         pref = type_pref[k = type];
01063                 if(extptr->extleng % typealign[type] != 0) {
01064                     dclerr("common alignment", comvar);
01065                     --nerr; /* don't give bad return code for this */
01066 #if 0
01067                     extptr->extleng = roundup(extptr->extleng, typealign[type]);
01068 #endif
01069                 } /* if extptr -> extleng % */
01070 
01071 /* Set the offset into the common block */
01072 
01073                 comvar->voffset = extptr->extleng;
01074                 comvar->vardesc.varno = extptr - extsymtab;
01075                 if(type == TYCHAR)
01076                         if (comvar->vleng)
01077                                 size = comvar->vleng->constblock.Const.ci;
01078                         else  {
01079                                 dclerr("character*(*) in common", comvar);
01080                                 size = 1;
01081                                 }
01082                 else
01083                         size = typesize[type];
01084                 if(t = comvar->vdim)
01085                     if( (neltp = t->nelt) && ISCONST(neltp) )
01086                         size *= neltp->constblock.Const.ci;
01087                     else
01088                         dclerr("adjustable array in common", comvar);
01089 
01090 /* Adjust the length of the common block so far */
01091 
01092                 extptr->extleng += size;
01093             } /* for */
01094 
01095             extptr->extype = k;
01096 
01097 /* Determine curno and, if new, save this identifier chain */
01098 
01099             q1 = extptr->extp;
01100             for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
01101                 if (struct_eq((chainp)q->datap, q1))
01102                         break;
01103             if (q)
01104                 extptr->curno = extptr->maxno - i;
01105             else {
01106                 extptr->curno = ++extptr->maxno;
01107                 extptr->allextp = mkchain((char *)extptr->extp,
01108                                                 extptr->allextp);
01109                 }
01110         } /* if extptr -> extstg == STGCOMMON */
01111 
01112 /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
01113    varno.  And the common block itself has its full size in extleng. */
01114 
01115 } /* docommon */

00726 {
00727         register int type;
00728         register Namep np;
00729         chainp p, p1;
00730         register Namep q;
00731         Addrp rs;
00732         int it, k;
00733         extern char dflttype[26];
00734         Extsym *entryname = ep->entryname;
00735 
00736         if (++nentry > 1)
00737                 p1_label((long)(extsymtab - entryname - 1));
00738 
00739 /* The main program isn't allowed to have parameters, so any given
00740    parameters are ignored */
00741 
00742         if(procclass == CLMAIN || procclass == CLBLOCK)
00743                 return;
00744 
00745 /* So now we're working with something other than CLMAIN or CLBLOCK.
00746    Determine the type of its return value. */
00747 
00748         impldcl( np = mkname(entryname->fextname) );
00749         type = np->vtype;
00750         proc_argchanges = prev_proc && type != entryname->extype;
00751         entryname->extseen = 1;
00752         if(proctype == TYUNKNOWN)
00753                 if( (proctype = type) == TYCHAR)
00754                         procleng = np->vleng ? np->vleng->constblock.Const.ci
00755                                              : (ftnint) (-1);
00756 
00757         if(proctype == TYCHAR)
00758         {
00759                 if(type != TYCHAR)
00760                         err("noncharacter entry of character function");
00761 
00762 /* Functions returning type   char   can only have multiple entries if all
00763    entries return the same length */
00764 
00765                 else if( (np->vleng ? np->vleng->constblock.Const.ci :
00766                     (ftnint) (-1)) != procleng)
00767                         err("mismatched character entry lengths");
00768         }
00769         else if(type == TYCHAR)
00770                 err("character entry of noncharacter function");
00771         else if(type != proctype)
00772                 multitype = YES;
00773         if(rtvlabel[type] == 0)
00774                 rtvlabel[type] = (int)newlabel();
00775         ep->typelabel = rtvlabel[type];
00776 
00777         if(type == TYCHAR)
00778         {
00779                 if(chslot < 0)
00780                 {
00781                         chslot = nextarg(TYADDR);
00782                         chlgslot = nextarg(TYLENG);
00783                 }
00784                 np->vstg = STGARG;
00785 
00786 /* Put a new argument in the function, one which will hold the result of
00787    a character function.  This will have to be named sometime, probably in
00788    mkarg(). */
00789 
00790                 if(procleng < 0) {
00791                         np->vleng = (expptr) mkarg(TYLENG, chlgslot);
00792                         np->vleng->addrblock.uname_tag = UNAM_IDENT;
00793                         strcpy (np -> vleng -> addrblock.user.ident,
00794                                 new_func_length());
00795                         }
00796                 if (!xretslot[TYCHAR]) {
00797                         xretslot[TYCHAR] = rs =
00798                                 autovar(0, type, ISCONST(np->vleng)
00799                                         ? np->vleng : ICON(0), "");
00800                         strcpy(rs->user.ident, "ret_val");
00801                         }
00802         }
00803 
00804 /* Handle a   complex   return type -- declare a new parameter (pointer to
00805    a complex value) */
00806 
00807         else if( ISCOMPLEX(type) ) {
00808                 if (!xretslot[type])
00809                         xretslot[type] =
00810                                 autovar(0, type, EXNULL, " ret_val");
00811                                 /* the blank is for use in out_addr */
00812                 np->vstg = STGARG;
00813                 if(cxslot < 0)
00814                         cxslot = nextarg(TYADDR);
00815                 }
00816         else if (type != TYSUBR) {
00817                 if (type == TYUNKNOWN) {
00818                         dclerr("untyped function", np);
00819                         proctype = type = np->vtype =
00820                                 dflttype[letter(np->fvarname[0])];
00821                         }
00822                 if (!xretslot[type])
00823                         xretslot[type] = retslot =
00824                                 autovar(1, type, EXNULL, " ret_val");
00825                                 /* the blank is for use in out_addr */
00826                 np->vstg = STGAUTO;
00827                 }
00828 
00829         for(p = ep->arglist ; p ; p = p->nextp)
00830                 if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
00831                         q->vknownarg = 1;
00832                         q->vardesc.varno = nextarg(TYADDR);
00833                         allargs = mkchain((char *)q, allargs);
00834                         q->argno = nallargs++;
00835                         }
00836                 else if (nentry == 1)
00837                         duparg(q);
00838                 else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
00839                         if ((Namep)p1->datap == q)
00840                                 duparg(q);
00841 
00842         k = 0;
00843         for(p = ep->arglist ; p ; p = p->nextp) {
00844                 if(! (( q = (Namep) (p->datap) )->vdcldone) )
00845                         {
00846                         impldcl(q);
00847                         q->vdcldone = YES;
00848                         if(q->vtype == TYCHAR)
00849                                 {
00850 
00851 /* If we don't know the length of a char*(*) (i.e. a string), we must add
00852    in this additional length argument. */
00853 
00854                                 ++nallchargs;
00855                                 if (q->vclass == CLPROC)
00856                                         nallchargs--;
00857                                 else if (q->vleng == NULL) {
00858                                         /* character*(*) */
00859                                         q->vleng = (expptr)
00860                                             mkarg(TYLENG, nextarg(TYLENG) );
00861                                         unamstring((Addrp)q->vleng,
00862                                                 new_arg_length(q));
00863                                         }
00864                                 }
00865                         }
00866                 if (q->vdimfinish)
00867                         dim_finish(q);
00868                 if (q->vtype == TYCHAR && q->vclass != CLPROC)
00869                         k++;
00870                 }
00871 
00872         if (entryname->extype != type)
00873                 changedtype(np);
00874 
00875         /* save information for checking consistency of arg lists */
00876 
00877         it = infertypes;
00878         if (entryname->exproto)
00879                 infertypes = 1;
00880         save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
00881                         0, np->fvarname, STGEXT, k, np->vtype, 2);
00882         infertypes = it;
00883 }

00965 {
00966         register struct Hashentry *p;
00967         register Namep q;
00968 
00969         for(p=hashtab; p<lasthash; ++p)
00970                 if( (q = p->varp) && q->vclass==CLNAMELIST)
00971                         namelist(q);
00972 }

00712 { errstr("duplicate argument %.80s", q->fvarname); }

00379 {
00380         register struct Entrypoint *ep;
00381         struct Entrypoint *ep0;
00382         chainp cp;
00383         extern char *err_proc;
00384         static char comblks[] = "common blocks";
00385 
00386         err_proc = comblks;
00387         docommon();
00388 
00389 /* Now the hash table entries for fields of common blocks have STGCOMMON,
00390    vdcldone, voffset, and varno.  And the common blocks themselves have
00391    their full sizes in extleng. */
00392 
00393         err_proc = "equivalences";
00394         doequiv();
00395 
00396         err_proc = comblks;
00397         docomleng();
00398 
00399 /* This implies that entry points in the declarations are buffered in
00400    entries   but not written out */
00401 
00402         err_proc = "entries";
00403         if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
00404                 /* entries could be 0 in case of an error */
00405                 do doentry(ep);
00406                         while(ep = ep->entnextp);
00407                 entries = (struct Entrypoint *)revchain((chainp)ep0);
00408                 }
00409 
00410         err_proc = 0;
00411         parstate = INEXEC;
00412         p1put(P1_PROCODE);
00413         freetemps();
00414         if (earlylabs) {
00415                 for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
00416                         p1_label((long)cp->datap);
00417                 frchain(&earlylabs);
00418                 }
00419         p1_line_number(lineno); /* for files that start with a MAIN program */
00420                                 /* that starts with an executable statement */
00421 }

00329 {
00330         struct Labelblock *lp;
00331         Extsym *ext;
00332 
00333         if(parstate < INDATA)
00334                 enddcl();
00335         if(ctlstack >= ctls)
00336                 err("DO loop or BLOCK IF not closed");
00337         for(lp = labeltab ; lp < labtabend ; ++lp)
00338                 if(lp->stateno!=0 && lp->labdefined==NO)
00339                         errstr("missing statement label %s",
00340                                 convic(lp->stateno) );
00341 
00342 /* Save copies of the common variables in extptr -> allextp */
00343 
00344         for (ext = extsymtab; ext < nextext; ext++)
00345                 if (ext -> extstg == STGCOMMON && ext -> extp) {
00346                         extern int usedefsforcommon;
00347 
00348 /* Write out the abbreviations for common block reference */
00349 
00350                         copy_data (ext -> extp);
00351                         if (usedefsforcommon) {
00352                                 wr_abbrevs (c_file, 1, ext -> extp);
00353                                 ext -> used_here = 1;
00354                                 }
00355                         else
00356                                 ext -> extp = CHNULL;
00357 
00358                         }
00359 
00360         if (nentry > 1)
00361                 fix_entry_returns();
00362         epicode();
00363         donmlist();
00364         dobss();
00365         start_formatting ();
00366         if (nentry > 1)
00367                 putentries(c_file);
00368 
00369         zap_changes();
00370         procinit();     /* clean up for next procedure */
00371 }

00279 {
00280         struct Entrypoint *e = entries;
00281         int k = 0;
00282 
00283         nice_printf(outfile, "switch(n__) {\n");
00284         next_tab(outfile);
00285         while(e = e->entnextp)
00286                 nice_printf(outfile, "case %d: goto %s;\n", ++k,
00287                         user_label((long)(extsymtab - e->entryname - 1)));
00288         nice_printf(outfile, "}\n\n");
00289         prev_tab(outfile);
00290         }

00523 {
00524         register Namep q;
00525         register struct Entrypoint *p;
00526 
00527         if(classKRH != CLENTRY)
00528                 puthead( procname = entry->cextname, classKRH);
00529         else
00530                 fprintf(diagfile, "       entry ");
00531         fprintf(diagfile, "   %s:\n", entry->fextname);
00532         fflush(diagfile);
00533         q = mkname(entry->fextname);
00534         if (type == TYSUBR)
00535                 q->vstg = STGEXT;
00536 
00537         type = lengtype(type, length);
00538         if(classKRH == CLPROC)
00539         {
00540                 procclass = CLPROC;
00541                 proctype = type;
00542                 procleng = type == TYCHAR ? length : 0;
00543         }
00544 
00545         p = ALLOC(Entrypoint);
00546 
00547         p->entnextp = entries;
00548         entries = p;
00549 
00550         p->entryname = entry;
00551         p->arglist = revchain(args);
00552         p->enamep = q;
00553 
00554         if(classKRH == CLENTRY)
00555         {
00556                 classKRH = CLPROC;
00557                 if(proctype == TYSUBR)
00558                         type = TYSUBR;
00559         }
00560 
00561         q->vclass = classKRH;
00562         q->vprocclass = 0;
00563         settype(q, type, length);
00564         q->vprocclass = PTHISPROC;
00565         /* hold all initial entry points till end of declarations */
00566         if(parstate >= INDATA)
00567                 doentry(p);
00568 }

00578 {
00579         extern int lastwasbranch;
00580 
00581         if(procclass==CLPROC)
00582         {
00583                 if(proctype==TYSUBR)
00584                 {
00585 
00586 /* Return a zero only when the alternate return mechanism has been
00587    specified in the function header */
00588 
00589                         if ((substars || Ansi) && lastwasbranch != YES)
00590                             p1_subr_ret (ICON(0));
00591                 }
00592                 else if (!multitype && lastwasbranch != YES)
00593                         retval(proctype);
00594         }
00595         else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
00596                 p1_subr_ret (ICON(0));
00597         lastwasbranch = NO;
00598 }

00126 {
00127         Addrp a;
00128         int i;
00129         struct Entrypoint *e;
00130         Namep np;
00131 
00132         e = entries = (struct Entrypoint *)revchain((chainp)entries);
00133         allargs = revchain(allargs);
00134         if (!multitype)
00135                 return;
00136 
00137         /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
00138 
00139         for(i = TYINT1; i <= TYLOGICAL; i++)
00140                 if (a = xretslot[i])
00141                         sprintf(a->user.ident, "(*ret_val).%s",
00142                                 postfix[i-TYINT1]);
00143 
00144         do {
00145                 np = e->enamep;
00146                 switch(np->vtype) {
00147                         case TYINT1:
00148                         case TYSHORT:
00149                         case TYLONG:
00150 #ifdef TYQUAD
00151                         case TYQUAD:
00152 #endif
00153                         case TYREAL:
00154                         case TYDREAL:
00155                         case TYCOMPLEX:
00156                         case TYDCOMPLEX:
00157                         case TYLOGICAL1:
00158                         case TYLOGICAL2:
00159                         case TYLOGICAL:
00160                                 np->vstg = STGARG;
00161                         }
00162                 }
00163                 while(e = e->entnextp);
00164         }

01194 {
01195         register chainp p, p1;
01196         register Addrp q;
01197         register int t;
01198 
01199         p1 = holdtemps;
01200         while(p = p1) {
01201                 q = (Addrp)p->datap;
01202                 t = q->vtype;
01203                 if (t == TYCHAR && q->varleng != 0) {
01204                         /* restore clobbered character string lengths */
01205                         frexpr(q->vleng);
01206                         q->vleng = ICON(q->varleng);
01207                         }
01208                 p1 = p->nextp;
01209                 p->nextp = templist[t];
01210                 templist[t] = p;
01211                 }
01212         holdtemps = 0;
01213         }

01187 {
01188         /* put block on chain of temps to be reclaimed */
01189         holdtemps = mkchain((char *)p, holdtemps);
01190 }

00984 {
00985         ftnint leng;
00986 
00987         leng = typesize[q->vtype];
00988         if(leng <= 0)
00989                 return(-1);
00990         if(q->vdim)
00991                 if( ISICON(q->vdim->nelt) )
00992                         leng *= q->vdim->nelt->constblock.Const.ci;
00993                 else    return(-1);
00994         if(q->vleng)
00995                 if( ISICON(q->vleng) )
00996                         leng *= q->vleng->constblock.Const.ci;
00997                 else return(-1);
00998         return(leng);
00999 }

01422 {
01423         if (!c)
01424                 return;
01425         if(v->vstg != STGUNKNOWN && !v->vimplstg)
01426                 dclerr(v->vstg == STGARG
01427                         ? "dummy arguments cannot be in common"
01428                         : "incompatible common declaration", v);
01429         else
01430         {
01431                 v->vstg = STGCOMMON;
01432                 c->extp = mkchain((char *)v, c->extp);
01433         }
01434 }

01534 {
01535         register int length = (int)len;
01536         switch(type)
01537         {
01538         case TYREAL:
01539                 if(length == typesize[TYDREAL])
01540                         return(TYDREAL);
01541                 if(length == typesize[TYREAL])
01542                         goto ret;
01543                 break;
01544 
01545         case TYCOMPLEX:
01546                 if(length == typesize[TYDCOMPLEX])
01547                         return(TYDCOMPLEX);
01548                 if(length == typesize[TYCOMPLEX])
01549                         goto ret;
01550                 break;
01551 
01552         case TYINT1:
01553         case TYSHORT:
01554         case TYDREAL:
01555         case TYDCOMPLEX:
01556         case TYCHAR:
01557         case TYLOGICAL1:
01558         case TYLOGICAL2:
01559         case TYUNKNOWN:
01560         case TYSUBR:
01561         case TYERROR:
01562 #ifdef TYQUAD
01563         case TYQUAD:
01564 #endif
01565                 goto ret;
01566 
01567         case TYLOGICAL:
01568                 switch(length) {
01569                         case 0: return tylog;
01570                         case 1: return TYLOGICAL1;
01571                         case 2: return TYLOGICAL2;
01572                         case 4: goto ret;
01573                         }
01574 #if 0 /*!!??!!*/
01575                 if(length == typesize[TYLOGICAL])
01576                         goto ret;
01577 #endif
01578                 break;
01579 
01580         case TYLONG:
01581                 if(length == 0)
01582                         return(tyint);
01583                 if (length == 1)
01584                         return TYINT1;
01585                 if(length == typesize[TYSHORT])
01586                         return(TYSHORT);
01587 #ifdef TYQUAD
01588                 if(length == typesize[TYQUAD] && use_tyquad)
01589                         return(TYQUAD);
01590 #endif
01591                 if(length == typesize[TYLONG])
01592                         goto ret;
01593                 break;
01594         default:
01595                 badtype("lengtype", type);
01596         }
01597 
01598         if(len != 0)
01599                 err("incompatible type-length combination");
01600 
01601 ret:
01602         return(type);
01603 }

01338 {
01339         Addrp rv;
01340         /* arrange for temporaries to be recycled */
01341         /* at the end of this statement... */
01342         rv = mktmpn(1,type,lengp);
01343         frtemp((Addrp)cpexpr((expptr)rv));
01344         return rv;
01345 }

01356 {
01357         Addrp rv;
01358         /* arrange for temporaries to be recycled */
01359         /* when this Addrp is freed */
01360         rv = mktmpn(1,type,lengp);
01361         rv->istemp = YES;
01362         return rv;
01363 }

01280 {
01281         ftnint leng;
01282         chainp p, oldp;
01283         register Addrp q;
01284         extern int krparens;
01285 
01286         if(type==TYUNKNOWN || type==TYERROR)
01287                 badtype("mktmpn", type);
01288 
01289         if(type==TYCHAR)
01290                 if(lengp && ISICON(lengp) )
01291                         leng = lengp->constblock.Const.ci;
01292                 else    {
01293                         err("adjustable length");
01294                         return( (Addrp) errnode() );
01295                 }
01296         else if (type > TYCHAR || type < TYADDR) {
01297                 erri("mktmpn: unexpected type %d", type);
01298                 exit(1);
01299                 }
01300 /*
01301  * if a temporary of appropriate shape is on the templist,
01302  * remove it from the list and return it
01303  */
01304         if (krparens == 2 && ONEOF(type,M(TYREAL)|M(TYCOMPLEX)))
01305                 type++;
01306         for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
01307         {
01308                 q = (Addrp) (p->datap);
01309                 if(q->ntempelt==nelt &&
01310                     (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
01311                 {
01312                         if(oldp)
01313                                 oldp->nextp = p->nextp;
01314                         else
01315                                 templist[type] = p->nextp;
01316                         free( (charptr) p);
01317                         return(q);
01318                 }
01319         }
01320         q = autovar(nelt, type, lengp, "");
01321         return(q);
01322 }

01008 {
01009         register chainp q;
01010         register Namep v;
01011         int y;
01012 
01013         if (!np->visused)
01014                 return;
01015         y = 0;
01016 
01017         for(q = np->varxptr.namelist ; q ; q = q->nextp)
01018         {
01019                 vardcl( v = (Namep) (q->datap) );
01020                 if( !ONEOF(v->vstg, MSKSTATIC) )
01021                         dclerr("may not appear in namelist", v);
01022                 else {
01023                         v->vnamelist = 1;
01024                         v->visused = 1;
01025                         v->vsave = 1;
01026                         y = 1;
01027                         }
01028         np->visused = y;
01029         }
01030 }

00480 {
00481         register Extsym *p;
00482         char buf[128], badname[64];
00483         static int nbad = 0;
00484         static char already[] = "external name already used";
00485 
00486         p = mkext(v->fvarname, addunder(v->cvarname));
00487 
00488         if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
00489         {
00490                 sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
00491                 if (substmsg) {
00492                         sprintf(buf,"%s\n\tsubstituting \"%s\"",
00493                                 already, badname);
00494                         dclerr(buf, v);
00495                         }
00496                 else
00497                         dclerr(already, v);
00498                 p = mkext(v->fvarname, badname);
00499         }
00500         v->vstg = STGAUTO;
00501         v->vprocclass = PTHISPROC;
00502         v->vclass = CLPROC;
00503         if (p->extstg == STGEXT)
00504                 prev_proc = 1;
00505         else
00506                 p->extstg = STGEXT;
00507         p->extinit = YES;
00508         v->vardesc.varno = p - extsymtab;
00509         return(p);
00510 }

00296 {
00297         if(parstate != OUTSIDE)
00298         {
00299                 execerr("missing end statement", CNULL);
00300                 endproc();
00301         }
00302 
00303         parstate = INSIDE;
00304         procclass = CLMAIN;     /* default */
00305 }

00894 {
00895         type = type;    /* shut up warning */
00896         return(lastargslot++);
00897         }

00653 {
00654         prolog(outfile, allargs);
00655 
00656         if (nentry > 1)
00657                 entry_goto(outfile);
00658         }

00174 {
00175         char base[MAXNAMELEN+4];
00176         struct Entrypoint *e;
00177         Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
00178         chainp args, lengths;
00179         int i, k, mt, nL, t, type;
00180         extern char *dfltarg[], **dfltproc;
00181 
00182         e = entries;
00183         if (!e->enamep) /* only possible with erroneous input */
00184                 return;
00185         nL = (nallargs + nallchargs) * sizeof(Namep *);
00186         A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
00187         Ae = A + nallargs;
00188         Alp = (Namep **)(Ae1 = Ae + nallchargs);
00189         i = k = 0;
00190         for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
00191                 np = (Namep)args->datap;
00192                 if (np->vtype == TYCHAR && np->vclass != CLPROC)
00193                         *a1 = &Ae[i++];
00194                 }
00195 
00196         mt = multitype;
00197         multitype = 0;
00198         sprintf(base, "%s0_", e->enamep->cvarname);
00199         do {
00200                 np = e->enamep;
00201                 lengths = length_comp(e, 0);
00202                 proctype = type = np->vtype;
00203                 if (protofile)
00204                         protowrite(protofile, type, np->cvarname, e, lengths);
00205                 nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
00206                 nice_printf(outfile, "%s", np->cvarname);
00207                 if (!Ansi) {
00208                         listargs(outfile, e, 0, lengths);
00209                         nice_printf(outfile, "\n");
00210                         }
00211                 list_arg_types(outfile, e, lengths, 0, "\n");
00212                 nice_printf(outfile, "{\n");
00213                 frchain(&lengths);
00214                 next_tab(outfile);
00215                 if (mt)
00216                         nice_printf(outfile,
00217                                 "Multitype ret_val;\n%s(%d, &ret_val",
00218                                 base, k); /*)*/
00219                 else if (ISCOMPLEX(type))
00220                         nice_printf(outfile, "%s(%d,%s", base, k,
00221                                 xretslot[type]->user.ident); /*)*/
00222                 else if (type == TYCHAR)
00223                         nice_printf(outfile,
00224                                 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
00225                 else
00226                         nice_printf(outfile, "return %s(%d", base, k); /*)*/
00227                 k++;
00228                 memset((char *)A, 0, nL);
00229                 for(args = e->arglist; args; args = args->nextp) {
00230                         np = (Namep)args->datap;
00231                         A[np->argno] = np;
00232                         if (np->vtype == TYCHAR && np->vclass != CLPROC)
00233                                 *Alp[np->argno] = np;
00234                         }
00235                 args = allargs;
00236                 for(a = A; a < Ae; a++, args = args->nextp) {
00237                         t = ((Namep)args->datap)->vtype;
00238                         nice_printf(outfile, ", %s", (np = *a)
00239                                 ? np->cvarname
00240                                 : ((Namep)args->datap)->vclass == CLPROC
00241                                 ? dfltproc[((Namep)args->datap)->vimpltype
00242                                         ? (Castargs ? TYUNKNOWN : TYSUBR)
00243                                         : t == TYREAL && forcedouble && !Castargs
00244                                         ? TYDREAL : t]
00245                                 : dfltarg[((Namep)args->datap)->vtype]);
00246                         }
00247                 for(; a < Ae1; a++)
00248                         if (np = *a)
00249                                 nice_printf(outfile, ", %s",
00250                                         new_arg_length(np));
00251                         else
00252                                 nice_printf(outfile, ", (ftnint)0");
00253                 nice_printf(outfile, /*(*/ ");\n");
00254                 if (mt) {
00255                         if (type == TYCOMPLEX)
00256                                 nice_printf(outfile,
00257                     "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\n");
00258                         else if (type == TYDCOMPLEX)
00259                                 nice_printf(outfile,
00260                     "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\n");
00261                         else if (type <= TYLOGICAL)
00262                                 nice_printf(outfile, "return ret_val.%s;\n",
00263                                         postfix[type-TYINT1]);
00264                         }
00265                 nice_printf(outfile, "}\n");
00266                 prev_tab(outfile);
00267                 }
00268                 while(e = e->entnextp);
00269         free((char *)A);
00270         }

00610 {
00611         register Addrp p;
00612 
00613         switch(t)
00614         {
00615         case TYCHAR:
00616         case TYCOMPLEX:
00617         case TYDCOMPLEX:
00618                 break;
00619 
00620         case TYLOGICAL:
00621                 t = tylogical;
00622         case TYINT1:
00623         case TYADDR:
00624         case TYSHORT:
00625         case TYLONG:
00626 #ifdef TYQUAD
00627         case TYQUAD:
00628 #endif
00629         case TYREAL:
00630         case TYDREAL:
00631         case TYLOGICAL1:
00632         case TYLOGICAL2:
00633                 p = (Addrp) cpexpr((expptr)retslot);
00634                 p->vtype = t;
00635                 p1_subr_ret (mkconv (t, fixtype((expptr)p)));
00636                 break;
00637 
00638         default:
00639                 badtype("retval", t);
00640         }
00641 }

01684 {
01685         register expptr q, t;
01686         register struct Dimblock *p;
01687         int i;
01688         extern chainp new_vars;
01689         char buf[256];
01690 
01691         if(v->vclass == CLUNKNOWN)
01692                 v->vclass = CLVAR;
01693         else if(v->vclass != CLVAR)
01694         {
01695                 dclerr("only variables may be arrays", v);
01696                 return;
01697         }
01698 
01699         v->vdim = p = (struct Dimblock *)
01700             ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
01701         p->ndim = nd--;
01702         p->nelt = ICON(1);
01703         doin_setbound = 1;
01704 
01705         if (noextflag)
01706                 for(i = 0; i <= nd; i++)
01707                         if (((q = dims[i].lb) && !ISINT(q->headblock.vtype))
01708                          || ((q = dims[i].ub) && !ISINT(q->headblock.vtype))) {
01709                                 sprintf(buf, "dimension %d of %s is not an integer.",
01710                                         i+1, v->fvarname);
01711                                 errext(buf);
01712                                 break;
01713                                 }
01714 
01715         for(i = 0; i <= nd; i++) {
01716                 if (((q = dims[i].lb) && !ISINT(q->headblock.vtype)))
01717                         dims[i].lb = mkconv(TYINT, q);
01718                 if (((q = dims[i].ub) && !ISINT(q->headblock.vtype)))
01719                         dims[i].ub = mkconv(TYINT, q);
01720                 }
01721 
01722         for(i = 0; i <= nd; ++i)
01723         {
01724                 if( (q = dims[i].ub) == NULL)
01725                 {
01726                         if(i == nd)
01727                         {
01728                                 frexpr(p->nelt);
01729                                 p->nelt = NULL;
01730                         }
01731                         else
01732                                 err("only last bound may be asterisk");
01733                         p->dims[i].dimsize = ICON(1);
01734                         p->dims[i].dimexpr = NULL;
01735                 }
01736                 else
01737                 {
01738 
01739                         if(dims[i].lb)
01740                         {
01741                                 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
01742                                 q = mkexpr(OPPLUS, q, ICON(1) );
01743                         }
01744                         if( ISCONST(q) )
01745                         {
01746                                 p->dims[i].dimsize = q;
01747                                 p->dims[i].dimexpr = (expptr) PNULL;
01748                         }
01749                         else {
01750                                 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
01751                                 p->dims[i].dimsize = (expptr)
01752                                         autovar(1, tyint, EXNULL, buf);
01753                                 p->dims[i].dimexpr = q;
01754                                 if (i == nd)
01755                                         v->vlastdim = new_vars;
01756                                 v->vdimfinish = 1;
01757                         }
01758                         if(p->nelt)
01759                                 p->nelt = mkexpr(OPSTAR, p->nelt,
01760                                     cpexpr(p->dims[i].dimsize) );
01761                 }
01762         }
01763 
01764         q = dims[nd].lb;
01765         if(q == NULL)
01766                 q = ICON(1);
01767 
01768         for(i = nd-1 ; i>=0 ; --i)
01769         {
01770                 t = dims[i].lb;
01771                 if(t == NULL)
01772                         t = ICON(1);
01773                 if(p->dims[i].dimsize)
01774                         q = mkexpr(OPPLUS, t,
01775                                 mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q));
01776         }
01777 
01778         if( ISCONST(q) )
01779         {
01780                 p->baseoffset = q;
01781                 p->basexpr = NULL;
01782         }
01783         else
01784         {
01785                 sprintf(buf, " %s_offset", v->fvarname);
01786                 p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
01787                 p->basexpr = q;
01788                 v->vdimfinish = 1;
01789         }
01790         doin_setbound = 0;
01791 }

01658 {
01659         if(v->vclass == CLUNKNOWN)
01660                 v->vclass = CLPROC;
01661         else if(v->vclass != CLPROC)
01662                 dclerr("invalid external declaration", v);
01663 
01664         if(v->vprocclass == PUNKNOWN)
01665                 v->vprocclass = PEXTERNAL;
01666         else if(v->vprocclass != PEXTERNAL)
01667                 dclerr("invalid external declaration", v);
01668 } /* setext */

01618 {
01619         int k;
01620 
01621         if(k = intrfunct(v->fvarname)) {
01622                 if ((*(struct Intrpacked *)&k).f4)
01623                         if (noextflag)
01624                                 goto unknown;
01625                         else
01626                                 dcomplex_seen++;
01627                 v->vardesc.varno = k;
01628                 }
01629         else {
01630  unknown:
01631                 dclerr("unknown intrinsic function", v);
01632                 return;
01633                 }
01634         if(v->vstg == STGUNKNOWN)
01635                 v->vstg = STGINTR;
01636         else if(v->vstg!=STGINTR)
01637                 dclerr("incompatible use of intrinsic function", v);
01638         if(v->vclass==CLUNKNOWN)
01639                 v->vclass = CLPROC;
01640         if(v->vprocclass == PUNKNOWN)
01641                 v->vprocclass = PINTRINSIC;
01642         else if(v->vprocclass != PINTRINSIC)
01643                 dclerr("invalid intrinsic declaration", v);
01644 }

01453 {
01454         int type1;
01455 
01456         if(type == TYUNKNOWN)
01457                 return;
01458 
01459         if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
01460         {
01461                 v->vtype = TYSUBR;
01462                 frexpr(v->vleng);
01463                 v->vleng = 0;
01464                 v->vimpltype = 0;
01465         }
01466         else if(type < 0)       /* storage class set */
01467         {
01468                 if(v->vstg == STGUNKNOWN)
01469                         v->vstg = - type;
01470                 else if(v->vstg != -type)
01471                         dclerr("incompatible storage declarations", v);
01472         }
01473         else if(v->vtype == TYUNKNOWN
01474                 || v->vtype != type
01475                         && (v->vimpltype || v->vinftype || v->vinfproc))
01476         {
01477                 if( (v->vtype = lengtype(type, length))==TYCHAR )
01478                         if (length>=0)
01479                                 v->vleng = ICON(length);
01480                         else if (parstate >= INDATA)
01481                                 v->vleng = ICON(1);     /* avoid a memory fault */
01482                 v->vimpltype = 0;
01483                 v->vinftype = 0; /* 19960709 */
01484                 v->vinfproc = 0; /* 19960709 */
01485 
01486                 if (v->vclass == CLPROC) {
01487                         if (v->vstg == STGEXT
01488                          && (type1 = extsymtab[v->vardesc.varno].extype)
01489                          &&  type1 != v->vtype)
01490                                 changedtype(v);
01491                         else if (v->vprocclass == PTHISPROC
01492                                         && (parstate >= INDATA
01493                                                 || procclass == CLMAIN)
01494                                         && !xretslot[type]) {
01495                                 xretslot[type] = autovar(ONEOF(type,
01496                                         MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
01497                                         v->vleng, " ret_val");
01498                                 if (procclass == CLMAIN)
01499                                         errstr(
01500                                 "illegal use of %.60s (main program name)",
01501                                         v->fvarname);
01502                                 /* not completely right, but enough to */
01503                                 /* avoid memory faults; we won't */
01504                                 /* emit any C as we have illegal Fortran */
01505                                 }
01506                         }
01507         }
01508         else if(v->vtype!=type) {
01509  incompat:
01510                 dclerr("incompatible type declarations", v);
01511                 }
01512         else if (type==TYCHAR)
01513                 if (v->vleng && v->vleng->constblock.Const.ci != length)
01514                         goto incompat;
01515                 else if (parstate >= INDATA)
01516                         v->vleng = ICON(1);     /* avoid a memory fault */
01517 }

00435 {
00436         register struct Entrypoint *p;
00437 
00438         p = ALLOC(Entrypoint);
00439         if(classKRH == CLMAIN) {
00440                 puthead(CNULL, CLMAIN);
00441                 if (progname)
00442                     strcpy (main_alias, progname->cextname);
00443         } else {
00444                 if (progname) {
00445                         /* Construct an empty subroutine with this name */
00446                         /* in case the name is needed to force loading */
00447                         /* of this block-data subprogram: the name can */
00448                         /* appear elsewhere in an external statement. */
00449                         entrypt(CLPROC, TYSUBR, (ftnint)0, progname, (chainp)0);
00450                         endproc();
00451                         newproc();
00452                         }
00453                 puthead(CNULL, CLBLOCK);
00454                 }
00455         if(classKRH == CLMAIN)
00456                 newentry( mkname(" MAIN"), 0 )->extinit = 1;
00457         p->entryname = progname;
00458         entries = p;
00459 
00460         procclass = classKRH;
00461         fprintf(diagfile, "   %s", (classKRH==CLMAIN ? "MAIN" : "BLOCK DATA") );
00462         if(progname) {
00463                 fprintf(diagfile, " %s", progname->fextname);
00464                 procname = progname->cextname;
00465                 }
00466         fprintf(diagfile, ":\n");
00467         fflush(diagfile);
00468 }

00108 {
00109         register int k;
00110         register char *t;
00111 
00112         k = strlen(s);
00113         if (k < IDENT_LEN) {
00114                 q->uname_tag = UNAM_IDENT;
00115                 t = q->user.ident;
00116                 }
00117         else {
00118                 q->uname_tag = UNAM_CHARP;
00119                 q->user.Charp = t = mem(k+1, 0);
00120                 }
00121         strcpy(t, s);
00122         }

01803 {
01804     for (; vars; vars = vars -> nextp) {
01805         Namep name = (Namep) vars -> datap;
01806         if (!name->visused)
01807                 continue;
01808 
01809         if (function_head)
01810             nice_printf (outfile, "#define ");
01811         else
01812             nice_printf (outfile, "#undef ");
01813         out_name (outfile, name);
01814 
01815         if (function_head) {
01816             Extsym *comm = &extsymtab[name -> vardesc.varno];
01817 
01818             nice_printf (outfile, " (");
01819             extern_out (outfile, comm);
01820             nice_printf (outfile, "%d.", comm->curno);
01821             nice_printf (outfile, "%s)", name->cvarname);
01822         } /* if function_head */
01823         nice_printf (outfile, "\n");
01824     } /* for */
01825 } /* wr_abbrevs */

00309 {
00310         register chainp cp;
00311         register Argtypes *at;
00312 
00313         /* arrange to get correct count of prototypes that would
00314            change by running f2c again */
00315 
00316         if (prev_proc && proc_argchanges)
00317                 proc_protochanges++;
00318         prev_proc = proc_argchanges = 0;
00319         for(cp = new_procs; cp; cp = cp->nextp)
00320                 if (at = ((Namep)cp->datap)->arginfo)
00321                         at->changes &= ~1;
00322         frchain(&new_procs);
00323         }

 { "g", "h", "i",

                                        "j",

                                        "r", "d", "c", "z", "g", "h", "i" }