386BSD 0.1 development

[unix-history] / usr / src / usr.bin / awk / bi_funct.c

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

This is a source file for mawk, an implementation of
the AWK programming language.

Mawk is distributed without warranty under the terms of
the GNU General Public License, version 2, 1991.
********************************************/

/* $Log:	bi_funct.c,v $
 * Revision 5.1  91/12/05  07:55:35  brennan
 * 1.1 pre-release
 * 
*/


#include "mawk.h"
#include "bi_funct.h"
#include "bi_vars.h"
#include "memory.h"
#include "init.h"
#include "files.h"
#include "fin.h"
#include "field.h"
#include "regexp.h"
#include "repl.h"
#include <math.h>


/* statics */
static STRING *PROTO(gsub, (PTR, CELL *, char *, int) ) ;
static void  PROTO( fplib_err, (char *, double, char *) ) ;


/* global for the disassembler */
BI_REC  bi_funct[] = { /* info to load builtins */

"index" , bi_index , 2, 2 ,
"substr" , bi_substr, 2, 3,
"length" , bi_length, 0, 1,
"sprintf" , bi_sprintf, 1, 255,
"sin", bi_sin , 1, 1 ,
"cos", bi_cos , 1, 1 ,
"atan2", bi_atan2, 2,2,
"exp", bi_exp, 1, 1,
"log", bi_log , 1, 1 ,
"int", bi_int, 1, 1,
"sqrt", bi_sqrt, 1, 1,
"rand" , bi_rand, 0, 0,
"srand", bi_srand, 0, 1,
"close", bi_close, 1, 1,
"system", bi_system, 1, 1,
"toupper", bi_toupper, 1, 1,
"tolower", bi_tolower, 1, 1,

(char *) 0, (PF_CP) 0, 0, 0 } ;



void bi_funct_init()
{ register BI_REC *p = bi_funct ;
  register SYMTAB *stp ;

  while ( p->name )
  { stp = insert( p->name ) ;
    stp->type = ST_BUILTIN ;
    stp->stval.bip = p++ ;
  }
  /* seed rand() off the clock */
  { CELL c ;

    c.type = 0 ; (void) bi_srand(&c) ;
  }

}

/**************************************************
 string builtins (except split (in split.c) and [g]sub (at end))
 **************************************************/

CELL *bi_length(sp)
  register  CELL *sp ;
{ unsigned len ;

  if ( sp->type == 0 )  cellcpy(sp, field) ;
  else sp-- ;

  if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  len = string(sp)->len ;

  free_STRING( string(sp) ) ;
  sp->type = C_DOUBLE ;
  sp->dval = (double) len ;

  return sp ;
}

char *str_str(target, key , key_len)
  register char *target, *key ;
  unsigned key_len ;
{ 
  switch( key_len )
  { case 0 :  return (char *) 0 ;
    case 1 :  return strchr( target, *key) ;
    case 2 :
        while ( target = strchr(target, *key) )
          if ( target[1] == key[1] )  return  target ;
          else target++ ;
        /*failed*/
        return (char *) 0 ;
  }
  key_len-- ;
  while ( target = strchr(target, *key) )
        if ( memcmp(target+1, key+1, SIZE_T(key_len)) == 0 ) return target ;
        else target++ ;
  /*failed*/
  return (char *) 0 ;
}



CELL *bi_index(sp)
  register CELL *sp ;
{ register int idx ;
  unsigned len ;
  char *p ;

  sp-- ;
  if ( TEST2(sp) != TWO_STRINGS )
        cast2_to_s(sp) ;

  if ( len = string(sp+1)->len )
    idx = (p = str_str(string(sp)->str,string(sp+1)->str,len))
          ? p - string(sp)->str + 1 : 0 ;

  else  /* index of the empty string */
    idx = 1 ;
  
  free_STRING( string(sp) ) ;
  free_STRING( string(sp+1) ) ;
  sp->type = C_DOUBLE ;
  sp->dval = (double) idx ;
  return sp ;
}

/*  substr(s, i, n)
    if l = length(s)
    then get the characters
    from  max(1,i) to min(l,n-i-1) inclusive */

CELL *bi_substr(sp)
  CELL *sp ;
{ int n_args, len ;
  register int i, n ;
  STRING *sval ;  /* substr(sval->str, i, n) */

  n_args = sp->type ;
  sp -= n_args ;
  if ( sp->type != C_STRING )  cast1_to_s(sp) ;
      /* don't use < C_STRING shortcut */
  sval = string(sp) ;

  if ( (len = sval->len) == 0 )  /* substr on null string */
  {  if ( n_args == 3 )  cell_destroy(sp+2) ;
     cell_destroy(sp+1) ;
     return sp ;
  }

  if ( n_args == 2 )  
  { n = MAX__INT  ;  
    if ( sp[1].type != C_DOUBLE ) cast1_to_d(sp+1) ; 
  }
  else
  { if ( TEST2(sp+1) != TWO_DOUBLES ) cast2_to_d(sp+1) ;
    n = (int) sp[2].dval ;
  }
  i = (int) sp[1].dval - 1 ; /* i now indexes into string */

  if ( i < 0 ) { n += i ; i = 0 ; }
  if ( n > len - i )  n = len - i ;

  if ( n <= 0 )  /* the null string */
  { 
    sp->ptr = (PTR) &null_str ;
    null_str.ref_cnt++ ;
  }
  else  /* got something */
  { 
    sp->ptr = (PTR) new_STRING((char *)0, n) ;
    (void) memcpy(string(sp)->str, sval->str + i, SIZE_T(n)) ;
  }

  free_STRING(sval) ;
  return sp ;
} 

/*
  match(s,r)
  sp[0] holds r, sp[-1] holds s
*/

CELL *bi_match(sp)
  register CELL *sp ;
{ 
  char *p ;
  unsigned length ;

  if ( sp->type != C_RE )  cast_to_RE(sp) ;
  if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;

  cell_destroy(RSTART) ;
  cell_destroy(RLENGTH) ;
  RSTART->type = C_DOUBLE ;
  RLENGTH->type = C_DOUBLE ;

  p = REmatch(string(sp)->str, (sp+1)->ptr, &length) ;

  if ( p )
  { sp->dval = (double) ( p - string(sp)->str + 1 ) ;
    RLENGTH->dval = (double) length ;
  }
  else
  { sp->dval = 0.0 ;
    RLENGTH->dval = -1.0 ; /* posix */
  }

  free_STRING(string(sp)) ;
  sp->type = C_DOUBLE ;

  RSTART->dval = sp->dval ;

  return sp ;
}

CELL *bi_toupper(sp)
  CELL *sp ;
{ STRING *old ;
  register char *p, *q ;

  if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  old = string(sp) ;
  sp->ptr = (PTR) new_STRING((char *) 0, old->len) ;

  q = string(sp)->str ; p = old->str ;

  while ( *p )
  {
    *q = *p++ ;
    if ( *q >= 'a' && *q <= 'z' )  *q += 'A' - 'a' ;
    q++ ;
  }
  free_STRING(old) ;
  return sp ;
}

CELL *bi_tolower(sp)
  CELL *sp ;
{ STRING *old ;
  register char *p, *q ;

  if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  old = string(sp) ;
  sp->ptr = (PTR) new_STRING((char *) 0, old->len) ;

  q = string(sp)->str ; p = old->str ;

  while ( *p )
  {
    *q = *p++ ;
    if ( *q >= 'A' && *q <= 'Z' )  *q += 'a' - 'A' ;
    q++ ;
  }
  free_STRING(old) ;
  return sp ;
}


/************************************************
  arithemetic builtins
 ************************************************/

static void fplib_err( fname, val, error)
  char *fname ;
  double val ;
  char *error ;
{
  rt_error("%s(%g) : %s" , fname, val, error) ;
}


CELL *bi_sin(sp)
  register CELL *sp ;
{ 
#if ! STDC_MATHERR
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = sin( sp->dval ) ;
  return sp ;
#else
  double x ;

  errno = 0 ;
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  x = sp->dval ;
  sp->dval = sin( sp->dval ) ;
  if ( errno )  fplib_err("sin", x, "loss of precision") ;
  return sp ;
#endif
}

CELL *bi_cos(sp)
  register CELL *sp ;
{ 
#if ! STDC_MATHERR
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = cos( sp->dval ) ;
  return sp ;
#else
  double x ;

  errno = 0 ;
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  x = sp->dval ;
  sp->dval = cos( sp->dval ) ;
  if ( errno )  fplib_err("cos", x, "loss of precision") ;
  return sp ;
#endif
}

CELL *bi_atan2(sp)
  register CELL *sp ;
{ 
#if  !  STDC_MATHERR
  sp-- ;
  if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  return sp ;
#else

  errno = 0 ;
  sp-- ;
  if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  if ( errno ) rt_error("atan2(0,0) : domain error") ;
  return sp ;
#endif
}

CELL *bi_log(sp)
  register CELL *sp ;
{ 
#if ! STDC_MATHERR
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = log( sp->dval ) ;
  return sp ;
#else
  double  x ;

  errno = 0 ;
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  x = sp->dval ;
  sp->dval = log( sp->dval ) ;
  if ( errno )  fplib_err("log", x, "domain error") ;
  return sp ;
#endif
}

CELL *bi_exp(sp)
  register CELL *sp ;
{ 
#if  ! STDC_MATHERR
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = exp(sp->dval) ;
  return sp ;
#else
  double  x ;

  errno = 0 ;
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  x = sp->dval ;
  sp->dval = exp(sp->dval) ;
  if ( errno && sp->dval)  fplib_err("exp", x, "overflow") ;
     /* on underflow sp->dval==0, ignore */
  return sp ;
#endif
}

CELL *bi_int(sp)
  register CELL *sp ;
{ if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = sp->dval >= 0.0 ? floor( sp->dval ) : ceil(sp->dval)  ;
  return sp ;
}

CELL *bi_sqrt(sp)
  register CELL *sp ;
{ 
#if  ! STDC_MATHERR
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  sp->dval = sqrt( sp->dval ) ;
  return sp ;
#else
  double x ;

  errno = 0 ;
  if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  x = sp->dval ;
  sp->dval = sqrt( sp->dval ) ;
  if ( errno )  fplib_err("sqrt", x, "domain error") ;
  return sp ;
#endif
}

#ifdef  __TURBOC__
long  biostime(int, long) ;
#define  time(x)  biostime(0,0L)
#else
#ifdef THINK_C
#include <time.h>
#else
#include <sys/types.h>
#endif
#endif


/* For portability, we'll use our own random number generator , taken
   from:  Park, SK and Miller KW, "Random Number Generators:
   Good Ones are Hard to Find", CACM, 31, 1192-1201, 1988.
*/

static long seed ;  /* must be >=1 and <= 2^31-1 */
static CELL cseed ; /* argument of last call to srand() */

#define         M       0x7fffffff   /* 2^31-1 */

CELL *bi_srand(sp)
  register CELL *sp ;
{ CELL c ;

  if ( sp->type == 0 ) /* seed off clock */
  { (void) cellcpy(sp, &cseed) ;
    cell_destroy(&cseed) ;
    cseed.type = C_DOUBLE ;
    cseed.dval = (double) time((time_t*) 0) ;
  }
  else /* user seed */
  { sp-- ;
    /* swap cseed and *sp ; don't need to adjust ref_cnts */
    c = *sp ; *sp = cseed ; cseed = c ;
  }

  /* The old seed is now in *sp ; move the value in cseed to
     seed in range 1 to M */

  (void) cellcpy(&c, &cseed) ;
  if ( c.type == C_NOINIT )  cast1_to_d(&c) ;

  seed =  c.type == C_DOUBLE ? ((int)c.dval & M) % M + 1 :
                        hash(string(&c)->str) % M + 1 ;

  cell_destroy(&c) ;

  /* crank it once so close seeds don't give a close 
       first result  */
#define   A     16807
#define   Q     127773   /* M/A */
#define   R     2836     /* M%A */
  seed = A * (seed%Q) - R * (seed/Q) ;
  if ( seed <= 0 )  seed += M ;

  return sp ;
}
    
CELL *bi_rand(sp)
  register CELL *sp ;
{ 
  register long test ;

  test = A * (seed%Q) - R * (seed/Q) ;
  if ( test <= 0 )  test += M ;

  (++sp)->type = C_DOUBLE ;
  sp->dval = (double)( seed = test ) / (double) M ;
  return sp ;

#undef   A
#undef   M
#undef   Q
#undef   R
}

/*************************************************
 miscellaneous builtins
 close, system and getline
 *************************************************/

CELL *bi_close(sp)
  register CELL *sp ;
{ int x ;

  if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  x = file_close( (STRING *) sp->ptr) ;
  free_STRING( string(sp) ) ;
  sp->type = C_DOUBLE ;
  sp->dval = (double) x ;
  return sp ;
}

#if   HAVE_REAL_PIPES

CELL *bi_system(sp)
  CELL *sp ;
{ int pid ;
  unsigned ret_val ;

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

  fflush(stdout) ; fflush(stderr) ;

  switch( pid = fork() )
  { case -1 :  /* fork failed */

       errmsg(errno, "could not create a new process") ;
       ret_val = 127 ;
       break ;

    case  0  :  /* the child */
       (void) execl(shell, shell, "-c", string(sp)->str, (char *) 0) ;
       /* if get here, execl() failed */
       errmsg(errno, "execute of %s failed", shell) ;
       fflush(stderr) ;
       _exit(127) ;

    default   :  /* wait for the child */
       ret_val = wait_for(pid) ;
       break ;
  }

  cell_destroy(sp) ;
  sp->type = C_DOUBLE ;
  sp->dval = (double) ret_val ;
  return sp ;
}

#endif /* HAVE_REAL_PIPES */

#ifdef  THINK_C

CELL *bi_system( sp )
  register CELL *sp ;
{ rt_error("no system call for the Macintosh Toy Operating System!!!") ;
  return sp ;
}

#endif


#if   MSDOS


CELL *bi_system( sp )
  register CELL *sp ;
{ int retval ;

  if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  retval = DOSexec(string(sp)->str) ;
  free_STRING(string(sp)) ;
  sp->type = C_DOUBLE ;
  sp->dval = (double) retval ;
  return sp ;
}

#endif


/*  getline()  */

/*  if type == 0 :  stack is 0 , target address

    if type == F_IN : stack is F_IN, expr(filename), target address

    if type == PIPE_IN : stack is PIPE_IN, target address, expr(pipename)
*/

CELL *bi_getline(sp)
  register CELL *sp ;
{ 
  CELL tc , *cp ;
  char *p ;
  unsigned len ;
  FIN *fin_p ;


  switch( sp->type )
  { 
    case 0 :
        sp-- ;
        if ( ! main_fin )  open_main() ;
    
        if ( ! (p = FINgets(main_fin, &len)) )
                goto  eof ;

        cp = (CELL *) sp->ptr ;
        if ( TEST2(NR) != TWO_DOUBLES ) cast2_to_d(NR) ;
        NR->dval += 1.0 ;
        FNR->dval += 1.0 ;
        break ;

    case  F_IN :
        sp-- ;
        if ( sp->type < C_STRING ) cast1_to_s(sp) ;
        fin_p = (FIN *) file_find(sp->ptr, F_IN) ;
        free_STRING(string(sp) ) ;
        sp-- ;

        if ( ! fin_p )   goto open_failure ;
        if ( ! (p = FINgets(fin_p, &len)) )  
        {
          FINsemi_close(fin_p) ;
          goto eof ; 
        }
        cp = (CELL *) sp->ptr ;
        break ;

    case PIPE_IN :
        sp -= 2 ;
        if ( sp->type < C_STRING ) cast1_to_s(sp) ;
        fin_p = (FIN *) file_find(sp->ptr, PIPE_IN) ;
        free_STRING(string(sp)) ;

        if ( ! fin_p )   goto open_failure ;
        if ( ! (p = FINgets(fin_p, &len)) ) 
        { 
          FINsemi_close(fin_p) ;
#if  HAVE_REAL_PIPES
          /* reclaim process slot */
          (void) wait_for(0) ;
#endif
          goto eof ; 
        }
        cp = (CELL *) (sp+1)->ptr ;
        break ;

    default : bozo("type in bi_getline") ;

  }

  /* we've read a line , store it */

    if ( len == 0 )
    { tc.type = C_STRING ; 
      tc.ptr = (PTR) &null_str ; 
      null_str.ref_cnt++ ;
    }
    else
    { tc.type = C_MBSTRN ;
      tc.ptr = (PTR) new_STRING((char *) 0, len) ;
      (void) memcpy( string(&tc)->str, p, SIZE_T(len)) ;
    }

    slow_cell_assign(cp, &tc) ;

    cell_destroy(&tc) ;

  sp->dval = 1.0  ;  goto done ;

open_failure :
  sp->dval = -1.0  ; goto done ;

eof :
  sp->dval = 0.0  ;  /* fall thru to done  */

done :
  sp->type = C_DOUBLE  ;
  return sp ;
}

/**********************************************
 sub() and gsub()
 **********************************************/

/* entry:  sp[0] = address of CELL to sub on
           sp[-1] = substitution CELL
           sp[-2] = regular expression to match
*/

CELL *bi_sub( sp )
  register CELL *sp ;
{ CELL *cp ; /* pointer to the replacement target */
  CELL tc ;  /* build the new string here */
  CELL sc ;  /* copy of the target CELL */
  char *front, *middle, *back ; /* pieces */
  unsigned front_len, middle_len, back_len ;

  sp -= 2 ;
  if ( sp->type != C_RE )  cast_to_RE(sp) ;
  if ( sp[1].type != C_REPL && sp[1].type != C_REPLV )
              cast_to_REPL(sp+1) ;
  cp = (CELL *) (sp+2)->ptr ;
  /* make a copy of the target, because we won't change anything
     including type unless the match works */
  (void) cellcpy(&sc, cp) ;
  if ( sc.type < C_STRING ) cast1_to_s(&sc) ;
  front = string(&sc)->str ;

  if ( middle = REmatch(front, sp->ptr, &middle_len) )
  { 
    front_len = middle - front ;
    back = middle + middle_len ; 
    back_len = string(&sc)->len - front_len - middle_len ;

    if ( (sp+1)->type == C_REPLV ) 
    { STRING *sval = new_STRING((char *) 0, middle_len) ;

      (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
      (void) replv_to_repl(sp+1, sval) ;
      free_STRING(sval) ;
    }

    tc.type = C_STRING ;
    tc.ptr = (PTR) new_STRING((char *) 0, 
             front_len + string(sp+1)->len + back_len ) ;

    { char *p = string(&tc)->str ;

      if ( front_len )
      { (void) memcpy(p, front, SIZE_T(front_len)) ;
        p += front_len ;
      }
      if ( string(sp+1)->len )
      { (void) memcpy(p, string(sp+1)->str, SIZE_T(string(sp+1)->len)) ;
        p += string(sp+1)->len ;
      }
      if ( back_len )  (void) memcpy(p, back, SIZE_T(back_len)) ;
    }

    slow_cell_assign(cp, &tc) ;

    free_STRING(string(&tc)) ;
  }

  free_STRING(string(&sc)) ;
  repl_destroy(sp+1) ;
  sp->type = C_DOUBLE ;
  sp->dval = middle != (char *) 0 ? 1.0 : 0.0 ;
  return sp ;
}

static  unsigned repl_cnt ;  /* number of global replacements */

/* recursive global subsitution 
   dealing with empty matches makes this mildly painful
*/

static STRING *gsub( re, repl, target, flag)
  PTR  re ;
  CELL *repl ;  /* always of type REPL or REPLV, 
       destroyed by caller */
  char *target ;
  int flag ; /* if on, match of empty string at front is OK */
{ char *front, *middle ;
  STRING *back ;
  unsigned front_len, middle_len ;
  STRING  *ret_val ;
  CELL xrepl ; /* a copy of repl so we can change repl */

  if ( ! (middle = REmatch(target, re, &middle_len)) )
      return  new_STRING(target) ; /* no match */

  (void) cellcpy(&xrepl, repl) ;

  if ( !flag && middle_len == 0 && middle == target ) 
  { /* match at front that's not allowed */

    if ( *target == 0 )  /* target is empty string */
    { repl_destroy(&xrepl) ;
      null_str.ref_cnt++ ;
      return & null_str ;
    }
    else
    { char xbuff[2] ;

      front_len = 0 ;
      /* make new repl with target[0] */
      repl_destroy(repl) ;
      xbuff[0] = *target++ ;  xbuff[1] = 0 ;
      repl->type = C_REPL ;
      repl->ptr = (PTR) new_STRING( xbuff ) ;
      back = gsub(re, &xrepl, target, 1) ;
    }
  }
  else  /* a match that counts */
  { repl_cnt++ ;

    front = target ;
    front_len = middle - target ;

    if ( *middle == 0 )  /* matched back of target */
    { back = &null_str ; null_str.ref_cnt++ ; }
    else back = gsub(re, &xrepl, middle + middle_len, 0) ;
      
    /* patch the &'s if needed */
    if ( repl->type == C_REPLV )
    { STRING *sval = new_STRING((char *) 0, middle_len) ;

      (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
      (void) replv_to_repl(repl, sval) ;
      free_STRING(sval) ;
    }
  }

  /* put the three pieces together */
  ret_val = new_STRING((char *)0,
              front_len + string(repl)->len + back->len); 
  { char *p = ret_val->str ;

    if ( front_len )
    { (void) memcpy(p, front, SIZE_T(front_len)) ; p += front_len ; }
    if ( string(repl)->len )
    { (void) memcpy(p, string(repl)->str, SIZE_T(string(repl)->len)) ;
      p += string(repl)->len ;
    }
    if ( back->len ) (void) memcpy(p, back->str, SIZE_T(back->len)) ;
  }

  /* cleanup, repl is freed by the caller */
  repl_destroy(&xrepl) ;
  free_STRING(back) ;

  return ret_val ;
}

/* set up for call to gsub() */
CELL *bi_gsub( sp )
  register CELL *sp ;
{ CELL *cp ;  /* pts at the replacement target */
  CELL sc  ;  /* copy of replacement target */
  CELL tc  ;  /* build the result here */

  sp -= 2 ;
  if ( sp->type != C_RE ) cast_to_RE(sp) ;
  if ( (sp+1)->type != C_REPL && (sp+1)->type != C_REPLV )
          cast_to_REPL(sp+1) ;

  (void) cellcpy(&sc, cp = (CELL *)(sp+2)->ptr) ;
  if ( sc.type < C_STRING ) cast1_to_s(&sc) ;

  repl_cnt = 0 ;
  tc.ptr = (PTR) gsub(sp->ptr, sp+1, string(&sc)->str, 1) ;

  if ( repl_cnt )
  { 
    tc.type = C_STRING ;
    slow_cell_assign(cp, &tc) ;
  }

  /* cleanup */
  free_STRING(string(&sc)) ; free_STRING(string(&tc)) ;
  repl_destroy(sp+1) ;

  sp->type = C_DOUBLE ;
  sp->dval = (double) repl_cnt ;
  return sp ;
}