home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 11 / AUCD11B.iso / LANGUAGES / WraithSet / AwkStuff / MawkSrc / c / execute < prev    next >
Encoding:
Text File  |  1999-11-06  |  31.6 KB  |  1,474 lines
  1.  
  2. /********************************************
  3. execute.c
  4. copyright 1991-1996, Michael D. Brennan
  5.  
  6. This is a source file for mawk, an implementation of
  7. the AWK programming language.
  8.  
  9. Mawk is distributed without warranty under the terms of
  10. the GNU General Public License, version 2, 1991.
  11. ********************************************/
  12.  
  13. /* $Log: execute.c,v $
  14.  * Revision 1.13  1996/02/01  04:39:40  mike
  15.  * dynamic array scheme
  16.  *
  17.  * Revision 1.12  1995/06/06  00:18:24  mike
  18.  * change mawk_exit(1) to mawk_exit(2)
  19.  *
  20.  * Revision 1.11  1995/03/08  00:06:24  mike
  21.  * add a pointer cast
  22.  *
  23.  * Revision 1.10  1994/12/13  00:12:10  mike
  24.  * delete A statement to delete all of A at once
  25.  *
  26.  * Revision 1.9  1994/10/25  23:36:11  mike
  27.  * clear aloop stack on _NEXT
  28.  *
  29.  * Revision 1.8  1994/10/08  19:15:35  mike
  30.  * remove SM_DOS
  31.  *
  32.  * Revision 1.7  1993/12/30  19:10:03  mike
  33.  * minor cleanup to _CALL
  34.  *
  35.  * Revision 1.6  1993/12/01  14:25:13  mike
  36.  * reentrant array loops
  37.  *
  38.  * Revision 1.5  1993/07/22  00:04:08  mike
  39.  * new op code _LJZ _LJNZ
  40.  *
  41.  * Revision 1.4  1993/07/14  12:18:21  mike
  42.  * run thru indent
  43.  *
  44.  * Revision 1.3     1993/07/14  11:50:17  mike
  45.  * rm SIZE_T and void casts
  46.  *
  47.  * Revision 1.2     1993/07/04  12:51:49  mike
  48.  * start on autoconfig changes
  49.  *
  50.  * Revision 5.10  1993/02/13  21:57:22    mike
  51.  * merge patch3
  52.  *
  53.  * Revision 5.9     1993/01/07  02:50:33  mike
  54.  * relative vs absolute code
  55.  *
  56.  * Revision 5.8     1993/01/01  21:30:48  mike
  57.  * split new_STRING() into new_STRING and new_STRING0
  58.  *
  59.  * Revision 5.7.1.1  1993/01/15     03:33:39  mike
  60.  * patch3: safer double to int conversion
  61.  *
  62.  * Revision 5.7     1992/12/17  02:48:01  mike
  63.  * 1.1.2d changes for DOS
  64.  *
  65.  * Revision 5.6     1992/11/29  18:57:50  mike
  66.  * field expressions convert to long so 16 bit and 32 bit
  67.  * systems behave the same
  68.  *
  69.  * Revision 5.5     1992/08/11  15:24:55  brennan
  70.  * patch2: F_PUSHA and FE_PUSHA
  71.  * If this is preparation for g?sub(r,s,$expr) or (++|--) on $expr,
  72.  * then if expr > NF, make sure $expr is set to ""
  73.  *
  74.  * Revision 5.4     1992/08/11  14:51:54  brennan
  75.  * patch2:  $expr++ is numeric even if $expr is string.
  76.  * I forgot to do this earlier when handling x++ case.
  77.  *
  78.  * Revision 5.3     1992/07/08  17:03:30  brennan
  79.  * patch 2
  80.  * revert to version 1.0 comparisons, i.e.
  81.  * page 44-45 of AWK book
  82.  *
  83.  * Revision 5.2     1992/04/20  21:40:40  brennan
  84.  * patch 2
  85.  * x++ is numeric, even if x is string
  86.  *
  87.  * Revision 5.1     1991/12/05  07:55:50  brennan
  88.  * 1.1 pre-release
  89.  *
  90. */
  91.  
  92.  
  93. #include "mawk.h"
  94. #include "code.h"
  95. #include "memory.h"
  96. #include "symtype.h"
  97. #include "field.h"
  98. #include "bi_funct.h"
  99. #include "bi_vars.h"
  100. #include "regexp.h"
  101. #include "repl.h"
  102. #include "fin.h"
  103. #include <math.h>
  104.  
  105. static int PROTO(compare, (CELL *)) ;
  106. static int PROTO(d_to_index, (double)) ;
  107.  
  108. #ifdef     NOINFO_SIGFPE
  109. static char dz_msg[] = "division by zero" ;
  110. #define     CHECK_DIVZERO(x) if( (x) == 0.0 )rt_error(dz_msg);else
  111. #endif
  112. #ifdef     RISCOS
  113. static char dz_msg[] = "division by zero" ;
  114. #define     CHECK_DIVZERO(x) if( (x) == 0.0 )rt_error(dz_msg);else
  115. #endif
  116.  
  117.  
  118. #ifdef     DEBUG
  119. static void PROTO(eval_overflow, (void)) ;
  120.  
  121. #define     inc_sp()   if( ++sp == eval_stack+EVAL_STACK_SIZE )\
  122.              eval_overflow()
  123. #else
  124.  
  125. /* If things are working, the eval stack should not overflow */
  126.  
  127. #define inc_sp()    sp++
  128. #endif
  129.  
  130. #define     SAFETY       16
  131. #define     DANGER       (EVAL_STACK_SIZE-SAFETY)
  132.  
  133. /*  The stack machine that executes the code */
  134.  
  135. CELL eval_stack[EVAL_STACK_SIZE] ;
  136. /* these can move for deep recursion */
  137. static CELL *stack_base = eval_stack ;
  138. static CELL *stack_danger = eval_stack + DANGER ;
  139.  
  140. #ifdef    DEBUG
  141. static void
  142. eval_overflow()
  143. {
  144.    overflow("eval stack", EVAL_STACK_SIZE) ;
  145. }
  146. #endif
  147.  
  148. /* holds info for array loops (on a stack) */
  149. typedef struct aloop_state {
  150.    struct aloop_state *link ;
  151.    CELL *var ;  /* for(var in A) */
  152.    STRING **base ;
  153.    STRING **ptr ;
  154.    STRING **limit ;
  155. } ALOOP_STATE ;
  156.  
  157. /* clean up aloop stack on next, return, exit */
  158. #define CLEAR_ALOOP_STACK() if(aloop_state){\
  159.         clear_aloop_stack(aloop_state);\
  160.         aloop_state=(ALOOP_STATE*)0;}else
  161.  
  162. static void clear_aloop_stack(top)
  163.    ALOOP_STATE *top ;
  164. {
  165.    ALOOP_STATE *q ;
  166.  
  167.    do {
  168.       while(top->ptr<top->limit) {
  169.      free_STRING(*top->ptr) ;
  170.      top->ptr++ ;
  171.       }
  172.       if (top->base < top->limit)
  173.      zfree(top->base, (top->limit-top->base)*sizeof(STRING*)) ;
  174.       q = top ; top = q->link ;
  175.       ZFREE(q) ;
  176.    } while (top) ;
  177. }
  178.    
  179.  
  180. static INST *restart_label ;     /* control flow labels */
  181. INST *next_label ;
  182. static CELL tc ;         /*useful temp */
  183.  
  184. void
  185. execute(cdp, sp, fp)
  186.    register INST *cdp ;         /* code ptr, start execution here */
  187.    register CELL *sp ;         /* eval_stack pointer */
  188.    CELL *fp ;             /* frame ptr into eval_stack for
  189.                user defined functions */
  190. {
  191.    /* some useful temporaries */
  192.    CELL *cp ;
  193.    int t ;
  194.  
  195.    /* save state for array loops via a stack */
  196.    ALOOP_STATE *aloop_state = (ALOOP_STATE*) 0 ;
  197.  
  198.    /* for moving the eval stack on deep recursion */
  199.    CELL *old_stack_base ;
  200.    CELL *old_sp ;
  201.  
  202. #ifdef    DEBUG
  203.    CELL *entry_sp = sp ;
  204. #endif
  205.  
  206.  
  207.    if (fp)
  208.    {
  209.       /* we are a function call, check for deep recursion */
  210.       if (sp > stack_danger)
  211.       {                /* change stacks */
  212.      old_stack_base = stack_base ;
  213.      old_sp = sp ;
  214.      stack_base = (CELL *) zmalloc(sizeof(CELL) * EVAL_STACK_SIZE) ;
  215.      stack_danger = stack_base + DANGER ;
  216.      sp = stack_base ;
  217.      /* waste 1 slot for ANSI, actually large model msdos breaks in
  218.          RET if we don't */
  219. #ifdef    DEBUG
  220.      entry_sp = sp ;
  221. #endif
  222.       }
  223.       else  old_stack_base = (CELL *) 0 ;
  224.    }
  225.  
  226.    while (1)
  227.       switch (cdp++->op)
  228.       {
  229.  
  230. /* HALT only used by the disassemble now ; this remains
  231.    so compilers don't offset the jump table */
  232.      case _HALT:
  233.  
  234.      case _STOP:        /* only for range patterns */
  235. #ifdef    DEBUG
  236.         if (sp != entry_sp + 1)  bozo("stop0") ;
  237. #endif
  238.         return ;
  239.  
  240.      case _PUSHC:
  241.         inc_sp() ;
  242.         cellcpy(sp, cdp++->ptr) ;
  243.         break ;
  244.  
  245.      case _PUSHD:
  246.         inc_sp() ;
  247.         sp->type = C_DOUBLE ;
  248.         sp->dval = *(double *) cdp++->ptr ;
  249.         break ;
  250.  
  251.      case _PUSHS:
  252.         inc_sp() ;
  253.         sp->type = C_STRING ;
  254.         sp->ptr = cdp++->ptr ;
  255.         string(sp)->ref_cnt++ ;
  256.         break ;
  257.  
  258.      case F_PUSHA:
  259.         cp = (CELL *) cdp->ptr ;
  260.         if (cp != field)
  261.         {
  262.            if (nf < 0)  split_field0() ;
  263.  
  264.            if (!(
  265. #ifdef MSDOS
  266.                SAMESEG(cp, field) &&
  267. #endif
  268.                cp >= NF && cp <= LAST_PFIELD))
  269.            {
  270.           /* its a real field $1, $2 ...
  271.              If its greater than $NF, we have to
  272.              make sure its set to ""  so that
  273.              (++|--) and g?sub() work right
  274.           */
  275.           t = field_addr_to_index(cp) ;
  276.           if (t > nf)
  277.           {
  278.              cell_destroy(cp) ;
  279.              cp->type = C_STRING ;
  280.              cp->ptr = (PTR) & null_str ;
  281.              null_str.ref_cnt++ ;
  282.           }
  283.            }
  284.         }
  285.         /* fall thru */
  286.  
  287.      case _PUSHA:
  288.      case A_PUSHA:
  289.         inc_sp() ;
  290.         sp->ptr = cdp++->ptr ;
  291.         break ;
  292.  
  293.      case _PUSHI:
  294.         /* put contents of next address on stack*/
  295.         inc_sp() ;
  296.         cellcpy(sp, cdp++->ptr) ;
  297.         break ;
  298.  
  299.      case L_PUSHI:
  300.         /* put the contents of a local var on stack,
  301.            cdp->op holds the offset from the frame pointer */
  302.         inc_sp() ;
  303.         cellcpy(sp, fp + cdp++->op) ;
  304.         break ;
  305.  
  306.      case L_PUSHA:
  307.         /* put a local address on eval stack */
  308.         inc_sp() ;
  309.         sp->ptr = (PTR) (fp + cdp++->op) ;
  310.         break ;
  311.  
  312.  
  313.      case F_PUSHI:
  314.  
  315.         /* push contents of $i
  316.            cdp[0] holds & $i , cdp[1] holds i */
  317.  
  318.         inc_sp() ;
  319.         if (nf < 0)     split_field0() ;
  320.         cp = (CELL *) cdp->ptr ;
  321.         t = (cdp + 1)->op ;
  322.         cdp += 2 ;
  323.  
  324.         if (t <= nf)  cellcpy(sp, cp) ;
  325.         else  /* an unset field */
  326.         {
  327.            sp->type = C_STRING ;
  328.            sp->ptr = (PTR) & null_str ;
  329.            null_str.ref_cnt++ ;
  330.         }
  331.         break ;
  332.  
  333.      case NF_PUSHI:
  334.  
  335.         inc_sp() ;
  336.         if (nf < 0)     split_field0() ;
  337.         cellcpy(sp, NF) ;
  338.         break ;
  339.  
  340.      case FE_PUSHA:
  341.  
  342.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  343.  
  344.         t = d_to_index(sp->dval) ;
  345.         if (t && nf < 0)  split_field0() ;
  346.         sp->ptr = (PTR) field_ptr(t) ;
  347.         if (t > nf)
  348.         {
  349.            /* make sure its set to "" */
  350.            cp = (CELL *) sp->ptr ;
  351.            cell_destroy(cp) ;
  352.            cp->type = C_STRING ;
  353.            cp->ptr = (PTR) & null_str ;
  354.            null_str.ref_cnt++ ;
  355.         }
  356.         break ;
  357.  
  358.      case FE_PUSHI:
  359.  
  360.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  361.  
  362.         t = d_to_index(sp->dval) ;
  363.  
  364.         if (nf < 0)     split_field0() ;
  365.         if (t <= nf)  cellcpy(sp, field_ptr(t)) ;
  366.         else
  367.         {
  368.            sp->type = C_STRING ;
  369.            sp->ptr = (PTR) & null_str ;
  370.            null_str.ref_cnt++ ;
  371.         }
  372.         break ;
  373.  
  374.  
  375.      case AE_PUSHA:
  376.         /* top of stack has an expr, cdp->ptr points at an
  377.        array, replace the expr with the cell address inside
  378.        the array */
  379.  
  380.         cp = array_find((ARRAY) cdp++->ptr, sp, CREATE) ;
  381.         cell_destroy(sp) ;
  382.         sp->ptr = (PTR) cp ;
  383.         break ;
  384.  
  385.      case AE_PUSHI:
  386.         /* top of stack has an expr, cdp->ptr points at an
  387.        array, replace the expr with the contents of the
  388.        cell inside the array */
  389.  
  390.         cp = array_find((ARRAY) cdp++->ptr, sp, CREATE) ;
  391.         cell_destroy(sp) ;
  392.         cellcpy(sp, cp) ;
  393.         break ;
  394.  
  395.      case LAE_PUSHI:
  396.         /*    sp[0] is an expression
  397.         cdp->op is offset from frame pointer of a CELL which
  398.            has an ARRAY in the ptr field, replace expr
  399.         with  array[expr]
  400.     */
  401.         cp = array_find((ARRAY) fp[cdp++->op].ptr, sp, CREATE) ;
  402.         cell_destroy(sp) ;
  403.         cellcpy(sp, cp) ;
  404.         break ;
  405.  
  406.      case LAE_PUSHA:
  407.         /*    sp[0] is an expression
  408.         cdp->op is offset from frame pointer of a CELL which
  409.            has an ARRAY in the ptr field, replace expr
  410.         with  & array[expr]
  411.     */
  412.         cp = array_find((ARRAY) fp[cdp++->op].ptr, sp, CREATE) ;
  413.         cell_destroy(sp) ;
  414.         sp->ptr = (PTR) cp ;
  415.         break ;
  416.  
  417.      case LA_PUSHA:
  418.         /*    cdp->op is offset from frame pointer of a CELL which
  419.            has an ARRAY in the ptr field. Push this ARRAY
  420.            on the eval stack
  421.     */
  422.         inc_sp() ;
  423.         sp->ptr = fp[cdp++->op].ptr ;
  424.         break ;
  425.  
  426.      case SET_ALOOP:
  427.         {
  428.            ALOOP_STATE *ap = ZMALLOC(ALOOP_STATE) ;
  429.            unsigned vector_size ;
  430.  
  431.            ap->var = (CELL *) sp[-1].ptr ;
  432.            ap->base = ap->ptr = array_loop_vector(
  433.                 (ARRAY)sp->ptr, &vector_size) ;
  434.            ap->limit = ap->base + vector_size ;
  435.            sp -= 2 ;
  436.  
  437.            /* push onto aloop stack */
  438.            ap->link = aloop_state ;
  439.            aloop_state = ap ;
  440.            cdp += cdp->op ;
  441.         }
  442.         break ;
  443.  
  444.      case  ALOOP :
  445.         {
  446.            ALOOP_STATE *ap = aloop_state ;
  447.            if (ap->ptr < ap->limit) 
  448.            {
  449.           cell_destroy(ap->var) ;
  450.           ap->var->type = C_STRING ;
  451.           ap->var->ptr = (PTR) *ap->ptr++ ;
  452.           cdp += cdp->op ;
  453.            }
  454.            else cdp++ ;
  455.         }
  456.         break ;
  457.           
  458.      case  POP_AL :
  459.         { 
  460.            /* finish up an array loop */
  461.            ALOOP_STATE *ap = aloop_state ;
  462.                aloop_state = ap->link ;
  463.            while(ap->ptr < ap->limit) {
  464.           free_STRING(*ap->ptr) ;
  465.           ap->ptr++ ;
  466.            }
  467.            if (ap->base < ap->limit)
  468.           zfree(ap->base,(ap->limit-ap->base)*sizeof(STRING*)) ;
  469.                ZFREE(ap) ;
  470.             }
  471.         break ;
  472.  
  473.      case _POP:
  474.         cell_destroy(sp) ;
  475.         sp-- ;
  476.         break ;
  477.  
  478.      case _ASSIGN:
  479.         /* top of stack has an expr, next down is an
  480.            address, put the expression in *address and
  481.            replace the address with the expression */
  482.  
  483.         /* don't propagate type C_MBSTRN */
  484.         if (sp->type == C_MBSTRN)  check_strnum(sp) ;
  485.         sp-- ;
  486.         cell_destroy(((CELL *) sp->ptr)) ;
  487.         cellcpy(sp, cellcpy(sp->ptr, sp + 1)) ;
  488.         cell_destroy(sp + 1) ;
  489.         break ;
  490.  
  491.      case F_ASSIGN:
  492.         /* assign to a field  */
  493.         if (sp->type == C_MBSTRN)  check_strnum(sp) ;
  494.         sp-- ;
  495.         field_assign((CELL *) sp->ptr, sp + 1) ;
  496.         cell_destroy(sp + 1) ;
  497.         cellcpy(sp, (CELL *) sp->ptr) ;
  498.         break ;
  499.  
  500.      case _ADD_ASG:
  501.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  502.         cp = (CELL *) (sp - 1)->ptr ;
  503.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  504.  
  505. #if SW_FP_CHECK            /* specific to V7 and XNX23A */
  506.         clrerr() ;
  507. #endif
  508.         cp->dval += sp--->dval ;
  509. #if SW_FP_CHECK
  510.         fpcheck() ;
  511. #endif
  512.         sp->type = C_DOUBLE ;
  513.         sp->dval = cp->dval ;
  514.         break ;
  515.  
  516.      case _SUB_ASG:
  517.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  518.         cp = (CELL *) (sp - 1)->ptr ;
  519.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  520. #if SW_FP_CHECK
  521.         clrerr() ;
  522. #endif
  523.         cp->dval -= sp--->dval ;
  524. #if SW_FP_CHECK
  525.         fpcheck() ;
  526. #endif
  527.         sp->type = C_DOUBLE ;
  528.         sp->dval = cp->dval ;
  529.         break ;
  530.  
  531.      case _MUL_ASG:
  532.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  533.         cp = (CELL *) (sp - 1)->ptr ;
  534.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  535. #if SW_FP_CHECK
  536.         clrerr() ;
  537. #endif
  538.         cp->dval *= sp--->dval ;
  539. #if SW_FP_CHECK
  540.         fpcheck() ;
  541. #endif
  542.         sp->type = C_DOUBLE ;
  543.         sp->dval = cp->dval ;
  544.         break ;
  545.  
  546.      case _DIV_ASG:
  547.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  548.         cp = (CELL *) (sp - 1)->ptr ;
  549.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  550.  
  551. #if  NOINFO_SIGFPE
  552.         CHECK_DIVZERO(sp->dval) ;
  553. #endif
  554. #ifdef RISCOS
  555.         CHECK_DIVZERO(sp->dval) ;
  556. #endif
  557. #if SW_FP_CHECK
  558.         clrerr() ;
  559. #endif
  560.         cp->dval /= sp--->dval ;
  561. #if SW_FP_CHECK
  562.         fpcheck() ;
  563. #endif
  564.         sp->type = C_DOUBLE ;
  565.         sp->dval = cp->dval ;
  566.         break ;
  567.  
  568.      case _MOD_ASG:
  569.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  570.         cp = (CELL *) (sp - 1)->ptr ;
  571.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  572.  
  573. #if  NOINFO_SIGFPE
  574.         CHECK_DIVZERO(sp->dval) ;
  575. #endif
  576. #ifdef RISCOS
  577.         CHECK_DIVZERO(sp->dval) ;
  578. #endif
  579.         cp->dval = fmod(cp->dval, sp--->dval) ;
  580.         sp->type = C_DOUBLE ;
  581.         sp->dval = cp->dval ;
  582.         break ;
  583.  
  584.      case _POW_ASG:
  585.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  586.         cp = (CELL *) (sp - 1)->ptr ;
  587.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  588.         cp->dval = pow(cp->dval, sp--->dval) ;
  589.         sp->type = C_DOUBLE ;
  590.         sp->dval = cp->dval ;
  591.         break ;
  592.  
  593.         /* will anyone ever use these ? */
  594.  
  595.      case F_ADD_ASG:
  596.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  597.         cp = (CELL *) (sp - 1)->ptr ;
  598.         cast1_to_d(cellcpy(&tc, cp)) ;
  599. #if SW_FP_CHECK
  600.         clrerr() ;
  601. #endif
  602.         tc.dval += sp--->dval ;
  603. #if SW_FP_CHECK
  604.         fpcheck() ;
  605. #endif
  606.         sp->type = C_DOUBLE ;
  607.         sp->dval = tc.dval ;
  608.         field_assign(cp, &tc) ;
  609.         break ;
  610.  
  611.      case F_SUB_ASG:
  612.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  613.         cp = (CELL *) (sp - 1)->ptr ;
  614.         cast1_to_d(cellcpy(&tc, cp)) ;
  615. #if SW_FP_CHECK
  616.         clrerr() ;
  617. #endif
  618.         tc.dval -= sp--->dval ;
  619. #if SW_FP_CHECK
  620.         fpcheck() ;
  621. #endif
  622.         sp->type = C_DOUBLE ;
  623.         sp->dval = tc.dval ;
  624.         field_assign(cp, &tc) ;
  625.         break ;
  626.  
  627.      case F_MUL_ASG:
  628.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  629.         cp = (CELL *) (sp - 1)->ptr ;
  630.         cast1_to_d(cellcpy(&tc, cp)) ;
  631. #if SW_FP_CHECK
  632.         clrerr() ;
  633. #endif
  634.         tc.dval *= sp--->dval ;
  635. #if SW_FP_CHECK
  636.         fpcheck() ;
  637. #endif
  638.         sp->type = C_DOUBLE ;
  639.         sp->dval = tc.dval ;
  640.         field_assign(cp, &tc) ;
  641.         break ;
  642.  
  643.      case F_DIV_ASG:
  644.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  645.         cp = (CELL *) (sp - 1)->ptr ;
  646.         cast1_to_d(cellcpy(&tc, cp)) ;
  647.  
  648. #if  NOINFO_SIGFPE
  649.         CHECK_DIVZERO(sp->dval) ;
  650. #endif
  651. #ifdef RISCOS
  652.         CHECK_DIVZERO(sp->dval) ;
  653. #endif
  654. #if SW_FP_CHECK
  655.         clrerr() ;
  656. #endif
  657.         tc.dval /= sp--->dval ;
  658. #if SW_FP_CHECK
  659.         fpcheck() ;
  660. #endif
  661.         sp->type = C_DOUBLE ;
  662.         sp->dval = tc.dval ;
  663.         field_assign(cp, &tc) ;
  664.         break ;
  665.  
  666.      case F_MOD_ASG:
  667.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  668.         cp = (CELL *) (sp - 1)->ptr ;
  669.         cast1_to_d(cellcpy(&tc, cp)) ;
  670.  
  671. #if  NOINFO_SIGFPE
  672.         CHECK_DIVZERO(sp->dval) ;
  673. #endif
  674. #ifdef RISCOS
  675.         CHECK_DIVZERO(sp->dval) ;
  676. #endif
  677.         tc.dval = fmod(tc.dval, sp--->dval) ;
  678.         sp->type = C_DOUBLE ;
  679.         sp->dval = tc.dval ;
  680.         field_assign(cp, &tc) ;
  681.         break ;
  682.  
  683.      case F_POW_ASG:
  684.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  685.         cp = (CELL *) (sp - 1)->ptr ;
  686.         cast1_to_d(cellcpy(&tc, cp)) ;
  687.         tc.dval = pow(tc.dval, sp--->dval) ;
  688.         sp->type = C_DOUBLE ;
  689.         sp->dval = tc.dval ;
  690.         field_assign(cp, &tc) ;
  691.         break ;
  692.  
  693.      case _ADD:
  694.         sp-- ;
  695.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  696. #if SW_FP_CHECK
  697.         clrerr() ;
  698. #endif
  699.         sp[0].dval += sp[1].dval ;
  700. #if SW_FP_CHECK
  701.         fpcheck() ;
  702. #endif
  703.         break ;
  704.  
  705.      case _SUB:
  706.         sp-- ;
  707.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  708. #if SW_FP_CHECK
  709.         clrerr() ;
  710. #endif
  711.         sp[0].dval -= sp[1].dval ;
  712. #if SW_FP_CHECK
  713.         fpcheck() ;
  714. #endif
  715.         break ;
  716.  
  717.      case _MUL:
  718.         sp-- ;
  719.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  720. #if SW_FP_CHECK
  721.         clrerr() ;
  722. #endif
  723.         sp[0].dval *= sp[1].dval ;
  724. #if SW_FP_CHECK
  725.         fpcheck() ;
  726. #endif
  727.         break ;
  728.  
  729.      case _DIV:
  730.         sp-- ;
  731.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  732.  
  733. #if  NOINFO_SIGFPE
  734.         CHECK_DIVZERO(sp[1].dval) ;
  735. #endif
  736. #ifdef RISCOS
  737.         CHECK_DIVZERO(sp[1].dval) ;
  738. #endif
  739. #if SW_FP_CHECK
  740.         clrerr() ;
  741. #endif
  742.         sp[0].dval /= sp[1].dval ;
  743. #if SW_FP_CHECK
  744.         fpcheck() ;
  745. #endif
  746.         break ;
  747.  
  748.      case _MOD:
  749.         sp-- ;
  750.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  751.  
  752. #if  NOINFO_SIGFPE
  753.         CHECK_DIVZERO(sp[1].dval) ;
  754. #endif
  755. #ifdef RISCOS
  756.         CHECK_DIVZERO(sp[1].dval) ;
  757. #endif
  758.         sp[0].dval = fmod(sp[0].dval, sp[1].dval) ;
  759.         break ;
  760.  
  761.      case _POW:
  762.         sp-- ;
  763.         if (TEST2(sp) != TWO_DOUBLES)  cast2_to_d(sp) ;
  764.         sp[0].dval = pow(sp[0].dval, sp[1].dval) ;
  765.         break ;
  766.  
  767.      case _NOT:
  768.         /* evaluates to 0.0 or 1.0 */
  769.       reswitch_1:
  770.         switch (sp->type)
  771.         {
  772.            case C_NOINIT:
  773.           sp->dval = 1.0 ; break ;
  774.            case C_DOUBLE:
  775.           sp->dval = sp->dval != 0.0 ? 0.0 : 1.0 ;
  776.           break ;
  777.            case C_STRING:
  778.           sp->dval = string(sp)->len ? 0.0 : 1.0 ;
  779.           free_STRING(string(sp)) ;
  780.           break ;
  781.            case C_STRNUM:    /* test as a number */
  782.           sp->dval = sp->dval != 0.0 ? 0.0 : 1.0 ;
  783.           free_STRING(string(sp)) ;
  784.           break ;
  785.            case C_MBSTRN:
  786.           check_strnum(sp) ;
  787.           goto reswitch_1 ;
  788.            default:
  789.           bozo("bad type on eval stack") ;
  790.         }
  791.         sp->type = C_DOUBLE ;
  792.         break ;
  793.  
  794.      case _TEST:
  795.         /* evaluates to 0.0 or 1.0 */
  796.       reswitch_2:
  797.         switch (sp->type)
  798.         {
  799.            case C_NOINIT:
  800.           sp->dval = 0.0 ; break ;
  801.            case C_DOUBLE:
  802.           sp->dval = sp->dval != 0.0 ? 1.0 : 0.0 ;
  803.           break ;
  804.            case C_STRING:
  805.           sp->dval = string(sp)->len ? 1.0 : 0.0 ;
  806.           free_STRING(string(sp)) ;
  807.           break ;
  808.            case C_STRNUM:    /* test as a number */
  809.           sp->dval = sp->dval != 0.0 ? 1.0 : 0.0 ;
  810.           free_STRING(string(sp)) ;
  811.           break ;
  812.            case C_MBSTRN:
  813.           check_strnum(sp) ;
  814.           goto reswitch_2 ;
  815.            default:
  816.           bozo("bad type on eval stack") ;
  817.         }
  818.         sp->type = C_DOUBLE ;
  819.         break ;
  820.  
  821.      case _UMINUS:
  822.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  823.         sp->dval = -sp->dval ;
  824.         break ;
  825.  
  826.      case _UPLUS:
  827.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  828.         break ;
  829.  
  830.      case _CAT:
  831.         {
  832.            unsigned len1, len2 ;
  833.            char *str1, *str2 ;
  834.            STRING *b ;
  835.  
  836.            sp-- ;
  837.            if (TEST2(sp) != TWO_STRINGS)  cast2_to_s(sp) ;
  838.            str1 = string(sp)->str ;
  839.            len1 = string(sp)->len ;
  840.            str2 = string(sp + 1)->str ;
  841.            len2 = string(sp + 1)->len ;
  842.  
  843.            b = new_STRING0(len1 + len2) ;
  844.            memcpy(b->str, str1, len1) ;
  845.            memcpy(b->str + len1, str2, len2) ;
  846.            free_STRING(string(sp)) ;
  847.            free_STRING(string(sp + 1)) ;
  848.  
  849.            sp->ptr = (PTR) b ;
  850.            break ;
  851.         }
  852.  
  853.      case _PUSHINT:
  854.         inc_sp() ;
  855.         sp->type = cdp++->op ;
  856.         break ;
  857.  
  858.      case _BUILTIN:
  859.      case _PRINT:
  860.         sp = (*(PF_CP) cdp++->ptr) (sp) ;
  861.         break ;
  862.  
  863.      case _POST_INC:
  864.         cp = (CELL *) sp->ptr ;
  865.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  866.         sp->type = C_DOUBLE ;
  867.         sp->dval = cp->dval ;
  868.         cp->dval += 1.0 ;
  869.         break ;
  870.  
  871.      case _POST_DEC:
  872.         cp = (CELL *) sp->ptr ;
  873.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  874.         sp->type = C_DOUBLE ;
  875.         sp->dval = cp->dval ;
  876.         cp->dval -= 1.0 ;
  877.         break ;
  878.  
  879.      case _PRE_INC:
  880.         cp = (CELL *) sp->ptr ;
  881.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  882.         sp->dval = cp->dval += 1.0 ;
  883.         sp->type = C_DOUBLE ;
  884.         break ;
  885.  
  886.      case _PRE_DEC:
  887.         cp = (CELL *) sp->ptr ;
  888.         if (cp->type != C_DOUBLE)  cast1_to_d(cp) ;
  889.         sp->dval = cp->dval -= 1.0 ;
  890.         sp->type = C_DOUBLE ;
  891.         break ;
  892.  
  893.  
  894.      case F_POST_INC:
  895.         cp = (CELL *) sp->ptr ;
  896.         cellcpy(&tc, cp) ;
  897.         cast1_to_d(&tc) ;
  898.         sp->type = C_DOUBLE ;
  899.         sp->dval = tc.dval ;
  900.         tc.dval += 1.0 ;
  901.         field_assign(cp, &tc) ;
  902.         break ;
  903.  
  904.      case F_POST_DEC:
  905.         cp = (CELL *) sp->ptr ;
  906.         cellcpy(&tc, cp) ;
  907.         cast1_to_d(&tc) ;
  908.         sp->type = C_DOUBLE ;
  909.         sp->dval = tc.dval ;
  910.         tc.dval -= 1.0 ;
  911.         field_assign(cp, &tc) ;
  912.         break ;
  913.  
  914.      case F_PRE_INC:
  915.         cp = (CELL *) sp->ptr ;
  916.         cast1_to_d(cellcpy(sp, cp)) ;
  917.         sp->dval += 1.0 ;
  918.         field_assign(cp, sp) ;
  919.         break ;
  920.  
  921.      case F_PRE_DEC:
  922.         cp = (CELL *) sp->ptr ;
  923.         cast1_to_d(cellcpy(sp, cp)) ;
  924.         sp->dval -= 1.0 ;
  925.         field_assign(cp, sp) ;
  926.         break ;
  927.  
  928.      case _JMP:
  929.         cdp += cdp->op ;
  930.         break ;
  931.  
  932.      case _JNZ:
  933.         /* jmp if top of stack is non-zero and pop stack */
  934.         if (test(sp))  cdp += cdp->op ;
  935.         else  cdp++ ;
  936.         cell_destroy(sp) ;
  937.         sp-- ;
  938.         break ;
  939.  
  940.      case _JZ:
  941.         /* jmp if top of stack is zero and pop stack */
  942.         if (!test(sp))  cdp += cdp->op ;
  943.         else  cdp++ ;
  944.         cell_destroy(sp) ;
  945.         sp-- ;
  946.         break ;
  947.  
  948.      case _LJZ:
  949.         /* special jump for logical and */
  950.         /* this is always preceded by _TEST */
  951.         if ( sp->dval == 0.0 )
  952.         {
  953.            /* take jump, but don't pop stack */
  954.            cdp += cdp->op ;
  955.         }
  956.         else
  957.         {
  958.            /* pop and don't jump */
  959.            sp-- ;
  960.            cdp++ ;
  961.         }
  962.         break ;
  963.            
  964.      case _LJNZ:
  965.         /* special jump for logical or */
  966.         /* this is always preceded by _TEST */
  967.         if ( sp->dval != 0.0 )
  968.         {
  969.            /* take jump, but don't pop stack */
  970.            cdp += cdp->op ;
  971.         }
  972.         else
  973.         {
  974.            /* pop and don't jump */
  975.            sp-- ;
  976.            cdp++ ;
  977.         }
  978.         break ;
  979.  
  980.         /*    the relation operations */
  981.         /*    compare() makes sure string ref counts are OK */
  982.      case _EQ:
  983.         t = compare(--sp) ;
  984.         sp->type = C_DOUBLE ;
  985.         sp->dval = t == 0 ? 1.0 : 0.0 ;
  986.         break ;
  987.  
  988.      case _NEQ:
  989.         t = compare(--sp) ;
  990.         sp->type = C_DOUBLE ;
  991.         sp->dval = t ? 1.0 : 0.0 ;
  992.         break ;
  993.  
  994.      case _LT:
  995.         t = compare(--sp) ;
  996.         sp->type = C_DOUBLE ;
  997.         sp->dval = t < 0 ? 1.0 : 0.0 ;
  998.         break ;
  999.  
  1000.      case _LTE:
  1001.         t = compare(--sp) ;
  1002.         sp->type = C_DOUBLE ;
  1003.         sp->dval = t <= 0 ? 1.0 : 0.0 ;
  1004.         break ;
  1005.  
  1006.      case _GT:
  1007.         t = compare(--sp) ;
  1008.         sp->type = C_DOUBLE ;
  1009.         sp->dval = t > 0 ? 1.0 : 0.0 ;
  1010.         break ;
  1011.  
  1012.      case _GTE:
  1013.         t = compare(--sp) ;
  1014.         sp->type = C_DOUBLE ;
  1015.         sp->dval = t >= 0 ? 1.0 : 0.0 ;
  1016.         break ;
  1017.  
  1018.      case _MATCH0:
  1019.         /* does $0 match, the RE at cdp? */
  1020.  
  1021.         inc_sp() ;
  1022.         if (field->type >= C_STRING)
  1023.         {
  1024.            sp->type = C_DOUBLE ;
  1025.            sp->dval = REtest(string(field)->str, cdp++->ptr)
  1026.           ? 1.0 : 0.0 ;
  1027.  
  1028.            break /* the case */ ;
  1029.         }
  1030.         else
  1031.         {
  1032.            cellcpy(sp, field) ;
  1033.            /* and FALL THRU */
  1034.         }
  1035.  
  1036.      case _MATCH1:
  1037.         /* does expr at sp[0] match RE at cdp */
  1038.         if (sp->type < C_STRING)  cast1_to_s(sp) ;
  1039.         t = REtest(string(sp)->str, cdp++->ptr) ;
  1040.         free_STRING(string(sp)) ;
  1041.         sp->type = C_DOUBLE ;
  1042.         sp->dval = t ? 1.0 : 0.0 ;
  1043.         break ;
  1044.  
  1045.  
  1046.      case _MATCH2:
  1047.         /* does sp[-1] match sp[0] as re */
  1048.         cast_to_RE(sp) ;
  1049.  
  1050.         if ((--sp)->type < C_STRING)  cast1_to_s(sp) ;
  1051.         t = REtest(string(sp)->str, (sp + 1)->ptr) ;
  1052.  
  1053.         free_STRING(string(sp)) ;
  1054.         sp->type = C_DOUBLE ;
  1055.         sp->dval = t ? 1.0 : 0.0 ;
  1056.         break ;
  1057.  
  1058.      case A_TEST:
  1059.         /* entry :    sp[0].ptr-> an array
  1060.             sp[-1]  is an expression
  1061.  
  1062.        we compute    (expression in array)  */
  1063.         sp-- ;
  1064.         cp = array_find((sp + 1)->ptr, sp, NO_CREATE) ;
  1065.         cell_destroy(sp) ;
  1066.         sp->type = C_DOUBLE ;
  1067.         sp->dval = (cp != (CELL *) 0) ? 1.0 : 0.0 ;
  1068.         break ;
  1069.  
  1070.      case A_DEL:
  1071.         /* sp[0].ptr ->  array
  1072.        sp[-1] is an expr
  1073.        delete  array[expr]    */
  1074.  
  1075.         array_delete(sp->ptr, sp - 1) ;
  1076.         cell_destroy(sp - 1) ;
  1077.         sp -= 2 ;
  1078.         break ;
  1079.  
  1080.      case DEL_A:
  1081.         /* free all the array at once */
  1082.         array_clear(sp->ptr) ;
  1083.         sp-- ;
  1084.         break ;
  1085.  
  1086.         /* form a multiple array index */
  1087.      case A_CAT:
  1088.         sp = array_cat(sp, cdp++->op) ;
  1089.         break ;
  1090.  
  1091.      case _EXIT:
  1092.         if (sp->type != C_DOUBLE)  cast1_to_d(sp) ;
  1093.         exit_code = d_to_i(sp->dval) ;
  1094.         sp-- ;
  1095.         /* fall thru */
  1096.  
  1097.      case _EXIT0:
  1098.  
  1099.         if (!end_start)  mawk_exit(exit_code) ;
  1100.  
  1101.         cdp = end_start ;
  1102.         end_start = (INST *) 0 ;     /* makes sure next exit exits */
  1103.  
  1104.         if (begin_start)  zfree(begin_start, begin_size) ;
  1105.         if (main_start)  zfree(main_start, main_size) ;
  1106.         sp = eval_stack - 1 ;/* might be in user function */
  1107.         CLEAR_ALOOP_STACK() ; /* ditto */
  1108.         break ;
  1109.  
  1110.      case _JMAIN:        /* go from BEGIN code to MAIN code */
  1111.         zfree(begin_start, begin_size) ;
  1112.         begin_start = (INST *) 0 ;
  1113.         cdp = main_start ;
  1114.         break ;
  1115.  
  1116.      case _OMAIN:
  1117.         if (!main_fin)  open_main() ;
  1118.         restart_label = cdp ;
  1119.         cdp = next_label ;
  1120.         break ;
  1121.  
  1122.      case _NEXT:
  1123.         /* next might be inside an aloop -- clear stack */
  1124.         CLEAR_ALOOP_STACK() ;
  1125.         cdp = next_label ;
  1126.         break ;
  1127.  
  1128.      case OL_GL:
  1129.         {
  1130.            char *p ;
  1131.            unsigned len ;
  1132.  
  1133.            if (!(p = FINgets(main_fin, &len)))
  1134.            {
  1135.           if (!end_start)  mawk_exit(0) ;
  1136.  
  1137.           cdp = end_start ;
  1138.           zfree(main_start, main_size) ;
  1139.           main_start = end_start = (INST *) 0 ;
  1140.            }
  1141.            else
  1142.            {
  1143.           set_field0(p, len) ;
  1144.           cdp = restart_label ;
  1145.           rt_nr++ ; rt_fnr++ ;
  1146.            }
  1147.         }
  1148.         break ;
  1149.  
  1150.      /* two kinds of OL_GL is a historical stupidity from working on
  1151.         a machine with very slow floating point emulation */
  1152.      case OL_GL_NR:
  1153.         {
  1154.            char *p ;
  1155.            unsigned len ;
  1156.  
  1157.            if (!(p = FINgets(main_fin, &len)))
  1158.            {
  1159.           if (!end_start)  mawk_exit(0) ;
  1160.  
  1161.           cdp = end_start ;
  1162.           zfree(main_start, main_size) ;
  1163.           main_start = end_start = (INST *) 0 ;
  1164.            }
  1165.            else
  1166.            {
  1167.           set_field0(p, len) ;
  1168.           cdp = restart_label ;
  1169.  
  1170.           if (TEST2(NR) != TWO_DOUBLES)     cast2_to_d(NR) ;
  1171.  
  1172.           NR->dval += 1.0 ; rt_nr++ ;
  1173.           FNR->dval += 1.0 ; rt_fnr++ ;
  1174.            }
  1175.         }
  1176.         break ;
  1177.  
  1178.  
  1179.      case _RANGE:
  1180. /* test a range pattern:  pat1, pat2 { action }
  1181.    entry :
  1182.        cdp[0].op -- a flag, test pat1 if on else pat2
  1183.        cdp[1].op -- offset of pat2 code from cdp
  1184.        cdp[2].op -- offset of action code from cdp
  1185.        cdp[3].op -- offset of code after the action from cdp
  1186.        cdp[4] -- start of pat1 code
  1187. */
  1188.  
  1189. #define FLAG    cdp[0].op
  1190. #define PAT2    cdp[1].op
  1191. #define ACTION      cdp[2].op
  1192. #define FOLLOW      cdp[3].op
  1193. #define PAT1      4
  1194.  
  1195.         if (FLAG)        /* test again pat1 */
  1196.         {
  1197.            execute(cdp + PAT1, sp, fp) ;
  1198.            t = test(sp + 1) ;
  1199.            cell_destroy(sp + 1) ;
  1200.            if (t)  FLAG = 0 ;
  1201.            else
  1202.            {
  1203.           cdp += FOLLOW ;
  1204.           break ;     /* break the switch */
  1205.            }
  1206.         }
  1207.  
  1208.         /* test against pat2 and then perform the action */
  1209.         execute(cdp + PAT2, sp, fp) ;
  1210.         FLAG = test(sp + 1) ;
  1211.         cell_destroy(sp + 1) ;
  1212.         cdp += ACTION ;
  1213.         break ;
  1214.  
  1215. /* function calls  */
  1216.  
  1217.      case _RET0:
  1218.         inc_sp() ;
  1219.         sp->type = C_NOINIT ;
  1220.         /* fall thru */
  1221.  
  1222.      case _RET:
  1223.  
  1224. #ifdef    DEBUG
  1225.         if (sp != entry_sp + 1)  bozo("ret") ;
  1226. #endif
  1227.         if (old_stack_base) /* reset stack */
  1228.         {
  1229.            /* move the return value */
  1230.            cellcpy(old_sp + 1, sp) ;
  1231.            cell_destroy(sp) ;
  1232.            zfree(stack_base, sizeof(CELL) * EVAL_STACK_SIZE) ;
  1233.            stack_base = old_stack_base ;
  1234.            stack_danger = old_stack_base + DANGER ;
  1235.         }
  1236.  
  1237.         /* return might be inside an aloop -- clear stack */
  1238.         CLEAR_ALOOP_STACK() ;
  1239.  
  1240.         return ;
  1241.  
  1242.      case _CALL:
  1243.         
  1244.         /*  cdp[0] holds ptr to "function block"
  1245.         cdp[1] holds number of input arguments
  1246.         */
  1247.  
  1248.         {
  1249.            FBLOCK *fbp = (FBLOCK *) cdp++->ptr ;
  1250.            int a_args = cdp++->op ;     /* actual number of args */
  1251.            CELL *nfp = sp - a_args + 1 ;     /* new fp for callee */
  1252.            CELL *local_p = sp + 1 ;     /* first local argument on stack */
  1253.            char *type_p ;     /* pts to type of an argument */
  1254.  
  1255.            if (fbp->nargs)    type_p = fbp->typev + a_args - 1 ;
  1256.  
  1257.            /* create space for locals */
  1258.            t = fbp->nargs - a_args ; /* t is number of locals */
  1259.            while (t>0)
  1260.            {
  1261.           t-- ; sp++ ; type_p++ ;
  1262.           sp->type = C_NOINIT ;
  1263.           if (*type_p == ST_LOCAL_ARRAY)
  1264.              sp->ptr = (PTR) new_ARRAY() ;
  1265.            }
  1266.  
  1267.            execute(fbp->code, sp, nfp) ;
  1268.  
  1269.            /* cleanup the callee's arguments */
  1270.            /* putting return value at top of eval stack */
  1271.            if (sp >= nfp)
  1272.            {
  1273.           cp = sp + 1 ;     /* cp -> the function return */
  1274.  
  1275.           do
  1276.           {
  1277.              if (*type_p == ST_LOCAL_ARRAY)
  1278.              {
  1279.             if (sp >= local_p)  
  1280.             {
  1281.                array_clear(sp->ptr) ;
  1282.                ZFREE((ARRAY)sp->ptr) ;
  1283.             }
  1284.              }
  1285.              else  cell_destroy(sp) ;
  1286.  
  1287.              type_p-- ; sp-- ;
  1288.  
  1289.           }
  1290.           while (sp >= nfp);
  1291.  
  1292.           cellcpy(++sp, cp) ;
  1293.           cell_destroy(cp) ;
  1294.            }
  1295.            else  sp++ ;        /* no arguments passed */
  1296.         }
  1297.         break ;
  1298.  
  1299.      default:
  1300.         bozo("bad opcode") ;
  1301.       }
  1302. }
  1303.  
  1304.  
  1305. /*
  1306.   return 0 if a numeric is zero else return non-zero
  1307.   return 0 if a string is "" else return non-zero
  1308. */
  1309. int
  1310. test(cp)
  1311.    register CELL *cp ;
  1312. {
  1313.  reswitch:
  1314.  
  1315.    switch (cp->type)
  1316.    {
  1317.       case C_NOINIT:
  1318.      return 0 ;
  1319.       case C_STRNUM:        /* test as a number */
  1320.       case C_DOUBLE:
  1321.      return cp->dval != 0.0 ;
  1322.       case C_STRING:
  1323.      return string(cp)->len ;
  1324.      case C_MBSTRN :  check_strnum(cp) ; goto reswitch ;
  1325.       default:
  1326.      bozo("bad cell type in call to test") ;
  1327.    }
  1328.    return 0 ;             /*can't get here: shutup */
  1329. }
  1330.  
  1331. /* compare cells at cp and cp+1 and
  1332.    frees STRINGs at those cells
  1333. */
  1334. static int
  1335. compare(cp)
  1336.    register CELL *cp ;
  1337. {
  1338.    int k ;
  1339.  
  1340.  reswitch:
  1341.  
  1342.    switch (TEST2(cp))
  1343.    {
  1344.       case TWO_NOINITS:
  1345.      return 0 ;
  1346.  
  1347.       case TWO_DOUBLES:
  1348.        two_d:
  1349.      return cp->dval > (cp + 1)->dval ? 1 :
  1350.         cp->dval < (cp + 1)->dval ? -1 : 0 ;
  1351.  
  1352.       case TWO_STRINGS:
  1353.       case STRING_AND_STRNUM:
  1354.        two_s:
  1355.      k = strcmp(string(cp)->str, string(cp + 1)->str) ;
  1356.      free_STRING(string(cp)) ;
  1357.      free_STRING(string(cp + 1)) ;
  1358.      return k ;
  1359.  
  1360.       case NOINIT_AND_DOUBLE:
  1361.       case NOINIT_AND_STRNUM:
  1362.       case DOUBLE_AND_STRNUM:
  1363.       case TWO_STRNUMS:
  1364.      cast2_to_d(cp) ; goto two_d ;
  1365.       case NOINIT_AND_STRING:
  1366.       case DOUBLE_AND_STRING:
  1367.      cast2_to_s(cp) ; goto two_s ;
  1368.       case TWO_MBSTRNS:
  1369.      check_strnum(cp) ; check_strnum(cp+1) ;
  1370.      goto reswitch ;
  1371.  
  1372.       case NOINIT_AND_MBSTRN:
  1373.       case DOUBLE_AND_MBSTRN:
  1374.       case STRING_AND_MBSTRN:
  1375.       case STRNUM_AND_MBSTRN:
  1376.      check_strnum(cp->type == C_MBSTRN ? cp : cp + 1) ;
  1377.      goto reswitch ;
  1378.  
  1379.       default:            /* there are no default cases */
  1380.      bozo("bad cell type passed to compare") ;
  1381.    }
  1382.    return 0 ;             /* shut up */
  1383. }
  1384.  
  1385. /* does not assume target was a cell, if so
  1386.    then caller should have made a previous
  1387.    call to cell_destroy     */
  1388.  
  1389. CELL *
  1390. cellcpy(target, source)
  1391.    register CELL *target, *source ;
  1392. {
  1393.    switch (target->type = source->type)
  1394.    {
  1395.       case C_NOINIT:
  1396.       case C_SPACE:
  1397.       case C_SNULL:
  1398.      break ;
  1399.  
  1400.       case C_DOUBLE:
  1401.      target->dval = source->dval ;
  1402.      break ;
  1403.  
  1404.       case C_STRNUM:
  1405.      target->dval = source->dval ;
  1406.      /* fall thru */
  1407.  
  1408.       case C_REPL:
  1409.       case C_MBSTRN:
  1410.       case C_STRING:
  1411.      string(source)->ref_cnt++ ;
  1412.      /* fall thru */
  1413.  
  1414.       case C_RE:
  1415.      target->ptr = source->ptr ;
  1416.      break ;
  1417.  
  1418.       case C_REPLV:
  1419.      replv_cpy(target, source) ;
  1420.      break ;
  1421.  
  1422.       default:
  1423.      bozo("bad cell passed to cellcpy()") ;
  1424.      break ;
  1425.    }
  1426.    return target ;
  1427. }
  1428.  
  1429. #ifdef     DEBUG
  1430.  
  1431. void
  1432. DB_cell_destroy(cp)        /* HANGOVER time */
  1433.    register CELL *cp ;
  1434. {
  1435.    switch (cp->type)
  1436.    {
  1437.       case C_NOINIT:
  1438.       case C_DOUBLE:
  1439.      break ;
  1440.  
  1441.       case C_MBSTRN:
  1442.       case C_STRING:
  1443.       case C_STRNUM:
  1444.      if (--string(cp)->ref_cnt == 0)
  1445.         zfree(string(cp), string(cp)->len + STRING_OH) ;
  1446.      break ;
  1447.  
  1448.       case C_RE:
  1449.      bozo("cell destroy called on RE cell") ;
  1450.       default:
  1451.      bozo("cell destroy called on bad cell type") ;
  1452.    }
  1453. }
  1454.  
  1455. #endif
  1456.  
  1457.  
  1458.  
  1459. /* convert a double d to a field index    $d -> $i */
  1460. static int
  1461. d_to_index(d)
  1462.    double d;
  1463. {
  1464.  
  1465.    if (d > MAX_FIELD)
  1466.       rt_overflow("maximum number of fields", MAX_FIELD) ;
  1467.  
  1468.    if (d >= 0.0)  return (int) d ;
  1469.  
  1470.    /* might include nan */
  1471.    rt_error("negative field index $%.6g", d) ;
  1472.    return 0 ;             /* shutup */
  1473. }
  1474.