user/mawk/execute.c

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