home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / f2c / src / proc.c < prev    next >
C/C++ Source or Header  |  1999-12-13  |  35KB  |  1,578 lines
  1. /****************************************************************
  2. Copyright 1990, 1991, 1992 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25. #include "names.h"
  26. #include "output.h"
  27. #include "p1defs.h"
  28.  
  29. #define EXNULL (union Expression *)0
  30.  
  31. LOCAL dobss(), docomleng(), docommon(), doentry(),
  32.     epicode(), nextarg(), retval();
  33.  
  34. static char Blank[] = BLANKCOMMON;
  35.  
  36.  static char *postfix[] = { "h", "i", "r", "d", "c", "z", "i" };
  37.  
  38.  chainp new_procs;
  39.  int prev_proc, proc_argchanges, proc_protochanges;
  40.  long first_lineno;
  41.  
  42.  void
  43. changedtype(q)
  44.  Namep q;
  45. {
  46.     char buf[200];
  47.     int qtype, type1;
  48.     register Extsym *e;
  49.     Argtypes *at;
  50.  
  51.     if (q->vtypewarned)
  52.         return;
  53.     q->vtypewarned = 1;
  54.     qtype = q->vtype;
  55.     e = &extsymtab[q->vardesc.varno];
  56.     if (!(at = e->arginfo)) {
  57.         if (!e->exused)
  58.             return;
  59.         }
  60.     else if (at->changes & 2 && qtype != TYUNKNOWN && !at->defined)
  61.         proc_protochanges++;
  62.     type1 = e->extype;
  63.     if (type1 == TYUNKNOWN)
  64.         return;
  65.     if (qtype == TYUNKNOWN)
  66.         /* e.g.,
  67.             subroutine foo
  68.             end
  69.             external foo
  70.             call goo(foo)
  71.             end
  72.         */
  73.         return;
  74.     sprintf(buf, "%.90s: inconsistent declarations:\n\
  75.     here %s%s, previously %s%s.", q->fvarname, ftn_types[qtype],
  76.         qtype == TYSUBR ? "" : " function",
  77.         ftn_types[type1], type1 == TYSUBR ? "" : " function");
  78.     warn(buf);
  79.     }
  80.  
  81.  void
  82. unamstring(q, s)
  83.  register Addrp q;
  84.  register char *s;
  85. {
  86.     register int k;
  87.     register char *t;
  88.  
  89.     k = strlen(s);
  90.     if (k < IDENT_LEN) {
  91.         q->uname_tag = UNAM_IDENT;
  92.         t = q->user.ident;
  93.         }
  94.     else {
  95.         q->uname_tag = UNAM_CHARP;
  96.         q->user.Charp = t = mem(k+1, 0);
  97.         }
  98.     strcpy(t, s);
  99.     }
  100.  
  101.  static void
  102. fix_entry_returns()    /* for multiple entry points */
  103. {
  104.     Addrp a;
  105.     int i;
  106.     struct Entrypoint *e;
  107.     Namep np;
  108.  
  109.     e = entries = (struct Entrypoint *)revchain((chainp)entries);
  110.     allargs = revchain(allargs);
  111.     if (!multitype)
  112.         return;
  113.  
  114.     /* TYLOGICAL should have been turned into TYLONG or TYSHORT by now */
  115.  
  116.     for(i = TYSHORT; i <= TYLOGICAL; i++)
  117.         if (a = xretslot[i])
  118.             sprintf(a->user.ident, "(*ret_val).%s",
  119.                 postfix[i-TYSHORT]);
  120.  
  121.     do {
  122.         np = e->enamep;
  123.         switch(np->vtype) {
  124.             case TYSHORT:
  125.             case TYLONG:
  126.             case TYREAL:
  127.             case TYDREAL:
  128.             case TYCOMPLEX:
  129.             case TYDCOMPLEX:
  130.             case TYLOGICAL:
  131.                 np->vstg = STGARG;
  132.             }
  133.         }
  134.         while(e = e->entnextp);
  135.     }
  136.  
  137.  static void
  138. putentries(outfile)    /* put out wrappers for multiple entries */
  139.  FILE *outfile;
  140. {
  141.     char base[IDENT_LEN];
  142.     struct Entrypoint *e;
  143.     Namep *A, *Ae, *Ae1, **Alp, *a, **a1, np;
  144.     chainp args, lengths, length_comp();
  145.     void listargs(), list_arg_types();
  146.     int i, k, mt, nL, type;
  147.     extern char *dfltarg[], **dfltproc;
  148.  
  149.     e = entries;
  150.     if (!e->enamep) /* only possible with erroneous input */
  151.         return;
  152.     nL = (nallargs + nallchargs) * sizeof(Namep *);
  153.     A = (Namep *)ckalloc(nL + nallargs*sizeof(Namep **));
  154.     Ae = A + nallargs;
  155.     Alp = (Namep **)(Ae1 = Ae + nallchargs);
  156.     i = k = 0;
  157.     for(a1 = Alp, args = allargs; args; a1++, args = args->nextp) {
  158.         np = (Namep)args->datap;
  159.         if (np->vtype == TYCHAR && np->vclass != CLPROC)
  160.             *a1 = &Ae[i++];
  161.         }
  162.  
  163.     mt = multitype;
  164.     multitype = 0;
  165.     sprintf(base, "%s0_", e->enamep->cvarname);
  166.     do {
  167.         np = e->enamep;
  168.         lengths = length_comp(e, 0);
  169.         proctype = type = np->vtype;
  170.         if (protofile)
  171.             protowrite(protofile, type, np->cvarname, e, lengths);
  172.         nice_printf(outfile, "\n%s ", c_type_decl(type, 1));
  173.         nice_printf(outfile, "%s", np->cvarname);
  174.         if (!Ansi) {
  175.             listargs(outfile, e, 0, lengths);
  176.             nice_printf(outfile, "\n");
  177.             }
  178.             list_arg_types(outfile, e, lengths, 0, "\n");
  179.         nice_printf(outfile, "{\n");
  180.         frchain(&lengths);
  181.         next_tab(outfile);
  182.         if (mt)
  183.             nice_printf(outfile,
  184.                 "Multitype ret_val;\n%s(%d, &ret_val",
  185.                 base, k); /*)*/
  186.         else if (ISCOMPLEX(type))
  187.             nice_printf(outfile, "%s(%d,%s", base, k,
  188.                 xretslot[type]->user.ident); /*)*/
  189.         else if (type == TYCHAR)
  190.             nice_printf(outfile,
  191.                 "%s(%d, ret_val, ret_val_len", base, k); /*)*/
  192.         else
  193.             nice_printf(outfile, "return %s(%d", base, k); /*)*/
  194.         k++;
  195.         memset((char *)A, 0, nL);
  196.         for(args = e->arglist; args; args = args->nextp) {
  197.             np = (Namep)args->datap;
  198.             A[np->argno] = np;
  199.             if (np->vtype == TYCHAR && np->vclass != CLPROC)
  200.                 *Alp[np->argno] = np;
  201.             }
  202.         args = allargs;
  203.         for(a = A; a < Ae; a++, args = args->nextp)
  204.             nice_printf(outfile, ", %s", (np = *a)
  205.                 ? np->cvarname
  206.                 : ((Namep)args->datap)->vclass == CLPROC
  207.                 ? dfltproc[((Namep)args->datap)->vtype]
  208.                 : dfltarg[((Namep)args->datap)->vtype]);
  209.         for(; a < Ae1; a++)
  210.             if (np = *a)
  211.                 nice_printf(outfile, ", %s_len", np->fvarname);
  212.             else
  213.                 nice_printf(outfile, ", (ftnint)0");
  214.         nice_printf(outfile, /*(*/ ");\n");
  215.         if (mt) {
  216.             if (type == TYCOMPLEX)
  217.                 nice_printf(outfile,
  218.             "r_v->r = ret_val.c.r; r_v->i = ret_val.c.i;\nreturn 0;\n");
  219.             else if (type == TYDCOMPLEX)
  220.                 nice_printf(outfile,
  221.             "r_v->r = ret_val.z.r; r_v->i = ret_val.z.i;\nreturn 0;\n");
  222.             else nice_printf(outfile, "return ret_val.%s;\n",
  223.                 postfix[type-TYSHORT]);
  224.             }
  225.         else if (ONEOF(type, M(TYCHAR)|M(TYCOMPLEX)|M(TYDCOMPLEX)))
  226.             nice_printf(outfile, "return 0;\n");
  227.         nice_printf(outfile, "}\n");
  228.         prev_tab(outfile);
  229.         }
  230.         while(e = e->entnextp);
  231.     free((char *)A);
  232.     }
  233.  
  234.  static void
  235. entry_goto(outfile)
  236.  FILEP outfile;
  237. {
  238.     struct Entrypoint *e = entries;
  239.     int k = 0;
  240.  
  241.     nice_printf(outfile, "switch(n__) {\n");
  242.     next_tab(outfile);
  243.     while(e = e->entnextp)
  244.         nice_printf(outfile, "case %d: goto %s;\n", ++k,
  245.             user_label((long)(extsymtab - e->entryname - 1)));
  246.     nice_printf(outfile, "}\n\n");
  247.     prev_tab(outfile);
  248.     }
  249.  
  250. /* start a new procedure */
  251.  
  252. newproc()
  253. {
  254.     if(parstate != OUTSIDE)
  255.     {
  256.         execerr("missing end statement", CNULL);
  257.         endproc();
  258.     }
  259.  
  260.     parstate = INSIDE;
  261.     procclass = CLMAIN;    /* default */
  262. }
  263.  
  264.  static void
  265. zap_changes()
  266. {
  267.     register chainp cp;
  268.     register Argtypes *at;
  269.  
  270.     /* arrange to get correct count of prototypes that would
  271.        change by running f2c again */
  272.  
  273.     if (prev_proc && proc_argchanges)
  274.         proc_protochanges++;
  275.     prev_proc = proc_argchanges = 0;
  276.     for(cp = new_procs; cp; cp = cp->nextp)
  277.         if (at = ((Namep)cp->datap)->arginfo)
  278.             at->changes &= ~1;
  279.     frchain(&new_procs);
  280.     }
  281.  
  282. /* end of procedure. generate variables, epilogs, and prologs */
  283.  
  284. endproc()
  285. {
  286.     struct Labelblock *lp;
  287.     Extsym *ext;
  288.  
  289.     if(parstate < INDATA)
  290.         enddcl();
  291.     if(ctlstack >= ctls)
  292.         err("DO loop or BLOCK IF not closed");
  293.     for(lp = labeltab ; lp < labtabend ; ++lp)
  294.         if(lp->stateno!=0 && lp->labdefined==NO)
  295.             errstr("missing statement label %s",
  296.                 convic(lp->stateno) );
  297.  
  298. /* Save copies of the common variables in extptr -> allextp */
  299.  
  300.     for (ext = extsymtab; ext < nextext; ext++)
  301.         if (ext -> extstg == STGCOMMON && ext -> extp) {
  302.             extern int usedefsforcommon;
  303.  
  304. /* Write out the abbreviations for common block reference */
  305.  
  306.             copy_data (ext -> extp);
  307.             if (usedefsforcommon) {
  308.                 wr_abbrevs (c_file, 1, ext -> extp);
  309.                 ext -> used_here = 1;
  310.                 }
  311.             else
  312.                 ext -> extp = CHNULL;
  313.  
  314.             }
  315.  
  316.     if (nentry > 1)
  317.         fix_entry_returns();
  318.     epicode();
  319.     donmlist();
  320.     dobss();
  321.     start_formatting ();
  322.     if (nentry > 1)
  323.         putentries(c_file);
  324.  
  325.     zap_changes();
  326.     procinit();    /* clean up for next procedure */
  327. }
  328.  
  329.  
  330.  
  331. /* End of declaration section of procedure.  Allocate storage. */
  332.  
  333. enddcl()
  334. {
  335.     register struct Entrypoint *ep;
  336.     struct Entrypoint *ep0;
  337.     extern void freetemps();
  338.     chainp cp;
  339.     extern char *err_proc;
  340.     static char comblks[] = "common blocks";
  341.  
  342.     err_proc = comblks;
  343.     docommon();
  344.  
  345. /* Now the hash table entries for fields of common blocks have STGCOMMON,
  346.    vdcldone, voffset, and varno.  And the common blocks themselves have
  347.    their full sizes in extleng. */
  348.  
  349.     err_proc = "equivalences";
  350.     doequiv();
  351.  
  352.     err_proc = comblks;
  353.     docomleng();
  354.  
  355. /* This implies that entry points in the declarations are buffered in
  356.    entries   but not written out */
  357.  
  358.     err_proc = "entries";
  359.     if (ep = ep0 = (struct Entrypoint *)revchain((chainp)entries)) {
  360.         /* entries could be 0 in case of an error */
  361.         do doentry(ep);
  362.             while(ep = ep->entnextp);
  363.         entries = (struct Entrypoint *)revchain((chainp)ep0);
  364.         }
  365.  
  366.     err_proc = 0;
  367.     parstate = INEXEC;
  368.     p1put(P1_PROCODE);
  369.     freetemps();
  370.     if (earlylabs) {
  371.         for(cp = earlylabs = revchain(earlylabs); cp; cp = cp->nextp)
  372.             p1_label((long)cp->datap);
  373.         frchain(&earlylabs);
  374.         }
  375. }
  376.  
  377. /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
  378.  
  379. /* Main program or Block data */
  380.  
  381. startproc(progname, class)
  382. Extsym * progname;
  383. int class;
  384. {
  385.     register struct Entrypoint *p;
  386.  
  387.     first_lineno = lineno;
  388.     p = ALLOC(Entrypoint);
  389.     if(class == CLMAIN) {
  390.         puthead(CNULL, CLMAIN);
  391.         if (progname)
  392.             strcpy (main_alias, progname->cextname);
  393.     } else
  394.         puthead(CNULL, CLBLOCK);
  395.     if(class == CLMAIN)
  396.         newentry( mkname(" MAIN"), 0 )->extinit = 1;
  397.     p->entryname = progname;
  398.     entries = p;
  399.  
  400.     procclass = class;
  401.     fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
  402.     if(progname) {
  403.         fprintf(diagfile, " %s", progname->fextname);
  404.         procname = progname->cextname;
  405.         }
  406.     fprintf(diagfile, ":\n");
  407.     fflush(diagfile);
  408. }
  409.  
  410. /* subroutine or function statement */
  411.  
  412. Extsym *newentry(v, substmsg)
  413.  register Namep v;
  414.  int substmsg;
  415. {
  416.     register Extsym *p;
  417.     char buf[128], badname[64];
  418.     static int nbad = 0;
  419.     static char already[] = "external name already used";
  420.  
  421.     p = mkext(v->fvarname, addunder(v->cvarname));
  422.  
  423.     if(p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
  424.     {
  425.         sprintf(badname, "%s_bad%d", v->fvarname, ++nbad);
  426.         if (substmsg) {
  427.             sprintf(buf,"%s\n\tsubstituting \"%s\"",
  428.                 already, badname);
  429.             dclerr(buf, v);
  430.             }
  431.         else
  432.             dclerr(already, v);
  433.         p = mkext(v->fvarname, badname);
  434.     }
  435.     v->vstg = STGAUTO;
  436.     v->vprocclass = PTHISPROC;
  437.     v->vclass = CLPROC;
  438.     if (p->extstg == STGEXT)
  439.         prev_proc = 1;
  440.     else
  441.         p->extstg = STGEXT;
  442.     p->extinit = YES;
  443.     v->vardesc.varno = p - extsymtab;
  444.     return(p);
  445. }
  446.  
  447.  
  448. entrypt(class, type, length, entry, args)
  449. int class, type;
  450. ftnint length;
  451. Extsym *entry;
  452. chainp args;
  453. {
  454.     register Namep q;
  455.     register struct Entrypoint *p;
  456.  
  457.     if(class != CLENTRY)
  458.         puthead( procname = entry->cextname, class);
  459.     else
  460.         fprintf(diagfile, "       entry ");
  461.     fprintf(diagfile, "   %s:\n", entry->fextname);
  462.     fflush(diagfile);
  463.     q = mkname(entry->fextname);
  464.     if (type == TYSUBR)
  465.         q->vstg = STGEXT;
  466.  
  467.     type = lengtype(type, length);
  468.     if(class == CLPROC)
  469.     {
  470.         procclass = CLPROC;
  471.         proctype = type;
  472.         procleng = type == TYCHAR ? length : 0;
  473.     }
  474.  
  475.     p = ALLOC(Entrypoint);
  476.  
  477.     p->entnextp = entries;
  478.     entries = p;
  479.  
  480.     p->entryname = entry;
  481.     p->arglist = revchain(args);
  482.     p->enamep = q;
  483.  
  484.     if(class == CLENTRY)
  485.     {
  486.         class = CLPROC;
  487.         if(proctype == TYSUBR)
  488.             type = TYSUBR;
  489.     }
  490.  
  491.     q->vclass = class;
  492.     q->vprocclass = 0;
  493.     settype(q, type, length);
  494.     q->vprocclass = PTHISPROC;
  495.     /* hold all initial entry points till end of declarations */
  496.     if(parstate >= INDATA)
  497.         doentry(p);
  498. }
  499.  
  500. /* generate epilogs */
  501.  
  502. /* epicode -- write out the proper function return mechanism at the end of
  503.    the procedure declaration.  Handles multiple return value types, as
  504.    well as cooercion into the proper value */
  505.  
  506. LOCAL epicode()
  507. {
  508.     extern int lastwasbranch;
  509.  
  510.     if(procclass==CLPROC)
  511.     {
  512.         if(proctype==TYSUBR)
  513.         {
  514.  
  515. /* Return a zero only when the alternate return mechanism has been
  516.    specified in the function header */
  517.  
  518.             if ((substars || Ansi) && lastwasbranch != YES)
  519.                 p1_subr_ret (ICON(0));
  520.         }
  521.         else if (!multitype && lastwasbranch != YES)
  522.             retval(proctype);
  523.     }
  524.     else if (procclass == CLMAIN && Ansi && lastwasbranch != YES)
  525.         p1_subr_ret (ICON(0));
  526.     lastwasbranch = NO;
  527. }
  528.  
  529.  
  530. /* generate code to return value of type  t */
  531.  
  532. LOCAL retval(t)
  533. register int t;
  534. {
  535.     register Addrp p;
  536.  
  537.     switch(t)
  538.     {
  539.     case TYCHAR:
  540.     case TYCOMPLEX:
  541.     case TYDCOMPLEX:
  542.         break;
  543.  
  544.     case TYLOGICAL:
  545.         t = tylogical;
  546.     case TYADDR:
  547.     case TYSHORT:
  548.     case TYLONG:
  549.     case TYREAL:
  550.     case TYDREAL:
  551.         p = (Addrp) cpexpr((expptr)retslot);
  552.         p->vtype = t;
  553.         p1_subr_ret (mkconv (t, fixtype((expptr)p)));
  554.         break;
  555.  
  556.     default:
  557.         badtype("retval", t);
  558.     }
  559. }
  560.  
  561.  
  562. /* Do parameter adjustments */
  563.  
  564. procode(outfile)
  565. FILE *outfile;
  566. {
  567.     prolog(outfile, allargs);
  568.  
  569.     if (nentry > 1)
  570.         entry_goto(outfile);
  571.     }
  572.  
  573. /* Finish bound computations now that all variables are declared.
  574.  * This used to be in setbound(), but under -u the following incurred
  575.  * an erroneous error message:
  576.  *    subroutine foo(x,n)
  577.  *    real x(n)
  578.  *    integer n
  579.  */
  580.  
  581.  static void
  582. dim_finish(v)
  583.  Namep v;
  584. {
  585.     register struct Dimblock *p;
  586.     register expptr q;
  587.     register int i, nd;
  588.     extern expptr make_int_expr();
  589.  
  590.     p = v->vdim;
  591.     v->vdimfinish = 0;
  592.     nd = p->ndim;
  593.     doin_setbound = 1;
  594.     for(i = 0; i < nd; i++)
  595.         if (q = p->dims[i].dimexpr) {
  596.             q = p->dims[i].dimexpr = make_int_expr(putx(fixtype(q)));
  597.             if (!ONEOF(q->headblock.vtype, MSKINT|MSKREAL))
  598.                 errstr("bad dimension type for %.70s",
  599.                     v->fvarname);
  600.             }
  601.     if (q = p->basexpr)
  602.         p->basexpr = make_int_expr(putx(fixtype(q)));
  603.     doin_setbound = 0;
  604.     }
  605.  
  606.  static void
  607. duparg(q)
  608.  Namep q;
  609. { errstr("duplicate argument %.80s", q->fvarname); }
  610.  
  611. /*
  612.    manipulate argument lists (allocate argument slot positions)
  613.  * keep track of return types and labels
  614.  */
  615.  
  616. LOCAL doentry(ep)
  617. struct Entrypoint *ep;
  618. {
  619.     register int type;
  620.     register Namep np;
  621.     chainp p, p1;
  622.     register Namep q;
  623.     Addrp mkarg(), rs;
  624.     int it, k;
  625.     extern char dflttype[26];
  626.     Extsym *entryname = ep->entryname;
  627.  
  628.     if (++nentry > 1)
  629.         p1_label((long)(extsymtab - entryname - 1));
  630.  
  631. /* The main program isn't allowed to have parameters, so any given
  632.    parameters are ignored */
  633.  
  634.     if(procclass == CLMAIN || procclass == CLBLOCK)
  635.         return;
  636.  
  637. /* So now we're working with something other than CLMAIN or CLBLOCK.
  638.    Determine the type of its return value. */
  639.  
  640.     impldcl( np = mkname(entryname->fextname) );
  641.     type = np->vtype;
  642.     proc_argchanges = prev_proc && type != entryname->extype;
  643.     entryname->extseen = 1;
  644.     if(proctype == TYUNKNOWN)
  645.         if( (proctype = type) == TYCHAR)
  646.             procleng = np->vleng ? np->vleng->constblock.Const.ci
  647.                          : (ftnint) (-1);
  648.  
  649.     if(proctype == TYCHAR)
  650.     {
  651.         if(type != TYCHAR)
  652.             err("noncharacter entry of character function");
  653.  
  654. /* Functions returning type   char   can only have multiple entries if all
  655.    entries return the same length */
  656.  
  657.         else if( (np->vleng ? np->vleng->constblock.Const.ci :
  658.             (ftnint) (-1)) != procleng)
  659.             err("mismatched character entry lengths");
  660.     }
  661.     else if(type == TYCHAR)
  662.         err("character entry of noncharacter function");
  663.     else if(type != proctype)
  664.         multitype = YES;
  665.     if(rtvlabel[type] == 0)
  666.         rtvlabel[type] = newlabel();
  667.     ep->typelabel = rtvlabel[type];
  668.  
  669.     if(type == TYCHAR)
  670.     {
  671.         if(chslot < 0)
  672.         {
  673.             chslot = nextarg(TYADDR);
  674.             chlgslot = nextarg(TYLENG);
  675.         }
  676.         np->vstg = STGARG;
  677.  
  678. /* Put a new argument in the function, one which will hold the result of
  679.    a character function.  This will have to be named sometime, probably in
  680.    mkarg(). */
  681.  
  682.         if(procleng < 0) {
  683.             np->vleng = (expptr) mkarg(TYLENG, chlgslot);
  684.             np->vleng->addrblock.uname_tag = UNAM_IDENT;
  685.             strcpy (np -> vleng -> addrblock.user.ident,
  686.                 new_func_length());
  687.             }
  688.         if (!xretslot[TYCHAR]) {
  689.             xretslot[TYCHAR] = rs =
  690.                 autovar(0, type, ISCONST(np->vleng)
  691.                     ? np->vleng : ICON(0), "");
  692.             strcpy(rs->user.ident, "ret_val");
  693.             }
  694.     }
  695.  
  696. /* Handle a   complex   return type -- declare a new parameter (pointer to
  697.    a complex value) */
  698.  
  699.     else if( ISCOMPLEX(type) ) {
  700.         if (!xretslot[type])
  701.             xretslot[type] =
  702.                 autovar(0, type, EXNULL, " ret_val");
  703.                 /* the blank is for use in out_addr */
  704.         np->vstg = STGARG;
  705.         if(cxslot < 0)
  706.             cxslot = nextarg(TYADDR);
  707.         }
  708.     else if (type != TYSUBR) {
  709.         if (type == TYUNKNOWN) {
  710.             dclerr("untyped function", np);
  711.             proctype = type = np->vtype =
  712.                 dflttype[letter(np->fvarname[0])];
  713.             }
  714.         if (!xretslot[type])
  715.             xretslot[type] = retslot =
  716.                 autovar(1, type, EXNULL, " ret_val");
  717.                 /* the blank is for use in out_addr */
  718.         np->vstg = STGAUTO;
  719.         }
  720.  
  721.     for(p = ep->arglist ; p ; p = p->nextp)
  722.         if(! (( q = (Namep) (p->datap) )->vknownarg) ) {
  723.             q->vknownarg = 1;
  724.             q->vardesc.varno = nextarg(TYADDR);
  725.             allargs = mkchain((char *)q, allargs);
  726.             q->argno = nallargs++;
  727.             }
  728.         else if (nentry == 1)
  729.             duparg(q);
  730.         else for(p1 = ep->arglist ; p1 != p; p1 = p1->nextp)
  731.             if ((Namep)p1->datap == q)
  732.                 duparg(q);
  733.  
  734.     k = 0;
  735.     for(p = ep->arglist ; p ; p = p->nextp) {
  736.         if(! (( q = (Namep) (p->datap) )->vdcldone) )
  737.             {
  738.             impldcl(q);
  739.             q->vdcldone = YES;
  740.             if(q->vtype == TYCHAR)
  741.                 {
  742.  
  743. /* If we don't know the length of a char*(*) (i.e. a string), we must add
  744.    in this additional length argument. */
  745.  
  746.                 ++nallchargs;
  747.                 if (q->vclass == CLPROC)
  748.                     nallchargs--;
  749.                 else if (q->vleng == NULL) {
  750.                     /* character*(*) */
  751.                     q->vleng = (expptr)
  752.                         mkarg(TYLENG, nextarg(TYLENG) );
  753.                     unamstring((Addrp)q->vleng,
  754.                         new_arg_length(q));
  755.                     }
  756.                 }
  757.             }
  758.         if (q->vdimfinish)
  759.             dim_finish(q);
  760.         if (q->vtype == TYCHAR && q->vclass != CLPROC)
  761.             k++;
  762.         }
  763.  
  764.     if (entryname->extype != type)
  765.         changedtype(np);
  766.  
  767.     /* save information for checking consistency of arg lists */
  768.  
  769.     it = infertypes;
  770.     if (entryname->exproto)
  771.         infertypes = 1;
  772.     save_argtypes(ep->arglist, &entryname->arginfo, &np->arginfo,
  773.             0, np->fvarname, STGEXT, k, np->vtype, 2);
  774.     infertypes = it;
  775. }
  776.  
  777.  
  778.  
  779. LOCAL nextarg(type)
  780. int type;
  781. {
  782.     int k;
  783.     k = lastargslot;
  784.     lastargslot += typesize[type];
  785.     return(k);
  786. }
  787.  
  788.  LOCAL
  789. dim_check(q)
  790.  Namep q;
  791. {
  792.     register struct Dimblock *vdim = q->vdim;
  793.  
  794.     if(!vdim->nelt || !ISICON(vdim->nelt))
  795.         dclerr("adjustable dimension on non-argument", q);
  796.     else if (vdim->nelt->constblock.Const.ci <= 0)
  797.         dclerr("nonpositive dimension", q);
  798.     }
  799.  
  800. LOCAL dobss()
  801. {
  802.     register struct Hashentry *p;
  803.     register Namep q;
  804.     int qstg, qclass, qtype;
  805.     Extsym *e;
  806.  
  807.     for(p = hashtab ; p<lasthash ; ++p)
  808.         if(q = p->varp)
  809.         {
  810.             qstg = q->vstg;
  811.             qtype = q->vtype;
  812.             qclass = q->vclass;
  813.  
  814.             if( (qclass==CLUNKNOWN && qstg!=STGARG) ||
  815.                 (qclass==CLVAR && qstg==STGUNKNOWN) ) {
  816.                 if (!(q->vis_assigned | q->vimpldovar))
  817.                     warn1("local variable %s never used",
  818.                         q->fvarname);
  819.                 }
  820.             else if(qclass==CLVAR && qstg==STGBSS)
  821.             { ; }
  822.  
  823. /* Give external procedures the proper storage class */
  824.  
  825.             else if(qclass==CLPROC && q->vprocclass==PEXTERNAL
  826.                     && qstg!=STGARG) {
  827.                 e = mkext(q->fvarname,addunder(q->cvarname));
  828.                 e->extstg = STGEXT;
  829.                 q->vardesc.varno = e - extsymtab;
  830.                 if (e->extype != qtype)
  831.                     changedtype(q);
  832.                 }
  833.             if(qclass==CLVAR) {
  834.                 if (qstg != STGARG && q->vdim)
  835.                 dim_check(q);
  836.             } /* if qclass == CLVAR */
  837.         }
  838.  
  839. }
  840.  
  841.  
  842.  
  843. donmlist()
  844. {
  845.     register struct Hashentry *p;
  846.     register Namep q;
  847.  
  848.     for(p=hashtab; p<lasthash; ++p)
  849.         if( (q = p->varp) && q->vclass==CLNAMELIST)
  850.             namelist(q);
  851. }
  852.  
  853.  
  854. /* iarrlen -- Returns the size of the array in bytes, or -1 */
  855.  
  856. ftnint iarrlen(q)
  857. register Namep q;
  858. {
  859.     ftnint leng;
  860.  
  861.     leng = typesize[q->vtype];
  862.     if(leng <= 0)
  863.         return(-1);
  864.     if(q->vdim)
  865.         if( ISICON(q->vdim->nelt) )
  866.             leng *= q->vdim->nelt->constblock.Const.ci;
  867.         else    return(-1);
  868.     if(q->vleng)
  869.         if( ISICON(q->vleng) )
  870.             leng *= q->vleng->constblock.Const.ci;
  871.         else return(-1);
  872.     return(leng);
  873. }
  874.  
  875. namelist(np)
  876. Namep np;
  877. {
  878.     register chainp q;
  879.     register Namep v;
  880.     int y;
  881.  
  882.     if (!np->visused)
  883.         return;
  884.     y = 0;
  885.  
  886.     for(q = np->varxptr.namelist ; q ; q = q->nextp)
  887.     {
  888.         vardcl( v = (Namep) (q->datap) );
  889.         if( !ONEOF(v->vstg, MSKSTATIC) )
  890.             dclerr("may not appear in namelist", v);
  891.         else {
  892.             v->vnamelist = 1;
  893.             v->visused = 1;
  894.             v->vsave = 1;
  895.             y = 1;
  896.             }
  897.     np->visused = y;
  898.     }
  899. }
  900.  
  901. /* docommon -- called at the end of procedure declarations, before
  902.    equivalences and the procedure body */
  903.  
  904. LOCAL docommon()
  905. {
  906.     register Extsym *extptr;
  907.     register chainp q, q1;
  908.     struct Dimblock *t;
  909.     expptr neltp;
  910.     register Namep comvar;
  911.     ftnint size;
  912.     int i, k, pref, type;
  913.     extern int type_pref[];
  914.  
  915.     for(extptr = extsymtab ; extptr<nextext ; ++extptr)
  916.     if (extptr->extstg == STGCOMMON && (q = extptr->extp)) {
  917.  
  918. /* If a common declaration also had a list of variables ... */
  919.  
  920.         q = extptr->extp = revchain(q);
  921.         pref = 1;
  922.         for(k = TYCHAR; q ; q = q->nextp)
  923.         {
  924.         comvar = (Namep) (q->datap);
  925.  
  926.         if(comvar->vdcldone == NO)
  927.             vardcl(comvar);
  928.         type = comvar->vtype;
  929.         if (pref < type_pref[type])
  930.             pref = type_pref[k = type];
  931.         if(extptr->extleng % typealign[type] != 0) {
  932.             dclerr("common alignment", comvar);
  933.             --nerr; /* don't give bad return code for this */
  934. #if 0
  935.             extptr->extleng = roundup(extptr->extleng, typealign[type]);
  936. #endif
  937.         } /* if extptr -> extleng % */
  938.  
  939. /* Set the offset into the common block */
  940.  
  941.         comvar->voffset = extptr->extleng;
  942.         comvar->vardesc.varno = extptr - extsymtab;
  943.         if(type == TYCHAR)
  944.             size = comvar->vleng->constblock.Const.ci;
  945.         else
  946.             size = typesize[type];
  947.         if(t = comvar->vdim)
  948.             if( (neltp = t->nelt) && ISCONST(neltp) )
  949.             size *= neltp->constblock.Const.ci;
  950.             else
  951.             dclerr("adjustable array in common", comvar);
  952.  
  953. /* Adjust the length of the common block so far */
  954.  
  955.         extptr->extleng += size;
  956.         } /* for */
  957.  
  958.         extptr->extype = k;
  959.  
  960. /* Determine curno and, if new, save this identifier chain */
  961.  
  962.         q1 = extptr->extp;
  963.         for (q = extptr->allextp, i = 0; q; i++, q = q->nextp)
  964.         if (struct_eq((chainp)q->datap, q1))
  965.             break;
  966.         if (q)
  967.         extptr->curno = extptr->maxno - i;
  968.         else {
  969.         extptr->curno = ++extptr->maxno;
  970.         extptr->allextp = mkchain((char *)extptr->extp,
  971.                         extptr->allextp);
  972.         }
  973.     } /* if extptr -> extstg == STGCOMMON */
  974.  
  975. /* Now the hash table entries have STGCOMMON, vdcldone, voffset, and
  976.    varno.  And the common block itself has its full size in extleng. */
  977.  
  978. } /* docommon */
  979.  
  980.  
  981. /* copy_data -- copy the Namep entries so they are available even after
  982.    the hash table is empty */
  983.  
  984. copy_data (list)
  985. chainp list;
  986. {
  987.     for (; list; list = list -> nextp) {
  988.     Namep namep = ALLOC (Nameblock);
  989.     int size, nd, i;
  990.     struct Dimblock *dp;
  991.  
  992.     cpn(sizeof(struct Nameblock), list->datap, (char *)namep);
  993.     namep->fvarname = strcpy(gmem(strlen(namep->fvarname)+1,0),
  994.         namep->fvarname);
  995.     namep->cvarname = strcmp(namep->fvarname, namep->cvarname)
  996.         ? strcpy(gmem(strlen(namep->cvarname)+1,0), namep->cvarname)
  997.         : namep->fvarname;
  998.     if (namep -> vleng)
  999.         namep -> vleng = (expptr) cpexpr (namep -> vleng);
  1000.     if (namep -> vdim) {
  1001.         nd = namep -> vdim -> ndim;
  1002.         size = sizeof(int) + (3 + 2 * nd) * sizeof (expptr);
  1003.         dp = (struct Dimblock *) ckalloc (size);
  1004.         cpn(size, (char *)namep->vdim, (char *)dp);
  1005.         namep -> vdim = dp;
  1006.         dp->nelt = (expptr)cpexpr(dp->nelt);
  1007.         for (i = 0; i < nd; i++) {
  1008.         dp -> dims[i].dimsize = (expptr) cpexpr (dp -> dims[i].dimsize);
  1009.         } /* for */
  1010.     } /* if */
  1011.     list -> datap = (char *) namep;
  1012.     } /* for */
  1013. } /* copy_data */
  1014.  
  1015.  
  1016.  
  1017. LOCAL docomleng()
  1018. {
  1019.     register Extsym *p;
  1020.  
  1021.     for(p = extsymtab ; p < nextext ; ++p)
  1022.         if(p->extstg == STGCOMMON)
  1023.         {
  1024.             if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng
  1025.                 && strcmp(Blank, p->cextname) )
  1026.                 warn1("incompatible lengths for common block %.60s",
  1027.                     p->fextname);
  1028.             if(p->maxleng < p->extleng)
  1029.                 p->maxleng = p->extleng;
  1030.             p->extleng = 0;
  1031.         }
  1032. }
  1033.  
  1034.  
  1035. /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
  1036.  
  1037. frtemp(p)
  1038. Addrp p;
  1039. {
  1040.     /* put block on chain of temps to be reclaimed */
  1041.     holdtemps = mkchain((char *)p, holdtemps);
  1042. }
  1043.  
  1044.  void
  1045. freetemps()
  1046. {
  1047.     register chainp p, p1;
  1048.     register Addrp q;
  1049.     register int t;
  1050.  
  1051.     p1 = holdtemps;
  1052.     while(p = p1) {
  1053.         q = (Addrp)p->datap;
  1054.         t = q->vtype;
  1055.         if (t == TYCHAR && q->varleng != 0) {
  1056.             /* restore clobbered character string lengths */
  1057.             frexpr(q->vleng);
  1058.             q->vleng = ICON(q->varleng);
  1059.             }
  1060.         p1 = p->nextp;
  1061.         p->nextp = templist[t];
  1062.         templist[t] = p;
  1063.         }
  1064.     holdtemps = 0;
  1065.     }
  1066.  
  1067. /* allocate an automatic variable slot for each of   nelt   variables */
  1068.  
  1069. Addrp autovar(nelt0, t, lengp, name)
  1070. register int nelt0, t;
  1071. expptr lengp;
  1072. char *name;
  1073. {
  1074.     ftnint leng;
  1075.     register Addrp q;
  1076.     char *temp_name ();
  1077.     register int nelt = nelt0 > 0 ? nelt0 : 1;
  1078.     extern char *av_pfix[];
  1079.  
  1080.     if(t == TYCHAR)
  1081.         if( ISICON(lengp) )
  1082.             leng = lengp->constblock.Const.ci;
  1083.         else    {
  1084.             Fatal("automatic variable of nonconstant length");
  1085.         }
  1086.     else
  1087.         leng = typesize[t];
  1088.  
  1089.     q = ALLOC(Addrblock);
  1090.     q->tag = TADDR;
  1091.     q->vtype = t;
  1092.     if(t == TYCHAR)
  1093.     {
  1094.         q->vleng = ICON(leng);
  1095.         q->varleng = leng;
  1096.     }
  1097.     q->vstg = STGAUTO;
  1098.     q->ntempelt = nelt;
  1099.     q->isarray = (nelt > 1);
  1100.     q->memoffset = ICON(0);
  1101.  
  1102.     /* kludge for nls so we can have ret_val rather than ret_val_4 */
  1103.     if (*name == ' ')
  1104.         unamstring(q, name);
  1105.     else {
  1106.         q->uname_tag = UNAM_IDENT;
  1107.         temp_name(av_pfix[t], ++autonum[t], q->user.ident);
  1108.         }
  1109.     if (nelt0 > 0)
  1110.         declare_new_addr (q);
  1111.     return(q);
  1112. }
  1113.  
  1114.  
  1115. /* Returns a temporary of the appropriate type.  Will reuse existing
  1116.    temporaries when possible */
  1117.  
  1118. Addrp mktmpn(nelt, type, lengp)
  1119. int nelt;
  1120. register int type;
  1121. expptr lengp;
  1122. {
  1123.     ftnint leng;
  1124.     chainp p, oldp;
  1125.     register Addrp q;
  1126.  
  1127.     if(type==TYUNKNOWN || type==TYERROR)
  1128.         badtype("mktmpn", type);
  1129.  
  1130.     if(type==TYCHAR)
  1131.         if(lengp && ISICON(lengp) )
  1132.             leng = lengp->constblock.Const.ci;
  1133.         else    {
  1134.             err("adjustable length");
  1135.             return( (Addrp) errnode() );
  1136.         }
  1137.     else if (type > TYCHAR || type < TYADDR) {
  1138.         erri("mktmpn: unexpected type %d", type);
  1139.         exit(1);
  1140.         }
  1141. /*
  1142.  * if a temporary of appropriate shape is on the templist,
  1143.  * remove it from the list and return it
  1144.  */
  1145.     for(oldp=CHNULL, p=templist[type];  p  ;  oldp=p, p=p->nextp)
  1146.     {
  1147.         q = (Addrp) (p->datap);
  1148.         if(q->ntempelt==nelt &&
  1149.             (type!=TYCHAR || q->vleng->constblock.Const.ci==leng) )
  1150.         {
  1151.             if(oldp)
  1152.                 oldp->nextp = p->nextp;
  1153.             else
  1154.                 templist[type] = p->nextp;
  1155.             free( (charptr) p);
  1156.             return(q);
  1157.         }
  1158.     }
  1159.     q = autovar(nelt, type, lengp, "");
  1160.     return(q);
  1161. }
  1162.  
  1163.  
  1164.  
  1165.  
  1166. /* mktmp -- create new local variable; call it something like   name
  1167.    lengp   is taken directly, not copied */
  1168.  
  1169. Addrp mktmp(type, lengp)
  1170. int type;
  1171. expptr lengp;
  1172. {
  1173.     Addrp rv;
  1174.     /* arrange for temporaries to be recycled */
  1175.     /* at the end of this statement... */
  1176.     rv = mktmpn(1,type,lengp);
  1177.     frtemp((Addrp)cpexpr((expptr)rv));
  1178.     return rv;
  1179. }
  1180.  
  1181. /* mktmp0 omits frtemp() */
  1182. Addrp mktmp0(type, lengp)
  1183. int type;
  1184. expptr lengp;
  1185. {
  1186.     Addrp rv;
  1187.     /* arrange for temporaries to be recycled */
  1188.     /* when this Addrp is freed */
  1189.     rv = mktmpn(1,type,lengp);
  1190.     rv->istemp = YES;
  1191.     return rv;
  1192. }
  1193.  
  1194. /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
  1195.  
  1196. /* comblock -- Declare a new common block.  Input parameters name the block;
  1197.    s   will be NULL if the block is unnamed */
  1198.  
  1199. Extsym *comblock(s)
  1200.  register char *s;
  1201. {
  1202.     Extsym *p;
  1203.     register char *t;
  1204.     register int c, i;
  1205.     char cbuf[256], *s0;
  1206.  
  1207. /* Give the unnamed common block a unique name */
  1208.  
  1209.     if(*s == 0)
  1210.         p = mkext(Blank,Blank);
  1211.     else {
  1212.         s0 = s;
  1213.         t = cbuf;
  1214.         for(i = 0; c = *t = *s++; t++)
  1215.             if (c == '_')
  1216.                 i = 1;
  1217.         if (i)
  1218.             *t++ = '_';
  1219.         t[0] = '_';
  1220.         t[1] = 0;
  1221.         p = mkext(s0,cbuf);
  1222.         }
  1223.     if(p->extstg == STGUNKNOWN)
  1224.         p->extstg = STGCOMMON;
  1225.     else if(p->extstg != STGCOMMON)
  1226.     {
  1227.         errstr("%.68s cannot be a common block name", s);
  1228.         return(0);
  1229.     }
  1230.  
  1231.     return( p );
  1232. }
  1233.  
  1234.  
  1235. /* incomm -- add a new variable to a common declaration */
  1236.  
  1237. incomm(c, v)
  1238. Extsym *c;
  1239. Namep v;
  1240. {
  1241.     if (!c)
  1242.         return;
  1243.     if(v->vstg != STGUNKNOWN && !v->vimplstg)
  1244.         dclerr(v->vstg == STGARG
  1245.             ? "dummy arguments cannot be in common"
  1246.             : "incompatible common declaration", v);
  1247.     else
  1248.     {
  1249.         v->vstg = STGCOMMON;
  1250.         c->extp = mkchain((char *)v, c->extp);
  1251.     }
  1252. }
  1253.  
  1254.  
  1255.  
  1256.  
  1257. /* settype -- set the type or storage class of a Namep object.  If
  1258.    v -> vstg == STGUNKNOWN && type < 0,   attempt to reset vstg to be
  1259.    -type.  This function will not change any earlier definitions in   v,
  1260.    in will only attempt to fill out more information give the other params */
  1261.  
  1262. settype(v, type, length)
  1263. register Namep  v;
  1264. register int type;
  1265. register ftnint length;
  1266. {
  1267.     int type1;
  1268.  
  1269.     if(type == TYUNKNOWN)
  1270.         return;
  1271.  
  1272.     if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
  1273.     {
  1274.         v->vtype = TYSUBR;
  1275.         frexpr(v->vleng);
  1276.         v->vleng = 0;
  1277.         v->vimpltype = 0;
  1278.     }
  1279.     else if(type < 0)    /* storage class set */
  1280.     {
  1281.         if(v->vstg == STGUNKNOWN)
  1282.             v->vstg = - type;
  1283.         else if(v->vstg != -type)
  1284.             dclerr("incompatible storage declarations", v);
  1285.     }
  1286.     else if(v->vtype == TYUNKNOWN || v->vimpltype && v->vtype != type)
  1287.     {
  1288.         if( (v->vtype = lengtype(type, length))==TYCHAR )
  1289.             if (length>=0)
  1290.                 v->vleng = ICON(length);
  1291.             else if (parstate >= INDATA)
  1292.                 v->vleng = ICON(1);    /* avoid a memory fault */
  1293.         v->vimpltype = 0;
  1294.  
  1295.         if (v->vclass == CLPROC) {
  1296.             if (v->vstg == STGEXT
  1297.              && (type1 = extsymtab[v->vardesc.varno].extype)
  1298.              &&  type1 != v->vtype)
  1299.                 changedtype(v);
  1300.             else if (v->vprocclass == PTHISPROC
  1301.                     && (parstate >= INDATA
  1302.                         || procclass == CLMAIN)
  1303.                     && !xretslot[type]) {
  1304.                 xretslot[type] = autovar(ONEOF(type,
  1305.                     MSKCOMPLEX|MSKCHAR) ? 0 : 1, type,
  1306.                     v->vleng, " ret_val");
  1307.                 if (procclass == CLMAIN)
  1308.                     errstr(
  1309.                 "illegal use of %.60s (main program name)",
  1310.                     v->fvarname);
  1311.                 /* not completely right, but enough to */
  1312.                 /* avoid memory faults; we won't */
  1313.                 /* emit any C as we have illegal Fortran */
  1314.                 }
  1315.             }
  1316.     }
  1317.     else if(v->vtype!=type) {
  1318.  incompat:
  1319.         dclerr("incompatible type declarations", v);
  1320.         }
  1321.     else if (type==TYCHAR)
  1322.         if (v->vleng && v->vleng->constblock.Const.ci != length)
  1323.             goto incompat;
  1324.         else if (parstate >= INDATA)
  1325.             v->vleng = ICON(1);    /* avoid a memory fault */
  1326. }
  1327.  
  1328.  
  1329.  
  1330.  
  1331.  
  1332. /* lengtype -- returns the proper compiler type, given input of Fortran
  1333.    type and length specifier */
  1334.  
  1335. lengtype(type, len)
  1336. register int type;
  1337. ftnint len;
  1338. {
  1339.     register int length = (int)len;
  1340.     switch(type)
  1341.     {
  1342.     case TYREAL:
  1343.         if(length == typesize[TYDREAL])
  1344.             return(TYDREAL);
  1345.         if(length == typesize[TYREAL])
  1346.             goto ret;
  1347.         break;
  1348.  
  1349.     case TYCOMPLEX:
  1350.         if(length == typesize[TYDCOMPLEX])
  1351.             return(TYDCOMPLEX);
  1352.         if(length == typesize[TYCOMPLEX])
  1353.             goto ret;
  1354.         break;
  1355.  
  1356.     case TYSHORT:
  1357.     case TYDREAL:
  1358.     case TYDCOMPLEX:
  1359.     case TYCHAR:
  1360.     case TYUNKNOWN:
  1361.     case TYSUBR:
  1362.     case TYERROR:
  1363.         goto ret;
  1364.  
  1365.     case TYLOGICAL:
  1366.         if(length == typesize[TYLOGICAL])
  1367.             goto ret;
  1368.         if(length == 1 || length == 2) {
  1369.             erri("treating LOGICAL*%d as LOGICAL", length);
  1370.             --nerr;    /* allow generation of .c file */
  1371.             goto ret;
  1372.             }
  1373.         break;
  1374.  
  1375.     case TYLONG:
  1376.         if(length == 0)
  1377.             return(tyint);
  1378.         if(length == typesize[TYSHORT])
  1379.             return(TYSHORT);
  1380.         if(length == typesize[TYLONG])
  1381.             goto ret;
  1382.         break;
  1383.     default:
  1384.         badtype("lengtype", type);
  1385.     }
  1386.  
  1387.     if(len != 0)
  1388.         err("incompatible type-length combination");
  1389.  
  1390. ret:
  1391.     return(type);
  1392. }
  1393.  
  1394.  
  1395.  
  1396.  
  1397.  
  1398. /* setintr -- Set Intrinsic function */
  1399.  
  1400. setintr(v)
  1401. register Namep  v;
  1402. {
  1403.     int k;
  1404.  
  1405.     if(v->vstg == STGUNKNOWN)
  1406.         v->vstg = STGINTR;
  1407.     else if(v->vstg!=STGINTR)
  1408.         dclerr("incompatible use of intrinsic function", v);
  1409.     if(v->vclass==CLUNKNOWN)
  1410.         v->vclass = CLPROC;
  1411.     if(v->vprocclass == PUNKNOWN)
  1412.         v->vprocclass = PINTRINSIC;
  1413.     else if(v->vprocclass != PINTRINSIC)
  1414.         dclerr("invalid intrinsic declaration", v);
  1415.     if(k = intrfunct(v->fvarname)) {
  1416.         if ((*(struct Intrpacked *)&k).f4)
  1417.             if (noextflag)
  1418.                 goto unknown;
  1419.             else
  1420.                 dcomplex_seen++;
  1421.         v->vardesc.varno = k;
  1422.         }
  1423.     else {
  1424.  unknown:
  1425.         dclerr("unknown intrinsic function", v);
  1426.         }
  1427. }
  1428.  
  1429.  
  1430.  
  1431. /* setext -- Set External declaration -- assume that unknowns will become
  1432.    procedures */
  1433.  
  1434. setext(v)
  1435. register Namep  v;
  1436. {
  1437.     if(v->vclass == CLUNKNOWN)
  1438.         v->vclass = CLPROC;
  1439.     else if(v->vclass != CLPROC)
  1440.         dclerr("invalid external declaration", v);
  1441.  
  1442.     if(v->vprocclass == PUNKNOWN)
  1443.         v->vprocclass = PEXTERNAL;
  1444.     else if(v->vprocclass != PEXTERNAL)
  1445.         dclerr("invalid external declaration", v);
  1446. } /* setext */
  1447.  
  1448.  
  1449.  
  1450.  
  1451. /* create dimensions block for array variable */
  1452.  
  1453. setbound(v, nd, dims)
  1454. register Namep  v;
  1455. int nd;
  1456. struct Dims dims[ ];
  1457. {
  1458.     register expptr q, t;
  1459.     register struct Dimblock *p;
  1460.     int i;
  1461.     extern chainp new_vars;
  1462.     char buf[256];
  1463.  
  1464.     if(v->vclass == CLUNKNOWN)
  1465.         v->vclass = CLVAR;
  1466.     else if(v->vclass != CLVAR)
  1467.     {
  1468.         dclerr("only variables may be arrays", v);
  1469.         return;
  1470.     }
  1471.  
  1472.     v->vdim = p = (struct Dimblock *)
  1473.         ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
  1474.     p->ndim = nd--;
  1475.     p->nelt = ICON(1);
  1476.     doin_setbound = 1;
  1477.  
  1478.     for(i = 0; i <= nd; ++i)
  1479.     {
  1480.         if( (q = dims[i].ub) == NULL)
  1481.         {
  1482.             if(i == nd)
  1483.             {
  1484.                 frexpr(p->nelt);
  1485.                 p->nelt = NULL;
  1486.             }
  1487.             else
  1488.                 err("only last bound may be asterisk");
  1489.             p->dims[i].dimsize = ICON(1);
  1490.             ;
  1491.             p->dims[i].dimexpr = NULL;
  1492.         }
  1493.         else
  1494.         {
  1495.  
  1496.             if(dims[i].lb)
  1497.             {
  1498.                 q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
  1499.                 q = mkexpr(OPPLUS, q, ICON(1) );
  1500.             }
  1501.             if( ISCONST(q) )
  1502.             {
  1503.                 p->dims[i].dimsize = q;
  1504.                 p->dims[i].dimexpr = (expptr) PNULL;
  1505.             }
  1506.             else {
  1507.                 sprintf(buf, " %s_dim%d", v->fvarname, i+1);
  1508.                 p->dims[i].dimsize = (expptr)
  1509.                     autovar(1, tyint, EXNULL, buf);
  1510.                 p->dims[i].dimexpr = q;
  1511.                 if (i == nd)
  1512.                     v->vlastdim = new_vars;
  1513.                 v->vdimfinish = 1;
  1514.             }
  1515.             if(p->nelt)
  1516.                 p->nelt = mkexpr(OPSTAR, p->nelt,
  1517.                     cpexpr(p->dims[i].dimsize) );
  1518.         }
  1519.     }
  1520.  
  1521.     q = dims[nd].lb;
  1522.     if(q == NULL)
  1523.         q = ICON(1);
  1524.  
  1525.     for(i = nd-1 ; i>=0 ; --i)
  1526.     {
  1527.         t = dims[i].lb;
  1528.         if(t == NULL)
  1529.             t = ICON(1);
  1530.         if(p->dims[i].dimsize)
  1531.             q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
  1532.     }
  1533.  
  1534.     if( ISCONST(q) )
  1535.     {
  1536.         p->baseoffset = q;
  1537.         p->basexpr = NULL;
  1538.     }
  1539.     else
  1540.     {
  1541.         sprintf(buf, " %s_offset", v->fvarname);
  1542.         p->baseoffset = (expptr) autovar(1, tyint, EXNULL, buf);
  1543.         p->basexpr = q;
  1544.         v->vdimfinish = 1;
  1545.     }
  1546.     doin_setbound = 0;
  1547. }
  1548.  
  1549.  
  1550.  
  1551. wr_abbrevs (outfile, function_head, vars)
  1552. FILE *outfile;
  1553. int function_head;
  1554. chainp vars;
  1555. {
  1556.     for (; vars; vars = vars -> nextp) {
  1557.     Namep name = (Namep) vars -> datap;
  1558.     if (!name->visused)
  1559.         continue;
  1560.  
  1561.     if (function_head)
  1562.         nice_printf (outfile, "#define ");
  1563.     else
  1564.         nice_printf (outfile, "#undef ");
  1565.     out_name (outfile, name);
  1566.  
  1567.     if (function_head) {
  1568.         Extsym *comm = &extsymtab[name -> vardesc.varno];
  1569.  
  1570.         nice_printf (outfile, " (");
  1571.         extern_out (outfile, comm);
  1572.         nice_printf (outfile, "%d.", comm->curno);
  1573.         nice_printf (outfile, "%s)", name->cvarname);
  1574.     } /* if function_head */
  1575.     nice_printf (outfile, "\n");
  1576.     } /* for */
  1577. } /* wr_abbrevs */
  1578.