home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / cmd / f77 / proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1979-05-05  |  15.3 KB  |  884 lines
  1. #include "defs"
  2.  
  3. /* start a new procedure */
  4.  
  5. newproc()
  6. {
  7. if(parstate != OUTSIDE)
  8.     {
  9.     execerr("missing end statement", 0);
  10.     endproc();
  11.     }
  12.  
  13. parstate = INSIDE;
  14. procclass = CLMAIN;    /* default */
  15. }
  16.  
  17.  
  18.  
  19. /* end of procedure. generate variables, epilogs, and prologs */
  20.  
  21. endproc()
  22. {
  23. struct labelblock *lp;
  24.  
  25. if(parstate < INDATA)
  26.     enddcl();
  27. if(ctlstack >= ctls)
  28.     err("DO loop or BLOCK IF not closed");
  29. for(lp = labeltab ; lp < labtabend ; ++lp)
  30.     if(lp->stateno!=0 && lp->labdefined==NO)
  31.         err1("missing statement number %s", convic(lp->stateno) );
  32.  
  33. epicode();
  34. procode();
  35. dobss();
  36. prdbginfo();
  37.  
  38. #if FAMILY == SCJ
  39.     putbracket();
  40. #endif
  41.  
  42. procinit();    /* clean up for next procedure */
  43. }
  44.  
  45.  
  46.  
  47. /* End of declaration section of procedure.  Allocate storage. */
  48.  
  49. enddcl()
  50. {
  51. register struct entrypoint *p;
  52.  
  53. parstate = INEXEC;
  54. docommon();
  55. doequiv();
  56. docomleng();
  57. for(p = entries ; p ; p = p->nextp)
  58.     doentry(p);
  59. }
  60.  
  61. /* ROUTINES CALLED WHEN ENCOUNTERING ENTRY POINTS */
  62.  
  63. /* Main program or Block data */
  64.  
  65. startproc(progname, class)
  66. struct extsym * progname;
  67. int class;
  68. {
  69. register struct entrypoint *p;
  70.  
  71. p = ALLOC(entrypoint);
  72. if(class == CLMAIN)
  73.     puthead("MAIN__", CLMAIN);
  74. else
  75.     puthead(NULL, CLBLOCK);
  76. if(class == CLMAIN)
  77.     newentry( mkname(5, "MAIN_") );
  78. p->entryname = progname;
  79. p->entrylabel = newlabel();
  80. entries = p;
  81.  
  82. procclass = class;
  83. retlabel = newlabel();
  84. fprintf(diagfile, "   %s", (class==CLMAIN ? "MAIN" : "BLOCK DATA") );
  85. if(progname)
  86.     fprintf(diagfile, " %s", nounder(XL, procname = progname->extname) );
  87. fprintf(diagfile, ":\n");
  88. }
  89.  
  90. /* subroutine or function statement */
  91.  
  92. struct extsym *newentry(v)
  93. register struct nameblock *v;
  94. {
  95. register struct extsym *p;
  96. struct extsym *mkext();
  97.  
  98. p = mkext( varunder(VL, v->varname) );
  99.  
  100. if(p==NULL || p->extinit || ! ONEOF(p->extstg, M(STGUNKNOWN)|M(STGEXT)) )
  101.     {
  102.     if(p == 0)
  103.         dclerr("invalid entry name", v);
  104.     else    dclerr("external name already used", v);
  105.     return(0);
  106.     }
  107. v->vstg = STGAUTO;
  108. v->vprocclass = PTHISPROC;
  109. v->vclass = CLPROC;
  110. p->extstg = STGEXT;
  111. p->extinit = YES;
  112. return(p);
  113. }
  114.  
  115.  
  116. entrypt(class, type, length, entry, args)
  117. int class, type;
  118. ftnint length;
  119. struct extsym *entry;
  120. chainp args;
  121. {
  122. register struct nameblock *q;
  123. register struct entrypoint *p;
  124.  
  125. if(class != CLENTRY)
  126.     puthead( varstr(XL, procname = entry->extname), class);
  127. if(class == CLENTRY)
  128.     fprintf(diagfile, "       entry ");
  129. fprintf(diagfile, "   %s:\n", nounder(XL, entry->extname));
  130. q = mkname(VL, nounder(XL,entry->extname) );
  131.  
  132. if( (type = lengtype(type, (int) length)) != TYCHAR)
  133.     length = 0;
  134. if(class == CLPROC)
  135.     {
  136.     procclass = CLPROC;
  137.     proctype = type;
  138.     procleng = length;
  139.  
  140.     retlabel = newlabel();
  141.     if(type == TYSUBR)
  142.         ret0label = newlabel();
  143.     }
  144.  
  145. p = ALLOC(entrypoint);
  146. entries = hookup(entries, p);
  147. p->entryname = entry;
  148. p->arglist = args;
  149. p->entrylabel = newlabel();
  150. p->enamep = q;
  151.  
  152. if(class == CLENTRY)
  153.     {
  154.     class = CLPROC;
  155.     if(proctype == TYSUBR)
  156.         type = TYSUBR;
  157.     }
  158.  
  159. q->vclass = class;
  160. q->vprocclass = PTHISPROC;
  161. settype(q, type, (int) length);
  162. /* hold all initial entry points till end of declarations */
  163. if(parstate >= INDATA)
  164.     doentry(p);
  165. }
  166.  
  167. /* generate epilogs */
  168.  
  169. LOCAL epicode()
  170. {
  171. register int i;
  172.  
  173. if(procclass==CLPROC)
  174.     {
  175.     if(proctype==TYSUBR)
  176.         {
  177.         putlabel(ret0label);
  178.         if(substars)
  179.             putforce(TYINT, ICON(0) );
  180.         putlabel(retlabel);
  181.         goret(TYSUBR);
  182.         }
  183.     else    {
  184.         putlabel(retlabel);
  185.         if(multitypes)
  186.             {
  187.             typeaddr = autovar(1, TYADDR, NULL);
  188.             putbranch( cpexpr(typeaddr) );
  189.             for(i = 0; i < NTYPES ; ++i)
  190.                 if(rtvlabel[i] != 0)
  191.                     {
  192.                     putlabel(rtvlabel[i]);
  193.                     retval(i);
  194.                     }
  195.             }
  196.         else
  197.             retval(proctype);
  198.         }
  199.     }
  200.  
  201. else if(procclass != CLBLOCK)
  202.     {
  203.     putlabel(retlabel);
  204.     goret(TYSUBR);
  205.     }
  206. }
  207.  
  208.  
  209. /* generate code to return value of type  t */
  210.  
  211. LOCAL retval(t)
  212. register int t;
  213. {
  214. register struct addrblock *p;
  215.  
  216. switch(t)
  217.     {
  218.     case TYCHAR:
  219.     case TYCOMPLEX:
  220.     case TYDCOMPLEX:
  221.         break;
  222.  
  223.     case TYLOGICAL:
  224.         t = tylogical;
  225.     case TYADDR:
  226.     case TYSHORT:
  227.     case TYLONG:
  228.         p = cpexpr(retslot);
  229.         p->vtype = t;
  230.         putforce(t, p);
  231.         break;
  232.  
  233.     case TYREAL:
  234.     case TYDREAL:
  235.         p = cpexpr(retslot);
  236.         p->vtype = t;
  237.         putforce(t, p);
  238.         break;
  239.  
  240.     default:
  241.         fatal1("retval: impossible type %d", t);
  242.     }
  243. goret(t);
  244. }
  245.  
  246.  
  247. /* Allocate extra argument array if needed. Generate prologs. */
  248.  
  249. LOCAL procode()
  250. {
  251. register struct entrypoint *p;
  252. struct addrblock *argvec;
  253.  
  254. #if TARGET==GCOS
  255.     argvec = autovar(lastargslot/SZADDR, TYADDR, NULL);
  256. #else
  257.     if(lastargslot>0 && nentry>1)
  258.         argvec = autovar(lastargslot/SZADDR, TYADDR, NULL);
  259.     else
  260.         argvec = NULL;
  261. #endif
  262.  
  263.  
  264. #if TARGET == PDP11
  265.     /* for the optimizer */
  266.     if(fudgelabel)
  267.         putlabel(fudgelabel);
  268. #endif
  269.  
  270. for(p = entries ; p ; p = p->nextp)
  271.     prolog(p, argvec);
  272.  
  273. #if FAMILY == SCJ
  274.     putrbrack(procno);
  275. #endif
  276.  
  277. prendproc();
  278. }
  279.  
  280. /*
  281.    manipulate argument lists (allocate argument slot positions)
  282.  * keep track of return types and labels
  283.  */
  284.  
  285. LOCAL doentry(ep)
  286. struct entrypoint *ep;
  287. {
  288. register int type;
  289. register struct nameblock *np;
  290. chainp p;
  291. register struct nameblock *q;
  292.  
  293. ++nentry;
  294. if(procclass == CLMAIN)
  295.     {
  296.     putlabel(ep->entrylabel);
  297.     return;
  298.     }
  299. else if(procclass == CLBLOCK)
  300.     return;
  301.  
  302. impldcl( np = mkname(VL, nounder(XL, ep->entryname->extname) ) );
  303. type = np->vtype;
  304. if(proctype == TYUNKNOWN)
  305.     if( (proctype = type) == TYCHAR)
  306.         procleng = (np->vleng ? np->vleng->const.ci : (ftnint) 0);
  307.  
  308. if(proctype == TYCHAR)
  309.     {
  310.     if(type != TYCHAR)
  311.         err("noncharacter entry of character function");
  312.     else if( (np->vleng ? np->vleng->const.ci : (ftnint) 0) != procleng)
  313.         err("mismatched character entry lengths");
  314.     }
  315. else if(type == TYCHAR)
  316.     err("character entry of noncharacter function");
  317. else if(type != proctype)
  318.     multitype = YES;
  319. if(rtvlabel[type] == 0)
  320.     rtvlabel[type] = newlabel();
  321. ep->typelabel = rtvlabel[type];
  322.  
  323. if(type == TYCHAR)
  324.     {
  325.     if(chslot < 0)
  326.         {
  327.         chslot = nextarg(TYADDR);
  328.         chlgslot = nextarg(TYLENG);
  329.         }
  330.     np->vstg = STGARG;
  331.     np->vardesc.varno = chslot;
  332.     if(procleng == 0)
  333.         np->vleng = mkarg(TYLENG, chlgslot);
  334.     }
  335. else if( ISCOMPLEX(type) )
  336.     {
  337.     np->vstg = STGARG;
  338.     if(cxslot < 0)
  339.         cxslot = nextarg(TYADDR);
  340.     np->vardesc.varno = cxslot;
  341.     }
  342. else if(type != TYSUBR)
  343.     {
  344.     if(nentry == 1)
  345.         retslot = autovar(1, TYDREAL, NULL);
  346.     np->vstg = STGAUTO;
  347.     np->voffset = retslot->memoffset->const.ci;
  348.     }
  349.  
  350. for(p = ep->arglist ; p ; p = p->nextp)
  351.     if(! ((q = p->datap)->vdcldone) )
  352.         q->vardesc.varno = nextarg(TYADDR);
  353.  
  354. for(p = ep->arglist ; p ; p = p->nextp)
  355.     if(! ((q = p->datap)->vdcldone) )
  356.         {
  357.         impldcl(q);
  358.         q->vdcldone = YES;
  359.         if(q->vtype == TYCHAR)
  360.             {
  361.             if(q->vleng == NULL)    /* character*(*) */
  362.                 q->vleng = mkarg(TYLENG, nextarg(TYLENG) );
  363.             else if(nentry == 1)
  364.                 nextarg(TYLENG);
  365.             }
  366.         else if(q->vclass==CLPROC && nentry==1)
  367.             nextarg(TYLENG) ;
  368.         }
  369.  
  370. putlabel(ep->entrylabel);
  371. }
  372.  
  373.  
  374.  
  375. LOCAL nextarg(type)
  376. int type;
  377. {
  378. int k;
  379. k = lastargslot;
  380. lastargslot += typesize[type];
  381. return(k);
  382. }
  383.  
  384. /* generate variable references */
  385.  
  386. LOCAL dobss()
  387. {
  388. register struct hashentry *p;
  389. register struct nameblock *q;
  390. register int i;
  391. int align;
  392. ftnint leng, iarrl, iarrlen();
  393. struct extsym *mkext();
  394. char *memname();
  395.  
  396. pruse(asmfile, USEBSS);
  397.  
  398. for(p = hashtab ; p<lasthash ; ++p)
  399.     if(q = p->varp)
  400.     {
  401.     if( (q->vclass==CLUNKNOWN && q->vstg!=STGARG) ||
  402.         (q->vclass==CLVAR && q->vstg==STGUNKNOWN) )
  403.         warn1("local variable %s never used", varstr(VL,q->varname) );
  404.     else if(q->vclass==CLVAR && q->vstg==STGBSS)
  405.         {
  406.         align = (q->vtype==TYCHAR ? ALILONG : typealign[q->vtype]);
  407.         if(bssleng % align != 0)
  408.             {
  409.             bssleng = roundup(bssleng, align);
  410.             preven(align);
  411.             }
  412.         prlocvar( memname(STGBSS, q->vardesc.varno), iarrl = iarrlen(q) );
  413.         bssleng += iarrl;
  414.         }
  415.     else if(q->vclass==CLPROC && q->vprocclass==PEXTERNAL && q->vstg!=STGARG)
  416.         mkext(varunder(VL, q->varname)) ->extstg = STGEXT;
  417.  
  418.     if(q->vclass==CLVAR && q->vstg!=STGARG)
  419.         {
  420.         if(q->vdim && !ISICON(q->vdim->nelt) )
  421.             dclerr("adjustable dimension on non-argument", q);
  422.         if(q->vtype==TYCHAR && (q->vleng==NULL || !ISICON(q->vleng)))
  423.             dclerr("adjustable leng on nonargument", q);
  424.         }
  425.     }
  426.  
  427. for(i = 0 ; i < nequiv ; ++i)
  428.     if(eqvclass[i].eqvinit==NO && (leng = eqvclass[i].eqvleng)!=0 )
  429.         {
  430.         bssleng = roundup(bssleng, ALIDOUBLE);
  431.         preven(ALIDOUBLE);
  432.         prlocvar( memname(STGEQUIV, i), leng);
  433.         bssleng += leng;
  434.         }
  435. }
  436.  
  437.  
  438.  
  439.  
  440. doext()
  441. {
  442. struct extsym *p;
  443.  
  444. for(p = extsymtab ; p<nextext ; ++p)
  445.     prext( varstr(XL, p->extname), p->maxleng, p->extinit);
  446. }
  447.  
  448.  
  449.  
  450.  
  451. ftnint iarrlen(q)
  452. register struct nameblock *q;
  453. {
  454. ftnint leng;
  455.  
  456. leng = typesize[q->vtype];
  457. if(leng <= 0)
  458.     return(-1);
  459. if(q->vdim)
  460.     if( ISICON(q->vdim->nelt) )
  461.         leng *= q->vdim->nelt->const.ci;
  462.     else    return(-1);
  463. if(q->vleng)
  464.     if( ISICON(q->vleng) )
  465.         leng *= q->vleng->const.ci;
  466.     else     return(-1);
  467. return(leng);
  468. }
  469.  
  470. LOCAL docommon()
  471. {
  472. register struct extsym *p;
  473. register chainp q;
  474. struct dimblock *t;
  475. expptr neltp;
  476. register struct nameblock *v;
  477. ftnint size;
  478. int type;
  479.  
  480. for(p = extsymtab ; p<nextext ; ++p)
  481.     if(p->extstg==STGCOMMON)
  482.         {
  483.         for(q = p->extp ; q ; q = q->nextp)
  484.             {
  485.             v = q->datap;
  486.             if(v->vdcldone == NO)
  487.                 vardcl(v);
  488.             type = v->vtype;
  489.             if(p->extleng % typealign[type] != 0)
  490.                 {
  491.                 dclerr("common alignment", v);
  492.                 p->extleng = roundup(p->extleng, typealign[type]);
  493.                 }
  494.             v->voffset = p->extleng;
  495.             v->vardesc.varno = p - extsymtab;
  496.             if(type == TYCHAR)
  497.                 size = v->vleng->const.ci;
  498.             else    size = typesize[type];
  499.             if(t = v->vdim)
  500.                 if( (neltp = t->nelt) && ISCONST(neltp) )
  501.                     size *= neltp->const.ci;
  502.                 else
  503.                     dclerr("adjustable array in common", v);
  504.             p->extleng += size;
  505.             }
  506.  
  507.         frchain( &(p->extp) );
  508.         }
  509. }
  510.  
  511.  
  512.  
  513.  
  514.  
  515. LOCAL docomleng()
  516. {
  517. register struct extsym *p;
  518.  
  519. for(p = extsymtab ; p < nextext ; ++p)
  520.     if(p->extstg == STGCOMMON)
  521.         {
  522.         if(p->maxleng!=0 && p->extleng!=0 && p->maxleng!=p->extleng &&
  523.             !eqn(XL,"_BLNK__ ",p->extname) )
  524.             warn1("incompatible lengths for common block %s",
  525.                 nounder(XL, p->extname) );
  526.         if(p->maxleng < p->extleng)
  527.             p->maxleng = p->extleng;
  528.         p->extleng = 0;
  529.     }
  530. }
  531.  
  532.  
  533.  
  534.  
  535. /* ROUTINES DEALING WITH AUTOMATIC AND TEMPORARY STORAGE */
  536.  
  537. frtemp(p)
  538. struct addrblock *p;
  539. {
  540. holdtemps = mkchain(p, holdtemps);
  541. }
  542.  
  543.  
  544.  
  545.  
  546. /* allocate an automatic variable slot */
  547.  
  548. struct addrblock *autovar(nelt, t, lengp)
  549. register int nelt, t;
  550. expptr lengp;
  551. {
  552. ftnint leng;
  553. register struct addrblock *q;
  554.  
  555. if(t == TYCHAR)
  556.     if( ISICON(lengp) )
  557.         leng = lengp->const.ci;
  558.     else    {
  559.         fatal("automatic variable of nonconstant length");
  560.         }
  561. else
  562.     leng = typesize[t];
  563. autoleng = roundup( autoleng, typealign[t]);
  564.  
  565. q = ALLOC(addrblock);
  566. q->tag = TADDR;
  567. q->vtype = t;
  568. if(t == TYCHAR)
  569.     q->vleng = ICON(leng);
  570. q->vstg = STGAUTO;
  571. q->ntempelt = nelt;
  572. #if TARGET==PDP11 || TARGET==VAX
  573.     /* stack grows downward */
  574.     autoleng += nelt*leng;
  575.     q->memoffset = ICON( - autoleng );
  576. #else
  577.     q->memoffset = ICON( autoleng );
  578.     autoleng += nelt*leng;
  579. #endif
  580.  
  581. return(q);
  582. }
  583.  
  584.  
  585. struct addrblock *mktmpn(nelt, type, lengp)
  586. int nelt;
  587. register int type;
  588. expptr lengp;
  589. {
  590. ftnint leng;
  591. chainp p, oldp;
  592. register struct addrblock *q;
  593.  
  594. if(type==TYUNKNOWN || type==TYERROR)
  595.     fatal1("mktmpn: invalid type %d", type);
  596.  
  597. if(type==TYCHAR)
  598.     if( ISICON(lengp) )
  599.         leng = lengp->const.ci;
  600.     else    {
  601.         err("adjustable length");
  602.         return( errnode() );
  603.         }
  604. for(oldp = &templist ; p = oldp->nextp ; oldp = p)
  605.     {
  606.     q = p->datap;
  607.     if(q->vtype==type && q->ntempelt==nelt &&
  608.         (type!=TYCHAR || q->vleng->const.ci==leng) )
  609.         {
  610.         oldp->nextp = p->nextp;
  611.         free(p);
  612.         return(q);
  613.         }
  614.     }
  615. q = autovar(nelt, type, lengp);
  616. q->istemp = YES;
  617. return(q);
  618. }
  619.  
  620.  
  621.  
  622.  
  623. struct addrblock *mktemp(type, lengp)
  624. int type;
  625. expptr lengp;
  626. {
  627. return( mktmpn(1,type,lengp) );
  628. }
  629.  
  630. /* VARIOUS ROUTINES FOR PROCESSING DECLARATIONS */
  631.  
  632. struct extsym *comblock(len, s)
  633. register int len;
  634. register char *s;
  635. {
  636. struct extsym *mkext(), *p;
  637.  
  638. if(len == 0)
  639.     {
  640.     s = BLANKCOMMON;
  641.     len = strlen(s);
  642.     }
  643. p = mkext( varunder(len, s) );
  644. if(p->extstg == STGUNKNOWN)
  645.     p->extstg = STGCOMMON;
  646. else if(p->extstg != STGCOMMON)
  647.     {
  648.     err1("%s cannot be a common block name", s);
  649.     return(0);
  650.     }
  651.  
  652. return( p );
  653. }
  654.  
  655.  
  656. incomm(c, v)
  657. struct extsym *c;
  658. struct nameblock *v;
  659. {
  660. if(v->vstg != STGUNKNOWN)
  661.     dclerr("incompatible common declaration", v);
  662. else
  663.     {
  664.     v->vstg = STGCOMMON;
  665.     c->extp = hookup(c->extp, mkchain(v,NULL) );
  666.     }
  667. }
  668.  
  669.  
  670.  
  671.  
  672. settype(v, type, length)
  673. register struct nameblock * v;
  674. register int type;
  675. register int length;
  676. {
  677. if(type == TYUNKNOWN)
  678.     return;
  679.  
  680. if(type==TYSUBR && v->vtype!=TYUNKNOWN && v->vstg==STGARG)
  681.     {
  682.     v->vtype = TYSUBR;
  683.     frexpr(v->vleng);
  684.     }
  685. else if(type < 0)    /* storage class set */
  686.     {
  687.     if(v->vstg == STGUNKNOWN)
  688.         v->vstg = - type;
  689.     else if(v->vstg != -type)
  690.         dclerr("incompatible storage declarations", v);
  691.     }
  692. else if(v->vtype == TYUNKNOWN)
  693.     {
  694.     if( (v->vtype = lengtype(type, length))==TYCHAR && length!=0)
  695.         v->vleng = ICON(length);
  696.     }
  697. else if(v->vtype!=type || (type==TYCHAR && v->vleng->const.ci!=length) )
  698.     dclerr("incompatible type declarations", v);
  699. }
  700.  
  701.  
  702.  
  703.  
  704.  
  705. lengtype(type, length)
  706. register int type;
  707. register int length;
  708. {
  709. switch(type)
  710.     {
  711.     case TYREAL:
  712.         if(length == 8)
  713.             return(TYDREAL);
  714.         if(length == 4)
  715.             goto ret;
  716.         break;
  717.  
  718.     case TYCOMPLEX:
  719.         if(length == 16)
  720.             return(TYDCOMPLEX);
  721.         if(length == 8)
  722.             goto ret;
  723.         break;
  724.  
  725.     case TYSHORT:
  726.     case TYDREAL:
  727.     case TYDCOMPLEX:
  728.     case TYCHAR:
  729.     case TYUNKNOWN:
  730.     case TYSUBR:
  731.     case TYERROR:
  732.         goto ret;
  733.  
  734.     case TYLOGICAL:
  735.         if(length == 4)
  736.             goto ret;
  737.         break;
  738.  
  739.     case TYLONG:
  740.         if(length == 0)
  741.             return(tyint);
  742.         if(length == 2)
  743.             return(TYSHORT);
  744.         if(length == 4)
  745.             goto ret;
  746.         break;
  747.     default:
  748.         fatal1("lengtype: invalid type %d", type);
  749.     }
  750.  
  751. if(length != 0)
  752.     err("incompatible type-length combination");
  753.  
  754. ret:
  755.     return(type);
  756. }
  757.  
  758.  
  759.  
  760.  
  761.  
  762. setintr(v)
  763. register struct nameblock * v;
  764. {
  765. register int k;
  766.  
  767. if(v->vstg == STGUNKNOWN)
  768.     v->vstg = STGINTR;
  769. else if(v->vstg!=STGINTR)
  770.     dclerr("incompatible use of intrinsic function", v);
  771. if(v->vclass==CLUNKNOWN)
  772.     v->vclass = CLPROC;
  773. if(v->vprocclass == PUNKNOWN)
  774.     v->vprocclass = PINTRINSIC;
  775. else if(v->vprocclass != PINTRINSIC)
  776.     dclerr("invalid intrinsic declaration", v);
  777. if(k = intrfunct(v->varname))
  778.     v->vardesc.varno = k;
  779. else
  780.     dclerr("unknown intrinsic function", v);
  781. }
  782.  
  783.  
  784.  
  785. setext(v)
  786. register struct nameblock * v;
  787. {
  788. if(v->vclass == CLUNKNOWN)
  789.     v->vclass = CLPROC;
  790. else if(v->vclass != CLPROC)
  791.     dclerr("invalid external declaration", v);
  792.  
  793. if(v->vprocclass == PUNKNOWN)
  794.     v->vprocclass = PEXTERNAL;
  795. else if(v->vprocclass != PEXTERNAL)
  796.     dclerr("invalid external declaration", v);
  797. }
  798.  
  799.  
  800.  
  801.  
  802. /* create dimensions block for array variable */
  803.  
  804. setbound(v, nd, dims)
  805. register struct nameblock * v;
  806. int nd;
  807. struct { expptr lb, ub; } dims[ ];
  808. {
  809. register expptr q, t;
  810. register struct dimblock *p;
  811. int i;
  812.  
  813. if(v->vclass == CLUNKNOWN)
  814.     v->vclass = CLVAR;
  815. else if(v->vclass != CLVAR)
  816.     {
  817.     dclerr("only variables may be arrays", v);
  818.     return;
  819.     }
  820.  
  821. v->vdim = p = (struct dimblock *) ckalloc( sizeof(int) + (3+2*nd)*sizeof(expptr) );
  822. p->ndim = nd;
  823. p->nelt = ICON(1);
  824.  
  825. for(i=0 ; i<nd ; ++i)
  826.     {
  827.     if( (q = dims[i].ub) == NULL)
  828.         {
  829.         if(i == nd-1)
  830.             {
  831.             frexpr(p->nelt);
  832.             p->nelt = NULL;
  833.             }
  834.         else
  835.             err("only last bound may be asterisk");
  836.         p->dims[i].dimsize = ICON(1);;
  837.         p->dims[i].dimexpr = NULL;
  838.         }
  839.     else
  840.         {
  841.         if(dims[i].lb)
  842.             {
  843.             q = mkexpr(OPMINUS, q, cpexpr(dims[i].lb));
  844.             q = mkexpr(OPPLUS, q, ICON(1) );
  845.             }
  846.         if( ISCONST(q) )
  847.             {
  848.             p->dims[i].dimsize = q;
  849.             p->dims[i].dimexpr = NULL;
  850.             }
  851.         else    {
  852.             p->dims[i].dimsize = autovar(1, tyint, NULL);
  853.             p->dims[i].dimexpr = q;
  854.             }
  855.         if(p->nelt)
  856.             p->nelt = mkexpr(OPSTAR, p->nelt, cpexpr(p->dims[i].dimsize));
  857.         }
  858.     }
  859.  
  860. q = dims[nd-1].lb;
  861. if(q == NULL)
  862.     q = ICON(1);
  863.  
  864. for(i = nd-2 ; i>=0 ; --i)
  865.     {
  866.     t = dims[i].lb;
  867.     if(t == NULL)
  868.         t = ICON(1);
  869.     if(p->dims[i].dimsize)
  870.         q = mkexpr(OPPLUS, t, mkexpr(OPSTAR, cpexpr(p->dims[i].dimsize), q) );
  871.     }
  872.  
  873. if( ISCONST(q) )
  874.     {
  875.     p->baseoffset = q;
  876.     p->basexpr = NULL;
  877.     }
  878. else
  879.     {
  880.     p->baseoffset = autovar(1, tyint, NULL);
  881.     p->basexpr = q;
  882.     }
  883. }
  884.