home *** CD-ROM | disk | FTP | other *** search
/ minnie.tuhs.org / unixen.tar / unixen / PDP-11 / Trees / V7 / usr / src / cmd / f77 / exec.c < prev    next >
Encoding:
C/C++ Source or Header  |  1979-05-05  |  9.4 KB  |  557 lines
  1. #include "defs"
  2.  
  3. /*   Logical IF codes
  4. */
  5.  
  6.  
  7. exif(p)
  8. expptr p;
  9. {
  10. pushctl(CTLIF);
  11. ctlstack->elselabel = newlabel();
  12. putif(p, ctlstack->elselabel);
  13. }
  14.  
  15.  
  16.  
  17. exelif(p)
  18. expptr p;
  19. {
  20. if(ctlstack->ctltype == CTLIF)
  21.     {
  22.     if(ctlstack->endlabel == 0)
  23.         ctlstack->endlabel = newlabel();
  24.     putgoto(ctlstack->endlabel);
  25.     putlabel(ctlstack->elselabel);
  26.     ctlstack->elselabel = newlabel();
  27.     putif(p, ctlstack->elselabel);
  28.     }
  29.  
  30. else    execerr("elseif out of place", 0);
  31. }
  32.  
  33.  
  34.  
  35.  
  36.  
  37. exelse()
  38. {
  39. if(ctlstack->ctltype==CTLIF)
  40.     {
  41.     if(ctlstack->endlabel == 0)
  42.         ctlstack->endlabel = newlabel();
  43.     putgoto( ctlstack->endlabel );
  44.     putlabel(ctlstack->elselabel);
  45.     ctlstack->ctltype = CTLELSE;
  46.     }
  47.  
  48. else    execerr("else out of place", 0);
  49. }
  50.  
  51.  
  52. exendif()
  53. {
  54. if(ctlstack->ctltype == CTLIF)
  55.     {
  56.     putlabel(ctlstack->elselabel);
  57.     if(ctlstack->endlabel)
  58.         putlabel(ctlstack->endlabel);
  59.     popctl();
  60.     }
  61. else if(ctlstack->ctltype == CTLELSE)
  62.     {
  63.     putlabel(ctlstack->endlabel);
  64.     popctl();
  65.     }
  66.  
  67. else
  68.     execerr("endif out of place", 0);
  69. }
  70.  
  71.  
  72.  
  73. LOCAL pushctl(code)
  74. int code;
  75. {
  76. register int i;
  77.  
  78. if(++ctlstack >= lastctl)
  79.     fatal("nesting too deep");
  80. ctlstack->ctltype = code;
  81. for(i = 0 ; i < 4 ; ++i)
  82.     ctlstack->ctlabels[i] = 0;
  83. ++blklevel;
  84. }
  85.  
  86.  
  87. LOCAL popctl()
  88. {
  89. if( ctlstack-- < ctls )
  90.     fatal("control stack empty");
  91. --blklevel;
  92. }
  93.  
  94.  
  95.  
  96. LOCAL poplab()
  97. {
  98. register struct labelblock  *lp;
  99.  
  100. for(lp = labeltab ; lp < highlabtab ; ++lp)
  101.     if(lp->labdefined)
  102.         {
  103.         /* mark all labels in inner blocks unreachable */
  104.         if(lp->blklevel > blklevel)
  105.             lp->labinacc = YES;
  106.         }
  107.     else if(lp->blklevel > blklevel)
  108.         {
  109.         /* move all labels referred to in inner blocks out a level */
  110.         lp->blklevel = blklevel;
  111.         }
  112. }
  113.  
  114.  
  115.  
  116. /*  BRANCHING CODE
  117. */
  118.  
  119. exgoto(lab)
  120. struct labelblock *lab;
  121. {
  122. putgoto(lab->labelno);
  123. }
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131. exequals(lp, rp)
  132. register struct primblock *lp;
  133. register expptr rp;
  134. {
  135. if(lp->tag != TPRIM)
  136.     {
  137.     err("assignment to a non-variable");
  138.     frexpr(lp);
  139.     frexpr(rp);
  140.     }
  141. else if(lp->namep->vclass!=CLVAR && lp->argsp)
  142.     {
  143.     if(parstate >= INEXEC)
  144.         err("statement function amid executables");
  145.     else
  146.         mkstfunct(lp, rp);
  147.     }
  148. else
  149.     {
  150.     if(parstate < INDATA)
  151.         enddcl();
  152.     puteq(mklhs(lp), rp);
  153.     }
  154. }
  155.  
  156.  
  157.  
  158. mkstfunct(lp, rp)
  159. struct primblock *lp;
  160. expptr rp;
  161. {
  162. register struct primblock *p;
  163. register struct nameblock *np;
  164. chainp args;
  165.  
  166. np = lp->namep;
  167. if(np->vclass == CLUNKNOWN)
  168.     np->vclass = CLPROC;
  169. else
  170.     {
  171.     dclerr("redeclaration of statement function", np);
  172.     return;
  173.     }
  174. np->vprocclass = PSTFUNCT;
  175. np->vstg = STGSTFUNCT;
  176. impldcl(np);
  177. args = (lp->argsp ? lp->argsp->listp : NULL);
  178. np->vardesc.vstfdesc = mkchain(args , rp );
  179.  
  180. for( ; args ; args = args->nextp)
  181.     if( (p = args->datap)->tag!=TPRIM ||
  182.         p->argsp || p->fcharp || p->lcharp)
  183.         err("non-variable argument in statement function definition");
  184.     else
  185.         {
  186.         vardcl(args->datap = p->namep);
  187.         free(p);
  188.         }
  189. }
  190.  
  191.  
  192.  
  193. excall(name, args, nstars, labels)
  194. struct hashentry *name;
  195. struct listblock *args;
  196. int nstars;
  197. struct labelblock *labels[ ];
  198. {
  199. register expptr p;
  200.  
  201. settype(name, TYSUBR, NULL);
  202. p = mkfunct( mkprim(name, args, NULL, NULL) );
  203. p->vtype = p->leftp->vtype = TYINT;
  204. if(nstars > 0)
  205.     putcmgo(p, nstars, labels);
  206. else putexpr(p);
  207. }
  208.  
  209.  
  210.  
  211. exstop(stop, p)
  212. int stop;
  213. register expptr p;
  214. {
  215. char *q;
  216. int n;
  217. struct constblock *mkstrcon();
  218.  
  219. if(p)
  220.     {
  221.     if( ! ISCONST(p) )
  222.         {
  223.         execerr("pause/stop argument must be constant", 0);
  224.         frexpr(p);
  225.         p = mkstrcon(0, 0);
  226.         }
  227.     else if( ISINT(p->vtype) )
  228.         {
  229.         q = convic(p->const.ci);
  230.         n = strlen(q);
  231.         if(n > 0)
  232.             {
  233.             p->const.ccp = copyn(n, q);
  234.             p->vtype = TYCHAR;
  235.             p->vleng = ICON(n);
  236.             }
  237.         else
  238.             p = mkstrcon(0, 0);
  239.         }
  240.     else if(p->vtype != TYCHAR)
  241.         {
  242.         execerr("pause/stop argument must be integer or string", 0);
  243.         p = mkstrcon(0, 0);
  244.         }
  245.     }
  246. else    p = mkstrcon(0, 0);
  247.  
  248. putexpr( call1(TYSUBR, (stop ? "s_stop" : "s_paus"), p) );
  249. }
  250.  
  251. /* DO LOOP CODE */
  252.  
  253. #define DOINIT    par[0]
  254. #define DOLIMIT    par[1]
  255. #define DOINCR    par[2]
  256.  
  257. #define VARSTEP    0
  258. #define POSSTEP    1
  259. #define NEGSTEP    2
  260.  
  261.  
  262. exdo(range, spec)
  263. int range;
  264. chainp spec;
  265. {
  266. register expptr p, q;
  267. expptr *q1;
  268. register struct nameblock *np;
  269. chainp cp;
  270. register int i;
  271. int dotype, incsign;
  272. struct addrblock *dovarp, *dostgp;
  273. expptr par[3];
  274.  
  275. pushctl(CTLDO);
  276. dorange = ctlstack->dolabel = range;
  277. np = spec->datap;
  278. ctlstack->donamep = NULL;
  279. if(np->vdovar)
  280.     {
  281.     err1("nested loops with variable %s", varstr(VL,np->varname));
  282.     ctlstack->donamep = NULL;
  283.     return;
  284.     }
  285.  
  286. dovarp = mklhs( mkprim(np, 0,0,0) );
  287. if( ! ONEOF(dovarp->vtype, MSKINT|MSKREAL) )
  288.     {
  289.     err("bad type on do variable");
  290.     return;
  291.     }
  292. ctlstack->donamep = np;
  293.  
  294. np->vdovar = YES;
  295. if( enregister(np) )
  296.     {
  297.     /* stgp points to a storage version, varp to a register version */
  298.     dostgp = dovarp;
  299.     dovarp = mklhs( mkprim(np, 0,0,0) );
  300.     }
  301. else
  302.     dostgp = NULL;
  303. dotype = dovarp->vtype;
  304.  
  305. for(i=0 , cp = spec->nextp ; cp!=NULL && i<3 ; cp = cp->nextp)
  306.     {
  307.     p = par[i++] = fixtype(cp->datap);
  308.     if( ! ONEOF(p->vtype, MSKINT|MSKREAL) )
  309.         {
  310.         err("bad type on DO parameter");
  311.         return;
  312.         }
  313.     }
  314.  
  315. frchain(&spec);
  316. switch(i)
  317.     {
  318.     case 0:
  319.     case 1:
  320.         err("too few DO parameters");
  321.         return;
  322.  
  323.     default:
  324.         err("too many DO parameters");
  325.         return;
  326.  
  327.     case 2:
  328.         DOINCR = ICON(1);
  329.  
  330.     case 3:
  331.         break;
  332.     }
  333.  
  334. ctlstack->endlabel = newlabel();
  335. ctlstack->dobodylabel = newlabel();
  336.  
  337. if( ISCONST(DOLIMIT) )
  338.     ctlstack->domax = mkconv(dotype, DOLIMIT);
  339. else
  340.     ctlstack->domax = mktemp(dotype, NULL);
  341.  
  342. if( ISCONST(DOINCR) )
  343.     {
  344.     ctlstack->dostep = mkconv(dotype, DOINCR);
  345.     if( (incsign = conssgn(ctlstack->dostep)) == 0)
  346.         err("zero DO increment");
  347.     ctlstack->dostepsign = (incsign > 0 ? POSSTEP : NEGSTEP);
  348.     }
  349. else
  350.     {
  351.     ctlstack->dostep = mktemp(dotype, NULL);
  352.     ctlstack->dostepsign = VARSTEP;
  353.     ctlstack->doposlabel = newlabel();
  354.     ctlstack->doneglabel = newlabel();
  355.     }
  356.  
  357. if( ISCONST(ctlstack->domax) && ISCONST(DOINIT) && ctlstack->dostepsign!=VARSTEP)
  358.     {
  359.     puteq(cpexpr(dovarp), cpexpr(DOINIT));
  360.     if( onetripflag )
  361.         frexpr(DOINIT);
  362.     else
  363.         {
  364.         q = mkexpr(OPPLUS, ICON(1),
  365.             mkexpr(OPMINUS, cpexpr(ctlstack->domax), cpexpr(DOINIT)) );
  366.         if(incsign != conssgn(q))
  367.             {
  368.             warn("DO range never executed");
  369.             putgoto(ctlstack->endlabel);
  370.             }
  371.         frexpr(q);
  372.         }
  373.     }
  374. else if(ctlstack->dostepsign!=VARSTEP && !onetripflag)
  375.     {
  376.     if( ISCONST(ctlstack->domax) )
  377.         q = cpexpr(ctlstack->domax);
  378.     else
  379.         q = mkexpr(OPASSIGN, cpexpr(ctlstack->domax), DOLIMIT);
  380.  
  381.     q1 = mkexpr(OPASSIGN, cpexpr(dovarp), DOINIT);
  382.     q = mkexpr( (ctlstack->dostepsign==POSSTEP ? OPLE : OPGE), q1, q);
  383.     putif(q, ctlstack->endlabel);
  384.     }
  385. else
  386.     {
  387.     if(! ISCONST(ctlstack->domax) )
  388.         puteq( cpexpr(ctlstack->domax), DOLIMIT);
  389.     q = DOINIT;
  390.     if( ! onetripflag )
  391.         q = mkexpr(OPMINUS, q,
  392.             mkexpr(OPASSIGN, cpexpr(ctlstack->dostep), DOINCR) );
  393.     puteq( cpexpr(dovarp), q);
  394.     if(onetripflag && ctlstack->dostepsign==VARSTEP)
  395.         puteq( cpexpr(ctlstack->dostep), DOINCR);
  396.     }
  397.  
  398. if(ctlstack->dostepsign == VARSTEP)
  399.     {
  400.     if(onetripflag)
  401.         putgoto(ctlstack->dobodylabel);
  402.     else
  403.         putif( mkexpr(OPGE, cpexpr(ctlstack->dostep), ICON(0)),
  404.             ctlstack->doneglabel );
  405.     putlabel(ctlstack->doposlabel);
  406.     putif( mkexpr(OPLE,
  407.         mkexpr(OPPLUSEQ, cpexpr(dovarp), cpexpr(ctlstack->dostep)),
  408.         cpexpr(ctlstack->domax) ),
  409.             ctlstack->endlabel);
  410.     }
  411. putlabel(ctlstack->dobodylabel);
  412. if(dostgp)
  413.     puteq(dostgp, cpexpr(dovarp));
  414. frexpr(dovarp);
  415. }
  416.  
  417.  
  418.  
  419. enddo(here)
  420. int here;
  421. {
  422. register struct ctlframe *q;
  423. register expptr t;
  424. struct nameblock *np;
  425. struct addrblock *ap;
  426. register int i;
  427.  
  428. while(here == dorange)
  429.     {
  430.     if(np = ctlstack->donamep)
  431.         {
  432.         t = mkexpr(OPPLUSEQ, mklhs(mkprim(ctlstack->donamep, 0,0,0)),
  433.             cpexpr(ctlstack->dostep) );
  434.     
  435.         if(ctlstack->dostepsign == VARSTEP)
  436.             {
  437.             putif( mkexpr(OPLE, cpexpr(ctlstack->dostep), ICON(0)), ctlstack->doposlabel);
  438.             putlabel(ctlstack->doneglabel);
  439.             putif( mkexpr(OPLT, t, ctlstack->domax), ctlstack->dobodylabel);
  440.             }
  441.         else
  442.             putif( mkexpr( (ctlstack->dostepsign==POSSTEP ? OPGT : OPLT),
  443.                 t, ctlstack->domax),
  444.                 ctlstack->dobodylabel);
  445.         putlabel(ctlstack->endlabel);
  446.         if(ap = memversion(np))
  447.             puteq(ap, mklhs( mkprim(np,0,0,0)) );
  448.         for(i = 0 ; i < 4 ; ++i)
  449.             ctlstack->ctlabels[i] = 0;
  450.         deregister(ctlstack->donamep);
  451.         ctlstack->donamep->vdovar = NO;
  452.         frexpr(ctlstack->dostep);
  453.         }
  454.  
  455.     popctl();
  456.     poplab();
  457.     dorange = 0;
  458.     for(q = ctlstack ; q>=ctls ; --q)
  459.         if(q->ctltype == CTLDO)
  460.             {
  461.             dorange = q->dolabel;
  462.             break;
  463.             }
  464.     }
  465. }
  466.  
  467. exassign(vname, labelval)
  468. struct nameblock *vname;
  469. struct labelblock *labelval;
  470. {
  471. struct addrblock *p;
  472. struct constblock *mkaddcon();
  473.  
  474. p = mklhs(mkprim(vname,0,0,0));
  475. if( ! ONEOF(p->vtype, MSKINT|MSKADDR) )
  476.     err("noninteger assign variable");
  477. else
  478.     puteq(p, mkaddcon(labelval->labelno) );
  479. }
  480.  
  481.  
  482.  
  483. exarif(expr, neglab, zerlab, poslab)
  484. expptr expr;
  485. struct labelblock *neglab, *zerlab, *poslab;
  486. {
  487. register int lm, lz, lp;
  488.  
  489. lm = neglab->labelno;
  490. lz = zerlab->labelno;
  491. lp = poslab->labelno;
  492. expr = fixtype(expr);
  493.  
  494. if( ! ONEOF(expr->vtype, MSKINT|MSKREAL) )
  495.     {
  496.     err("invalid type of arithmetic if expression");
  497.     frexpr(expr);
  498.     }
  499. else
  500.     {
  501.     if(lm == lz)
  502.         exar2(OPLE, expr, lm, lp);
  503.     else if(lm == lp)
  504.         exar2(OPNE, expr, lm, lz);
  505.     else if(lz == lp)
  506.         exar2(OPGE, expr, lz, lm);
  507.     else
  508.         prarif(expr, lm, lz, lp);
  509.     }
  510. }
  511.  
  512.  
  513.  
  514. LOCAL exar2(op, e, l1, l2)
  515. int op;
  516. expptr e;
  517. int l1, l2;
  518. {
  519. putif( mkexpr(op, e, ICON(0)), l2);
  520. putgoto(l1);
  521. }
  522.  
  523.  
  524. exreturn(p)
  525. register expptr p;
  526. {
  527. if(procclass != CLPROC)
  528.     warn("RETURN statement in main or block data");
  529. if(p && (proctype!=TYSUBR || procclass!=CLPROC) )
  530.     {
  531.     err("alternate return in nonsubroutine");
  532.     p = 0;
  533.     }
  534.  
  535. if(p)
  536.     {
  537.     putforce(TYINT, p);
  538.     putgoto(retlabel);
  539.     }
  540. else
  541.     putgoto(proctype==TYSUBR ? ret0label : retlabel);
  542. }
  543.  
  544.  
  545.  
  546. exasgoto(labvar)
  547. struct hashentry *labvar;
  548. {
  549. register struct addrblock *p;
  550.  
  551. p = mklhs( mkprim(labvar,0,0,0) );
  552. if( ! ISINT(p->vtype) )
  553.     err("assigned goto variable must be integer");
  554. else
  555.     putbranch(p);
  556. }
  557.