mawk0.97.shar 2 of 6

Mike Brennan brennan at ssc-vax.UUCP
Sun May 12 00:51:06 AEST 1991


------------------cut here----------------
  { case C_NOINIT :  cp->dval = 0.0 ; break ;

    case C_DOUBLE :  goto two ;
    case C_STRNUM :  
            free_STRING( string(cp) ) ;
            break ;

    case C_MBSTRN :
    case C_STRING :  
            s = (STRING *) cp->ptr ;

#if FPE_TRAPS  /* look for overflow error */
            errno = 0 ;
            cp->dval = strtod(s->str,(char **)0) ;
            if ( errno && cp->dval != 0.0 ) /* ignore underflow */
                rt_error("overflow converting %s to double", s) ;
#else
            cp->dval = strtod(s->str,(char **)0) ;
#endif
            free_STRING(s) ;
            break ;

    default :
            bozo("cast on bad type") ;
  }
  cp->type = C_DOUBLE ;

two:   cp++ ;
  switch( cp->type )
  { case C_NOINIT :  cp->dval = 0.0 ; break ;

    case C_DOUBLE :  return ;
    case C_STRNUM :  
            free_STRING( string(cp) ) ;
            break ;

    case C_MBSTRN :
    case C_STRING :  
            s = (STRING *) cp->ptr ;

#if FPE_TRAPS  /* look for overflow error */
            errno = 0 ;
            cp->dval = strtod(s->str,(char **)0) ;
            if ( errno && cp->dval != 0.0 ) /* ignore underflow */
                rt_error("overflow converting %s to double", s) ;
#else
            cp->dval = strtod(s->str,(char **)0) ;
#endif
            free_STRING(s) ;
            break ;

    default :
            bozo("cast on bad type") ;
  }
  cp->type = C_DOUBLE ;
}

void cast1_to_s( cp )
  register CELL *cp ;
{ 
  switch( cp->type )
  { case C_NOINIT :  
        null_str.ref_cnt++ ;
        cp->ptr = (PTR) &null_str ;
        break ;

    case C_DOUBLE  :
        (void) sprintf(temp_buff.string_buff ,
            string(field+OFMT)->str, cp->dval) ;

        cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
        break ;

    case C_STRING :  return ;

    case C_MBSTRN :
    case C_STRNUM :  break ;

    default :  bozo("bad type on cast") ;
  }
  cp->type = C_STRING ;
}

void cast2_to_s( cp )
  register CELL *cp ;
{ 

  switch( cp->type )
  { case C_NOINIT : 
        null_str.ref_cnt++ ;
        cp->ptr = (PTR) &null_str ;
        break ;

    case C_DOUBLE  :
        (void) sprintf(temp_buff.string_buff,
            string(field+OFMT)->str, cp->dval ) ;

        cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
        break ;

    case C_STRING :  goto two ;

    case C_MBSTRN :
    case C_STRNUM :  break ;

    default :  bozo("bad type on cast") ;
  }
  cp->type = C_STRING ;

two:
  cp++ ;

  switch( cp->type )
  { case C_NOINIT :  
        null_str.ref_cnt++ ; 
        cp->ptr = (PTR) &null_str ;
        break ;

    case C_DOUBLE  :
        (void) sprintf(temp_buff.string_buff,
            string(field+OFMT)->str, cp->dval) ;

        cp->ptr = (PTR) new_STRING(temp_buff.string_buff) ;
        break ;

    case C_STRING :  return ;

    case C_MBSTRN :
    case C_STRNUM :  break ;

    default :  bozo("bad type on cast") ;
  }
  cp->type = C_STRING ;
}

void  cast_to_RE( cp )
  register CELL *cp ;
{ register PTR p ;

  if ( cp->type < C_STRING )  cast1_to_s(cp) ;

  p = re_compile( string(cp) ) ;
  free_STRING( string(cp) ) ;
  cp->type = C_RE ;
  cp->ptr = p ;

}

void  cast_for_split(cp)
  register CELL *cp ;
{
  static char meta[] = "^$.*+?|[]()" ;
  static char xbuff[] = "\\X" ;
  int c ;
  unsigned len ;
    
  if ( cp->type < C_STRING )  cast1_to_s(cp) ;

  if ( (len = string(cp)->len) == 1 )
  {
        if ( (c = string(cp)->str[0]) == ' ' )
        { free_STRING(string(cp)) ;
          cp->type = C_SPACE ; 
          return ; 
        }
        else
        if ( strchr(meta, c) )
        { xbuff[1] = c ;
          free_STRING(string(cp)) ;
          cp->ptr = (PTR) new_STRING(xbuff) ;
        }
  }
  else
  if ( len == 0 ) 
  { free_STRING(string(cp)) ;
    cp->type = C_SNULL ; 
    return ; 
  }

  cast_to_RE(cp) ;
}

/* input: cp-> a CELL of type C_MBSTRN (maybe strnum)
   test it -- casting it to the appropriate type
   which is C_STRING or C_STRNUM
*/

void check_strnum( cp )
  CELL *cp ;
{ char *test ;
  register unsigned char *s , *q ;

  cp->type = C_STRING ; /* assume not C_STRNUM */
  s = (unsigned char *) string(cp)->str ;
  q = s + string(cp)->len ;
  while ( scan_code[*s] == SC_SPACE )  s++ ;
  if ( s == q )  return ;

  while ( scan_code[ q[-1] ] == SC_SPACE )  q-- ;
  if ( scan_code[ q[-1] ] != SC_DIGIT &&
       q[-1] != '.' )   return ;

  switch ( scan_code[*s] )
  {
    case SC_DIGIT :
    case SC_PLUS  :
    case SC_MINUS :
    case SC_DOT   :

#if FPE_TRAPS
             errno = 0 ;
             cp->dval  = strtod((char *)s, &test) ;
             if ( errno && cp->dval != 0.0 )
                rt_error(
                "overflow converting %s to double" , s) ;
#else
             cp->dval = strtod(s, &test) ;
#endif

             if ((char *) q == test )  cp->type = C_STRNUM ;
  }
}

/* cast a CELL to a replacement cell */

void cast_to_REPL( cp )
  register CELL *cp ;
{ register STRING *sval ;

  if ( cp->type < C_STRING )  cast1_to_s(cp) ;
  sval = (STRING *) cp->ptr ;

  (void) cellcpy(cp, repl_compile(sval)) ;
  free_STRING(sval) ;
}


#if   NO_STRTOD

static char d_str[] =
"^[ \t]*[-+]?([0-9]+\\.?|\\.[0-9])[0-9]*([eE][-+]?[0-9]+)?" ;

static PTR d_ptr ;

void strtod_init()
{ STRING *sval = new_STRING(d_str) ;

  d_ptr = re_compile(sval) ;
  free_STRING(sval) ;
}

double strtod( s, endptr)
  char *s , **endptr ;
{ double atof() ;

  if ( endptr )
  { unsigned len ;

    (void) REmatch(s, d_ptr, &len) ;
    *endptr = s + len ;
  }
  return  atof(s) ;
}
#endif  /* NO_STRTOD */

#if   NO_FMOD

double  fmod(x, y)
  double x, y ;
{ double modf() ;
  double ipart ;

  return modf(x/y, &ipart) * y ;
}

#endif  /* NO_FMOD */



@//E*O*F mawk0.97/cast.c//
chmod u=rw,g=r,o=r mawk0.97/cast.c
 
echo x - mawk0.97/code.c
sed 's/^@//' > "mawk0.97/code.c" <<'@//E*O*F mawk0.97/code.c//'

/********************************************
code.c
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/


/* $Log:	code.c,v $
 * Revision 2.1  91/04/08  08:22:46  brennan
 * VERSION 0.97
 * 
*/

/*  code.c  */

#include "mawk.h"
#include "code.h"
#include "init.h"


#define   CODE_SZ      (PAGE_SZ*sizeof(INST))

INST *code_ptr  ;
INST *main_start , *main_code_ptr ;
INST *begin_start , *begin_code_ptr ;
INST *end_start , *end_code_ptr ;
unsigned  main_size, begin_size, end_size ;

void  PROTO(fdump, (void) ) ;

void  code_init()
{ 
  main_code_ptr = main_start = (INST *) zmalloc(CODE_SZ) ;
  begin_code_ptr = begin_start = (INST *) zmalloc(CODE_SZ) ;
  end_code_ptr = end_start = (INST *) zmalloc(CODE_SZ) ;
  code_ptr = main_code_ptr ;
}

void code_cleanup()
{
  if ( dump_code )  fdump() ; /* dumps all functions */

  begin_code_ptr++->op = _HALT ;
  if ( (begin_size = begin_code_ptr - begin_start) == 1 ) /* empty */
  {
      zfree( begin_start, CODE_SZ ) ;
      begin_start = (INST *) 0 ;
  }
  else
  if ( begin_size > PAGE_SZ ) overflow("BEGIN code" , PAGE_SZ) ;
  else
  {  begin_size *= sizeof(INST) ;
     begin_start = (INST *) zrealloc(begin_start,CODE_SZ,begin_size) ;
     if ( dump_code )
     { fprintf(stderr, "BEGIN\n") ;
       da(begin_start, stderr) ; 
     }
  }

  end_code_ptr++->op = _HALT ;
  if ( (end_size = end_code_ptr - end_start) == 1 ) /* empty */
  {
      zfree( end_start, CODE_SZ ) ;
      end_start = (INST *) 0 ;
  }
  else
  if ( end_size > PAGE_SZ ) overflow("END code" , PAGE_SZ) ;
  else
  {  end_size *= sizeof(INST) ;
     end_start = (INST *) zrealloc(end_start, CODE_SZ, end_size) ;
     if ( dump_code )
     { fprintf(stderr, "END\n") ;
       da(end_start, stderr) ;
     }
  }

  code_ptr++->op = _HALT ;
  if ( (main_size = code_ptr - main_start) == 1 ) /* empty */
  {
      zfree( main_start, CODE_SZ ) ;
      main_start = (INST *) 0 ;
  }
  else
  if ( main_size > PAGE_SZ ) overflow("MAIN code" , PAGE_SZ) ;
  else
  {  main_size *= sizeof(INST) ;
     main_start = (INST *) zrealloc(main_start, CODE_SZ, main_size) ;
     if ( dump_code )
     { fprintf(stderr, "MAIN\n") ;
       da(main_start, stderr) ;
     }
  }
}
@//E*O*F mawk0.97/code.c//
chmod u=rw,g=r,o=r mawk0.97/code.c
 
echo x - mawk0.97/code.h
sed 's/^@//' > "mawk0.97/code.h" <<'@//E*O*F mawk0.97/code.h//'

/********************************************
code.h
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/


/* $Log:	code.h,v $
 * Revision 2.1  91/04/08  08:22:48  brennan
 * VERSION 0.97
 * 
*/


/*  code.h  */

#ifndef  CODE_H
#define  CODE_H

#include "memory.h"
#include <setjmp.h>

/* coding scope */
#define   SCOPE_MAIN    0
#define   SCOPE_BEGIN   1  
#define   SCOPE_END     2
#define   SCOPE_FUNCT   3


extern  INST  *code_ptr ;
extern  INST  *begin_start , *begin_code_ptr ;
extern  INST  *end_start , *end_code_ptr ;
extern  INST  *main_start, *main_code_ptr ;
extern  unsigned begin_size, end_size, main_size ;

extern  CELL  eval_stack[] ;


#define  code1(x)  code_ptr++ -> op = (x)

#define  code2(x,y)    (void)( code_ptr++ -> op = (x) ,\
                         code_ptr++ -> ptr = (PTR)(y) )


/*  the machine opcodes  */

#define _HALT            0
#define _STOP            1
#define _STOP0           2  
#define _PUSHC           3
#define _PUSHINT         4
#define _PUSHA           5
#define _PUSHI           6
#define L_PUSHA          7
#define L_PUSHI          8
#define AE_PUSHA         9
#define AE_PUSHI        10
#define A_PUSHA         11
#define LAE_PUSHA       12
#define LAE_PUSHI       13
#define LA_PUSHA        14
#define F_PUSHA         15
#define FE_PUSHA        16
#define F_PUSHI         17
#define FE_PUSHI        18
#define _POP            19
#define _PULL           20
#define _DUP            21
#define _ADD            22
#define _SUB            23
#define _MUL            24
#define _DIV            25
#define _MOD            26
#define _POW            27
#define _NOT            28
#define _TEST           29
#define A_TEST          30
#define A_DEL           31
#define A_LOOP          32
#define A_CAT           33
#define _UMINUS         34
#define _UPLUS          35
#define _ASSIGN         36
#define _ADD_ASG        37
#define _SUB_ASG        38
#define _MUL_ASG        39
#define _DIV_ASG        40
#define _MOD_ASG        41
#define _POW_ASG        42
#define F_ASSIGN        43
#define F_ADD_ASG       44
#define F_SUB_ASG       45
#define F_MUL_ASG       46
#define F_DIV_ASG       47
#define F_MOD_ASG       48
#define F_POW_ASG       49
#define _CAT            50
#define _BUILTIN        51
#define _PRINT          52
#define _POST_INC       53
#define _POST_DEC       54
#define _PRE_INC        55
#define _PRE_DEC        56
#define F_POST_INC      57
#define F_POST_DEC      58
#define F_PRE_INC       59
#define F_PRE_DEC       60
#define _JMP            61
#define _JNZ            62
#define _JZ             63
#define _EQ             64
#define _NEQ            65
#define _LT             66
#define _LTE            67
#define _GT             68
#define _GTE            69
#define _MATCH          70
#define _EXIT           71
#define _EXIT0          72
#define _NEXT           73
#define _RANGE          74
#define _CALL           75
#define _RET            76
#define _RET0           77


/* next and exit statements */

extern jmp_buf  exit_jump, next_jump ;
extern int exit_code ;

#endif  /* CODE_H */
@//E*O*F mawk0.97/code.h//
chmod u=rw,g=r,o=r mawk0.97/code.h
 
echo x - mawk0.97/da.c
sed 's/^@//' > "mawk0.97/da.c" <<'@//E*O*F mawk0.97/da.c//'

/********************************************
da.c
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/


/* $Log:	da.c,v $
 * Revision 2.1  91/04/08  08:22:50  brennan
 * VERSION 0.97
 * 
*/


/*  da.c  */
/*  disassemble code */ 


#include  "mawk.h"
#include  "code.h"
#include  "bi_funct.h"
#include  "repl.h"
#include  "field.h"

char *PROTO(find_bi_name, (PF_CP) ) ;

void  da(start, fp)
  INST *start ;
  FILE *fp ;
{ CELL *cp ;
  register INST *p = start ;

  while ( 1 )
  { /* print the relative code address (label) */
    fprintf(fp,"%03d ", p - start) ;

    switch( p++->op )
    {
      case _HALT :  fprintf(fp,"halt\n") ; return ;
      case _STOP :  fprintf(fp,"stop\n") ; break  ;
      case _STOP0 : fprintf(fp, "stop0\n") ; break ;

      case _PUSHC :
            cp = (CELL *) p++->ptr ;
            switch( cp->type )
            { case C_DOUBLE :
                  fprintf(fp,"pushc\t%.6g\n" ,  cp ->dval) ;
                  break ;

              case C_STRING :
                  fprintf(fp,"pushc\t\"%s\"\n" ,
                          ((STRING *)cp->ptr)->str) ;
                  break ;

              case C_RE :
                  fprintf(fp,"pushc\t0x%x\t/%s/\n" , cp->ptr ,
                    re_uncompile(cp->ptr) ) ;
                  break ;

              case C_SPACE : 
                  fprintf(fp, "pushc\tspace split\n") ;
                  break ;

              case C_SNULL : 
                  fprintf(fp, "pushc\tnull split\n") ;
                  break ;
              case C_REPL  :
                  fprintf(fp, "pushc\trepl\t%s\n" ,
                        repl_uncompile(cp) ) ;
                  break ;
              case C_REPLV :
                  fprintf(fp, "pushc\treplv\t%s\n" ,
                        repl_uncompile(cp) ) ;
                  break ;
                  
              default :
                  fprintf(fp,"pushc\tWEIRD\n") ;  ;
                  break ;
            }
            break ;

      case _PUSHA :
            fprintf(fp,"pusha\t0x%x\n", p++ -> ptr) ;
            break ;

      case _PUSHI :
            if ( (CELL *)p->ptr == field )
                fprintf(fp, "pushi\t$0\n") ;
            else fprintf(fp,"pushi\t0x%x\n", p -> ptr) ;
            p++ ;
            break ;

      case  L_PUSHA :
            fprintf( fp, "l_pusha\t%d\n", p++->op) ;
            break ;

      case  L_PUSHI :
            fprintf( fp, "l_pushi\t%d\n", p++->op) ;
            break ;

      case  LAE_PUSHI :
            fprintf( fp, "lae_pushi\t%d\n", p++->op) ;
            break ;

      case  LAE_PUSHA :
            fprintf( fp, "lae_pusha\t%d\n", p++->op) ;
            break ;

      case  LA_PUSHA :
            fprintf( fp, "la_pusha\t%d\n", p++->op) ;
            break ;

      case F_PUSHA :
            fprintf(fp,"f_pusha\t$%d\n" , (CELL *) p++->ptr - field ) ;
            break ;

      case F_PUSHI :
            fprintf(fp,"f_pushi\t$%d\n" , (CELL *) p++->ptr - field ) ;
            break ;

      case FE_PUSHA :
            fprintf(fp,"fe_pusha\n" ) ;
            break ;

      case FE_PUSHI :
            fprintf(fp,"fe_pushi\n" ) ;
            break ;

      case AE_PUSHA :
            fprintf(fp,"ae_pusha\t0x%x\n" , p++->ptr) ;
            break ;

      case AE_PUSHI :
            fprintf(fp,"ae_pushi\t0x%x\n" , p++->ptr) ;
            break ;

      case A_PUSHA :
            fprintf(fp,"a_pusha\t0x%x\n" , p++->ptr) ;
            break ;

      case A_TEST :
            fprintf(fp,"a_test\n" ) ;
            break ;

      case A_DEL :
            fprintf(fp,"a_del\n" ) ;
            break ;

      case A_CAT :
            fprintf(fp,"a_cat\t%d\n", p++->op ) ;
            break ;

      case _POP :
            fprintf(fp,"pop\n") ;
            break ;

      case  _ADD :
            fprintf(fp,"add\n") ; break ;

      case  _SUB :
            fprintf(fp,"sub\n") ; break ;
      case  _MUL :
            fprintf(fp,"mul\n") ; break ;
      case  _DIV :
            fprintf(fp,"div\n") ; break ;
      case  _MOD :
            fprintf(fp,"mod\n") ; break ;
      case  _POW :
            fprintf(fp,"pow\n") ; break ;
      case  _NOT :
            fprintf(fp,"not\n") ; break ;
      case  _UMINUS :
            fprintf(fp,"uminus\n") ; break ;
      case  _UPLUS :
            fprintf(fp,"plus\n") ; break ;
      case  _DUP :
            fprintf(fp,"dup\n") ; break ;
      case  _TEST :
            fprintf(fp,"test\n") ; break ;

      case  _CAT  :
            fprintf(fp,"cat\n") ; break ;

      case  _ASSIGN :
            fprintf(fp,"assign\n") ; break ;
      case  _ADD_ASG :
            fprintf(fp,"add_asg\n") ; break ;
      case  _SUB_ASG :
            fprintf(fp,"sub_asg\n") ; break ;
      case  _MUL_ASG :
            fprintf(fp,"mul_asg\n") ; break ;
      case  _DIV_ASG :
            fprintf(fp,"div_asg\n") ; break ;
      case  _MOD_ASG :
            fprintf(fp,"mod_asg\n") ; break ;
      case  _POW_ASG :
            fprintf(fp,"pow_asg\n") ; break ;

      case  F_ASSIGN :
            fprintf(fp,"f_assign\n") ; break ;
      case  F_ADD_ASG :
            fprintf(fp,"f_add_asg\n") ; break ;
      case  F_SUB_ASG :
            fprintf(fp,"f_sub_asg\n") ; break ;
      case  F_MUL_ASG :
            fprintf(fp,"f_mul_asg\n") ; break ;
      case  F_DIV_ASG :
            fprintf(fp,"f_div_asg\n") ; break ;
      case  F_MOD_ASG :
            fprintf(fp,"f_mod_asg\n") ; break ;
      case  F_POW_ASG :
            fprintf(fp,"f_pow_asg\n") ; break ;

      case  _PUSHINT :
            fprintf(fp,"pushint\t%d\n" , p++ -> op ) ;
            break ;

      case  _BUILTIN  :
            fprintf(fp,"%s\n" , 
                    find_bi_name( (PF_CP) p++ -> ptr ) ) ;
            break ;

      case  _PRINT :
            fprintf(fp,"%s\n", 
            (PF_CP) p++ -> ptr == bi_printf
                ? "printf" : "print") ;
            break ;
      
      case  _POST_INC :
            fprintf(fp,"post_inc\n") ; break ;

      case  _POST_DEC :
            fprintf(fp,"post_dec\n") ; break ;

      case  _PRE_INC :
            fprintf(fp,"pre_inc\n") ; break ;

      case  _PRE_DEC :
            fprintf(fp,"pre_dec\n") ; break ;

      case  F_POST_INC :
            fprintf(fp,"f_post_inc\n") ; break ;

      case  F_POST_DEC :
            fprintf(fp,"f_post_dec\n") ; break ;

      case  F_PRE_INC :
            fprintf(fp,"f_pre_inc\n") ; break ;

      case  F_PRE_DEC :
            fprintf(fp,"f_pre_dec\n") ; break ;

      case  _JMP :
      case  _JNZ :
      case  _JZ  :
          { int j = (p-1)->op ;
            char *s = j == _JMP ? "jmp" : 
                      j == _JNZ ? "jnz" : "jz" ;

            fprintf(fp,"%s\t\t%03d\n" , s ,
              (p - start) + p->op - 1 ) ;
            p++ ;
            break ;
          }
    
      case  _EQ  :
            fprintf(fp,"eq\n") ; break ;

      case  _NEQ  :
            fprintf(fp,"neq\n") ; break ;

      case  _LT  :
            fprintf(fp,"lt\n") ; break ;

      case  _LTE  :
            fprintf(fp,"lte\n") ; break ;

      case  _GT  :
            fprintf(fp,"gt\n") ; break ;

      case  _GTE  :
            fprintf(fp,"gte\n") ; break ;

      case  _MATCH :
            fprintf(fp,"match_op\n") ; break ;

      case  A_LOOP :
            fprintf(fp,"a_loop\t%03d\n", p-start+p[1].op) ;
            p += 2 ;
            break ;

      case  _EXIT  :
            fprintf(fp, "exit\n") ; break ;

      case  _EXIT0  :
            fprintf(fp, "exit0\n") ; break ;

      case  _NEXT  :
            fprintf(fp, "next\n") ; break ;

      case  _RET  :
            fprintf(fp, "ret\n") ; break ;
      case  _RET0 :
            fprintf(fp, "ret0\n") ; break ;

      case  _CALL :
            fprintf(fp, "call\t%s\t%d\n", 
                ((FBLOCK*)p->ptr)->name , p[1].op) ;
            p += 2 ;
            break ;

      case  _RANGE :
            fprintf(fp, "range\t%03d %03d %03d\n",
              /* label for pat2, action, follow */
              p - start + p[1].op ,
              p - start + p[2].op ,
              p - start + p[3].op ) ;
            p += 4 ; 
            break ;
      default :
            fprintf(fp,"bad instruction\n") ;
            return ;
    }
  }
}

static struct {
PF_CP action ;
char *name ;
} special_cases[] = {
bi_length, "length",
bi_split, "split",
bi_match, "match",
bi_getline,"getline",
bi_sub, "sub",
bi_gsub , "gsub",
(PF_CP) 0, (char *) 0 } ;

static char *find_bi_name( p )
  PF_CP p ;
{ BI_REC *q ;
  int i ;

  for( q = bi_funct ; q->name ; q++ )
    if ( q->fp == p )  /* found */
        return q->name ;
  /* next check some special cases */
  for( i = 0 ; special_cases[i].action ; i++)
    if ( special_cases[i].action == p )
        return  special_cases[i].name ;

  return  "unknown builtin" ;
}

static struct fdump {
struct fdump *link ;
FBLOCK  *fbp ;
}  *fdump_list ;  /* linked list of all user functions */

void add_to_fdump_list( fbp )
  FBLOCK *fbp ;
{ struct fdump *p = (struct fdump *)zmalloc(sizeof(struct fdump)) ;
  p->fbp = fbp ;
  p->link = fdump_list ;  fdump_list = p ;
}

void  fdump()
{
  register struct fdump *p, *q = fdump_list ;

  while ( p = q )
  { q = p->link ;
    fprintf(stderr, "function %s\n" , p->fbp->name) ;
    da(p->fbp->code, stderr) ;
    zfree(p, sizeof(struct fdump)) ;
  }
}
@//E*O*F mawk0.97/da.c//
chmod u=rw,g=r,o=r mawk0.97/da.c
 
echo x - mawk0.97/error.c
sed 's/^@//' > "mawk0.97/error.c" <<'@//E*O*F mawk0.97/error.c//'

/********************************************
error.c
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/


/* $Log:	error.c,v $
 * Revision 2.2  91/04/09  12:38:52  brennan
 * added static to funct decls to satisfy STARDENT compiler
 * 
 * Revision 2.1  91/04/08  08:22:52  brennan
 * VERSION 0.97
 * 
*/


#include  "mawk.h"
#include  "scan.h"
#include  "bi_vars.h"

#ifndef  EOF
#define  EOF  (-1)
#endif

/* statics */
static void  PROTO( check_FILENAME, (void) ) ;
static void  PROTO( unexpected_char, (void) ) ;
static void  PROTO( missing, (int, char *, int) ) ;
static char *PROTO( type_to_str, (int) ) ;


static struct token_str  {
short token ;
char *str ; }  token_str[] = {
EOF , "end of file" ,
NL , "end of line",
SEMI_COLON , ";" ,
LBRACE , "{" ,
RBRACE , "}" ,
SC_FAKE_SEMI_COLON, "}",
LPAREN , "(" ,
RPAREN , ")" ,
LBOX , "[",
RBOX , "]",
QMARK , "?",
COLON , ":",
OR, "||",
AND, "&&",
P_OR, "||",
P_AND, "&&",
ASSIGN , "=" ,
ADD_ASG, "+=",
SUB_ASG, "-=",
MUL_ASG, "*=",
DIV_ASG, "/=",
MOD_ASG, "%=",
POW_ASG, "^=",
EQ  , "==" ,
NEQ , "!=",
LT, "<" ,
LTE, "<=" ,
GT, ">",
GTE, ">=" ,
MATCH, "~",
NOT_MATCH, "!~",
PLUS , "+" ,
MINUS, "-" ,
MUL , "*" ,
DIV, "/"  , 
MOD, "%" ,
POW, "^" ,
INC , "++" ,
DEC , "--" ,
NOT, "!" ,
COMMA, "," ,
CONSTANT , temp_buff.string_buff ,
ID , temp_buff.string_buff ,
FUNCT_ID , temp_buff.string_buff ,
BUILTIN , temp_buff.string_buff ,
IO_OUT, temp_buff.string_buff, 
IO_IN, "<" ,
PIPE, "|" ,
DOLLAR, "$" ,
FIELD, "$" ,
0, (char *) 0 } ;

/* if paren_cnt >0 and we see one of these, we are missing a ')' */
static int missing_rparen[] =
{ EOF, NL, SEMI_COLON, SC_FAKE_SEMI_COLON, RBRACE, 0 } ;

/* ditto for '}' */
static int missing_rbrace[] =
{ EOF, BEGIN, END , 0 } ;

static void missing( c, n , ln)
  int c ;
  char *n ;
  int ln ;
{ errmsg(0, "line %u: missing %c near %s" , ln, c, n) ; }
  
void  yyerror(s)
  char *s ; /* we won't use s as input 
  (yacc and bison force this).
  We will use s for storage to keep lint or the compiler
  off our back */
{ struct token_str *p ;
  int *ip ;

  s = (char *) 0 ;

  for ( p = token_str ; p->token ; p++ )
      if ( current_token == p->token )
      { s = p->str ; break ; }

  if ( ! s )  /* search the keywords */
         s = find_kw_str(current_token) ;

  if ( s )
  {
    if ( paren_cnt )
        for( ip = missing_rparen ; *ip ; ip++)
          if ( *ip == current_token )
          { missing(')', s, token_lineno) ;
            paren_cnt = 0 ;
            goto done ;
          }

    if ( brace_cnt )
        for( ip = missing_rbrace ; *ip ; ip++)
          if ( *ip == current_token )
          { missing('}', s, token_lineno) ;
            brace_cnt = 0 ;
            goto done ;
          }

    compile_error("syntax error at or near %s", s) ;

  }
  else  /* special cases */
  switch ( current_token )
  {
    case UNEXPECTED :
            unexpected_char() ; 
            goto done ;

    case BAD_DECIMAL :
            compile_error(
              "syntax error in decimal constant %s",
              temp_buff.string_buff ) ;
            break ;

    case RE :
            compile_error(
            "syntax error at or near /%s/", 
            temp_buff.string_buff ) ;
            break ;

    default :
            compile_error("syntax error") ;
            break ;
  }
  return ;

done :
  if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}

/* system provided errnos and messages */
extern int sys_nerr ;
extern char *sys_errlist[] ;

#ifdef  __STDC__
#include <stdarg.h>

/* generic error message with a hook into the system error 
   messages if errnum > 0 */

void  errmsg(int errnum, char *format, ...)
{ va_list args ;

  fprintf(stderr, "%s: " , progname) ;
  va_start(args, format) ;
  (void) vfprintf(stderr, format, args) ;
  va_end(args) ;
  if ( errnum > 0 && errnum < sys_nerr )
    fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
  fprintf( stderr, "\n") ;
}

void  compile_error(char *format, ...)
{ va_list args ;

  fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
  va_start(args, format) ;
  vfprintf(stderr, format, args) ;
  va_end(args) ;
  fprintf(stderr, "\n") ;
  if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}

void  rt_error( char *format, ...)
{ va_list args ;

  fprintf(stderr, "%s: run time error: " , progname ) ;
  va_start(args, format) ;
  vfprintf(stderr, format, args) ;
  va_end(args) ;
  check_FILENAME() ;
  fprintf(stderr, "\n\t(FILENAME=\"%s\" FNR=%g NR=%g)\n" ,
     string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
     bi_vars[NR].dval) ;
  mawk_exit(1) ;
}

#else

#include <varargs.h>

/*  void errmsg(errnum, format, ...) */

void  errmsg( va_alist)
  va_dcl
{ va_list ap ;
  int errnum ;
  char *format ;

  fprintf(stderr, "%s: " , progname) ;
  va_start(ap) ;
  errnum = va_arg(ap, int) ;
  format = va_arg(ap, char *) ;
  (void) vfprintf(stderr, format, ap) ;
  if ( errnum > 0 && errnum < sys_nerr )
    fprintf(stderr, " (%s)" , sys_errlist[errnum]) ;
  fprintf( stderr, "\n") ;
}

void compile_error( va_alist )
  va_dcl
{ va_list args ;
  char *format ;

  fprintf(stderr, "%s: line %u: " , progname, token_lineno) ;
  va_start(args) ;
  format = va_arg(args, char *) ;
  vfprintf(stderr, format, args) ;
  va_end(args) ;
  fprintf(stderr, "\n") ;
  if ( ++compile_error_count == MAX_COMPILE_ERRORS ) mawk_exit(1) ;
}

void  rt_error( va_alist )
  va_dcl
{ va_list args ;
  char *format ;

  fprintf(stderr, "%s: run time error: " , progname ) ;
  va_start(args) ;
  format = va_arg(args, char *) ;
  vfprintf(stderr, format, args) ;
  va_end(args) ;
  check_FILENAME() ;
  fprintf(stderr, "\n\tFILENAME=\"%s\" FNR=%g NR=%g\n" ,
     string(bi_vars+FILENAME)->str, bi_vars[FNR].dval,
     bi_vars[NR].dval) ;
  mawk_exit(1) ;
}

#endif

void bozo(s)
  char *s ;
{ errmsg(0, "bozo: %s" , s) ; mawk_exit(1) ; }

void overflow(s, size)
  char *s ; unsigned size ;
{ errmsg(0 , "program limit exceeded: %s size=%u", s, size) ;
  mawk_exit(1) ; }

static void check_FILENAME()
{
  if ( bi_vars[FILENAME].type != C_STRING )
          cast1_to_s(bi_vars + FILENAME) ;
  if ( bi_vars[FNR].type != C_DOUBLE )
          cast1_to_d(bi_vars + FNR ) ;
  if ( bi_vars[NR].type != C_DOUBLE )
          cast1_to_d(bi_vars + NR ) ;
}

/* run time */
void rt_overflow(s, size)
  char *s ; unsigned size ;
{ check_FILENAME() ;
  errmsg(0 , 
  "program limit exceeded: %s size=%u\n\
\t(FILENAME=\"%s\" FNR=%g NR=%g)", 
   s, size, string(bi_vars+FILENAME)->str, 
   bi_vars[FNR].dval,
   bi_vars[NR].dval) ;
   mawk_exit(1) ;
}

static void unexpected_char()
{ int c = yylval.ival ;

  fprintf(stderr, "%s: %u: ", progname, token_lineno) ;
  if ( c > ' ')
      fprintf(stderr, "unexpected character '%c'\n" , c) ;
  else
      fprintf(stderr, "unexpected character 0x%02x\n" , c) ;
}

static char *type_to_str( type )
  int type ;
{ char *retval ;

  switch( type )
  {
    case  ST_VAR :  retval = "variable" ; break ;
    case  ST_ARRAY :  retval = "array" ; break ;
    case  ST_FUNCT :  retval = "function" ; break ;
    case  ST_LOCAL_VAR : retval = "local variable" ; break ;
    case  ST_LOCAL_ARRAY : retval = "local array" ; break ;
    default : bozo("type_to_str") ;
  }
  return retval ;
}

/* emit an error message about a type clash */
void type_error(p)
  SYMTAB *p ;
{ compile_error("illegal reference to %s %s", 
    type_to_str(p->type) , p->name) ;
}


@//E*O*F mawk0.97/error.c//
chmod u=rw,g=r,o=r mawk0.97/error.c
 
echo x - mawk0.97/execute.c
sed 's/^@//' > "mawk0.97/execute.c" <<'@//E*O*F mawk0.97/execute.c//'

/********************************************
execute.c
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/

/* $Log:	execute.c,v $
 * Revision 2.2  91/04/09  12:38:54  brennan
 * added static to funct decls to satisfy STARDENT compiler
 * 
 * Revision 2.1  91/04/08  08:22:55  brennan
 * VERSION 0.97
 * 
*/


#include "mawk.h"
#include "code.h"
#include "memory.h"
#include "symtype.h"
#include "field.h"
#include "bi_funct.h"
#include "regexp.h"
#include "repl.h"
#include <math.h>

/* static functions */
static int PROTO( compare, (CELL *) ) ;
static void PROTO( eval_overflow, (void) ) ;

#ifdef   DEBUG
#define  inc_sp()   if( ++sp == eval_stack+EVAL_STACK_SIZE )\
                         eval_overflow()
#else

/* If things are working, the only reason the eval stack should
   overflow is too much function recursion
   (checked for at _CALL below  */

#define inc_sp()    sp++
#endif

#define  SAFETY    3    /* if we get within 3 of stack top emit 
         overflow */

/*  The stack machine that executes the code */

CELL  eval_stack[EVAL_STACK_SIZE] ;

static void eval_overflow()
{ overflow("eval stack" , EVAL_STACK_SIZE) ; mawk_exit(1) ; }

/* if this flag is on, recursive calls to execute need to
   return to the _CALL statement.  This only happens
   inside array loops */
int  returning ;  

INST  *execute(cdp, sp, fp)
  register INST *cdp ;  /* code ptr, start execution here */
  register CELL *sp ;   /* eval_stack pointer */
  CELL *fp ;            /* frame ptr into eval_stack for
                           user defined functions */
{ 
  /* some useful temporaries */
  CELL *cp , tc ;
  int t ;

#ifdef  DEBUG
  CELL *entry_sp = sp ;
#endif

  while ( 1 )
    switch( cdp++ -> op )
    {   case  _HALT :
        case  _STOP :  

#ifdef   DEBUG
/* check the stack is sane */
                if ( sp != entry_sp ) bozo("stop") ;
                return cdp - 1 ;

        case  _STOP0  : /* if debugging stops range patterns */
                if ( sp != entry_sp+1 ) bozo("stop0") ;
#else
        case  _STOP0  :
#endif
                return cdp -  1 ;

        case  _PUSHC :  
            inc_sp() ;
            (void) cellcpy(sp, cdp++ -> ptr) ;
            break ;

        case  F_PUSHA :
            if ( (CELL*)cdp->ptr != field && nf < 0 ) split_field0() ;
            /* fall thru */

        case  _PUSHA :
        case  A_PUSHA :
            inc_sp() ;
            sp -> ptr = cdp++ -> ptr ;
            break ;

        case _PUSHI :  /* put contents of next address on stack*/
            inc_sp() ;
            (void) cellcpy(sp, cdp++ -> ptr) ;
            break ;
            
        case L_PUSHI :  
            /* put the contents of a local var on stack,
               cdp->op holds the offset from the frame pointer */
            inc_sp() ;
            (void) cellcpy(sp, fp + cdp++->op) ;
            break ;

        case L_PUSHA : /* put a local address on eval stack */
            inc_sp() ;
            sp->ptr = (PTR)(fp + cdp++->op) ;
            break ;


        case F_PUSHI :

        /* note $0 , RS , FS and OFMT are loaded by _PUSHI */

            inc_sp() ;
            if ( nf < 0 )  split_field0() ;
            if ( (t = (CELL *) cdp->ptr - field) <= nf ||
                  t == NF  )
            { (void) cellcpy(sp, cdp++ -> ptr) ; }
            else  /* an unset field */
            { sp->type = C_STRING ;
              sp->ptr = (PTR) & null_str ;
              null_str.ref_cnt++ ;
              cdp++ ;
            }
            break ;

        case  FE_PUSHA :
            if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
            if ( (t = (int) sp->dval) < 0 )
                rt_error( "negative field index(%d)", t) ;
            if ( t > MAX_FIELD )
                rt_overflow("MAX_FIELD", MAX_FIELD) ;
            if ( t && nf < 0 )  split_field0() ;
            sp->ptr = (PTR) &field[t] ;
            break ;

        case  FE_PUSHI :
            if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;

            if ( (t = (int) sp->dval) == 0 )
            { (void) cellcpy(sp, &field[0]) ; break ; }

            if ( t < 0 )
                  rt_error( "negative field index(%d)", t) ;
            if ( t > MAX_FIELD )
                  rt_overflow("MAX_FIELD", MAX_FIELD) ;

            if ( nf < 0)  split_field0() ;
            if ( t <= nf ) (void) cellcpy(sp, &field[t]) ;
            else
            { sp->type = C_STRING ;
              sp->ptr = (PTR) & null_str ;
              null_str.ref_cnt++ ;
            }
            break ; 


        case  AE_PUSHA :
        /* top of stack has an expr, cdp->ptr points at an
           array, replace the expr with the cell address inside
           the array */
            cast1_to_s(sp) ;
            cp = array_find((ARRAY)cdp++->ptr, sp->ptr, 0) ;
            free_STRING( string(sp) );
            sp->ptr = (PTR) cp ;
            break ;

        case  AE_PUSHI :
        /* top of stack has an expr, cdp->ptr points at an
           array, replace the expr with the contents of the
           cell inside the array */
            cast1_to_s(sp) ;
            cp = array_find((ARRAY) cdp++->ptr, sp->ptr, 0) ;
            free_STRING(string(sp)) ;
            (void) cellcpy(sp, cp) ;
            break ;

        case  LAE_PUSHI :
        /*  sp[0] is an expression
            cdp->op is offset from frame pointer of a CELL which
               has an ARRAY in the ptr field, replace expr
            with  array[expr]
        */
            cast1_to_s(sp) ;
            cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
            free_STRING(string(sp)) ;
            (void) cellcpy(sp, cp) ;
            break ;
            
        case  LAE_PUSHA :
        /*  sp[0] is an expression
            cdp->op is offset from frame pointer of a CELL which
               has an ARRAY in the ptr field, replace expr
            with  & array[expr]
        */
            cast1_to_s(sp) ;
            cp = array_find( (ARRAY)fp[cdp++->op].ptr, sp->ptr, 0) ;
            free_STRING(string(sp)) ;
            sp->ptr = (PTR) cp ;
            break ;
            
        case  LA_PUSHA  :
        /*  cdp->op is offset from frame pointer of a CELL which
               has an ARRAY in the ptr field. Push this ARRAY
               on the eval stack
        */
            inc_sp() ;
            sp->ptr = fp[cdp++->op].ptr ;
            break ;

        case  A_LOOP :
            cdp = array_loop(cdp,sp,fp) ;
            if ( returning ) return cdp ; /*value doesn't matter*/
            sp -= 2 ;
            break ;

        case  _POP : 
            cell_destroy(sp) ;
            sp-- ;
            break ;

        case _DUP  :
            (void) cellcpy(sp+1, sp) ;
            sp++ ; break ;

        case  _ASSIGN :
            /* top of stack has an expr, next down is an
               address, put the expression in *address and
               replace the address with the expression */

            /* don't propagate type C_MBSTRN */
            if ( sp->type == C_MBSTRN ) check_strnum(sp) ;
            sp-- ;
            cell_destroy( ((CELL *)sp->ptr) ) ;
            (void) cellcpy( sp, cellcpy(sp->ptr, sp+1) ) ;
            cell_destroy(sp+1) ;
            break ;

        case  F_ASSIGN : /* assign to a field  */
            if (sp->type == C_MBSTRN) check_strnum(sp) ;
            sp-- ;
            field_assign((CELL*)sp->ptr - field, sp+1) ;
            cell_destroy(sp+1) ;
            (void) cellcpy(sp, (CELL *) sp->ptr) ;
            break ;

        case  _ADD_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval += sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        case  _SUB_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval -= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        case  _MUL_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval *= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        case  _DIV_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval /= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        case  _MOD_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval = fmod(cp->dval,sp-- -> dval) ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        case  _POW_ASG:
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval = pow(cp->dval,sp-- -> dval) ;
            sp->type = C_DOUBLE ;
            sp->dval = cp->dval ;
            break ;

        /* will anyone ever use these ? */

        case F_ADD_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval += sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_SUB_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval -= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_MUL_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval *= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_DIV_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval /= sp-- -> dval ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_MOD_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval = fmod(tc.dval, sp-- -> dval) ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_POW_ASG :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            cp = (CELL *) (sp-1)->ptr ;
            cast1_to_d( cellcpy(&tc, cp) ) ;
            tc.dval = pow(tc.dval, sp-- -> dval) ;
            sp->type = C_DOUBLE ;
            sp->dval = tc.dval ;
            field_assign(cp-field, &tc) ;
            break ;

        case _ADD :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval += sp[1].dval ;
            break ;

        case _SUB :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval -= sp[1].dval ;
            break ;

        case _MUL :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval *= sp[1].dval ;
            break ;

        case _DIV :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval /= sp[1].dval ;
            break ;

        case _MOD :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval = fmod(sp[0].dval,sp[1].dval) ;
            break ;

        case _POW :
            sp-- ;
            if ( TEST2(sp) != TWO_DOUBLES )
                    cast2_to_d(sp) ;
            sp[0].dval = pow(sp[0].dval,sp[1].dval) ;
            break ;

        case _NOT :
        reswitch_1:
            switch( sp->type )
            { case C_NOINIT :
                    sp->dval = 1.0 ; break ;
              case C_DOUBLE :
                    sp->dval =  sp->dval ? 0.0 : 1.0 ;
                    break ;
              case C_STRING :
                    sp->dval = string(sp)->len ? 0.0 : 1.0 ;
                    free_STRING(string(sp)) ;
                    break ;
              case C_STRNUM : /* test as a number */
                    sp->dval = sp->dval ? 0.0 : 1.0 ;
                    free_STRING(string(sp)) ;
                    break ;
              case C_MBSTRN :
                    check_strnum(sp) ;
                    goto reswitch_1 ;
              default :
                    bozo("bad type on eval stack") ;
            }
            sp->type = C_DOUBLE ;
            break  ;

        case _TEST :
        reswitch_2:
            switch( sp->type )
            { case C_NOINIT :
                    sp->dval = 0.0 ; break ;
              case C_DOUBLE :
                    sp->dval = sp->dval ? 1.0 : 0.0 ;
                    break ;
              case C_STRING :
                    sp->dval  = string(sp)->len ? 1.0 : 0.0 ;
                    free_STRING(string(sp)) ;
                    break ;
              case C_STRNUM : /* test as a number */
                    sp->dval  = sp->dval ? 0.0 : 1.0 ;
                    free_STRING(string(sp)) ;
                    break ;
              case C_MBSTRN :
                    check_strnum(sp) ;
                    goto reswitch_2 ;
              default :
                    bozo("bad type on eval stack") ;
            }
            sp->type = C_DOUBLE ;
            break ;

        case _UMINUS :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            sp->dval = - sp->dval ;
            break ;

        case _UPLUS :  
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            break ;

        case _CAT :
            { unsigned len1, len2 ;
              char *str1, *str2 ;
              STRING *b ;
              
              sp-- ;
              if ( TEST2(sp) != TWO_STRINGS )
                    cast2_to_s(sp) ;
              str1 = string(sp)->str ;
              len1 = string(sp)->len ;
              str2 = string(sp+1)->str ;
              len2 = string(sp+1)->len ;

              b = new_STRING((char *)0, len1+len2) ;
              (void) memcpy(b->str, str1, len1) ;
              (void) memcpy(b->str + len1, str2, len2) ;
              free_STRING(string(sp)) ;
              free_STRING( string(sp+1) ) ;

              sp->ptr = (PTR) b ;
              break ;
            }

        case _PUSHINT :
            inc_sp() ;
            sp->type = cdp++ -> op ;
            break ;

        case _BUILTIN :
        case _PRINT :
            sp = (* (PF_CP) cdp++ -> ptr) (sp) ;
            break ;

        case _POST_INC :
            (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval += 1.0 ;
            break ;

        case _POST_DEC :
            (void) cellcpy(sp, cp = (CELL *)sp->ptr) ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            cp->dval -= 1.0 ;
            break ;

        case _PRE_INC :
            cp = (CELL *) sp->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            sp->dval = cp->dval += 1.0 ;
            sp->type = C_DOUBLE ;
            break ;

        case _PRE_DEC :
            cp = (CELL *) sp->ptr ;
            if ( cp->type != C_DOUBLE ) cast1_to_d(cp) ;
            sp->dval = cp->dval -= 1.0 ;
            sp->type = C_DOUBLE ;
            break ;


        case F_POST_INC  :
            cp = (CELL *) sp->ptr ;
            (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
            cast1_to_d(&tc) ;
            tc.dval += 1.0 ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_POST_DEC  :
            cp = (CELL *) sp->ptr ;
            (void) cellcpy(sp, cellcpy(&tc, cp) ) ;
            cast1_to_d(&tc) ;
            tc.dval -= 1.0 ;
            field_assign(cp-field, &tc) ;
            break ;

        case F_PRE_INC :
            cp = (CELL *) sp->ptr ;
            cast1_to_d(cellcpy(&tc, cp)) ;
            sp->dval = tc.dval += 1.0 ;
            sp->type = C_DOUBLE ;
            field_assign(cp-field, sp) ;
            break ;

        case F_PRE_DEC :
            cp = (CELL *) sp->ptr ;
            cast1_to_d(cellcpy(&tc, cp)) ;
            sp->dval = tc.dval -= 1.0 ;
            sp->type = C_DOUBLE ;
            field_assign(cp-field, sp) ;
            break ;

        case _JMP  :
            cdp += cdp->op - 1 ;
            break ;

        case _JNZ  :
            /* jmp if top of stack is non-zero and pop stack */
            if ( test( sp ) )
                cdp += cdp->op - 1 ;
            else  cdp++ ;
            cell_destroy(sp) ;
            sp-- ;
            break ;

        case _JZ  :
            /* jmp if top of stack is zero and pop stack */
            if ( ! test( sp ) )
                cdp += cdp->op - 1 ;
            else  cdp++ ;
            cell_destroy(sp) ;
            sp-- ;
            break ;

    /*  the relation operations */
    /*  compare() makes sure string ref counts are OK */
        case  _EQ :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t == 0 ? 1.0 : 0.0 ;
            break ;

        case  _NEQ :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t ? 1.0 : 0.0 ;
            break ;

        case  _LT :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t < 0 ? 1.0 : 0.0 ;
            break ;

        case  _LTE :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t <= 0 ? 1.0 : 0.0 ;
            break ;

        case  _GT :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t > 0 ? 1.0 : 0.0 ;
            break ;

        case  _GTE :
            t = compare(--sp) ;
            sp->type = C_DOUBLE ;
            sp->dval = t >= 0 ? 1.0 : 0.0 ;
            break ;

        case  _MATCH :
            /* does sp[-1] match sp[0] as re */
            if ( sp->type != C_RE )  cast_to_RE(sp) ;

            if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;
            t = REtest(string(sp)->str, (sp+1)->ptr) ; 

            free_STRING(string(sp)) ;
            sp->type = C_DOUBLE ;
            sp->dval = t ? 1.0 : 0.0 ;
            break ;

        case  A_TEST :
        /* entry :  sp[0].ptr-> an array
                    sp[-1]  is an expression

           we compute   expression in array  */
            if ( (--sp)->type < C_STRING ) cast1_to_s(sp) ;
            t = array_test( (sp+1)->ptr, string(sp)) ;
            free_STRING(string(sp)) ;
            sp->type = C_DOUBLE ;
            sp->dval = t ? 1.0 : 0.0 ;
            break ;

        case  A_DEL :
        /* sp[0].ptr ->  array)
           sp[-1] is an expr
           delete  array[expr]  */

            cast1_to_s(--sp) ;
            array_delete( sp[1].ptr , sp->ptr) ;
            free_STRING( string(sp) ) ;
            sp-- ;
            break ;
        
        /* form a multiple array index */
        case A_CAT :
            sp = array_cat(sp, cdp++->op) ;
            break ;

        case  _EXIT0 :
            longjmp( exit_jump, 1) ;

        case  _EXIT  :
            if ( sp->type != C_DOUBLE ) cast1_to_d(sp) ;
            exit_code = (int) sp->dval ;
            longjmp( exit_jump, 1) ;

        case  _NEXT :
            longjmp(next_jump, 1) ;

        case  _RANGE :
/* test a range pattern:  pat1, pat2 { action }
   entry :
       cdp[0].op -- a flag, test pat1 if on else pat2
       cdp[1].op -- offset of pat2 code from cdp
       cdp[2].op -- offset of action code from cdp
       cdp[3].op -- offset of code after the action from cdp
       cdp[4] -- start of pat1 code
*/

#define FLAG    cdp[0].op
#define PAT2    cdp[1].op
#define ACTION    cdp[2].op
#define FOLLOW    cdp[3].op
#define PAT1      4

            if ( FLAG )  /* test again pat1 */
            { 
              (void) execute(cdp + PAT1,sp, fp) ;
              t = test(sp+1) ;
              cell_destroy(sp+1) ;
              if ( t )  FLAG = 0 ;
              else
              { cdp += FOLLOW ;
                break ;  /* break the switch */
              }
            }

            /* test against pat2 and then perform the action */
            (void) execute(cdp + PAT2, sp, fp) ;
            FLAG  = test(sp+1) ;
            cell_destroy(sp+1) ; 
            cdp += ACTION ;
            break ;

/* function calls  */

      case  _RET0  :
            inc_sp() ;
            sp->type = C_NOINIT ;
            /* fall thru */

      case  _RET   :

#ifdef  DEBUG
            if ( sp != entry_sp+1 ) bozo("ret") ;
#endif
            returning = 1 ;
            return  cdp-1 ;

      case  _CALL  :

            { FBLOCK *fbp = (FBLOCK*) cdp++->ptr ;
              int a_args = cdp++->op ; /* actual number of args */
              CELL *nfp = sp - a_args + 1 ; /* new fp for callee */
              CELL *local_p = sp+1; /* first local argument on stack */
              char *type_p ;  /* pts to type of an argument */

              if ( fbp->nargs ) type_p = fbp->typev + a_args ;

              /* create space for locals */
              if ( t = fbp->nargs - a_args ) /* have local args */
              {
                if ( sp + t >= eval_stack + EVAL_STACK_SIZE - SAFETY )
                   eval_overflow() ;

                while ( t-- )  
                { (++sp)->type = C_NOINIT ;
                  if ( *type_p++ == ST_LOCAL_ARRAY )
                        sp->ptr = (PTR) new_ARRAY() ;
                }
              }
              type_p-- ; /* *type_p is type of last arg */ 

              (void) execute(fbp->code, sp, nfp) ;
#ifdef  DEBUG
if ( !returning )  bozo("call") ;
#endif
              returning = 0 ;

              /* cleanup the callee's arguments */
              if ( sp >= nfp ) 
              {
                cp = sp+1 ;  /* cp -> the function return */

                do
                {
                  if ( *type_p-- == ST_LOCAL_ARRAY )
                  {  if ( sp >= local_p ) array_free(sp->ptr) ; }
                  else  cell_destroy(sp) ;

                } while ( --sp >= nfp ) ;
                    
                (void) cellcpy(++sp, cp) ;
                cell_destroy(cp) ;
              }
              else  sp++ ; /* no arguments passed */
            }
            break ;

        default :
            bozo("bad opcode") ;
    }
}

int test( cp )  /* test if a cell is null or not */
  register CELL *cp ;
{ 
reswitch :

  switch ( cp->type )
  {
    case C_NOINIT :  return  0 ;
    case C_STRNUM :  /* test as a number */
    case C_DOUBLE :  return  cp->dval != 0.0 ;
    case C_STRING :  return  string(cp)->len ;
    case C_MBSTRN :  check_strnum(cp) ; goto reswitch ;

    default :
      bozo("bad cell type in call to test") ;
  }
}

/* compare cells at cp and cp+1 and
   frees STRINGs at those cells
*/

static int compare(cp)
  register CELL *cp ;
{ int k ;

reswitch :

  switch( TEST2(cp) )
  { case TWO_NOINITS :  return 0 ; 
    
    case TWO_DOUBLES :
    two_d:
            return  cp->dval > (cp+1)->dval ? 1 :
                    cp->dval < (cp+1)->dval ? -1 : 0 ;
    
    case TWO_STRINGS :
    case STRING_AND_STRNUM :
    two_s:
            k = strcmp(string(cp)->str, string(cp+1)->str) ;
            free_STRING( string(cp) ) ;
            free_STRING( string(cp+1) ) ;
            return k ;

    case  NOINIT_AND_DOUBLE  :
    case  NOINIT_AND_STRNUM  :
    case  DOUBLE_AND_STRNUM  :
    case TWO_STRNUMS :
            cast2_to_d(cp) ; goto two_d ;

    case  NOINIT_AND_STRING  :
    case  DOUBLE_AND_STRING  :
            cast2_to_s(cp) ; goto two_s ;

    case  TWO_MBSTRNS :
            check_strnum(cp) ; check_strnum(cp+1) ;
            goto reswitch ;

    case  NOINIT_AND_MBSTRN :
    case  DOUBLE_AND_MBSTRN :
    case  STRING_AND_MBSTRN :
    case  STRNUM_AND_MBSTRN :
            check_strnum( cp->type == C_MBSTRN ? cp : cp+1 ) ;
            goto reswitch ;

    default :  /* there are no default cases */
            bozo("bad cell type passed to compare") ;
  }
}

/* does not assume target was a cell, if so
   then caller should have made a previous
   call to cell_destroy  */

CELL *cellcpy(target, source)
  register CELL *target, *source ;
{ switch( target->type = source->type )
  { case C_NOINIT : 
    case C_SPACE  : 
    case C_SNULL  :
            break ;

    case C_DOUBLE :
            target->dval = source->dval ;
            break ;

    case C_STRNUM :
            target->dval = source->dval ;
            /* fall thru */

    case C_REPL    :
    case C_MBSTRN  :
    case C_STRING  :
            string(source)->ref_cnt++ ;
            /* fall thru */

    case C_RE  :
            target->ptr = source->ptr ;
            break ;

    case  C_REPLV :
            (void)  replv_cpy(target, source) ;
            break ;

    default :
            bozo("bad cell passed to cellcpy()") ;
            break ;
  }
  return  target ;
}

#ifdef   DEBUG

void  DB_cell_destroy(cp)    /* HANGOVER time */
  register CELL *cp ;
{
  switch( cp->type )
  { case C_NOINIT :
    case C_DOUBLE :  break ;

    case C_MBSTRN :
    case C_STRING :
    case C_STRNUM :
            if ( -- string(cp)->ref_cnt == 0 )
                zfree(string(cp) , string(cp)->len+5) ;
            break ;

    case  C_RE :
            bozo("cell destroy called on RE cell") ;
    default :
            bozo("cell destroy called on bad cell type") ;
  }
}

#endif
@//E*O*F mawk0.97/execute.c//
chmod u=rw,g=r,o=r mawk0.97/execute.c
 
echo x - mawk0.97/fcall.c
sed 's/^@//' > "mawk0.97/fcall.c" <<'@//E*O*F mawk0.97/fcall.c//'

/********************************************
fcall.c
copyright 1991, Michael D. Brennan

This is a source file for mawk, an implementation of
the Awk programming language as defined in
Aho, Kernighan and Weinberger, The AWK Programming Language,
Addison-Wesley, 1988.

See the accompaning file, LIMITATIONS, for restrictions
regarding modification and redistribution of this
program in source or binary form.
********************************************/


/*$Log:	fcall.c,v $
 * Revision 2.1  91/04/08  08:22:59  brennan
 * VERSION 0.97
 * 
*/

#include "mawk.h"
#include "symtype.h"
#include "code.h"

/* This file has functions involved with type checking of
   function calls
*/

static  FCALL_REC *PROTO(first_pass, (FCALL_REC *) ) ;
static  CA_REC    *PROTO(call_arg_check, (FBLOCK *, CA_REC *,
        INST *, unsigned) ) ;
static  int PROTO(arg_cnt_ok, (FBLOCK *,CA_REC *, unsigned) ) ;


static int check_progress ;
    /* flag that indicates call_arg_check() was able to type
       check some call arguments */

/* type checks a list of call arguments,
   returns a list of arguments whose type is still unknown
*/
static CA_REC *call_arg_check( callee, entry_list , start,  line_no)
  FBLOCK *callee ;
  CA_REC *entry_list  ;  
  INST  *start ; /* to locate patch */
  unsigned line_no ; /* for error messages */
{ register CA_REC *q ;
  CA_REC *exit_list  = (CA_REC *) 0 ;

  check_progress = 0 ;

  /* loop :
       take q off entry_list
       test it
           if OK  zfree(q)  else put on exit_list
  */
     
  while ( q = entry_list )
  {
    entry_list = q->link ;

    if ( q->type == ST_NONE )
    { /* try to infer the type */
      /* it might now be in symbol table */
      if ( q->sym_p->type == ST_VAR )
      { /* set type and patch */
        q->type = CA_EXPR ;
        start[q->call_offset+1].ptr  = (PTR) q->sym_p->stval.cp ;
      }
      else
      if ( q->sym_p->type == ST_ARRAY )
      { q->type = CA_ARRAY ;
        start[q->call_offset].op = A_PUSHA ;
        start[q->call_offset+1].ptr = (PTR) q->sym_p->stval.array ;
      } 
      else /* try to infer from callee */
      {
        switch( callee->typev[q->arg_num] )
        {
          case  ST_LOCAL_VAR :
                q->type = CA_EXPR ;
                q->sym_p->type = ST_VAR ;
                q->sym_p->stval.cp = new_CELL() ;
                q->sym_p->stval.cp->type = C_NOINIT ;
                start[q->call_offset+1].ptr  = 
                         (PTR) q->sym_p->stval.cp ;
                break ;

          case  ST_LOCAL_ARRAY :
                q->type = CA_ARRAY ;
                q->sym_p->type = ST_ARRAY ;
                q->sym_p->stval.array = new_ARRAY() ;
                start[q->call_offset].op = A_PUSHA ;
                start[q->call_offset+1].ptr = 
                      (PTR) q->sym_p->stval.array ;
                break ;
        }
      }
    }
    else
    if ( q->type == ST_LOCAL_NONE )
    { /* try to infer the type */
      if ( * q->type_p == ST_LOCAL_VAR )
      { /* set type , don't need to patch */
        q->type = CA_EXPR ;
      }
      else
      if ( * q->type_p == ST_LOCAL_ARRAY )
      { q->type = CA_ARRAY ;
        start[q->call_offset].op = LA_PUSHA ;
        /* offset+1 op is OK */
      } 
      else /* try to infer from callee */
      {
        switch( callee->typev[q->arg_num] )
        {
          case  ST_LOCAL_VAR :
                q->type = CA_EXPR ;
                * q->type_p = ST_LOCAL_VAR ;
                /* do not need to patch */
                break ;

          case  ST_LOCAL_ARRAY :
                q->type = CA_ARRAY ;
                * q->type_p = ST_LOCAL_ARRAY ;
                start[q->call_offset].op = LA_PUSHA ;
                break ;
        }
      }
    }

    /* if we still do not know the type put on the new list
       else type check */

    if ( q->type == ST_NONE || q->type == ST_LOCAL_NONE )
    {
      q->link = exit_list ;
      exit_list = q ;
    }
    else  /* type known */
    {
      if ( callee->typev[q->arg_num] == ST_LOCAL_NONE )
           callee->typev[q->arg_num] = q->type ;

      else
      if ( q->type != callee->typev[q->arg_num] )
      {
        errmsg(0, "line %u: type error in arg(%d) in call to %s",
          line_no, q->arg_num+1, callee->name) ;
        if ( ++compile_error_count == MAX_COMPILE_ERRORS )
                    mawk_exit(1) ;
      }

      zfree(q, sizeof(CA_REC)) ;
      check_progress = 1 ;
    }
  } /* while */

  return  exit_list ;
}


static  int  arg_cnt_ok( fbp, q, line_no )
  FBLOCK  *fbp ;
  CA_REC  *q ;
  unsigned line_no ;
{
  if ( q->arg_num  >= fbp->nargs )
  {
    errmsg(0, "line %u: too many arguments in call to %s" ,
       line_no, fbp->name ) ;
    if ( ++compile_error_count == MAX_COMPILE_ERRORS ) 
              mawk_exit(1) ;

    return  0 ;
  }
  else  return 1 ;
}


FCALL_REC  *resolve_list ;
        /* function calls whose arg types need checking 
           are stored on this list */


/* on first pass thru the resolve list
   we check :
      if forward referenced functions were really defined
      if right number of arguments
   and compute call_start which is now known
*/

static  FCALL_REC *first_pass( p )
  register FCALL_REC *p ;
{ FCALL_REC dummy ;



More information about the Alt.sources mailing list