home *** CD-ROM | disk | FTP | other *** search
/ Garbo / Garbo.cdr / pc / source / mawk.lzh / mawk.2 < prev    next >
Encoding:
Text File  |  1991-05-19  |  60.5 KB  |  2,410 lines
  1.   { case C_NOINIT :  cp->dval = 0.0 ; break ;
  2.  
  3.     case C_DOUBLE :  goto two ;
  4.     case C_STRNUM :  
  5.             free_STRING( string(cp) ) ;
  6.             break ;
  7.  
  8.     case C_MBSTRN :
  9.     case C_STRING :  
  10.             s = (STRING *) cp->ptr ;
  11.  
  12. #if FPE_TRAPS  /* look for overflow error */
  13.             errno = 0 ;
  14.             cp->dval = strtod(s->str,(char **)0) ;
  15.             if ( errno && cp->dval != 0.0 ) /* ignore underflow */
  16.                 rt_error("overflow converting %s to double", s) ;
  17. #else
  18.             cp->dval = strtod(s->str,(char **)0) ;
  19. #endif
  20.             free_STRING(s) ;
  21.             break ;
  22.  
  23.     default :
  24.             bozo("cast on bad type") ;
  25.   }
  26.   cp->type = C_DOUBLE ;
  27.  
  28. two:   cp++ ;
  29.   switch( cp->type )
  30.   { case C_NOINIT :  cp->dval = 0.0 ; break ;
  31.  
  32.     case C_DOUBLE :  return ;
  33.     case C_STRNUM :  
  34.             free_STRING( string(cp) ) ;
  35.             break ;
  36.  
  37.     case C_MBSTRN :
  38.     case C_STRING :  
  39.             s = (STRING *) cp->ptr ;
  40.  
  41. #if FPE_TRAPS  /* look for overflow error */
  42.             errno = 0 ;
  43.             cp->dval = strtod(s->str,(char **)0) ;
  44.             if ( errno && cp->dval != 0.0 ) /* ignore underflow */
  45.                 rt_error("overflow converting %s to double", s) ;
  46. #else
  47.             cp->dval = strtod(s->str,(char **)0) ;
  48. #endif
  49.             free_STRING(s) ;
  50.             break ;
  51.  
  52.     default :
  53.             bozo("cast on bad type") ;
  54.   }
  55.   cp->type = C_DOUBLE ;
  56. }
  57.  
  58. void cast1_to_s( cp )
  59.   register CELL *cp ;
  60. { 
  61.   switch( cp->type )
  62.   { case C_NOINIT :  
  63.         null_str.ref_cnt++ ;
  64.         cp->ptr = (PTR) &null_str ;
  65.         break ;
  66.  
  67.     case C_DOUBLE  :
  68.         (void) sprintf(temp_buff.string_buff ,
  69.             string(field+OFMT)->str, cp->dval) ;
  70.  
  71.         cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
  72.         break ;
  73.  
  74.     case C_STRING :  return ;
  75.  
  76.     case C_MBSTRN :
  77.     case C_STRNUM :  break ;
  78.  
  79.     default :  bozo("bad type on cast") ;
  80.   }
  81.   cp->type = C_STRING ;
  82. }
  83.  
  84. void cast2_to_s( cp )
  85.   register CELL *cp ;
  86. { 
  87.  
  88.   switch( cp->type )
  89.   { case C_NOINIT : 
  90.         null_str.ref_cnt++ ;
  91.         cp->ptr = (PTR) &null_str ;
  92.         break ;
  93.  
  94.     case C_DOUBLE  :
  95.         (void) sprintf(temp_buff.string_buff,
  96.             string(field+OFMT)->str, cp->dval ) ;
  97.  
  98.         cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
  99.         break ;
  100.  
  101.     case C_STRING :  goto two ;
  102.  
  103.     case C_MBSTRN :
  104.     case C_STRNUM :  break ;
  105.  
  106.     default :  bozo("bad type on cast") ;
  107.   }
  108.   cp->type = C_STRING ;
  109.  
  110. two:
  111.   cp++ ;
  112.  
  113.   switch( cp->type )
  114.   { case C_NOINIT :  
  115.         null_str.ref_cnt++ ; 
  116.         cp->ptr = (PTR) &null_str ;
  117.         break ;
  118.  
  119.     case C_DOUBLE  :
  120.         (void) sprintf(temp_buff.string_buff,
  121.             string(field+OFMT)->str, cp->dval) ;
  122.  
  123.         cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
  124.         break ;
  125.  
  126.     case C_STRING :  return ;
  127.  
  128.     case C_MBSTRN :
  129.     case C_STRNUM :  break ;
  130.  
  131.     default :  bozo("bad type on cast") ;
  132.   }
  133.   cp->type = C_STRING ;
  134. }
  135.  
  136. void  cast_to_RE( cp )
  137.   register CELL *cp ;
  138. { register PTR p ;
  139.  
  140.   if ( cp->type < C_STRING )  cast1_to_s(cp) ;
  141.  
  142.   p = re_compile( string(cp) ) ;
  143.   free_STRING( string(cp) ) ;
  144.   cp->type = C_RE ;
  145.   cp->ptr = p ;
  146.  
  147. }
  148.  
  149. void  cast_for_split(cp)
  150.   register CELL *cp ;
  151. {
  152.   static char meta[] = "^$.*+?|[]()" ;
  153.   static char xbuff[] = "\\X" ;
  154.   int c ;
  155.   unsigned len ;
  156.     
  157.   if ( cp->type < C_STRING )  cast1_to_s(cp) ;
  158.  
  159.   if ( (len = string(cp)->len) == 1 )
  160.   {
  161.         if ( (c = string(cp)->str[0]) == ' ' )
  162.         { free_STRING(string(cp)) ;
  163.           cp->type = C_SPACE ; 
  164.           return ; 
  165.         }
  166.         else
  167.         if ( strchr(meta, c) )
  168.         { xbuff[1] = c ;
  169.           free_STRING(string(cp)) ;
  170.           cp->ptr = (PTR) new_STRING(xbuff) ;
  171.         }
  172.   }
  173.   else
  174.   if ( len == 0 ) 
  175.   { free_STRING(string(cp)) ;
  176.     cp->type = C_SNULL ; 
  177.     return ; 
  178.   }
  179.  
  180.   cast_to_RE(cp) ;
  181. }
  182.  
  183. /* input: cp-> a CELL of type C_MBSTRN (maybe strnum)
  184.    test it -- casting it to the appropriate type
  185.    which is C_STRING or C_STRNUM
  186. */
  187.  
  188. void check_strnum( cp )
  189.   CELL *cp ;
  190. { char *test ;
  191.   register unsigned char *s , *q ;
  192.  
  193.   cp->type = C_STRING ; /* assume not C_STRNUM */
  194.   s = (unsigned char *) string(cp)->str ;
  195.   q = s + string(cp)->len ;
  196.   while ( scan_code[*s] == SC_SPACE )  s++ ;
  197.   if ( s == q )  return ;
  198.  
  199.   while ( scan_code[ q[-1] ] == SC_SPACE )  q-- ;
  200.   if ( scan_code[ q[-1] ] != SC_DIGIT &&
  201.        q[-1] != '.' )   return ;
  202.  
  203.   switch ( scan_code[*s] )
  204.   {
  205.     case SC_DIGIT :
  206.     case SC_PLUS  :
  207.     case SC_MINUS :
  208.     case SC_DOT   :
  209.  
  210. #if FPE_TRAPS
  211.              errno = 0 ;
  212.              cp->dval  = strtod((char *)s, &test) ;
  213.              if ( errno && cp->dval != 0.0 )
  214.                 rt_error(
  215.                 "overflow converting %s to double" , s) ;
  216. #else
  217.              cp->dval = strtod(s, &test) ;
  218. #endif
  219.  
  220.              if ((char *) q == test )  cp->type = C_STRNUM ;
  221.   }
  222. }
  223.  
  224. /* cast a CELL to a replacement cell */
  225.  
  226. void cast_to_REPL( cp )
  227.   register CELL *cp ;
  228. { register STRING *sval ;
  229.  
  230.   if ( cp->type < C_STRING )  cast1_to_s(cp) ;
  231.   sval = (STRING *) cp->ptr ;
  232.  
  233.   (void) cellcpy(cp, repl_compile(sval)) ;
  234.   free_STRING(sval) ;
  235. }
  236.  
  237.  
  238. #if   NO_STRTOD
  239.  
  240. static char d_str[] =
  241. "^[ \t]*[-+]?([0-9]+\\.?|\\.[0-9])[0-9]*([eE][-+]?[0-9]+)?" ;
  242.  
  243. static PTR d_ptr ;
  244.  
  245. void strtod_init()
  246. { STRING *sval = new_STRING(d_str) ;
  247.  
  248.   d_ptr = re_compile(sval) ;
  249.   free_STRING(sval) ;
  250. }
  251.  
  252. double strtod( s, endptr)
  253.   char *s , **endptr ;
  254. { double atof() ;
  255.  
  256.   if ( endptr )
  257.   { unsigned len ;
  258.  
  259.     (void) REmatch(s, d_ptr, &len) ;
  260.     *endptr = s + len ;
  261.   }
  262.   return  atof(s) ;
  263. }
  264. #endif  /* NO_STRTOD */
  265.  
  266. #if   NO_FMOD
  267.  
  268. double  fmod(x, y)
  269.   double x, y ;
  270. { double modf() ;
  271.   double ipart ;
  272.  
  273.   return modf(x/y, &ipart) * y ;
  274. }
  275.  
  276. #endif  /* NO_FMOD */
  277.  
  278.  
  279.  
  280. @//E*O*F mawk0.97/cast.c//
  281. chmod u=rw,g=r,o=r mawk0.97/cast.c
  282.  
  283. echo x - mawk0.97/code.c
  284. sed 's/^@//' > "mawk0.97/code.c" <<'@//E*O*F mawk0.97/code.c//'
  285.  
  286. /********************************************
  287. code.c
  288. copyright 1991, Michael D. Brennan
  289.  
  290. This is a source file for mawk, an implementation of
  291. the Awk programming language as defined in
  292. Aho, Kernighan and Weinberger, The AWK Programming Language,
  293. Addison-Wesley, 1988.
  294.  
  295. See the accompaning file, LIMITATIONS, for restrictions
  296. regarding modification and redistribution of this
  297. program in source or binary form.
  298. ********************************************/
  299.  
  300.  
  301. /* $Log:    code.c,v $
  302.  * Revision 2.1  91/04/08  08:22:46  brennan
  303.  * VERSION 0.97
  304.  * 
  305. */
  306.  
  307. /*  code.c  */
  308.  
  309. #include "mawk.h"
  310. #include "code.h"
  311. #include "init.h"
  312.  
  313.  
  314. #define   CODE_SZ      (PAGE_SZ*sizeof(INST))
  315.  
  316. INST *code_ptr  ;
  317. INST *main_start , *main_code_ptr ;
  318. INST *begin_start , *begin_code_ptr ;
  319. INST *end_start , *end_code_ptr ;
  320. unsigned  main_size, begin_size, end_size ;
  321.  
  322. void  PROTO(fdump, (void) ) ;
  323.  
  324. void  code_init()
  325. { 
  326.   main_code_ptr = main_start = (INST *) zmalloc(CODE_SZ) ;
  327.   begin_code_ptr = begin_start = (INST *) zmalloc(CODE_SZ) ;
  328.   end_code_ptr = end_start = (INST *) zmalloc(CODE_SZ) ;
  329.   code_ptr = main_code_ptr ;
  330. }
  331.  
  332. void code_cleanup()
  333. {
  334.   if ( dump_code )  fdump() ; /* dumps all functions */
  335.  
  336.   begin_code_ptr++->op = _HALT ;
  337.   if ( (begin_size = begin_code_ptr - begin_start) == 1 ) /* empty */
  338.   {
  339.       zfree( begin_start, CODE_SZ ) ;
  340.       begin_start = (INST *) 0 ;
  341.   }
  342.   else
  343.   if ( begin_size > PAGE_SZ ) overflow("BEGIN code" , PAGE_SZ) ;
  344.   else
  345.   {  begin_size *= sizeof(INST) ;
  346.      begin_start = (INST *) zrealloc(begin_start,CODE_SZ,begin_size) ;
  347.      if ( dump_code )
  348.      { fprintf(stderr, "BEGIN\n") ;
  349.        da(begin_start, stderr) ; 
  350.      }
  351.   }
  352.  
  353.   end_code_ptr++->op = _HALT ;
  354.   if ( (end_size = end_code_ptr - end_start) == 1 ) /* empty */
  355.   {
  356.       zfree( end_start, CODE_SZ ) ;
  357.       end_start = (INST *) 0 ;
  358.   }
  359.   else
  360.   if ( end_size > PAGE_SZ ) overflow("END code" , PAGE_SZ) ;
  361.   else
  362.   {  end_size *= sizeof(INST) ;
  363.      end_start = (INST *) zrealloc(end_start, CODE_SZ, end_size) ;
  364.      if ( dump_code )
  365.      { fprintf(stderr, "END\n") ;
  366.        da(end_start, stderr) ;
  367.      }
  368.   }
  369.  
  370.   code_ptr++->op = _HALT ;
  371.   if ( (main_size = code_ptr - main_start) == 1 ) /* empty */
  372.   {
  373.       zfree( main_start, CODE_SZ ) ;
  374.       main_start = (INST *) 0 ;
  375.   }
  376.   else
  377.   if ( main_size > PAGE_SZ ) overflow("MAIN code" , PAGE_SZ) ;
  378.   else
  379.   {  main_size *= sizeof(INST) ;
  380.      main_start = (INST *) zrealloc(main_start, CODE_SZ, main_size) ;
  381.      if ( dump_code )
  382.      { fprintf(stderr, "MAIN\n") ;
  383.        da(main_start, stderr) ;
  384.      }
  385.   }
  386. }
  387. @//E*O*F mawk0.97/code.c//
  388. chmod u=rw,g=r,o=r mawk0.97/code.c
  389.  
  390. echo x - mawk0.97/code.h
  391. sed 's/^@//' > "mawk0.97/code.h" <<'@//E*O*F mawk0.97/code.h//'
  392.  
  393. /********************************************
  394. code.h
  395. copyright 1991, Michael D. Brennan
  396.  
  397. This is a source file for mawk, an implementation of
  398. the Awk programming language as defined in
  399. Aho, Kernighan and Weinberger, The AWK Programming Language,
  400. Addison-Wesley, 1988.
  401.  
  402. See the accompaning file, LIMITATIONS, for restrictions
  403. regarding modification and redistribution of this
  404. program in source or binary form.
  405. ********************************************/
  406.  
  407.  
  408. /* $Log:    code.h,v $
  409.  * Revision 2.1  91/04/08  08:22:48  brennan
  410.  * VERSION 0.97
  411.  * 
  412. */
  413.  
  414.  
  415. /*  code.h  */
  416.  
  417. #ifndef  CODE_H
  418. #define  CODE_H
  419.  
  420. #include "memory.h"
  421. #include <setjmp.h>
  422.  
  423. /* coding scope */
  424. #define   SCOPE_MAIN    0
  425. #define   SCOPE_BEGIN   1  
  426. #define   SCOPE_END     2
  427. #define   SCOPE_FUNCT   3
  428.  
  429.  
  430. extern  INST  *code_ptr ;
  431. extern  INST  *begin_start , *begin_code_ptr ;
  432. extern  INST  *end_start , *end_code_ptr ;
  433. extern  INST  *main_start, *main_code_ptr ;
  434. extern  unsigned begin_size, end_size, main_size ;
  435.  
  436. extern  CELL  eval_stack[] ;
  437.  
  438.  
  439. #define  code1(x)  code_ptr++ -> op = (x)
  440.  
  441. #define  code2(x,y)    (void)( code_ptr++ -> op = (x) ,\
  442.                          code_ptr++ -> ptr = (PTR)(y) )
  443.  
  444.  
  445. /*  the machine opcodes  */
  446.  
  447. #define _HALT            0
  448. #define _STOP            1
  449. #define _STOP0           2  
  450. #define _PUSHC           3
  451. #define _PUSHINT         4
  452. #define _PUSHA           5
  453. #define _PUSHI           6
  454. #define L_PUSHA          7
  455. #define L_PUSHI          8
  456. #define AE_PUSHA         9
  457. #define AE_PUSHI        10
  458. #define A_PUSHA         11
  459. #define LAE_PUSHA       12
  460. #define LAE_PUSHI       13
  461. #define LA_PUSHA        14
  462. #define F_PUSHA         15
  463. #define FE_PUSHA        16
  464. #define F_PUSHI         17
  465. #define FE_PUSHI        18
  466. #define _POP            19
  467. #define _PULL           20
  468. #define _DUP            21
  469. #define _ADD            22
  470. #define _SUB            23
  471. #define _MUL            24
  472. #define _DIV            25
  473. #define _MOD            26
  474. #define _POW            27
  475. #define _NOT            28
  476. #define _TEST           29
  477. #define A_TEST          30
  478. #define A_DEL           31
  479. #define A_LOOP          32
  480. #define A_CAT           33
  481. #define _UMINUS         34
  482. #define _UPLUS          35
  483. #define _ASSIGN         36
  484. #define _ADD_ASG        37
  485. #define _SUB_ASG        38
  486. #define _MUL_ASG        39
  487. #define _DIV_ASG        40
  488. #define _MOD_ASG        41
  489. #define _POW_ASG        42
  490. #define F_ASSIGN        43
  491. #define F_ADD_ASG       44
  492. #define F_SUB_ASG       45
  493. #define F_MUL_ASG       46
  494. #define F_DIV_ASG       47
  495. #define F_MOD_ASG       48
  496. #define F_POW_ASG       49
  497. #define _CAT            50
  498. #define _BUILTIN        51
  499. #define _PRINT          52
  500. #define _POST_INC       53
  501. #define _POST_DEC       54
  502. #define _PRE_INC        55
  503. #define _PRE_DEC        56
  504. #define F_POST_INC      57
  505. #define F_POST_DEC      58
  506. #define F_PRE_INC       59
  507. #define F_PRE_DEC       60
  508. #define _JMP            61
  509. #define _JNZ            62
  510. #define _JZ             63
  511. #define _EQ             64
  512. #define _NEQ            65
  513. #define _LT             66
  514. #define _LTE            67
  515. #define _GT             68
  516. #define _GTE            69
  517. #define _MATCH          70
  518. #define _EXIT           71
  519. #define _EXIT0          72
  520. #define _NEXT           73
  521. #define _RANGE          74
  522. #define _CALL           75
  523. #define _RET            76
  524. #define _RET0           77
  525.  
  526.  
  527. /* next and exit statements */
  528.  
  529. extern jmp_buf  exit_jump, next_jump ;
  530. extern int exit_code ;
  531.  
  532. #endif  /* CODE_H */
  533. @//E*O*F mawk0.97/code.h//
  534. chmod u=rw,g=r,o=r mawk0.97/code.h
  535.  
  536. echo x - mawk0.97/da.c
  537. sed 's/^@//' > "mawk0.97/da.c" <<'@//E*O*F mawk0.97/da.c//'
  538.  
  539. /********************************************
  540. da.c
  541. copyright 1991, Michael D. Brennan
  542.  
  543. This is a source file for mawk, an implementation of
  544. the Awk programming language as defined in
  545. Aho, Kernighan and Weinberger, The AWK Programming Language,
  546. Addison-Wesley, 1988.
  547.  
  548. See the accompaning file, LIMITATIONS, for restrictions
  549. regarding modification and redistribution of this
  550. program in source or binary form.
  551. ********************************************/
  552.  
  553.  
  554. /* $Log:    da.c,v $
  555.  * Revision 2.1  91/04/08  08:22:50  brennan
  556.  * VERSION 0.97
  557.  * 
  558. */
  559.  
  560.  
  561. /*  da.c  */
  562. /*  disassemble code */ 
  563.  
  564.  
  565. #include  "mawk.h"
  566. #include  "code.h"
  567. #include  "bi_funct.h"
  568. #include  "repl.h"
  569. #include  "field.h"
  570.  
  571. char *PROTO(find_bi_name, (PF_CP) ) ;
  572.  
  573. void  da(start, fp)
  574.   INST *start ;
  575.   FILE *fp ;
  576. { CELL *cp ;
  577.   register INST *p = start ;
  578.  
  579.   while ( 1 )
  580.   { /* print the relative code address (label) */
  581.     fprintf(fp,"%03d ", p - start) ;
  582.  
  583.     switch( p++->op )
  584.     {
  585.       case _HALT :  fprintf(fp,"halt\n") ; return ;
  586.       case _STOP :  fprintf(fp,"stop\n") ; break  ;
  587.       case _STOP0 : fprintf(fp, "stop0\n") ; break ;
  588.  
  589.       case _PUSHC :
  590.             cp = (CELL *) p++->ptr ;
  591.             switch( cp->type )
  592.             { case C_DOUBLE :
  593.                   fprintf(fp,"pushc\t%.6g\n" ,  cp ->dval) ;
  594.                   break ;
  595.  
  596.               case C_STRING :
  597.                   fprintf(fp,"pushc\t\"%s\"\n" ,
  598.                           ((STRING *)cp->ptr)->str) ;
  599.                   break ;
  600.  
  601.               case C_RE :
  602.                   fprintf(fp,"pushc\t0x%x\t/%s/\n" , cp->ptr ,
  603.                     re_uncompile(cp->ptr) ) ;
  604.                   break ;
  605.  
  606.               case C_SPACE : 
  607.                   fprintf(fp, "pushc\tspace split\n") ;
  608.                   break ;
  609.  
  610.               case C_SNULL : 
  611.                   fprintf(fp, "pushc\tnull split\n") ;
  612.                   break ;
  613.               case C_REPL  :
  614.                   fprintf(fp, "pushc\trepl\t%s\n" ,
  615.                         repl_uncompile(cp) ) ;
  616.                   break ;
  617.               case C_REPLV :
  618.                   fprintf(fp, "pushc\treplv\t%s\n" ,
  619.                         repl_uncompile(cp) ) ;
  620.                   break ;
  621.                   
  622.               default :
  623.                   fprintf(fp,"pushc\tWEIRD\n") ;  ;
  624.                   break ;
  625.             }
  626.             break ;
  627.  
  628.       case _PUSHA :
  629.             fprintf(fp,"pusha\t0x%x\n", p++ -> ptr) ;
  630.             break ;
  631.  
  632.       case _PUSHI :
  633.             if ( (CELL *)p->ptr == field )
  634.                 fprintf(fp, "pushi\t$0\n") ;
  635.             else fprintf(fp,"pushi\t0x%x\n", p -> ptr) ;
  636.             p++ ;
  637.             break ;
  638.  
  639.       case  L_PUSHA :
  640.             fprintf( fp, "l_pusha\t%d\n", p++->op) ;
  641.             break ;
  642.  
  643.       case  L_PUSHI :
  644.             fprintf( fp, "l_pushi\t%d\n", p++->op) ;
  645.             break ;
  646.  
  647.       case  LAE_PUSHI :
  648.             fprintf( fp, "lae_pushi\t%d\n", p++->op) ;
  649.             break ;
  650.  
  651.       case  LAE_PUSHA :
  652.             fprintf( fp, "lae_pusha\t%d\n", p++->op) ;
  653.             break ;
  654.  
  655.       case  LA_PUSHA :
  656.             fprintf( fp, "la_pusha\t%d\n", p++->op) ;
  657.             break ;
  658.  
  659.       case F_PUSHA :
  660.             fprintf(fp,"f_pusha\t$%d\n" , (CELL *) p++->ptr - field ) ;
  661.             break ;
  662.  
  663.       case F_PUSHI :
  664.             fprintf(fp,"f_pushi\t$%d\n" , (CELL *) p++->ptr - field ) ;
  665.             break ;
  666.  
  667.       case FE_PUSHA :
  668.             fprintf(fp,"fe_pusha\n" ) ;
  669.             break ;
  670.  
  671.       case FE_PUSHI :
  672.             fprintf(fp,"fe_pushi\n" ) ;
  673.             break ;
  674.  
  675.       case AE_PUSHA :
  676.             fprintf(fp,"ae_pusha\t0x%x\n" , p++->ptr) ;
  677.             break ;
  678.  
  679.       case AE_PUSHI :
  680.             fprintf(fp,"ae_pushi\t0x%x\n" , p++->ptr) ;
  681.             break ;
  682.  
  683.       case A_PUSHA :
  684.             fprintf(fp,"a_pusha\t0x%x\n" , p++->ptr) ;
  685.             break ;
  686.  
  687.       case A_TEST :
  688.             fprintf(fp,"a_test\n" ) ;
  689.             break ;
  690.  
  691.       case A_DEL :
  692.             fprintf(fp,"a_del\n" ) ;
  693.             break ;
  694.  
  695.       case A_CAT :
  696.             fprintf(fp,"a_cat\t%d\n", p++->op ) ;
  697.             break ;
  698.  
  699.       case _POP :
  700.             fprintf(fp,"pop\n") ;
  701.             break ;
  702.  
  703.       case  _ADD :
  704.             fprintf(fp,"add\n") ; break ;
  705.  
  706.       case  _SUB :
  707.             fprintf(fp,"sub\n") ; break ;
  708.       case  _MUL :
  709.             fprintf(fp,"mul\n") ; break ;
  710.       case  _DIV :
  711.             fprintf(fp,"div\n") ; break ;
  712.       case  _MOD :
  713.             fprintf(fp,"mod\n") ; break ;
  714.       case  _POW :
  715.             fprintf(fp,"pow\n") ; break ;
  716.       case  _NOT :
  717.             fprintf(fp,"not\n") ; break ;
  718.       case  _UMINUS :
  719.             fprintf(fp,"uminus\n") ; break ;
  720.       case  _UPLUS :
  721.             fprintf(fp,"plus\n") ; break ;
  722.       case  _DUP :
  723.             fprintf(fp,"dup\n") ; break ;
  724.       case  _TEST :
  725.             fprintf(fp,"test\n") ; break ;
  726.  
  727.       case  _CAT  :
  728.             fprintf(fp,"cat\n") ; break ;
  729.  
  730.       case  _ASSIGN :
  731.             fprintf(fp,"assign\n") ; break ;
  732.       case  _ADD_ASG :
  733.             fprintf(fp,"add_asg\n") ; break ;
  734.       case  _SUB_ASG :
  735.             fprintf(fp,"sub_asg\n") ; break ;
  736.       case  _MUL_ASG :
  737.             fprintf(fp,"mul_asg\n") ; break ;
  738.       case  _DIV_ASG :
  739.             fprintf(fp,"div_asg\n") ; break ;
  740.       case  _MOD_ASG :
  741.             fprintf(fp,"mod_asg\n") ; break ;
  742.       case  _POW_ASG :
  743.             fprintf(fp,"pow_asg\n") ; break ;
  744.  
  745.       case  F_ASSIGN :
  746.             fprintf(fp,"f_assign\n") ; break ;
  747.       case  F_ADD_ASG :
  748.             fprintf(fp,"f_add_asg\n") ; break ;
  749.       case  F_SUB_ASG :
  750.             fprintf(fp,"f_sub_asg\n") ; break ;
  751.       case  F_MUL_ASG :
  752.             fprintf(fp,"f_mul_asg\n") ; break ;
  753.       case  F_DIV_ASG :
  754.             fprintf(fp,"f_div_asg\n") ; break ;
  755.       case  F_MOD_ASG :
  756.             fprintf(fp,"f_mod_asg\n") ; break ;
  757.       case  F_POW_ASG :
  758.             fprintf(fp,"f_pow_asg\n") ; break ;
  759.  
  760.       case  _PUSHINT :
  761.             fprintf(fp,"pushint\t%d\n" , p++ -> op ) ;
  762.             break ;
  763.  
  764.       case  _BUILTIN  :
  765.             fprintf(fp,"%s\n" , 
  766.                     find_bi_name( (PF_CP) p++ -> ptr ) ) ;
  767.             break ;
  768.  
  769.       case  _PRINT :
  770.             fprintf(fp,"%s\n", 
  771.             (PF_CP) p++ -> ptr == bi_printf
  772.                 ? "printf" : "print") ;
  773.             break ;
  774.       
  775.       case  _POST_INC :
  776.             fprintf(fp,"post_inc\n") ; break ;
  777.  
  778.       case  _POST_DEC :
  779.             fprintf(fp,"post_dec\n") ; break ;
  780.  
  781.       case  _PRE_INC :
  782.             fprintf(fp,"pre_inc\n") ; break ;
  783.  
  784.       case  _PRE_DEC :
  785.             fprintf(fp,"pre_dec\n") ; break ;
  786.  
  787.       case  F_POST_INC :
  788.             fprintf(fp,"f_post_inc\n") ; break ;
  789.  
  790.       case  F_POST_DEC :
  791.             fprintf(fp,"f_post_dec\n") ; break ;
  792.  
  793.       case  F_PRE_INC :
  794.             fprintf(fp,"f_pre_inc\n") ; break ;
  795.  
  796.       case  F_PRE_DEC :
  797.             fprintf(fp,"f_pre_dec\n") ; break ;
  798.  
  799.       case  _JMP :
  800.       case  _JNZ :
  801.       case  _JZ  :
  802.           { int j = (p-1)->op ;
  803.             char *s = j == _JMP ? "jmp" : 
  804.                       j == _JNZ ? "jnz" : "jz" ;
  805.  
  806.             fprintf(fp,"%s\t\t%03d\n" , s ,
  807.               (p - start) + p->op - 1 ) ;
  808.             p++ ;
  809.             break ;
  810.           }
  811.     
  812.       case  _EQ  :
  813.             fprintf(fp,"eq\n") ; break ;
  814.  
  815.       case  _NEQ  :
  816.             fprintf(fp,"neq\n") ; break ;
  817.  
  818.       case  _LT  :
  819.             fprintf(fp,"lt\n") ; break ;
  820.  
  821.       case  _LTE  :
  822.             fprintf(fp,"lte\n") ; break ;
  823.  
  824.       case  _GT  :
  825.             fprintf(fp,"gt\n") ; break ;
  826.  
  827.       case  _GTE  :
  828.             fprintf(fp,"gte\n") ; break ;
  829.  
  830.       case  _MATCH :
  831.             fprintf(fp,"match_op\n") ; break ;
  832.  
  833.       case  A_LOOP :
  834.             fprintf(fp,"a_loop\t%03d\n", p-start+p[1].op) ;
  835.             p += 2 ;
  836.             break ;
  837.  
  838.       case  _EXIT  :
  839.             fprintf(fp, "exit\n") ; break ;
  840.  
  841.       case  _EXIT0  :
  842.             fprintf(fp, "exit0\n") ; break ;
  843.  
  844.       case  _NEXT  :
  845.             fprintf(fp, "next\n") ; break ;
  846.  
  847.       case  _RET  :
  848.             fprintf(fp, "ret\n") ; break ;
  849.       case  _RET0 :
  850.             fprintf(fp, "ret0\n") ; break ;
  851.  
  852.       case  _CALL :
  853.             fprintf(fp, "call\t%s\t%d\n", 
  854.                 ((FBLOCK*)p->ptr)->name , p[1].op) ;
  855.             p += 2 ;
  856.             break ;
  857.  
  858.       case  _RANGE :
  859.             fprintf(fp, "range\t%03d %03d %03d\n",
  860.               /* label for pat2, action, follow */
  861.               p - start + p[1].op ,
  862.               p - start + p[2].op ,
  863.               p - start + p[3].op ) ;
  864.             p += 4 ; 
  865.             break ;
  866.       default :
  867.             fprintf(fp,"bad instruction\n") ;
  868.             return ;
  869.     }
  870.   }
  871. }
  872.  
  873. static struct {
  874. PF_CP action ;
  875. char *name ;
  876. } special_cases[] = {
  877. bi_length, "length",
  878. bi_split, "split",
  879. bi_match, "match",
  880. bi_getline,"getline",
  881. bi_sub, "sub",
  882. bi_gsub , "gsub",
  883. (PF_CP) 0, (char *) 0 } ;
  884.  
  885. static char *find_bi_name( p )
  886.   PF_CP p ;
  887. { BI_REC *q ;
  888.   int i ;
  889.  
  890.   for( q = bi_funct ; q->name ; q++ )
  891.     if ( q->fp == p )  /* found */
  892.         return q->name ;
  893.   /* next check some special cases */
  894.   for( i = 0 ; special_cases[i].action ; i++)
  895.     if ( special_cases[i].action == p )
  896.         return  special_cases[i].name ;
  897.  
  898.   return  "unknown builtin" ;
  899. }
  900.  
  901. static struct fdump {
  902. struct fdump *link ;
  903. FBLOCK  *fbp ;
  904. }  *fdump_list ;  /* linked list of all user functions */
  905.  
  906. void add_to_fdump_list( fbp )
  907.   FBLOCK *fbp ;
  908. { struct fdump *p = (struct fdump *)zmalloc(sizeof(struct fdump)) ;
  909.   p->fbp = fbp ;
  910.   p->link = fdump_list ;  fdump_list = p ;
  911. }
  912.  
  913. void  fdump()
  914. {
  915.   register struct fdump *p, *q = fdump_list ;
  916.  
  917.   while ( p = q )
  918.   { q = p->link ;
  919.     fprintf(stderr, "function %s\n" , p->fbp->name) ;
  920.     da(p->fbp->code, stderr) ;
  921.     zfree(p, sizeof(struct fdump)) ;
  922.   }
  923. }
  924. @//E*O*F mawk0.97/da.c//
  925. chmod u=rw,g=r,o=r mawk0.97/da.c
  926.  
  927. echo x - mawk0.97/error.c
  928. sed 's/^@//' > "mawk0.97/error.c" <<'@//E*O*F mawk0.97/error.c//'
  929.  
  930. /********************************************
  931. error.c
  932. copyright 1991, Michael D. Brennan
  933.  
  934. This is a source file for mawk, an implementation of
  935. the Awk programming language as defined in
  936. Aho, Kernighan and Weinberger, The AWK Programming Language,
  937. Addison-Wesley, 1988.
  938.  
  939. See the accompaning file, LIMITATIONS, for restrictions
  940. regarding modification and redistribution of this
  941. program in source or binary form.
  942. ********************************************/
  943.  
  944.  
  945. /* $Log:    error.c,v $
  946.  * Revision 2.2  91/04/09  12:38:52  brennan
  947.  * added static to funct decls to satisfy STARDENT compiler
  948.  * 
  949.  * Revision 2.1  91/04/08  08:22:52  brennan
  950.  * VERSION 0.97
  951.  * 
  952. */
  953.  
  954.  
  955. #include  "mawk.h"
  956. #include  "scan.h"
  957. #include  "bi_vars.h"
  958.  
  959. #ifndef  EOF
  960. #define  EOF  (-1)
  961. #endif
  962.  
  963. /* statics */
  964. static void  PROTO( check_FILENAME, (void) ) ;
  965. static void  PROTO( unexpected_char, (void) ) ;
  966. static void  PROTO( missing, (int, char *, int) ) ;
  967. static char *PROTO( type_to_str, (int) ) ;
  968.  
  969.  
  970. static struct token_str  {
  971. short token ;
  972. char *str ; }  token_str[] = {
  973. EOF , "end of file" ,
  974. NL , "end of line",
  975. SEMI_COLON , ";" ,
  976. LBRACE , "{" ,
  977. RBRACE , "}" ,
  978. SC_FAKE_SEMI_COLON, "}",
  979. LPAREN , "(" ,
  980. RPAREN , ")" ,
  981. LBOX , "[",
  982. RBOX , "]",
  983. QMARK , "?",
  984. COLON , ":",
  985. OR, "||",
  986. AND, "&&",
  987. P_OR, "||",
  988. P_AND, "&&",
  989. ASSIGN , "=" ,
  990. ADD_ASG, "+=",
  991. SUB_ASG, "-=",
  992. MUL_ASG, "*=",
  993. DIV_ASG, "/=",
  994. MOD_ASG, "%=",
  995. POW_ASG, "^=",
  996. EQ  , "==" ,
  997. NEQ , "!=",
  998. LT, "<" ,
  999. LTE, "<=" ,
  1000. GT, ">",
  1001. GTE, ">=" ,
  1002. MATCH, "~",
  1003. NOT_MATCH, "!~",
  1004. PLUS , "+" ,
  1005. MINUS, "-" ,
  1006. MUL , "*" ,
  1007. DIV, "/"  , 
  1008. MOD, "%" ,
  1009. POW, "^" ,
  1010. INC , "++" ,
  1011. DEC , "--" ,
  1012. NOT, "!" ,
  1013. COMMA, "," ,
  1014. CONSTANT , temp_buff.string_buff ,
  1015. ID , temp_buff.string_buff ,
  1016. FUNCT_ID , temp_buff.string_buff ,
  1017. BUILTIN , temp_buff.string_buff ,
  1018. IO_OUT, temp_buff.string_buff, 
  1019. IO_IN, "<" ,
  1020. PIPE, "|" ,
  1021. DOLLAR, "$" ,
  1022. FIELD, "$" ,
  1023. 0, (char *) 0 } ;
  1024.  
  1025. /* if paren_cnt >0 and we see one of these, we are missing a ')' */
  1026. static int missing_rparen[] =
  1027. { EOF, NL, SEMI_COLON, SC_FAKE_SEMI_COLON, RBRACE, 0 } ;
  1028.  
  1029. /* ditto for '}' */
  1030. static int missing_rbrace[] =
  1031. { EOF, BEGIN, END , 0 } ;
  1032.  
  1033. static void missing( c, n , ln)
  1034.   int c ;
  1035.   char *n ;
  1036.   int ln ;
  1037. { errmsg(0, "line %u: missing %c near %s" , ln, c, n) ; }
  1038.   
  1039. void  yyerror(s)
  1040.   char *s ; /* we won't use s as input 
  1041.   (yacc and bison force this).
  1042.   We will use s for storage to keep lint or the compiler
  1043.   off our back */
  1044. { struct token_str *p ;
  1045.   int *ip ;
  1046.  
  1047.   s = (char *) 0 ;
  1048.  
  1049.   for ( p = token_str ; p->token ; p++ )
  1050.       if ( current_token == p->token )
  1051.       { s = p->str ; break ; }
  1052.  
  1053.   if ( ! s )  /* search the keywords */
  1054.          s = find_kw_str(current_token) ;
  1055.  
  1056.   if ( s )
  1057.   {
  1058.     if ( paren_cnt )
  1059.         for( ip = missing_rparen ; *ip ; ip++)
  1060.           if ( *ip == current_token )
  1061.           { missing(')', s, token_lineno) ;
  1062.             paren_cnt = 0 ;
  1063.             goto done ;
  1064.           }
  1065.  
  1066.     if ( brace_cnt )
  1067.         for( ip = missing_rbrace ; *ip ; ip++)
  1068.           if ( *ip == current_token )
  1069.           { missing('}', s, token_lineno) ;
  1070.             brace_cnt = 0 ;
  1071.             goto done ;
  1072.           }
  1073.  
  1074.     compile_error("syntax error at or near %s", s) ;
  1075.  
  1076.   }
  1077.   else  /* special cases */
  1078.   switch ( current_token )
  1079.   {
  1080.     case UNEXPECTED :
  1081.             unexpected_char() ; 
  1082.             goto done ;
  1083.  
  1084.     case BAD_DECIMAL :
  1085.             compile_error(
  1086.               "syntax error in decimal constant %s",
  1087.               temp_buff.string_buff ) ;
  1088.             break ;
  1089.  
  1090.     case RE :
  1091.             compile_error(
  1092.             "syntax error at or near /%s/", 
  1093.             temp_buff.string_buff ) ;
  1094.             break ;
  1095.  
  1096.     default :
  1097.             compile_error("syntax error") ;
  1098.             break ;
  1099.   }
  1100.   return ;
  1101.  
  1102. done :
  1103.   if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
  1104. }
  1105.  
  1106. /* system provided errnos and messages */
  1107. extern int sys_nerr ;
  1108. extern char *sys_errlist[] ;
  1109.  
  1110. #ifdef  __STDC__
  1111. #include <stdarg.h>
  1112.  
  1113. /* generic error message with a hook into the system error 
  1114.    messages if errnum > 0 */
  1115.  
  1116. void  errmsg(int errnum, char *format, ...)
  1117. { va_list args ;
  1118.  
  1119.   fprintf(stderr, "%s: " , progname) ;
  1120.   va_start(args, format) ;
  1121.   (void) vfprintf(stderr, format, args) ;
  1122.   va_end(args) ;
  1123.   if ( errnum > 0 && errnum < sys_nerr )
  1124.     fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
  1125.   fprintf( stderr, "\n") ;
  1126. }
  1127.  
  1128. void  compile_error(char *format, ...)
  1129. { va_list args ;
  1130.  
  1131.   fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
  1132.   va_start(args, format) ;
  1133.   vfprintf(stderr, format, args) ;
  1134.   va_end(args) ;
  1135.   fprintf(stderr, "\n") ;
  1136.   if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
  1137. }
  1138.  
  1139. void  rt_error( char *format, ...)
  1140. { va_list args ;
  1141.  
  1142.   fprintf(stderr, "%s: run time error: " , progname ) ;
  1143.   va_start(args, format) ;
  1144.   vfprintf(stderr, format, args) ;
  1145.   va_end(args) ;
  1146.   check_FILENAME() ;
  1147.   fprintf(stderr, "\n\t(FILENAME=\"%s\" FNR=%g NR=%g)\n" ,
  1148.      string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
  1149.      bi_vars[NR].dval) ;
  1150.   mawk_exit(1) ;
  1151. }
  1152.  
  1153. #else
  1154.  
  1155. #include <varargs.h>
  1156.  
  1157. /*  void errmsg(errnum, format, ...) */
  1158.  
  1159. void  errmsg( va_alist)
  1160.   va_dcl
  1161. { va_list ap ;
  1162.   int errnum ;
  1163.   char *format ;
  1164.  
  1165.   fprintf(stderr, "%s: " , progname) ;
  1166.   va_start(ap) ;
  1167.   errnum = va_arg(ap, int) ;
  1168.   format = va_arg(ap, char *) ;
  1169.   (void) vfprintf(stderr, format, ap) ;
  1170.   if ( errnum > 0 && errnum < sys_nerr )
  1171.     fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
  1172.   fprintf( stderr, "\n") ;
  1173. }
  1174.  
  1175. void compile_error( va_alist )
  1176.   va_dcl
  1177. { va_list args ;
  1178.   char *format ;
  1179.  
  1180.   fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
  1181.   va_start(args) ;
  1182.   format = va_arg(args, char *) ;
  1183.   vfprintf(stderr, format, args) ;
  1184.   va_end(args) ;
  1185.   fprintf(stderr, "\n") ;
  1186.   if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
  1187. }
  1188.  
  1189. void  rt_error( va_alist )
  1190.   va_dcl
  1191. { va_list args ;
  1192.   char *format ;
  1193.  
  1194.   fprintf(stderr, "%s: run time error: " , progname ) ;
  1195.   va_start(args) ;
  1196.   format = va_arg(args, char *) ;
  1197.   vfprintf(stderr, format, args) ;
  1198.   va_end(args) ;
  1199.   check_FILENAME() ;
  1200.   fprintf(stderr, "\n\tFILENAME=\"%s\" FNR=%g NR=%g\n" ,
  1201.      string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
  1202.      bi_vars[NR].dval) ;
  1203.   mawk_exit(1) ;
  1204. }
  1205.  
  1206. #endif
  1207.  
  1208. void bozo(s)
  1209.   char *s ;
  1210. { errmsg(0, "bozo: %s" , s) ; mawk_exit(1) ; }
  1211.  
  1212. void overflow(s, size)
  1213.   char *s ; unsigned size ;
  1214. { errmsg(0 , "program limit exceeded: %s size=%u", s, size) ;
  1215.   mawk_exit(1) ; }
  1216.  
  1217. static void check_FILENAME()
  1218. {
  1219.   if ( bi_vars[FILENAME].type != C_STRING )
  1220.           cast1_to_s(bi_vars + FILENAME) ;
  1221.   if ( bi_vars[FNR].type != C_DOUBLE )
  1222.           cast1_to_d(bi_vars + FNR ) ;
  1223.   if ( bi_vars[NR].type != C_DOUBLE )
  1224.           cast1_to_d(bi_vars + NR ) ;
  1225. }
  1226.  
  1227. /* run time */
  1228. void rt_overflow(s, size)
  1229.   char *s ; unsigned size ;
  1230. { check_FILENAME() ;
  1231.   errmsg(0 , 
  1232.   "program limit exceeded: %s size=%u\n\
  1233. \t(FILENAME=\"%s\" FNR=%g NR=%g)", 
  1234.    s, size, string(bi_vars+FILENAME)->str, 
  1235.    bi_vars[FNR].dval,
  1236.    bi_vars[NR].dval) ;
  1237.    mawk_exit(1) ;
  1238. }
  1239.  
  1240. static void unexpected_char()
  1241. { int c = yylval.ival ;
  1242.  
  1243.   fprintf(stderr, "%s: %u: ", progname, token_lineno) ;
  1244.   if ( c > ' ')
  1245.       fprintf(stderr, "unexpected character '%c'\n" , c) ;
  1246.   else
  1247.       fprintf(stderr, "unexpected character 0x%02x\n" , c) ;
  1248. }
  1249.  
  1250. static char *type_to_str( type )
  1251.   int type ;
  1252. { char *retval ;
  1253.  
  1254.   switch( type )
  1255.   {
  1256.     case  ST_VAR :  retval = "variable" ; break ;
  1257.     case  ST_ARRAY :  retval = "array" ; break ;
  1258.     case  ST_FUNCT :  retval = "function" ; break ;
  1259.     case  ST_LOCAL_VAR : retval = "local variable" ; break ;
  1260.     case  ST_LOCAL_ARRAY : retval = "local array" ; break ;
  1261.     default : bozo("type_to_str") ;
  1262.   }
  1263.   return retval ;
  1264. }
  1265.  
  1266. /* emit an error message about a type clash */
  1267. void type_error(p)
  1268.   SYMTAB *p ;
  1269. { compile_error("illegal reference to %s %s", 
  1270.     type_to_str(p->type) , p->name) ;
  1271. }
  1272.  
  1273.  
  1274. @//E*O*F mawk0.97/error.c//
  1275. chmod u=rw,g=r,o=r mawk0.97/error.c
  1276.  
  1277. echo x - mawk0.97/execute.c
  1278. sed 's/^@//' > "mawk0.97/execute.c" <<'@//E*O*F mawk0.97/execute.c//'
  1279.  
  1280. /********************************************
  1281. execute.c
  1282. copyright 1991, Michael D. Brennan
  1283.  
  1284. This is a source file for mawk, an implementation of
  1285. the Awk programming language as defined in
  1286. Aho, Kernighan and Weinberger, The AWK Programming Language,
  1287. Addison-Wesley, 1988.
  1288.  
  1289. See the accompaning file, LIMITATIONS, for restrictions
  1290. regarding modification and redistribution of this
  1291. program in source or binary form.
  1292. ********************************************/
  1293.  
  1294. /* $Log:    execute.c,v $
  1295.  * Revision 2.2  91/04/09  12:38:54  brennan
  1296.  * added static to funct decls to satisfy STARDENT compiler
  1297.  * 
  1298.  * Revision 2.1  91/04/08  08:22:55  brennan
  1299.  * VERSION 0.97
  1300.  * 
  1301. */
  1302.  
  1303.  
  1304. #include "mawk.h"
  1305. #include "code.h"
  1306. #include "memory.h"
  1307. #include "symtype.h"
  1308. #include "field.h"
  1309. #include "bi_funct.h"
  1310. #include "regexp.h"
  1311. #include "repl.h"
  1312. #include <math.h>
  1313.  
  1314. /* static functions */
  1315. static int PROTO( compare, (CELL *) ) ;
  1316. static void PROTO( eval_overflow, (void) ) ;
  1317.  
  1318. #ifdef   DEBUG
  1319. #define  inc_sp()   if( ++sp == eval_stack+EVAL_STACK_SIZE )\
  1320.                          eval_overflow()
  1321. #else
  1322.  
  1323. /* If things are working, the only reason the eval stack should
  1324.    overflow is too much function recursion
  1325.    (checked for at _CALL below  */
  1326.  
  1327. #define inc_sp()    sp++
  1328. #endif
  1329.  
  1330. #define  SAFETY    3    /* if we get within 3 of stack top emit 
  1331.          overflow */
  1332.  
  1333. /*  The stack machine that executes the code */
  1334.  
  1335. CELL  eval_stack[EVAL_STACK_SIZE] ;
  1336.  
  1337. static void eval_overflow()
  1338. { overflow("eval stack" , EVAL_STACK_SIZE) ; mawk_exit(1) ; }
  1339.  
  1340. /* if this flag is on, recursive calls to execute need to
  1341.    return to the _CALL statement.  This only happens
  1342.    inside array loops */
  1343. int  returning ;  
  1344.  
  1345. INST  *execute(cdp, sp, fp)
  1346.   register INST *cdp ;  /* code ptr, start execution here */
  1347.   register CELL *sp ;   /* eval_stack pointer */
  1348.   CELL *fp ;            /* frame ptr into eval_stack for
  1349.                            user defined functions */
  1350. { 
  1351.   /* some useful temporaries */
  1352.   CELL *cp , tc ;
  1353.   int t ;
  1354.  
  1355. #ifdef  DEBUG
  1356.   CELL *entry_sp = sp ;
  1357. #endif
  1358.  
  1359.   while ( 1 )
  1360.     switch( cdp++ -> op )
  1361.     {   case  _HALT :
  1362.         case  _STOP :  
  1363.  
  1364. #ifdef   DEBUG
  1365. /* check the stack is sane */
  1366.                 if ( sp != entry_sp ) bozo("stop") ;
  1367.                 return cdp - 1 ;
  1368.  
  1369.         case  _STOP0  : /* if debugging stops range patterns */
  1370.                 if ( sp != entry_sp+1 ) bozo("stop0") ;
  1371. #else
  1372.         case  _STOP0  :
  1373. #endif
  1374.                 return cdp -  1 ;
  1375.  
  1376.         case  _PUSHC :  
  1377.             inc_sp() ;
  1378.             (void) cellcpy(sp, cdp++ -> ptr) ;
  1379.             break ;
  1380.  
  1381.         case  F_PUSHA :
  1382.             if ( (CELL*)cdp->ptr != field && nf < 0 ) split_field0() ;
  1383.             /* fall thru */
  1384.  
  1385.         case  _PUSHA :
  1386.         case  A_PUSHA :
  1387.             inc_sp() ;
  1388.             sp -> ptr = cdp++ -> ptr ;
  1389.             break ;
  1390.  
  1391.         case _PUSHI :  /* put contents of next address on stack*/
  1392.             inc_sp() ;
  1393.             (void) cellcpy(sp, cdp++ -> ptr) ;
  1394.             break ;
  1395.             
  1396.         case L_PUSHI :  
  1397.             /* put the contents of a local var on stack,
  1398.                cdp->op holds the offset from the frame pointer */
  1399.             inc_sp() ;
  1400.             (void) cellcpy(sp, fp + cdp++->op) ;
  1401.             break ;
  1402.  
  1403.         case L_PUSHA : /* put a local address on eval stack */
  1404.             inc_sp() ;
  1405.             sp->ptr = (PTR)(fp + cdp++->op) ;
  1406.             break ;
  1407.  
  1408.  
  1409.         case F_PUSHI :
  1410.  
  1411.         /* note $0 , RS , FS and OFMT are loaded by _PUSHI */
  1412.  
  1413.             inc_sp() ;
  1414.             if ( nf < 0 )  split_field0() ;
  1415.             if ( (t = (CELL *) cdp->ptr - field) <= nf ||
  1416.                   t == NF  )
  1417.             { (void) cellcpy(sp, cdp++ -> ptr) ; }
  1418.             else  /* an unset field */
  1419.             { sp->type = C_STRING ;
  1420.               sp->ptr = (PTR) & null_str ;
  1421.               null_str.ref_cnt++ ;
  1422.               cdp++ ;
  1423.             }
  1424.             break ;
  1425.  
  1426.         case  FE_PUSHA :
  1427.             if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  1428.             if ( (t = (int) sp->dval) < 0 )
  1429.                 rt_error( "negative field index(%d)", t) ;
  1430.             if ( t > MAX_FIELD )
  1431.                 rt_overflow("MAX_FIELD", MAX_FIELD) ;
  1432.             if ( t && nf < 0 )  split_field0() ;
  1433.             sp->ptr = (PTR) &field[t] ;
  1434.             break ;
  1435.  
  1436.         case  FE_PUSHI :
  1437.             if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  1438.  
  1439.             if ( (t = (int) sp->dval) == 0 )
  1440.             { (void) cellcpy(sp, &field[0]) ; break ; }
  1441.  
  1442.             if ( t < 0 )
  1443.                   rt_error( "negative field index(%d)", t) ;
  1444.             if ( t > MAX_FIELD )
  1445.                   rt_overflow("MAX_FIELD", MAX_FIELD) ;
  1446.  
  1447.             if ( nf < 0)  split_field0() ;
  1448.             if ( t <= nf ) (void) cellcpy(sp, &field[t]) ;
  1449.             else
  1450.             { sp->type = C_STRING ;
  1451.               sp->ptr = (PTR) & null_str ;
  1452.               null_str.ref_cnt++ ;
  1453.             }
  1454.             break ; 
  1455.  
  1456.  
  1457.         case  AE_PUSHA :
  1458.         /* top of stack has an expr, cdp->ptr points at an
  1459.            array, replace the expr with the cell address inside
  1460.            the array */
  1461.             cast1_to_s(sp) ;
  1462.             cp = array_find((ARRAY)cdp++->ptr, sp->ptr, 0) ;
  1463.             free_STRING( string(sp) );
  1464.             sp->ptr = (PTR) cp ;
  1465.             break ;
  1466.  
  1467.         case  AE_PUSHI :
  1468.         /* top of stack has an expr, cdp->ptr points at an
  1469.            array, replace the expr with the contents of the
  1470.            cell inside the array */
  1471.             cast1_to_s(sp) ;
  1472.             cp = array_find((ARRAY) cdp++->ptr, sp->ptr, 0) ;
  1473.             free_STRING(string(sp)) ;
  1474.             (void) cellcpy(sp, cp) ;
  1475.             break ;
  1476.  
  1477.         case  LAE_PUSHI :
  1478.         /*  sp[0] is an expression
  1479.             cdp->op is offset from frame pointer of a CELL which
  1480.                has an ARRAY in the ptr field, replace expr
  1481.             with  array[expr]
  1482.         */
  1483.             cast1_to_s(sp) ;
  1484.             cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
  1485.             free_STRING(string(sp)) ;
  1486.             (void) cellcpy(sp, cp) ;
  1487.             break ;
  1488.             
  1489.         case  LAE_PUSHA :
  1490.         /*  sp[0] is an expression
  1491.             cdp->op is offset from frame pointer of a CELL which
  1492.                has an ARRAY in the ptr field, replace expr
  1493.             with  & array[expr]
  1494.         */
  1495.             cast1_to_s(sp) ;
  1496.             cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
  1497.             free_STRING(string(sp)) ;
  1498.             sp->ptr = (PTR) cp ;
  1499.             break ;
  1500.             
  1501.         case  LA_PUSHA  :
  1502.         /*  cdp->op is offset from frame pointer of a CELL which
  1503.                has an ARRAY in the ptr field. Push this ARRAY
  1504.                on the eval stack
  1505.         */
  1506.             inc_sp() ;
  1507.             sp->ptr = fp[cdp++->op].ptr ;
  1508.             break ;
  1509.  
  1510.         case  A_LOOP :
  1511.             cdp = array_loop(cdp,sp,fp) ;
  1512.             if ( returning ) return cdp ; /*value doesn't matter*/
  1513.             sp -= 2 ;
  1514.             break ;
  1515.  
  1516.         case  _POP : 
  1517.             cell_destroy(sp) ;
  1518.             sp-- ;
  1519.             break ;
  1520.  
  1521.         case _DUP  :
  1522.             (void) cellcpy(sp+1, sp) ;
  1523.             sp++ ; break ;
  1524.  
  1525.         case  _ASSIGN :
  1526.             /* top of stack has an expr, next down is an
  1527.                address, put the expression in *address and
  1528.                replace the address with the expression */
  1529.  
  1530.             /* don't propagate type C_MBSTRN */
  1531.             if ( sp->type == C_MBSTRN ) check_strnum(sp) ;
  1532.             sp-- ;
  1533.             cell_destroy( ((CELL *)sp->ptr) ) ;
  1534.             (void) cellcpy( sp, cellcpy(sp->ptr, sp+1) ) ;
  1535.             cell_destroy(sp+1) ;
  1536.             break ;
  1537.  
  1538.         case  F_ASSIGN : /* assign to a field  */
  1539.             if (sp->type == C_MBSTRN) check_strnum(sp) ;
  1540.             sp-- ;
  1541.             field_assign((CELL*)sp->ptr - field, sp+1) ;
  1542.             cell_destroy(sp+1) ;
  1543.             (void) cellcpy(sp, (CELL *) sp->ptr) ;
  1544.             break ;
  1545.  
  1546.         case  _ADD_ASG:
  1547.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1548.             cp = (CELL *) (sp-1)->ptr ;
  1549.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1550.             cp->dval += sp-- -> dval ;
  1551.             sp->type = C_DOUBLE ;
  1552.             sp->dval = cp->dval ;
  1553.             break ;
  1554.  
  1555.         case  _SUB_ASG:
  1556.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1557.             cp = (CELL *) (sp-1)->ptr ;
  1558.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1559.             cp->dval -= sp-- -> dval ;
  1560.             sp->type = C_DOUBLE ;
  1561.             sp->dval = cp->dval ;
  1562.             break ;
  1563.  
  1564.         case  _MUL_ASG:
  1565.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1566.             cp = (CELL *) (sp-1)->ptr ;
  1567.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1568.             cp->dval *= sp-- -> dval ;
  1569.             sp->type = C_DOUBLE ;
  1570.             sp->dval = cp->dval ;
  1571.             break ;
  1572.  
  1573.         case  _DIV_ASG:
  1574.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1575.             cp = (CELL *) (sp-1)->ptr ;
  1576.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1577.             cp->dval /= sp-- -> dval ;
  1578.             sp->type = C_DOUBLE ;
  1579.             sp->dval = cp->dval ;
  1580.             break ;
  1581.  
  1582.         case  _MOD_ASG:
  1583.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1584.             cp = (CELL *) (sp-1)->ptr ;
  1585.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1586.             cp->dval = fmod(cp->dval,sp-- -> dval) ;
  1587.             sp->type = C_DOUBLE ;
  1588.             sp->dval = cp->dval ;
  1589.             break ;
  1590.  
  1591.         case  _POW_ASG:
  1592.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1593.             cp = (CELL *) (sp-1)->ptr ;
  1594.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1595.             cp->dval = pow(cp->dval,sp-- -> dval) ;
  1596.             sp->type = C_DOUBLE ;
  1597.             sp->dval = cp->dval ;
  1598.             break ;
  1599.  
  1600.         /* will anyone ever use these ? */
  1601.  
  1602.         case F_ADD_ASG :
  1603.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1604.             cp = (CELL *) (sp-1)->ptr ;
  1605.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1606.             tc.dval += sp-- -> dval ;
  1607.             sp->type = C_DOUBLE ;
  1608.             sp->dval = tc.dval ;
  1609.             field_assign(cp-field, &tc) ;
  1610.             break ;
  1611.  
  1612.         case F_SUB_ASG :
  1613.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1614.             cp = (CELL *) (sp-1)->ptr ;
  1615.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1616.             tc.dval -= sp-- -> dval ;
  1617.             sp->type = C_DOUBLE ;
  1618.             sp->dval = tc.dval ;
  1619.             field_assign(cp-field, &tc) ;
  1620.             break ;
  1621.  
  1622.         case F_MUL_ASG :
  1623.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1624.             cp = (CELL *) (sp-1)->ptr ;
  1625.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1626.             tc.dval *= sp-- -> dval ;
  1627.             sp->type = C_DOUBLE ;
  1628.             sp->dval = tc.dval ;
  1629.             field_assign(cp-field, &tc) ;
  1630.             break ;
  1631.  
  1632.         case F_DIV_ASG :
  1633.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1634.             cp = (CELL *) (sp-1)->ptr ;
  1635.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1636.             tc.dval /= sp-- -> dval ;
  1637.             sp->type = C_DOUBLE ;
  1638.             sp->dval = tc.dval ;
  1639.             field_assign(cp-field, &tc) ;
  1640.             break ;
  1641.  
  1642.         case F_MOD_ASG :
  1643.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1644.             cp = (CELL *) (sp-1)->ptr ;
  1645.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1646.             tc.dval = fmod(tc.dval, sp-- -> dval) ;
  1647.             sp->type = C_DOUBLE ;
  1648.             sp->dval = tc.dval ;
  1649.             field_assign(cp-field, &tc) ;
  1650.             break ;
  1651.  
  1652.         case F_POW_ASG :
  1653.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1654.             cp = (CELL *) (sp-1)->ptr ;
  1655.             cast1_to_d( cellcpy(&tc, cp) ) ;
  1656.             tc.dval = pow(tc.dval, sp-- -> dval) ;
  1657.             sp->type = C_DOUBLE ;
  1658.             sp->dval = tc.dval ;
  1659.             field_assign(cp-field, &tc) ;
  1660.             break ;
  1661.  
  1662.         case _ADD :
  1663.             sp-- ;
  1664.             if ( TEST2(sp) != TWO_DOUBLES )
  1665.                     cast2_to_d(sp) ;
  1666.             sp[0].dval += sp[1].dval ;
  1667.             break ;
  1668.  
  1669.         case _SUB :
  1670.             sp-- ;
  1671.             if ( TEST2(sp) != TWO_DOUBLES )
  1672.                     cast2_to_d(sp) ;
  1673.             sp[0].dval -= sp[1].dval ;
  1674.             break ;
  1675.  
  1676.         case _MUL :
  1677.             sp-- ;
  1678.             if ( TEST2(sp) != TWO_DOUBLES )
  1679.                     cast2_to_d(sp) ;
  1680.             sp[0].dval *= sp[1].dval ;
  1681.             break ;
  1682.  
  1683.         case _DIV :
  1684.             sp-- ;
  1685.             if ( TEST2(sp) != TWO_DOUBLES )
  1686.                     cast2_to_d(sp) ;
  1687.             sp[0].dval /= sp[1].dval ;
  1688.             break ;
  1689.  
  1690.         case _MOD :
  1691.             sp-- ;
  1692.             if ( TEST2(sp) != TWO_DOUBLES )
  1693.                     cast2_to_d(sp) ;
  1694.             sp[0].dval = fmod(sp[0].dval,sp[1].dval) ;
  1695.             break ;
  1696.  
  1697.         case _POW :
  1698.             sp-- ;
  1699.             if ( TEST2(sp) != TWO_DOUBLES )
  1700.                     cast2_to_d(sp) ;
  1701.             sp[0].dval = pow(sp[0].dval,sp[1].dval) ;
  1702.             break ;
  1703.  
  1704.         case _NOT :
  1705.         reswitch_1:
  1706.             switch( sp->type )
  1707.             { case C_NOINIT :
  1708.                     sp->dval = 1.0 ; break ;
  1709.               case C_DOUBLE :
  1710.                     sp->dval =  sp->dval ? 0.0 : 1.0 ;
  1711.                     break ;
  1712.               case C_STRING :
  1713.                     sp->dval = string(sp)->len ? 0.0 : 1.0 ;
  1714.                     free_STRING(string(sp)) ;
  1715.                     break ;
  1716.               case C_STRNUM : /* test as a number */
  1717.                     sp->dval = sp->dval ? 0.0 : 1.0 ;
  1718.                     free_STRING(string(sp)) ;
  1719.                     break ;
  1720.               case C_MBSTRN :
  1721.                     check_strnum(sp) ;
  1722.                     goto reswitch_1 ;
  1723.               default :
  1724.                     bozo("bad type on eval stack") ;
  1725.             }
  1726.             sp->type = C_DOUBLE ;
  1727.             break  ;
  1728.  
  1729.         case _TEST :
  1730.         reswitch_2:
  1731.             switch( sp->type )
  1732.             { case C_NOINIT :
  1733.                     sp->dval = 0.0 ; break ;
  1734.               case C_DOUBLE :
  1735.                     sp->dval = sp->dval ? 1.0 : 0.0 ;
  1736.                     break ;
  1737.               case C_STRING :
  1738.                     sp->dval  = string(sp)->len ? 1.0 : 0.0 ;
  1739.                     free_STRING(string(sp)) ;
  1740.                     break ;
  1741.               case C_STRNUM : /* test as a number */
  1742.                     sp->dval  = sp->dval ? 0.0 : 1.0 ;
  1743.                     free_STRING(string(sp)) ;
  1744.                     break ;
  1745.               case C_MBSTRN :
  1746.                     check_strnum(sp) ;
  1747.                     goto reswitch_2 ;
  1748.               default :
  1749.                     bozo("bad type on eval stack") ;
  1750.             }
  1751.             sp->type = C_DOUBLE ;
  1752.             break ;
  1753.  
  1754.         case _UMINUS :
  1755.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1756.             sp->dval = - sp->dval ;
  1757.             break ;
  1758.  
  1759.         case _UPLUS :  
  1760.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1761.             break ;
  1762.  
  1763.         case _CAT :
  1764.             { unsigned len1, len2 ;
  1765.               char *str1, *str2 ;
  1766.               STRING *b ;
  1767.               
  1768.               sp-- ;
  1769.               if ( TEST2(sp) != TWO_STRINGS )
  1770.                     cast2_to_s(sp) ;
  1771.               str1 = string(sp)->str ;
  1772.               len1 = string(sp)->len ;
  1773.               str2 = string(sp+1)->str ;
  1774.               len2 = string(sp+1)->len ;
  1775.  
  1776.               b = new_STRING((char *)0, len1+len2) ;
  1777.               (void) memcpy(b->str, str1, len1) ;
  1778.               (void) memcpy(b->str + len1, str2, len2) ;
  1779.               free_STRING(string(sp)) ;
  1780.               free_STRING( string(sp+1) ) ;
  1781.  
  1782.               sp->ptr = (PTR) b ;
  1783.               break ;
  1784.             }
  1785.  
  1786.         case _PUSHINT :
  1787.             inc_sp() ;
  1788.             sp->type = cdp++ -> op ;
  1789.             break ;
  1790.  
  1791.         case _BUILTIN :
  1792.         case _PRINT :
  1793.             sp = (* (PF_CP) cdp++ -> ptr) (sp) ;
  1794.             break ;
  1795.  
  1796.         case _POST_INC :
  1797.             (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
  1798.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1799.             cp->dval += 1.0 ;
  1800.             break ;
  1801.  
  1802.         case _POST_DEC :
  1803.             (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
  1804.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1805.             cp->dval -= 1.0 ;
  1806.             break ;
  1807.  
  1808.         case _PRE_INC :
  1809.             cp = (CELL *) sp->ptr ;
  1810.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1811.             sp->dval = cp->dval += 1.0 ;
  1812.             sp->type = C_DOUBLE ;
  1813.             break ;
  1814.  
  1815.         case _PRE_DEC :
  1816.             cp = (CELL *) sp->ptr ;
  1817.             if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
  1818.             sp->dval = cp->dval -= 1.0 ;
  1819.             sp->type = C_DOUBLE ;
  1820.             break ;
  1821.  
  1822.  
  1823.         case F_POST_INC  :
  1824.             cp = (CELL *) sp->ptr ;
  1825.             (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
  1826.             cast1_to_d(&tc) ;
  1827.             tc.dval += 1.0 ;
  1828.             field_assign(cp-field, &tc) ;
  1829.             break ;
  1830.  
  1831.         case F_POST_DEC  :
  1832.             cp = (CELL *) sp->ptr ;
  1833.             (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
  1834.             cast1_to_d(&tc) ;
  1835.             tc.dval -= 1.0 ;
  1836.             field_assign(cp-field, &tc) ;
  1837.             break ;
  1838.  
  1839.         case F_PRE_INC :
  1840.             cp = (CELL *) sp->ptr ;
  1841.             cast1_to_d(cellcpy(&tc, cp)) ;
  1842.             sp->dval = tc.dval += 1.0 ;
  1843.             sp->type = C_DOUBLE ;
  1844.             field_assign(cp-field, sp) ;
  1845.             break ;
  1846.  
  1847.         case F_PRE_DEC :
  1848.             cp = (CELL *) sp->ptr ;
  1849.             cast1_to_d(cellcpy(&tc, cp)) ;
  1850.             sp->dval = tc.dval -= 1.0 ;
  1851.             sp->type = C_DOUBLE ;
  1852.             field_assign(cp-field, sp) ;
  1853.             break ;
  1854.  
  1855.         case _JMP  :
  1856.             cdp += cdp->op - 1 ;
  1857.             break ;
  1858.  
  1859.         case _JNZ  :
  1860.             /* jmp if top of stack is non-zero and pop stack */
  1861.             if ( test( sp ) )
  1862.                 cdp += cdp->op - 1 ;
  1863.             else  cdp++ ;
  1864.             cell_destroy(sp) ;
  1865.             sp-- ;
  1866.             break ;
  1867.  
  1868.         case _JZ  :
  1869.             /* jmp if top of stack is zero and pop stack */
  1870.             if ( ! test( sp ) )
  1871.                 cdp += cdp->op - 1 ;
  1872.             else  cdp++ ;
  1873.             cell_destroy(sp) ;
  1874.             sp-- ;
  1875.             break ;
  1876.  
  1877.     /*  the relation operations */
  1878.     /*  compare() makes sure string ref counts are OK */
  1879.         case  _EQ :
  1880.             t = compare(--sp) ;
  1881.             sp->type = C_DOUBLE ;
  1882.             sp->dval = t == 0 ? 1.0 : 0.0 ;
  1883.             break ;
  1884.  
  1885.         case  _NEQ :
  1886.             t = compare(--sp) ;
  1887.             sp->type = C_DOUBLE ;
  1888.             sp->dval = t ? 1.0 : 0.0 ;
  1889.             break ;
  1890.  
  1891.         case  _LT :
  1892.             t = compare(--sp) ;
  1893.             sp->type = C_DOUBLE ;
  1894.             sp->dval = t < 0 ? 1.0 : 0.0 ;
  1895.             break ;
  1896.  
  1897.         case  _LTE :
  1898.             t = compare(--sp) ;
  1899.             sp->type = C_DOUBLE ;
  1900.             sp->dval = t <= 0 ? 1.0 : 0.0 ;
  1901.             break ;
  1902.  
  1903.         case  _GT :
  1904.             t = compare(--sp) ;
  1905.             sp->type = C_DOUBLE ;
  1906.             sp->dval = t > 0 ? 1.0 : 0.0 ;
  1907.             break ;
  1908.  
  1909.         case  _GTE :
  1910.             t = compare(--sp) ;
  1911.             sp->type = C_DOUBLE ;
  1912.             sp->dval = t >= 0 ? 1.0 : 0.0 ;
  1913.             break ;
  1914.  
  1915.         case  _MATCH :
  1916.             /* does sp[-1] match sp[0] as re */
  1917.             if ( sp->type != C_RE )  cast_to_RE(sp) ;
  1918.  
  1919.             if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;
  1920.             t = REtest(string(sp)->str, (sp+1)->ptr) ; 
  1921.  
  1922.             free_STRING(string(sp)) ;
  1923.             sp->type = C_DOUBLE ;
  1924.             sp->dval = t ? 1.0 : 0.0 ;
  1925.             break ;
  1926.  
  1927.         case  A_TEST :
  1928.         /* entry :  sp[0].ptr-> an array
  1929.                     sp[-1]  is an expression
  1930.  
  1931.            we compute   expression in array  */
  1932.             if ( (--sp)->type < C_STRING ) cast1_to_s(sp) ;
  1933.             t = array_test( (sp+1)->ptr, string(sp)) ;
  1934.             free_STRING(string(sp)) ;
  1935.             sp->type = C_DOUBLE ;
  1936.             sp->dval = t ? 1.0 : 0.0 ;
  1937.             break ;
  1938.  
  1939.         case  A_DEL :
  1940.         /* sp[0].ptr ->  array)
  1941.            sp[-1] is an expr
  1942.            delete  array[expr]  */
  1943.  
  1944.             cast1_to_s(--sp) ;
  1945.             array_delete( sp[1].ptr , sp->ptr) ;
  1946.             free_STRING( string(sp) ) ;
  1947.             sp-- ;
  1948.             break ;
  1949.         
  1950.         /* form a multiple array index */
  1951.         case A_CAT :
  1952.             sp = array_cat(sp, cdp++->op) ;
  1953.             break ;
  1954.  
  1955.         case  _EXIT0 :
  1956.             longjmp( exit_jump, 1) ;
  1957.  
  1958.         case  _EXIT  :
  1959.             if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
  1960.             exit_code = (int) sp->dval ;
  1961.             longjmp( exit_jump, 1) ;
  1962.  
  1963.         case  _NEXT :
  1964.             longjmp(next_jump, 1) ;
  1965.  
  1966.         case  _RANGE :
  1967. /* test a range pattern:  pat1, pat2 { action }
  1968.    entry :
  1969.        cdp[0].op -- a flag, test pat1 if on else pat2
  1970.        cdp[1].op -- offset of pat2 code from cdp
  1971.        cdp[2].op -- offset of action code from cdp
  1972.        cdp[3].op -- offset of code after the action from cdp
  1973.        cdp[4] -- start of pat1 code
  1974. */
  1975.  
  1976. #define FLAG    cdp[0].op
  1977. #define PAT2    cdp[1].op
  1978. #define ACTION    cdp[2].op
  1979. #define FOLLOW    cdp[3].op
  1980. #define PAT1      4
  1981.  
  1982.             if ( FLAG )  /* test again pat1 */
  1983.             { 
  1984.               (void) execute(cdp + PAT1,sp, fp) ;
  1985.               t = test(sp+1) ;
  1986.               cell_destroy(sp+1) ;
  1987.               if ( t )  FLAG = 0 ;
  1988.               else
  1989.               { cdp += FOLLOW ;
  1990.                 break ;  /* break the switch */
  1991.               }
  1992.             }
  1993.  
  1994.             /* test against pat2 and then perform the action */
  1995.             (void) execute(cdp + PAT2, sp, fp) ;
  1996.             FLAG  = test(sp+1) ;
  1997.             cell_destroy(sp+1) ; 
  1998.             cdp += ACTION ;
  1999.             break ;
  2000.  
  2001. /* function calls  */
  2002.  
  2003.       case  _RET0  :
  2004.             inc_sp() ;
  2005.             sp->type = C_NOINIT ;
  2006.             /* fall thru */
  2007.  
  2008.       case  _RET   :
  2009.  
  2010. #ifdef  DEBUG
  2011.             if ( sp != entry_sp+1 ) bozo("ret") ;
  2012. #endif
  2013.             returning = 1 ;
  2014.             return  cdp-1 ;
  2015.  
  2016.       case  _CALL  :
  2017.  
  2018.             { FBLOCK *fbp = (FBLOCK*) cdp++->ptr ;
  2019.               int a_args = cdp++->op ; /* actual number of args */
  2020.               CELL *nfp = sp - a_args + 1 ; /* new fp for callee */
  2021.               CELL *local_p = sp+1; /* first local argument on stack */
  2022.               char *type_p ;  /* pts to type of an argument */
  2023.  
  2024.               if ( fbp->nargs ) type_p = fbp->typev + a_args ;
  2025.  
  2026.               /* create space for locals */
  2027.               if ( t = fbp->nargs - a_args ) /* have local args */
  2028.               {
  2029.                 if ( sp + t >= eval_stack + EVAL_STACK_SIZE - SAFETY )
  2030.                    eval_overflow() ;
  2031.  
  2032.                 while ( t-- )  
  2033.                 { (++sp)->type = C_NOINIT ;
  2034.                   if ( *type_p++ == ST_LOCAL_ARRAY )
  2035.                         sp->ptr = (PTR) new_ARRAY() ;
  2036.                 }
  2037.               }
  2038.               type_p-- ; /* *type_p is type of last arg */ 
  2039.  
  2040.               (void) execute(fbp->code, sp, nfp) ;
  2041. #ifdef  DEBUG
  2042. if ( !returning )  bozo("call") ;
  2043. #endif
  2044.               returning = 0 ;
  2045.  
  2046.               /* cleanup the callee's arguments */
  2047.               if ( sp >= nfp ) 
  2048.               {
  2049.                 cp = sp+1 ;  /* cp -> the function return */
  2050.  
  2051.                 do
  2052.                 {
  2053.                   if ( *type_p-- == ST_LOCAL_ARRAY )
  2054.                   {  if ( sp >= local_p ) array_free(sp->ptr) ; }
  2055.                   else  cell_destroy(sp) ;
  2056.  
  2057.                 } while ( --sp >= nfp ) ;
  2058.                     
  2059.                 (void) cellcpy(++sp, cp) ;
  2060.                 cell_destroy(cp) ;
  2061.               }
  2062.               else  sp++ ; /* no arguments passed */
  2063.             }
  2064.             break ;
  2065.  
  2066.         default :
  2067.             bozo("bad opcode") ;
  2068.     }
  2069. }
  2070.  
  2071. int test( cp )  /* test if a cell is null or not */
  2072.   register CELL *cp ;
  2073. { 
  2074. reswitch :
  2075.  
  2076.   switch ( cp->type )
  2077.   {
  2078.     case C_NOINIT :  return  0 ;
  2079.     case C_STRNUM :  /* test as a number */
  2080.     case C_DOUBLE :  return  cp->dval != 0.0 ;
  2081.     case C_STRING :  return  string(cp)->len ;
  2082.     case C_MBSTRN :  check_strnum(cp) ; goto reswitch ;
  2083.  
  2084.     default :
  2085.       bozo("bad cell type in call to test") ;
  2086.   }
  2087. }
  2088.  
  2089. /* compare cells at cp and cp+1 and
  2090.    frees STRINGs at those cells
  2091. */
  2092.  
  2093. static int compare(cp)
  2094.   register CELL *cp ;
  2095. { int k ;
  2096.  
  2097. reswitch :
  2098.  
  2099.   switch( TEST2(cp) )
  2100.   { case TWO_NOINITS :  return 0 ; 
  2101.     
  2102.     case TWO_DOUBLES :
  2103.     two_d:
  2104.             return  cp->dval > (cp+1)->dval ? 1 :
  2105.                     cp->dval < (cp+1)->dval ? -1 : 0 ;
  2106.     
  2107.     case TWO_STRINGS :
  2108.     case STRING_AND_STRNUM :
  2109.     two_s:
  2110.             k = strcmp(string(cp)->str, string(cp+1)->str) ;
  2111.             free_STRING( string(cp) ) ;
  2112.             free_STRING( string(cp+1) ) ;
  2113.             return k ;
  2114.  
  2115.     case  NOINIT_AND_DOUBLE  :
  2116.     case  NOINIT_AND_STRNUM  :
  2117.     case  DOUBLE_AND_STRNUM  :
  2118.     case TWO_STRNUMS :
  2119.             cast2_to_d(cp) ; goto two_d ;
  2120.  
  2121.     case  NOINIT_AND_STRING  :
  2122.     case  DOUBLE_AND_STRING  :
  2123.             cast2_to_s(cp) ; goto two_s ;
  2124.  
  2125.     case  TWO_MBSTRNS :
  2126.             check_strnum(cp) ; check_strnum(cp+1) ;
  2127.             goto reswitch ;
  2128.  
  2129.     case  NOINIT_AND_MBSTRN :
  2130.     case  DOUBLE_AND_MBSTRN :
  2131.     case  STRING_AND_MBSTRN :
  2132.     case  STRNUM_AND_MBSTRN :
  2133.             check_strnum( cp->type == C_MBSTRN ? cp : cp+1 ) ;
  2134.             goto reswitch ;
  2135.  
  2136.     default :  /* there are no default cases */
  2137.             bozo("bad cell type passed to compare") ;
  2138.   }
  2139. }
  2140.  
  2141. /* does not assume target was a cell, if so
  2142.    then caller should have made a previous
  2143.    call to cell_destroy  */
  2144.  
  2145. CELL *cellcpy(target, source)
  2146.   register CELL *target, *source ;
  2147. { switch( target->type = source->type )
  2148.   { case C_NOINIT : 
  2149.     case C_SPACE  : 
  2150.     case C_SNULL  :
  2151.             break ;
  2152.  
  2153.     case C_DOUBLE :
  2154.             target->dval = source->dval ;
  2155.             break ;
  2156.  
  2157.     case C_STRNUM :
  2158.             target->dval = source->dval ;
  2159.             /* fall thru */
  2160.  
  2161.     case C_REPL    :
  2162.     case C_MBSTRN  :
  2163.     case C_STRING  :
  2164.             string(source)->ref_cnt++ ;
  2165.             /* fall thru */
  2166.  
  2167.     case C_RE  :
  2168.             target->ptr = source->ptr ;
  2169.             break ;
  2170.  
  2171.     case  C_REPLV :
  2172.             (void)  replv_cpy(target, source) ;
  2173.             break ;
  2174.  
  2175.     default :
  2176.             bozo("bad cell passed to cellcpy()") ;
  2177.             break ;
  2178.   }
  2179.   return  target ;
  2180. }
  2181.  
  2182. #ifdef   DEBUG
  2183.  
  2184. void  DB_cell_destroy(cp)    /* HANGOVER time */
  2185.   register CELL *cp ;
  2186. {
  2187.   switch( cp->type )
  2188.   { case C_NOINIT :
  2189.     case C_DOUBLE :  break ;
  2190.  
  2191.     case C_MBSTRN :
  2192.     case C_STRING :
  2193.     case C_STRNUM :
  2194.             if ( -- string(cp)->ref_cnt == 0 )
  2195.                 zfree(string(cp) , string(cp)->len+5) ;
  2196.             break ;
  2197.  
  2198.     case  C_RE :
  2199.             bozo("cell destroy called on RE cell") ;
  2200.     default :
  2201.             bozo("cell destroy called on bad cell type") ;
  2202.   }
  2203. }
  2204.  
  2205. #endif
  2206. @//E*O*F mawk0.97/execute.c//
  2207. chmod u=rw,g=r,o=r mawk0.97/execute.c
  2208.  
  2209. echo x - mawk0.97/fcall.c
  2210. sed 's/^@//' > "mawk0.97/fcall.c" <<'@//E*O*F mawk0.97/fcall.c//'
  2211.  
  2212. /********************************************
  2213. fcall.c
  2214. copyright 1991, Michael D. Brennan
  2215.  
  2216. This is a source file for mawk, an implementation of
  2217. the Awk programming language as defined in
  2218. Aho, Kernighan and Weinberger, The AWK Programming Language,
  2219. Addison-Wesley, 1988.
  2220.  
  2221. See the accompaning file, LIMITATIONS, for restrictions
  2222. regarding modification and redistribution of this
  2223. program in source or binary form.
  2224. ********************************************/
  2225.  
  2226.  
  2227. /*$Log:    fcall.c,v $
  2228.  * Revision 2.1  91/04/08  08:22:59  brennan
  2229.  * VERSION 0.97
  2230.  * 
  2231. */
  2232.  
  2233. #include "mawk.h"
  2234. #include "symtype.h"
  2235. #include "code.h"
  2236.  
  2237. /* This file has functions involved with type checking of
  2238.    function calls
  2239. */
  2240.  
  2241. static  FCALL_REC *PROTO(first_pass, (FCALL_REC *) ) ;
  2242. static  CA_REC    *PROTO(call_arg_check, (FBLOCK *, CA_REC *,
  2243.         INST *, unsigned) ) ;
  2244. static  int PROTO(arg_cnt_ok, (FBLOCK *,CA_REC *, unsigned) ) ;
  2245.  
  2246.  
  2247. static int check_progress ;
  2248.     /* flag that indicates call_arg_check() was able to type
  2249.        check some call arguments */
  2250.  
  2251. /* type checks a list of call arguments,
  2252.    returns a list of arguments whose type is still unknown
  2253. */
  2254. static CA_REC *call_arg_check( callee, entry_list , start,  line_no)
  2255.   FBLOCK *callee ;
  2256.   CA_REC *entry_list  ;  
  2257.   INST  *start ; /* to locate patch */
  2258.   unsigned line_no ; /* for error messages */
  2259. { register CA_REC *q ;
  2260.   CA_REC *exit_list  = (CA_REC *) 0 ;
  2261.  
  2262.   check_progress = 0 ;
  2263.  
  2264.   /* loop :
  2265.        take q off entry_list
  2266.        test it
  2267.            if OK  zfree(q)  else put on exit_list
  2268.   */
  2269.      
  2270.   while ( q = entry_list )
  2271.   {
  2272.     entry_list = q->link ;
  2273.  
  2274.     if ( q->type == ST_NONE )
  2275.     { /* try to infer the type */
  2276.       /* it might now be in symbol table */
  2277.       if ( q->sym_p->type == ST_VAR )
  2278.       { /* set type and patch */
  2279.         q->type = CA_EXPR ;
  2280.         start[q->call_offset+1].ptr  = (PTR) q->sym_p->stval.cp ;
  2281.       }
  2282.       else
  2283.       if ( q->sym_p->type == ST_ARRAY )
  2284.       { q->type = CA_ARRAY ;
  2285.         start[q->call_offset].op = A_PUSHA ;
  2286.         start[q->call_offset+1].ptr = (PTR) q->sym_p->stval.array ;
  2287.       } 
  2288.       else /* try to infer from callee */
  2289.       {
  2290.         switch( callee->typev[q->arg_num] )
  2291.         {
  2292.           case  ST_LOCAL_VAR :
  2293.                 q->type = CA_EXPR ;
  2294.                 q->sym_p->type = ST_VAR ;
  2295.                 q->sym_p->stval.cp = new_CELL() ;
  2296.                 q->sym_p->stval.cp->type = C_NOINIT ;
  2297.                 start[q->call_offset+1].ptr  = 
  2298.                          (PTR) q->sym_p->stval.cp ;
  2299.                 break ;
  2300.  
  2301.           case  ST_LOCAL_ARRAY :
  2302.                 q->type = CA_ARRAY ;
  2303.                 q->sym_p->type = ST_ARRAY ;
  2304.                 q->sym_p->stval.array = new_ARRAY() ;
  2305.                 start[q->call_offset].op = A_PUSHA ;
  2306.                 start[q->call_offset+1].ptr = 
  2307.                       (PTR) q->sym_p->stval.array ;
  2308.                 break ;
  2309.         }
  2310.       }
  2311.     }
  2312.     else
  2313.     if ( q->type == ST_LOCAL_NONE )
  2314.     { /* try to infer the type */
  2315.       if ( * q->type_p == ST_LOCAL_VAR )
  2316.       { /* set type , don't need to patch */
  2317.         q->type = CA_EXPR ;
  2318.       }
  2319.       else
  2320.       if ( * q->type_p == ST_LOCAL_ARRAY )
  2321.       { q->type = CA_ARRAY ;
  2322.         start[q->call_offset].op = LA_PUSHA ;
  2323.         /* offset+1 op is OK */
  2324.       } 
  2325.       else /* try to infer from callee */
  2326.       {
  2327.         switch( callee->typev[q->arg_num] )
  2328.         {
  2329.           case  ST_LOCAL_VAR :
  2330.                 q->type = CA_EXPR ;
  2331.                 * q->type_p = ST_LOCAL_VAR ;
  2332.                 /* do not need to patch */
  2333.                 break ;
  2334.  
  2335.           case  ST_LOCAL_ARRAY :
  2336.                 q->type = CA_ARRAY ;
  2337.                 * q->type_p = ST_LOCAL_ARRAY ;
  2338.                 start[q->call_offset].op = LA_PUSHA ;
  2339.                 break ;
  2340.         }
  2341.       }
  2342.     }
  2343.  
  2344.     /* if we still do not know the type put on the new list
  2345.        else type check */
  2346.  
  2347.     if ( q->type == ST_NONE || q->type == ST_LOCAL_NONE )
  2348.     {
  2349.       q->link = exit_list ;
  2350.       exit_list = q ;
  2351.     }
  2352.     else  /* type known */
  2353.     {
  2354.       if ( callee->typev[q->arg_num] == ST_LOCAL_NONE )
  2355.            callee->typev[q->arg_num] = q->type ;
  2356.  
  2357.       else
  2358.       if ( q->type != callee->typev[q->arg_num] )
  2359.       {
  2360.         errmsg(0, "line %u: type error in arg(%d) in call to %s",
  2361.           line_no, q->arg_num+1, callee->name) ;
  2362.         if ( ++compile_error_count == MAX_COMPILE_ERRORS )
  2363.                     mawk_exit(1) ;
  2364.       }
  2365.  
  2366.       zfree(q, sizeof(CA_REC)) ;
  2367.       check_progress = 1 ;
  2368.     }
  2369.   } /* while */
  2370.  
  2371.   return  exit_list ;
  2372. }
  2373.  
  2374.  
  2375. static  int  arg_cnt_ok( fbp, q, line_no )
  2376.   FBLOCK  *fbp ;
  2377.   CA_REC  *q ;
  2378.   unsigned line_no ;
  2379. {
  2380.   if ( q->arg_num  >= fbp->nargs )
  2381.   {
  2382.     errmsg(0, "line %u: too many arguments in call to %s" ,
  2383.        line_no, fbp->name ) ;
  2384.     if ( ++compile_error_count == MAX_COMPILE_ERRORS ) 
  2385.               mawk_exit(1) ;
  2386.  
  2387.     return  0 ;
  2388.   }
  2389.   else  return 1 ;
  2390. }
  2391.  
  2392.  
  2393. FCALL_REC  *resolve_list ;
  2394.         /* function calls whose arg types need checking 
  2395.            are stored on this list */
  2396.  
  2397.  
  2398. /* on first pass thru the resolve list
  2399.    we check :
  2400.       if forward referenced functions were really defined
  2401.       if right number of arguments
  2402.    and compute call_start which is now known
  2403. */
  2404.  
  2405. static  FCALL_REC *first_pass( p )
  2406.   register FCALL_REC *p ;
  2407. { FCALL_REC dummy ;
  2408.  
  2409.  
  2410.