home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / bsd_srcs / usr.bin / pascal / src / stat.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-16  |  16.6 KB  |  730 lines
  1. /*-
  2.  * Copyright (c) 1980 The Regents of the University of California.
  3.  * All rights reserved.
  4.  *
  5.  * Redistribution and use in source and binary forms, with or without
  6.  * modification, are permitted provided that the following conditions
  7.  * are met:
  8.  * 1. Redistributions of source code must retain the above copyright
  9.  *    notice, this list of conditions and the following disclaimer.
  10.  * 2. Redistributions in binary form must reproduce the above copyright
  11.  *    notice, this list of conditions and the following disclaimer in the
  12.  *    documentation and/or other materials provided with the distribution.
  13.  * 3. All advertising materials mentioning features or use of this software
  14.  *    must display the following acknowledgement:
  15.  *    This product includes software developed by the University of
  16.  *    California, Berkeley and its contributors.
  17.  * 4. Neither the name of the University nor the names of its contributors
  18.  *    may be used to endorse or promote products derived from this software
  19.  *    without specific prior written permission.
  20.  *
  21.  * THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
  22.  * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  23.  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  24.  * ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  25.  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  26.  * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  27.  * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  28.  * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  29.  * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  30.  * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  31.  * SUCH DAMAGE.
  32.  */
  33.  
  34. #ifndef lint
  35. static char sccsid[] = "@(#)stat.c    5.2 (Berkeley) 4/16/91";
  36. #endif /* not lint */
  37.  
  38. #include "whoami.h"
  39. #include "0.h"
  40. #include "tree.h"
  41. #include "objfmt.h"
  42. #ifdef PC
  43. #   include <pcc.h>
  44. #   include "pc.h"
  45. #endif PC
  46. #include "tmps.h"
  47.  
  48. int cntstat;
  49. short cnts = 3;
  50. #include "opcode.h"
  51. #include "tree_ty.h"
  52.  
  53. /*
  54.  * Statement list
  55.  */
  56. statlist(r)
  57.     struct tnode *r;
  58. {
  59.     register struct tnode *sl;
  60.  
  61.     for (sl=r; sl != TR_NIL; sl=sl->list_node.next)
  62.         statement(sl->list_node.list);
  63. }
  64.  
  65. /*
  66.  * Statement
  67.  */
  68. statement(r)
  69.     struct tnode *r;
  70. {
  71.     register struct tnode *tree_node;
  72.     register struct nl *snlp;
  73.     struct tmps soffset;
  74.  
  75.     tree_node = r;
  76.     snlp = nlp;
  77.     soffset = sizes[cbn].curtmps;
  78. top:
  79.     if (cntstat) {
  80.         cntstat = 0;
  81.         putcnt();
  82.     }
  83.     if (tree_node == TR_NIL)
  84.         return;
  85.     line = tree_node->lined.line_no; 
  86.     if (tree_node->tag == T_LABEL) {
  87.         labeled(tree_node->label_node.lbl_ptr);
  88.         tree_node = tree_node->label_node.stmnt;
  89.         noreach = FALSE;
  90.         cntstat = 1;
  91.         goto top;
  92.     }
  93.     if (noreach) {
  94.         noreach = FALSE;
  95.         warning();
  96.         error("Unreachable statement");
  97.     }
  98.     switch (tree_node->tag) {
  99.         case T_PCALL:
  100.             putline();
  101. #            ifdef OBJ
  102.                 proc(tree_node);
  103. #            endif OBJ
  104. #            ifdef PC
  105.                 pcproc( tree_node );
  106. #            endif PC
  107.             break;
  108.         case T_ASGN:
  109.             putline();
  110.             asgnop(&(tree_node->asg_node));
  111.             break;
  112.         case T_GOTO:
  113.             putline();
  114.             gotoop(tree_node->goto_node.lbl_ptr);
  115.             noreach = TRUE;
  116.             cntstat = 1;
  117.             break;
  118.         default:
  119.             level++;
  120.             switch (tree_node->tag) {
  121.                 default:
  122.                     panic("stat");
  123.                 case T_IF:
  124.                 case T_IFEL:
  125.                     ifop(&(tree_node->if_node));
  126.                     break;
  127.                 case T_WHILE:
  128.                     whilop(&(tree_node->whi_cas));
  129.                     noreach = FALSE;
  130.                     break;
  131.                 case T_REPEAT:
  132.                     repop(&(tree_node->repeat));
  133.                     break;
  134.                 case T_FORU:
  135.                 case T_FORD:
  136.                         forop(tree_node);
  137.                     noreach = FALSE;
  138.                     break;
  139.                 case T_BLOCK:
  140.                     statlist(tree_node->stmnt_blck.stmnt_list);
  141.                     break;
  142.                 case T_CASE:
  143.                     putline();
  144. #                    ifdef OBJ
  145.                         caseop(&(tree_node->whi_cas));
  146. #                    endif OBJ
  147. #                    ifdef PC
  148.                         pccaseop(&(tree_node->whi_cas));
  149. #                    endif PC
  150.                     break;
  151.                 case T_WITH:
  152.                     withop(&(tree_node->with_node));
  153.                     break;
  154.             }
  155.             --level;
  156.             if (gotos[cbn])
  157.                 ungoto();
  158.             break;
  159.     }
  160.     /*
  161.      * Free the temporary name list entries defined in
  162.      * expressions, e.g. STRs, and WITHPTRs from withs.
  163.      */
  164.     nlfree(snlp);
  165.         /*
  166.          *    free any temporaries allocated for this statement
  167.          *    these come from strings and sets.
  168.          */
  169.     tmpfree(&soffset);
  170. }
  171.  
  172. ungoto()
  173. {
  174.     register struct nl *p;
  175.  
  176.     for (p = gotos[cbn]; p != NLNIL; p = p->chain)
  177.         if ((p->nl_flags & NFORWD) != 0) {
  178.             if (p->value[NL_GOLEV] != NOTYET)
  179.                 if (p->value[NL_GOLEV] > level)
  180.                     p->value[NL_GOLEV] = level;
  181.         } else
  182.             if (p->value[NL_GOLEV] != DEAD)
  183.                 if (p->value[NL_GOLEV] > level)
  184.                     p->value[NL_GOLEV] = DEAD;
  185. }
  186.  
  187. putcnt()
  188. {
  189.  
  190.     if (monflg == FALSE) {
  191.         return;
  192.     }
  193.     inccnt( getcnt() );
  194. }
  195.  
  196. int
  197. getcnt()
  198.     {
  199.     
  200.     return ++cnts;
  201.     }
  202.  
  203. inccnt( counter )
  204.     int    counter;
  205.     {
  206.  
  207. #    ifdef OBJ
  208.         (void) put(2, O_COUNT, counter );
  209. #    endif OBJ
  210. #    ifdef PC
  211.         putRV( PCPCOUNT , 0 , counter * sizeof (long) , NGLOBAL , PCCT_INT );
  212.         putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
  213.         putop( PCCOM_ASG PCC_PLUS , PCCT_INT );
  214.         putdot( filename , line );
  215. #    endif PC
  216.     }
  217.  
  218. putline()
  219. {
  220.  
  221. #    ifdef OBJ
  222.         if (opt('p') != 0)
  223.             (void) put(2, O_LINO, line);
  224.  
  225.         /*
  226.          * put out line number information for pdx
  227.          */
  228.         lineno(line);
  229.  
  230. #    endif OBJ
  231. #    ifdef PC
  232.         static lastline;
  233.  
  234.         if ( line != lastline ) {
  235.         stabline( line );
  236.         lastline = line;
  237.         }
  238.         if ( opt( 'p' ) ) {
  239.         if ( opt('t') ) {
  240.             putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR )
  241.                 , "_LINO" );
  242.             putop( PCCOM_UNARY PCC_CALL , PCCT_INT );
  243.             putdot( filename , line );
  244.         } else {
  245.             putRV( STMTCOUNT , 0 , 0 , NGLOBAL , PCCT_INT );
  246.             putleaf( PCC_ICON , 1 , 0 , PCCT_INT , (char *) 0 );
  247.             putop( PCCOM_ASG PCC_PLUS , PCCT_INT );
  248.             putdot( filename , line );
  249.         }
  250.         }
  251. #    endif PC
  252. }
  253.  
  254. /*
  255.  * With varlist do stat
  256.  *
  257.  * With statement requires an extra word
  258.  * in automatic storage for each level of withing.
  259.  * These indirect pointers are initialized here, and
  260.  * the scoping effect of the with statement occurs
  261.  * because lookup examines the field names of the records
  262.  * associated with the WITHPTRs on the withlist.
  263.  */
  264. withop(s)
  265.     WITH_NODE *s;
  266. {
  267.     register struct tnode *p;
  268.     register struct nl *r;
  269.     struct nl    *tempnlp;
  270.     struct nl *swl;
  271.  
  272.     putline();
  273.     swl = withlist;
  274.     for (p = s->var_list; p != TR_NIL; p = p->list_node.next) {
  275.         tempnlp = tmpalloc((long) (sizeof(int *)), nl+TPTR, REGOK);
  276.             /*
  277.              *    no one uses the allocated temporary namelist entry,
  278.              *    since we have to use it before we know its type;
  279.              *    but we use its runtime location for the with pointer.
  280.              */
  281. #        ifdef OBJ
  282.             (void) put(2, O_LV | cbn <<8+INDX, tempnlp -> value[ NL_OFFS ] );
  283. #        endif OBJ
  284. #        ifdef PC
  285.             putRV( (char *) 0 , cbn , tempnlp -> value[ NL_OFFS ] ,
  286.                 tempnlp -> extra_flags , PCCTM_PTR|PCCT_STRTY );
  287. #        endif PC
  288.         r = lvalue(p->list_node.list, MOD , LREQ );
  289.         if (r == NLNIL)
  290.             continue;
  291.         if (r->class != RECORD) {
  292.             error("Variable in with statement refers to %s, not to a record", nameof(r));
  293.             continue;
  294.         }
  295.         r = defnl((char *) 0, WITHPTR, r, tempnlp -> value[ NL_OFFS ] );
  296. #        ifdef PC
  297.             r -> extra_flags |= tempnlp -> extra_flags;
  298. #        endif PC
  299.         r->nl_next = withlist;
  300.         withlist = r;
  301. #        ifdef OBJ
  302.             (void) put(1, PTR_AS);
  303. #        endif OBJ
  304. #        ifdef PC
  305.             putop( PCC_ASSIGN , PCCTM_PTR|PCCT_STRTY );
  306.             putdot( filename , line );
  307. #        endif PC
  308.     }
  309.     statement(s->stmnt);
  310.     withlist = swl;
  311. }
  312.  
  313. extern    flagwas;
  314. /*
  315.  * var := expr
  316.  */
  317. asgnop(r)
  318.     ASG_NODE *r;
  319. {
  320.     register struct nl *p;
  321.     register struct tnode *av;
  322.  
  323.     /*
  324.      * Asgnop's only function is
  325.      * to handle function variable
  326.      * assignments.  All other assignment
  327.      * stuff is handled by asgnop1.
  328.      * the if below checks for unqualified lefthandside:
  329.      * necessary for fvars.
  330.      */
  331.     av = r->lhs_var;
  332.     if (av != TR_NIL && av->tag == T_VAR && av->var_node.qual == TR_NIL) {
  333.         p = lookup1(av->var_node.cptr);
  334.         if (p != NLNIL)
  335.             p->nl_flags = flagwas;
  336.         if (p != NLNIL && p->class == FVAR) {
  337.             /*
  338.              * Give asgnop1 the func
  339.              * which is the chain of
  340.              * the FVAR.
  341.              */
  342.             p->nl_flags |= NUSED|NMOD;
  343.             p = p->chain;
  344.             if (p == NLNIL) {
  345.                 p = rvalue(r->rhs_expr, NLNIL , RREQ );
  346.                 return;
  347.             }
  348. #            ifdef OBJ
  349.                 (void) put(2, O_LV | bn << 8+INDX, (int)p->value[NL_OFFS]);
  350.                 if (isa(p->type, "i") && width(p->type) == 1)
  351.                     (void) asgnop1(r, nl+T2INT);
  352.                 else
  353.                     (void) asgnop1(r, p->type);
  354. #            endif OBJ
  355. #            ifdef PC
  356.                 /*
  357.                  * this should be the lvalue of the fvar,
  358.                  * but since the second pass knows to use
  359.                  * the address of the left operand of an
  360.                  * assignment, what i want here is an rvalue.
  361.                  * see note in funchdr about fvar allocation.
  362.                  */
  363.                 p = p -> ptr[ NL_FVAR ];
  364.                 putRV( p -> symbol , bn , p -> value[ NL_OFFS ] ,
  365.                     p -> extra_flags , p2type( p -> type ) );
  366.                 (void) asgnop1( r , p -> type );
  367. #            endif PC
  368.             return;
  369.         }
  370.     }
  371.     (void) asgnop1(r, NLNIL);
  372. }
  373.  
  374. /*
  375.  * Asgnop1 handles all assignments.
  376.  * If p is not nil then we are assigning
  377.  * to a function variable, otherwise
  378.  * we look the variable up ourselves.
  379.  */
  380. struct nl *
  381. asgnop1(r, p)
  382.     ASG_NODE *r;
  383.     register struct nl *p;
  384. {
  385.     register struct nl *p1;
  386.     int    clas;
  387. #ifdef OBJ
  388.     int w;
  389. #endif OBJ
  390.  
  391. #ifdef OBJ
  392.     if (p == NLNIL) {
  393.         p = lvalue(r->lhs_var, MOD|ASGN|NOUSE , LREQ );
  394.         if ( p == NLNIL ) {
  395.         (void) rvalue( r->rhs_expr , NLNIL , RREQ );
  396.         return NLNIL;
  397.         }
  398.         w = width(p);
  399.     } else {
  400.         /*
  401.          * assigning to the return value, which is at least
  402.          * of width two since it resides on the stack
  403.          */
  404.         w = width(p);
  405.         if (w < 2)
  406.         w = 2;
  407.     }
  408.     clas = classify(p);
  409.     if ((clas == TARY || clas == TSTR) && p->chain->class == CRANGE) {
  410.         p1 = lvalue(r->rhs_expr, p , LREQ ); /* SHOULD THIS BE rvalue? */
  411.     } else {
  412.         p1 = rvalue(r->rhs_expr, p , RREQ );
  413.     }
  414. #   endif OBJ
  415. #   ifdef PC
  416.     if (p == NLNIL) {
  417.         /* check for conformant array type */
  418.         codeoff();
  419.         p = rvalue(r->lhs_var, MOD|ASGN|NOUSE, LREQ);
  420.         codeon();
  421.         if (p == NLNIL) {
  422.         (void) rvalue(r->rhs_expr, NLNIL, RREQ);
  423.         return NLNIL;
  424.         }
  425.         clas = classify(p);
  426.         if ((clas == TARY || clas == TSTR) && p->chain->class == CRANGE) {
  427.         return pcasgconf(r, p);
  428.         } else {
  429.         /*
  430.          * since the second pass knows that it should reference
  431.          * the lefthandside of asignments, what i need here is
  432.          * an rvalue.
  433.          */
  434.         p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , RREQ );
  435.         }
  436.         if ( p == NLNIL ) {
  437.         (void) rvalue( r->rhs_expr , NLNIL , RREQ );
  438.         return NLNIL;
  439.         }
  440.     }
  441.         /*
  442.          *    if this is a scalar assignment,
  443.          *        then i want to rvalue the righthandside.
  444.          *    if this is a structure assignment,
  445.          *        then i want an lvalue to the righthandside.
  446.          *  that's what the intermediate form sez.
  447.          */
  448.     switch ( classify( p ) ) {
  449.         case TINT:
  450.         case TCHAR:
  451.         case TBOOL:
  452.         case TSCAL:
  453.         precheck( p , "_RANG4" , "_RSNG4" );
  454.         /* and fall through */
  455.         case TDOUBLE:
  456.         case TPTR:
  457.         p1 = rvalue( r->rhs_expr , p , RREQ );
  458.         break;
  459.         default:
  460.         p1 = rvalue( r->rhs_expr , p , LREQ );
  461.         break;
  462.     }
  463. #    endif PC
  464.     if (p1 == NLNIL)
  465.         return (NLNIL);
  466.     if (incompat(p1, p, r->rhs_expr)) {
  467.         cerror("Type of expression clashed with type of variable in assignment");
  468.         return (NLNIL);
  469.     }
  470. #    ifdef OBJ
  471.         switch (classify(p)) {
  472.             case TINT:
  473.             case TBOOL:
  474.             case TCHAR:
  475.             case TSCAL:
  476.                 rangechk(p, p1);
  477.                 (void) gen(O_AS2, O_AS2, w, width(p1));
  478.                 break;
  479.             case TDOUBLE:
  480.             case TPTR:
  481.                 (void) gen(O_AS2, O_AS2, w, width(p1));
  482.                 break;
  483.             case TARY:
  484.             case TSTR:
  485.                 if (p->chain->class == CRANGE) {
  486.                 /* conformant array assignment */
  487.                 p1 = p->chain;
  488.                 w = width(p1->type);
  489.                 putcbnds(p1, 1);
  490.                 putcbnds(p1, 0);
  491.                 gen(NIL, T_SUB, w, w);
  492.                 put(2, w > 2? O_CON24: O_CON2, 1);
  493.                 gen(NIL, T_ADD, w, w);
  494.                 putcbnds(p1, 2);
  495.                 gen(NIL, T_MULT, w, w);
  496.                 put(1, O_VAS);
  497.                 break;
  498.                 }
  499.                 /* else fall through */
  500.             default:
  501.                 (void) put(2, O_AS, w);
  502.                 break;
  503.         }
  504. #    endif OBJ
  505. #    ifdef PC
  506.         switch (classify(p)) {
  507.             case TINT:
  508.             case TBOOL:
  509.             case TCHAR:
  510.             case TSCAL:
  511.                 postcheck(p, p1);
  512.                 sconv(p2type(p1), p2type(p));
  513.                 putop( PCC_ASSIGN , p2type( p ) );
  514.                 putdot( filename , line );
  515.                 break;
  516.             case TPTR:
  517.                 putop( PCC_ASSIGN , p2type( p ) );
  518.                 putdot( filename , line );
  519.                 break;
  520.             case TDOUBLE:
  521.                 sconv(p2type(p1), p2type(p));
  522.                 putop( PCC_ASSIGN , p2type( p ) );
  523.                 putdot( filename , line );
  524.                 break;
  525.             default:
  526.                 putstrop(PCC_STASG, PCCM_ADDTYPE(p2type(p), PCCTM_PTR),
  527.                     (int) lwidth(p), align(p));
  528.                 putdot( filename , line );
  529.                 break;
  530.         }
  531. #    endif PC
  532.     return (p);    /* Used by for statement */
  533. }
  534.  
  535. #ifdef PC
  536. /*
  537.  * assignment to conformant arrays.  Since these are variable length,
  538.  *    we use blkcpy() to perform the assignment.
  539.  *    blkcpy(rhs, lhs, (upper - lower + 1) * width)
  540.  */
  541. struct nl *
  542. pcasgconf(r, p)
  543.     register ASG_NODE *r;
  544.     struct nl *p;
  545. {
  546.     struct nl *p1;
  547.  
  548.     if (r == (ASG_NODE *) TR_NIL || p == NLNIL)
  549.         return NLNIL;
  550.     putleaf( PCC_ICON , 0 , 0 , PCCM_ADDTYPE( PCCTM_FTN | PCCT_INT , PCCTM_PTR) , "_blkcpy" );
  551.     p1 = rvalue( r->rhs_expr , p , LREQ );
  552.     if (p1 == NLNIL)
  553.         return NLNIL;
  554.     p = lvalue( r->lhs_var , MOD|ASGN|NOUSE , LREQ );
  555.     if (p == NLNIL)
  556.         return NLNIL;
  557.     putop(PCC_CM, PCCT_INT);
  558.         /* upper bound */
  559.     p1 = p->chain->nptr[1];
  560.     putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
  561.         p1->extra_flags, p2type( p1 ) );
  562.         /* minus lower bound */
  563.     p1 = p->chain->nptr[0];
  564.     putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
  565.         p1->extra_flags, p2type( p1 ) );
  566.     putop( PCC_MINUS, PCCT_INT );
  567.         /* add one */
  568.     putleaf(PCC_ICON, 1, 0, PCCT_INT, 0);
  569.     putop( PCC_PLUS, PCCT_INT );
  570.         /* and multiply by the width */
  571.     p1 = p->chain->nptr[2];
  572.     putRV(p1->symbol, (p1->nl_block & 037), p1->value[0],
  573.         p1->extra_flags, p2type( p1 ) );
  574.     putop( PCC_MUL , PCCT_INT );
  575.     putop(PCC_CM, PCCT_INT);
  576.     putop(PCC_CALL, PCCT_INT);
  577.     putdot( filename , line);
  578.     return p;
  579. }
  580. #endif PC
  581.  
  582. /*
  583.  * if expr then stat [ else stat ]
  584.  */
  585. ifop(if_n)
  586.     IF_NODE *if_n;
  587. {
  588.     register struct nl *p;
  589.     register l1, l2;    /* l1 is start of else, l2 is end of else */
  590.     int goc;
  591.     bool nr;
  592.  
  593.     goc = gocnt;
  594.     putline();
  595.     p = rvalue(if_n->cond_expr, NLNIL , RREQ );
  596.     if (p == NIL) {
  597.         statement(if_n->then_stmnt);
  598.         noreach = FALSE;
  599.         statement(if_n->else_stmnt);
  600.         noreach = FALSE;
  601.         return;
  602.     }
  603.     if (isnta(p, "b")) {
  604.         error("Type of expression in if statement must be Boolean, not %s", nameof(p));
  605.         statement(if_n->then_stmnt);
  606.         noreach = FALSE;
  607.         statement(if_n->else_stmnt);
  608.         noreach = FALSE;
  609.         return;
  610.     }
  611. #    ifdef OBJ
  612.         l1 = put(2, O_IF, getlab());
  613. #    endif OBJ
  614. #    ifdef PC
  615.         l1 = (int) getlab();
  616.         putleaf( PCC_ICON , l1 , 0 , PCCT_INT , (char *) 0 );
  617.         putop( PCC_CBRANCH , PCCT_INT );
  618.         putdot( filename , line );
  619. #    endif PC
  620.     putcnt();
  621.     statement(if_n->then_stmnt);
  622.     nr = noreach;
  623.     if (if_n->else_stmnt != TR_NIL) {
  624.         /*
  625.          * else stat
  626.          */
  627.         --level;
  628.         ungoto();
  629.         ++level;
  630. #        ifdef OBJ
  631.             l2 = put(2, O_TRA, getlab());
  632. #        endif OBJ
  633. #        ifdef PC
  634.             l2 = (int) getlab();
  635.             putjbr( (long) l2 );
  636. #        endif PC
  637.         patch((PTR_DCL)l1);
  638.         noreach = FALSE;
  639.         statement(if_n->else_stmnt);
  640.         noreach = (noreach && nr)?TRUE:FALSE;
  641.         l1 = l2;
  642.     } else
  643.         noreach = FALSE;
  644.     patch((PTR_DCL)l1);
  645.     if (goc != gocnt)
  646.         putcnt();
  647. }
  648.  
  649. /*
  650.  * while expr do stat
  651.  */
  652. whilop(w_node)
  653.     WHI_CAS *w_node;
  654. {
  655.     register struct nl *p;
  656.     register char *l1, *l2;
  657.     int goc;
  658.  
  659.     goc = gocnt;
  660.     l1 = getlab();
  661.     (void) putlab(l1);
  662.     putline();
  663.     p = rvalue(w_node->expr, NLNIL , RREQ );
  664.     if (p == NLNIL) {
  665.         statement(w_node->stmnt_list);
  666.         noreach = FALSE;
  667.         return;
  668.     }
  669.     if (isnta(p, "b")) {
  670.         error("Type of expression in while statement must be Boolean, not %s", nameof(p));
  671.         statement(w_node->stmnt_list);
  672.         noreach = FALSE;
  673.         return;
  674.     }
  675.     l2 = getlab();
  676. #    ifdef OBJ
  677.         (void) put(2, O_IF, l2);
  678. #    endif OBJ
  679. #    ifdef PC
  680.         putleaf( PCC_ICON , (int) l2 , 0 , PCCT_INT , (char *) 0 );
  681.         putop( PCC_CBRANCH , PCCT_INT );
  682.         putdot( filename , line );
  683. #    endif PC
  684.     putcnt();
  685.     statement(w_node->stmnt_list);
  686. #    ifdef OBJ
  687.         (void) put(2, O_TRA, l1);
  688. #    endif OBJ
  689. #    ifdef PC
  690.         putjbr( (long) l1 );
  691. #    endif PC
  692.     patch((PTR_DCL) l2);
  693.     if (goc != gocnt)
  694.         putcnt();
  695. }
  696.  
  697. /*
  698.  * repeat stat* until expr
  699.  */
  700. repop(r)
  701.     REPEAT *r;
  702. {
  703.     register struct nl *p;
  704.     register l;
  705.     int goc;
  706.  
  707.     goc = gocnt;
  708.     l = (int) putlab(getlab());
  709.     putcnt();
  710.     statlist(r->stmnt_list);
  711.     line = r->line_no;
  712.     p = rvalue(r->term_expr, NLNIL , RREQ );
  713.     if (p == NLNIL)
  714.         return;
  715.     if (isnta(p,"b")) {
  716.         error("Until expression type must be Boolean, not %s, in repeat statement", nameof(p));
  717.         return;
  718.     }
  719. #    ifdef OBJ
  720.         (void) put(2, O_IF, l);
  721. #    endif OBJ
  722. #    ifdef PC
  723.         putleaf( PCC_ICON , l , 0 , PCCT_INT , (char *) 0 );
  724.         putop( PCC_CBRANCH , PCCT_INT );
  725.         putdot( filename , line );
  726. #    endif PC
  727.     if (goc != gocnt)
  728.         putcnt();
  729. }
  730.