home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / m / mawk11as.zip / BI_FUNCT.C < prev    next >
C/C++ Source or Header  |  1991-12-18  |  20KB  |  867 lines
  1.  
  2. /********************************************
  3. bi_funct.c
  4. copyright 1991, Michael D. Brennan
  5.  
  6. This is a source file for mawk, an implementation of
  7. the AWK programming language.
  8.  
  9. Mawk is distributed without warranty under the terms of
  10. the GNU General Public License, version 2, 1991.
  11. ********************************************/
  12.  
  13. /* $Log:    bi_funct.c,v $
  14.  * Revision 5.1  91/12/05  07:55:35  brennan
  15.  * 1.1 pre-release
  16.  * 
  17. */
  18.  
  19.  
  20. #include "mawk.h"
  21. #include "bi_funct.h"
  22. #include "bi_vars.h"
  23. #include "memory.h"
  24. #include "init.h"
  25. #include "files.h"
  26. #include "fin.h"
  27. #include "field.h"
  28. #include "regexp.h"
  29. #include "repl.h"
  30. #include <math.h>
  31.  
  32.  
  33. /* statics */
  34. static STRING *PROTO(gsub, (PTR, CELL *, char *, int) ) ;
  35. static void  PROTO( fplib_err, (char *, double, char *) ) ;
  36.  
  37.  
  38. /* global for the disassembler */
  39. BI_REC  bi_funct[] = { /* info to load builtins */
  40.  
  41. "index" , bi_index , 2, 2 ,
  42. "substr" , bi_substr, 2, 3,
  43. "length" , bi_length, 0, 1,
  44. "sprintf" , bi_sprintf, 1, 255,
  45. "sin", bi_sin , 1, 1 ,
  46. "cos", bi_cos , 1, 1 ,
  47. "atan2", bi_atan2, 2,2,
  48. "exp", bi_exp, 1, 1,
  49. "log", bi_log , 1, 1 ,
  50. "int", bi_int, 1, 1,
  51. "sqrt", bi_sqrt, 1, 1,
  52. "rand" , bi_rand, 0, 0,
  53. "srand", bi_srand, 0, 1,
  54. "close", bi_close, 1, 1,
  55. "system", bi_system, 1, 1,
  56. "toupper", bi_toupper, 1, 1,
  57. "tolower", bi_tolower, 1, 1,
  58.  
  59. (char *) 0, (PF_CP) 0, 0, 0 } ;
  60.  
  61.  
  62.  
  63. void bi_funct_init()
  64. { register BI_REC *p = bi_funct ;
  65.   register SYMTAB *stp ;
  66.  
  67.   while ( p->name )
  68.   { stp = insert( p->name ) ;
  69.     stp->type = ST_BUILTIN ;
  70.     stp->stval.bip = p++ ;
  71.   }
  72.   /* seed rand() off the clock */
  73.   { CELL c ;
  74.  
  75.     c.type = 0 ; (void) bi_srand(&c) ;
  76.   }
  77.  
  78. }
  79.  
  80. /**************************************************
  81.  string builtins (except split (in split.c) and [g]sub (at end))
  82.  **************************************************/
  83.  
  84. CELL *bi_length(sp)
  85.   register  CELL *sp ;
  86. { unsigned len ;
  87.  
  88.   if ( sp->type == 0 )  cellcpy(sp, field) ;
  89.   else sp-- ;
  90.  
  91.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  92.   len = string(sp)->len ;
  93.  
  94.   free_STRING( string(sp) ) ;
  95.   sp->type = C_DOUBLE ;
  96.   sp->dval = (double) len ;
  97.  
  98.   return sp ;
  99. }
  100.  
  101. char *str_str(target, key , key_len)
  102.   register char *target, *key ;
  103.   unsigned key_len ;
  104. { 
  105.   switch( key_len )
  106.   { case 0 :  return (char *) 0 ;
  107.     case 1 :  return strchr( target, *key) ;
  108.     case 2 :
  109.         while ( target = strchr(target, *key) )
  110.           if ( target[1] == key[1] )  return  target ;
  111.           else target++ ;
  112.         /*failed*/
  113.         return (char *) 0 ;
  114.   }
  115.   key_len-- ;
  116.   while ( target = strchr(target, *key) )
  117.         if ( memcmp(target+1, key+1, SIZE_T(key_len)) == 0 ) return target ;
  118.         else target++ ;
  119.   /*failed*/
  120.   return (char *) 0 ;
  121. }
  122.  
  123.  
  124.  
  125. CELL *bi_index(sp)
  126.   register CELL *sp ;
  127. { register int idx ;
  128.   unsigned len ;
  129.   char *p ;
  130.  
  131.   sp-- ;
  132.   if ( TEST2(sp) != TWO_STRINGS )
  133.         cast2_to_s(sp) ;
  134.  
  135.   if ( len = string(sp+1)->len )
  136.     idx = (p = str_str(string(sp)->str,string(sp+1)->str,len))
  137.           ? p - string(sp)->str + 1 : 0 ;
  138.  
  139.   else  /* index of the empty string */
  140.     idx = 1 ;
  141.   
  142.   free_STRING( string(sp) ) ;
  143.   free_STRING( string(sp+1) ) ;
  144.   sp->type = C_DOUBLE ;
  145.   sp->dval = (double) idx ;
  146.   return sp ;
  147. }
  148.  
  149. /*  substr(s, i, n)
  150.     if l = length(s)
  151.     then get the characters
  152.     from  max(1,i) to min(l,n-i-1) inclusive */
  153.  
  154. CELL *bi_substr(sp)
  155.   CELL *sp ;
  156. { int n_args, len ;
  157.   register int i, n ;
  158.   STRING *sval ;  /* substr(sval->str, i, n) */
  159.  
  160.   n_args = sp->type ;
  161.   sp -= n_args ;
  162.   if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  163.       /* don't use < C_STRING shortcut */
  164.   sval = string(sp) ;
  165.  
  166.   if ( (len = sval->len) == 0 )  /* substr on null string */
  167.   {  if ( n_args == 3 )  cell_destroy(sp+2) ;
  168.      cell_destroy(sp+1) ;
  169.      return sp ;
  170.   }
  171.  
  172.   if ( n_args == 2 )  
  173.   { n = MAX__INT  ;  
  174.     if ( sp[1].type != C_DOUBLE ) cast1_to_d(sp+1) ; 
  175.   }
  176.   else
  177.   { if ( TEST2(sp+1) != TWO_DOUBLES ) cast2_to_d(sp+1) ;
  178.     n = (int) sp[2].dval ;
  179.   }
  180.   i = (int) sp[1].dval - 1 ; /* i now indexes into string */
  181.  
  182.   if ( i < 0 ) { n += i ; i = 0 ; }
  183.   if ( n > len - i )  n = len - i ;
  184.  
  185.   if ( n <= 0 )  /* the null string */
  186.   { 
  187.     sp->ptr = (PTR) &null_str ;
  188.     null_str.ref_cnt++ ;
  189.   }
  190.   else  /* got something */
  191.   { 
  192.     sp->ptr = (PTR) new_STRING((char *)0, n) ;
  193.     (void) memcpy(string(sp)->str, sval->str + i, SIZE_T(n)) ;
  194.   }
  195.  
  196.   free_STRING(sval) ;
  197.   return sp ;
  198. } 
  199.  
  200. /*
  201.   match(s,r)
  202.   sp[0] holds r, sp[-1] holds s
  203. */
  204.  
  205. CELL *bi_match(sp)
  206.   register CELL *sp ;
  207. { 
  208.   char *p ;
  209.   unsigned length ;
  210.  
  211.   if ( sp->type != C_RE )  cast_to_RE(sp) ;
  212.   if ( (--sp)->type < C_STRING )  cast1_to_s(sp) ;
  213.  
  214.   cell_destroy(RSTART) ;
  215.   cell_destroy(RLENGTH) ;
  216.   RSTART->type = C_DOUBLE ;
  217.   RLENGTH->type = C_DOUBLE ;
  218.  
  219.   p = REmatch(string(sp)->str, (sp+1)->ptr, &length) ;
  220.  
  221.   if ( p )
  222.   { sp->dval = (double) ( p - string(sp)->str + 1 ) ;
  223.     RLENGTH->dval = (double) length ;
  224.   }
  225.   else
  226.   { sp->dval = 0.0 ;
  227.     RLENGTH->dval = -1.0 ; /* posix */
  228.   }
  229.  
  230.   free_STRING(string(sp)) ;
  231.   sp->type = C_DOUBLE ;
  232.  
  233.   RSTART->dval = sp->dval ;
  234.  
  235.   return sp ;
  236. }
  237.  
  238. CELL *bi_toupper(sp)
  239.   CELL *sp ;
  240. { STRING *old ;
  241.   register char *p, *q ;
  242.  
  243.   if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  244.   old = string(sp) ;
  245.   sp->ptr = (PTR) new_STRING((char *) 0, old->len) ;
  246.  
  247.   q = string(sp)->str ; p = old->str ;
  248.  
  249.   while ( *p )
  250.   {
  251.     *q = *p++ ;
  252.     if ( *q >= 'a' && *q <= 'z' )  *q += 'A' - 'a' ;
  253.     q++ ;
  254.   }
  255.   free_STRING(old) ;
  256.   return sp ;
  257. }
  258.  
  259. CELL *bi_tolower(sp)
  260.   CELL *sp ;
  261. { STRING *old ;
  262.   register char *p, *q ;
  263.  
  264.   if ( sp->type != C_STRING )  cast1_to_s(sp) ;
  265.   old = string(sp) ;
  266.   sp->ptr = (PTR) new_STRING((char *) 0, old->len) ;
  267.  
  268.   q = string(sp)->str ; p = old->str ;
  269.  
  270.   while ( *p )
  271.   {
  272.     *q = *p++ ;
  273.     if ( *q >= 'A' && *q <= 'Z' )  *q += 'a' - 'A' ;
  274.     q++ ;
  275.   }
  276.   free_STRING(old) ;
  277.   return sp ;
  278. }
  279.  
  280.  
  281. /************************************************
  282.   arithemetic builtins
  283.  ************************************************/
  284.  
  285. static void fplib_err( fname, val, error)
  286.   char *fname ;
  287.   double val ;
  288.   char *error ;
  289. {
  290.   rt_error("%s(%g) : %s" , fname, val, error) ;
  291. }
  292.  
  293.  
  294. CELL *bi_sin(sp)
  295.   register CELL *sp ;
  296. { 
  297. #if ! STDC_MATHERR
  298.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  299.   sp->dval = sin( sp->dval ) ;
  300.   return sp ;
  301. #else
  302.   double x ;
  303.  
  304.   errno = 0 ;
  305.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  306.   x = sp->dval ;
  307.   sp->dval = sin( sp->dval ) ;
  308.   if ( errno )  fplib_err("sin", x, "loss of precision") ;
  309.   return sp ;
  310. #endif
  311. }
  312.  
  313. CELL *bi_cos(sp)
  314.   register CELL *sp ;
  315. { 
  316. #if ! STDC_MATHERR
  317.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  318.   sp->dval = cos( sp->dval ) ;
  319.   return sp ;
  320. #else
  321.   double x ;
  322.  
  323.   errno = 0 ;
  324.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  325.   x = sp->dval ;
  326.   sp->dval = cos( sp->dval ) ;
  327.   if ( errno )  fplib_err("cos", x, "loss of precision") ;
  328.   return sp ;
  329. #endif
  330. }
  331.  
  332. CELL *bi_atan2(sp)
  333.   register CELL *sp ;
  334. { 
  335. #if  !  STDC_MATHERR
  336.   sp-- ;
  337.   if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  338.   sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  339.   return sp ;
  340. #else
  341.  
  342.   errno = 0 ;
  343.   sp-- ;
  344.   if ( TEST2(sp) != TWO_DOUBLES ) cast2_to_d(sp) ;
  345.   sp->dval = atan2(sp->dval, (sp+1)->dval) ;
  346.   if ( errno ) rt_error("atan2(0,0) : domain error") ;
  347.   return sp ;
  348. #endif
  349. }
  350.  
  351. CELL *bi_log(sp)
  352.   register CELL *sp ;
  353. { 
  354. #if ! STDC_MATHERR
  355.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  356.   sp->dval = log( sp->dval ) ;
  357.   return sp ;
  358. #else
  359.   double  x ;
  360.  
  361.   errno = 0 ;
  362.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  363.   x = sp->dval ;
  364.   sp->dval = log( sp->dval ) ;
  365.   if ( errno )  fplib_err("log", x, "domain error") ;
  366.   return sp ;
  367. #endif
  368. }
  369.  
  370. CELL *bi_exp(sp)
  371.   register CELL *sp ;
  372. { 
  373. #if  ! STDC_MATHERR
  374.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  375.   sp->dval = exp(sp->dval) ;
  376.   return sp ;
  377. #else
  378.   double  x ;
  379.  
  380.   errno = 0 ;
  381.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  382.   x = sp->dval ;
  383.   sp->dval = exp(sp->dval) ;
  384.   if ( errno && sp->dval)  fplib_err("exp", x, "overflow") ;
  385.      /* on underflow sp->dval==0, ignore */
  386.   return sp ;
  387. #endif
  388. }
  389.  
  390. CELL *bi_int(sp)
  391.   register CELL *sp ;
  392. { if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  393.   sp->dval = sp->dval >= 0.0 ? floor( sp->dval ) : ceil(sp->dval)  ;
  394.   return sp ;
  395. }
  396.  
  397. CELL *bi_sqrt(sp)
  398.   register CELL *sp ;
  399. { 
  400. #if  ! STDC_MATHERR
  401.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  402.   sp->dval = sqrt( sp->dval ) ;
  403.   return sp ;
  404. #else
  405.   double x ;
  406.  
  407.   errno = 0 ;
  408.   if ( sp->type != C_DOUBLE )  cast1_to_d(sp) ;
  409.   x = sp->dval ;
  410.   sp->dval = sqrt( sp->dval ) ;
  411.   if ( errno )  fplib_err("sqrt", x, "domain error") ;
  412.   return sp ;
  413. #endif
  414. }
  415.  
  416. #ifdef  __TURBOC__
  417. long  biostime(int, long) ;
  418. #define  time(x)  biostime(0,0L)
  419. #else
  420. #ifdef THINK_C
  421. #include <time.h>
  422. #else
  423. #include <sys/types.h>
  424. #endif
  425. #endif
  426.  
  427.  
  428. /* For portability, we'll use our own random number generator , taken
  429.    from:  Park, SK and Miller KW, "Random Number Generators:
  430.    Good Ones are Hard to Find", CACM, 31, 1192-1201, 1988.
  431. */
  432.  
  433. static long seed ;  /* must be >=1 and <= 2^31-1 */
  434. static CELL cseed ; /* argument of last call to srand() */
  435.  
  436. #define         M       0x7fffffff   /* 2^31-1 */
  437.  
  438. CELL *bi_srand(sp)
  439.   register CELL *sp ;
  440. { CELL c ;
  441.  
  442.   if ( sp->type == 0 ) /* seed off clock */
  443.   { (void) cellcpy(sp, &cseed) ;
  444.     cell_destroy(&cseed) ;
  445.     cseed.type = C_DOUBLE ;
  446.     cseed.dval = (double) time((time_t*) 0) ;
  447.   }
  448.   else /* user seed */
  449.   { sp-- ;
  450.     /* swap cseed and *sp ; don't need to adjust ref_cnts */
  451.     c = *sp ; *sp = cseed ; cseed = c ;
  452.   }
  453.  
  454.   /* The old seed is now in *sp ; move the value in cseed to
  455.      seed in range 1 to M */
  456.  
  457.   (void) cellcpy(&c, &cseed) ;
  458.   if ( c.type == C_NOINIT )  cast1_to_d(&c) ;
  459.  
  460.   seed =  c.type == C_DOUBLE ? ((int)c.dval & M) % M + 1 :
  461.                         hash(string(&c)->str) % M + 1 ;
  462.  
  463.   cell_destroy(&c) ;
  464.  
  465.   /* crank it once so close seeds don't give a close 
  466.        first result  */
  467. #define   A     16807
  468. #define   Q     127773   /* M/A */
  469. #define   R     2836     /* M%A */
  470.   seed = A * (seed%Q) - R * (seed/Q) ;
  471.   if ( seed <= 0 )  seed += M ;
  472.  
  473.   return sp ;
  474. }
  475.     
  476. CELL *bi_rand(sp)
  477.   register CELL *sp ;
  478. { 
  479.   register long test ;
  480.  
  481.   test = A * (seed%Q) - R * (seed/Q) ;
  482.   if ( test <= 0 )  test += M ;
  483.  
  484.   (++sp)->type = C_DOUBLE ;
  485.   sp->dval = (double)( seed = test ) / (double) M ;
  486.   return sp ;
  487.  
  488. #undef   A
  489. #undef   M
  490. #undef   Q
  491. #undef   R
  492. }
  493.  
  494. /*************************************************
  495.  miscellaneous builtins
  496.  close, system and getline
  497.  *************************************************/
  498.  
  499. CELL *bi_close(sp)
  500.   register CELL *sp ;
  501. { int x ;
  502.  
  503.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  504.   x = file_close( (STRING *) sp->ptr) ;
  505.   free_STRING( string(sp) ) ;
  506.   sp->type = C_DOUBLE ;
  507.   sp->dval = (double) x ;
  508.   return sp ;
  509. }
  510.  
  511. #if   HAVE_REAL_PIPES
  512.  
  513. CELL *bi_system(sp)
  514.   CELL *sp ;
  515. { int pid ;
  516.   unsigned ret_val ;
  517.  
  518.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  519.  
  520.   fflush(stdout) ; fflush(stderr) ;
  521.  
  522.   switch( pid = fork() )
  523.   { case -1 :  /* fork failed */
  524.  
  525.        errmsg(errno, "could not create a new process") ;
  526.        ret_val = 127 ;
  527.        break ;
  528.  
  529.     case  0  :  /* the child */
  530.        (void) execl(shell, shell, "-c", string(sp)->str, (char *) 0) ;
  531.        /* if get here, execl() failed */
  532.        errmsg(errno, "execute of %s failed", shell) ;
  533.        fflush(stderr) ;
  534.        _exit(127) ;
  535.  
  536.     default   :  /* wait for the child */
  537.        ret_val = wait_for(pid) ;
  538.        break ;
  539.   }
  540.  
  541.   cell_destroy(sp) ;
  542.   sp->type = C_DOUBLE ;
  543.   sp->dval = (double) ret_val ;
  544.   return sp ;
  545. }
  546.  
  547. #endif /* HAVE_REAL_PIPES */
  548.  
  549. #ifdef  THINK_C
  550.  
  551. CELL *bi_system( sp )
  552.   register CELL *sp ;
  553. { rt_error("no system call for the Macintosh Toy Operating System!!!") ;
  554.   return sp ;
  555. }
  556.  
  557. #endif
  558.  
  559.  
  560. #if   MSDOS
  561.  
  562.  
  563. CELL *bi_system( sp )
  564.   register CELL *sp ;
  565. { int retval ;
  566.  
  567.   if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  568.   retval = DOSexec(string(sp)->str) ;
  569.   free_STRING(string(sp)) ;
  570.   sp->type = C_DOUBLE ;
  571.   sp->dval = (double) retval ;
  572.   return sp ;
  573. }
  574.  
  575. #endif
  576.  
  577.  
  578. /*  getline()  */
  579.  
  580. /*  if type == 0 :  stack is 0 , target address
  581.  
  582.     if type == F_IN : stack is F_IN, expr(filename), target address
  583.  
  584.     if type == PIPE_IN : stack is PIPE_IN, target address, expr(pipename)
  585. */
  586.  
  587. CELL *bi_getline(sp)
  588.   register CELL *sp ;
  589. { 
  590.   CELL tc , *cp ;
  591.   char *p ;
  592.   unsigned len ;
  593.   FIN *fin_p ;
  594.  
  595.  
  596.   switch( sp->type )
  597.   { 
  598.     case 0 :
  599.         sp-- ;
  600.         if ( ! main_fin )  open_main() ;
  601.     
  602.         if ( ! (p = FINgets(main_fin, &len)) )
  603.                 goto  eof ;
  604.  
  605.         cp = (CELL *) sp->ptr ;
  606.         if ( TEST2(NR) != TWO_DOUBLES ) cast2_to_d(NR) ;
  607.         NR->dval += 1.0 ;
  608.         FNR->dval += 1.0 ;
  609.         break ;
  610.  
  611.     case  F_IN :
  612.         sp-- ;
  613.         if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  614.         fin_p = (FIN *) file_find(sp->ptr, F_IN) ;
  615.         free_STRING(string(sp) ) ;
  616.         sp-- ;
  617.  
  618.         if ( ! fin_p )   goto open_failure ;
  619.         if ( ! (p = FINgets(fin_p, &len)) )  
  620.         {
  621.           FINsemi_close(fin_p) ;
  622.           goto eof ; 
  623.         }
  624.         cp = (CELL *) sp->ptr ;
  625.         break ;
  626.  
  627.     case PIPE_IN :
  628.         sp -= 2 ;
  629.         if ( sp->type < C_STRING ) cast1_to_s(sp) ;
  630.         fin_p = (FIN *) file_find(sp->ptr, PIPE_IN) ;
  631.         free_STRING(string(sp)) ;
  632.  
  633.         if ( ! fin_p )   goto open_failure ;
  634.         if ( ! (p = FINgets(fin_p, &len)) ) 
  635.         { 
  636.           FINsemi_close(fin_p) ;
  637. #if  HAVE_REAL_PIPES
  638.           /* reclaim process slot */
  639.           (void) wait_for(0) ;
  640. #endif
  641.           goto eof ; 
  642.         }
  643.         cp = (CELL *) (sp+1)->ptr ;
  644.         break ;
  645.  
  646.     default : bozo("type in bi_getline") ;
  647.  
  648.   }
  649.  
  650.   /* we've read a line , store it */
  651.  
  652.     if ( len == 0 )
  653.     { tc.type = C_STRING ; 
  654.       tc.ptr = (PTR) &null_str ; 
  655.       null_str.ref_cnt++ ;
  656.     }
  657.     else
  658.     { tc.type = C_MBSTRN ;
  659.       tc.ptr = (PTR) new_STRING((char *) 0, len) ;
  660.       (void) memcpy( string(&tc)->str, p, SIZE_T(len)) ;
  661.     }
  662.  
  663.     slow_cell_assign(cp, &tc) ;
  664.  
  665.     cell_destroy(&tc) ;
  666.  
  667.   sp->dval = 1.0  ;  goto done ;
  668.  
  669. open_failure :
  670.   sp->dval = -1.0  ; goto done ;
  671.  
  672. eof :
  673.   sp->dval = 0.0  ;  /* fall thru to done  */
  674.  
  675. done :
  676.   sp->type = C_DOUBLE  ;
  677.   return sp ;
  678. }
  679.  
  680. /**********************************************
  681.  sub() and gsub()
  682.  **********************************************/
  683.  
  684. /* entry:  sp[0] = address of CELL to sub on
  685.            sp[-1] = substitution CELL
  686.            sp[-2] = regular expression to match
  687. */
  688.  
  689. CELL *bi_sub( sp )
  690.   register CELL *sp ;
  691. { CELL *cp ; /* pointer to the replacement target */
  692.   CELL tc ;  /* build the new string here */
  693.   CELL sc ;  /* copy of the target CELL */
  694.   char *front, *middle, *back ; /* pieces */
  695.   unsigned front_len, middle_len, back_len ;
  696.  
  697.   sp -= 2 ;
  698.   if ( sp->type != C_RE )  cast_to_RE(sp) ;
  699.   if ( sp[1].type != C_REPL && sp[1].type != C_REPLV )
  700.               cast_to_REPL(sp+1) ;
  701.   cp = (CELL *) (sp+2)->ptr ;
  702.   /* make a copy of the target, because we won't change anything
  703.      including type unless the match works */
  704.   (void) cellcpy(&sc, cp) ;
  705.   if ( sc.type < C_STRING ) cast1_to_s(&sc) ;
  706.   front = string(&sc)->str ;
  707.  
  708.   if ( middle = REmatch(front, sp->ptr, &middle_len) )
  709.   { 
  710.     front_len = middle - front ;
  711.     back = middle + middle_len ; 
  712.     back_len = string(&sc)->len - front_len - middle_len ;
  713.  
  714.     if ( (sp+1)->type == C_REPLV ) 
  715.     { STRING *sval = new_STRING((char *) 0, middle_len) ;
  716.  
  717.       (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
  718.       (void) replv_to_repl(sp+1, sval) ;
  719.       free_STRING(sval) ;
  720.     }
  721.  
  722.     tc.type = C_STRING ;
  723.     tc.ptr = (PTR) new_STRING((char *) 0, 
  724.              front_len + string(sp+1)->len + back_len ) ;
  725.  
  726.     { char *p = string(&tc)->str ;
  727.  
  728.       if ( front_len )
  729.       { (void) memcpy(p, front, SIZE_T(front_len)) ;
  730.         p += front_len ;
  731.       }
  732.       if ( string(sp+1)->len )
  733.       { (void) memcpy(p, string(sp+1)->str, SIZE_T(string(sp+1)->len)) ;
  734.         p += string(sp+1)->len ;
  735.       }
  736.       if ( back_len )  (void) memcpy(p, back, SIZE_T(back_len)) ;
  737.     }
  738.  
  739.     slow_cell_assign(cp, &tc) ;
  740.  
  741.     free_STRING(string(&tc)) ;
  742.   }
  743.  
  744.   free_STRING(string(&sc)) ;
  745.   repl_destroy(sp+1) ;
  746.   sp->type = C_DOUBLE ;
  747.   sp->dval = middle != (char *) 0 ? 1.0 : 0.0 ;
  748.   return sp ;
  749. }
  750.  
  751. static  unsigned repl_cnt ;  /* number of global replacements */
  752.  
  753. /* recursive global subsitution 
  754.    dealing with empty matches makes this mildly painful
  755. */
  756.  
  757. static STRING *gsub( re, repl, target, flag)
  758.   PTR  re ;
  759.   CELL *repl ;  /* always of type REPL or REPLV, 
  760.        destroyed by caller */
  761.   char *target ;
  762.   int flag ; /* if on, match of empty string at front is OK */
  763. { char *front, *middle ;
  764.   STRING *back ;
  765.   unsigned front_len, middle_len ;
  766.   STRING  *ret_val ;
  767.   CELL xrepl ; /* a copy of repl so we can change repl */
  768.  
  769.   if ( ! (middle = REmatch(target, re, &middle_len)) )
  770.       return  new_STRING(target) ; /* no match */
  771.  
  772.   (void) cellcpy(&xrepl, repl) ;
  773.  
  774.   if ( !flag && middle_len == 0 && middle == target ) 
  775.   { /* match at front that's not allowed */
  776.  
  777.     if ( *target == 0 )  /* target is empty string */
  778.     { repl_destroy(&xrepl) ;
  779.       null_str.ref_cnt++ ;
  780.       return & null_str ;
  781.     }
  782.     else
  783.     { char xbuff[2] ;
  784.  
  785.       front_len = 0 ;
  786.       /* make new repl with target[0] */
  787.       repl_destroy(repl) ;
  788.       xbuff[0] = *target++ ;  xbuff[1] = 0 ;
  789.       repl->type = C_REPL ;
  790.       repl->ptr = (PTR) new_STRING( xbuff ) ;
  791.       back = gsub(re, &xrepl, target, 1) ;
  792.     }
  793.   }
  794.   else  /* a match that counts */
  795.   { repl_cnt++ ;
  796.  
  797.     front = target ;
  798.     front_len = middle - target ;
  799.  
  800.     if ( *middle == 0 )  /* matched back of target */
  801.     { back = &null_str ; null_str.ref_cnt++ ; }
  802.     else back = gsub(re, &xrepl, middle + middle_len, 0) ;
  803.       
  804.     /* patch the &'s if needed */
  805.     if ( repl->type == C_REPLV )
  806.     { STRING *sval = new_STRING((char *) 0, middle_len) ;
  807.  
  808.       (void) memcpy(sval->str, middle, SIZE_T(middle_len)) ;
  809.       (void) replv_to_repl(repl, sval) ;
  810.       free_STRING(sval) ;
  811.     }
  812.   }
  813.  
  814.   /* put the three pieces together */
  815.   ret_val = new_STRING((char *)0,
  816.               front_len + string(repl)->len + back->len); 
  817.   { char *p = ret_val->str ;
  818.  
  819.     if ( front_len )
  820.     { (void) memcpy(p, front, SIZE_T(front_len)) ; p += front_len ; }
  821.     if ( string(repl)->len )
  822.     { (void) memcpy(p, string(repl)->str, SIZE_T(string(repl)->len)) ;
  823.       p += string(repl)->len ;
  824.     }
  825.     if ( back->len ) (void) memcpy(p, back->str, SIZE_T(back->len)) ;
  826.   }
  827.  
  828.   /* cleanup, repl is freed by the caller */
  829.   repl_destroy(&xrepl) ;
  830.   free_STRING(back) ;
  831.  
  832.   return ret_val ;
  833. }
  834.  
  835. /* set up for call to gsub() */
  836. CELL *bi_gsub( sp )
  837.   register CELL *sp ;
  838. { CELL *cp ;  /* pts at the replacement target */
  839.   CELL sc  ;  /* copy of replacement target */
  840.   CELL tc  ;  /* build the result here */
  841.  
  842.   sp -= 2 ;
  843.   if ( sp->type != C_RE ) cast_to_RE(sp) ;
  844.   if ( (sp+1)->type != C_REPL && (sp+1)->type != C_REPLV )
  845.           cast_to_REPL(sp+1) ;
  846.  
  847.   (void) cellcpy(&sc, cp = (CELL *)(sp+2)->ptr) ;
  848.   if ( sc.type < C_STRING ) cast1_to_s(&sc) ;
  849.  
  850.   repl_cnt = 0 ;
  851.   tc.ptr = (PTR) gsub(sp->ptr, sp+1, string(&sc)->str, 1) ;
  852.  
  853.   if ( repl_cnt )
  854.   { 
  855.     tc.type = C_STRING ;
  856.     slow_cell_assign(cp, &tc) ;
  857.   }
  858.  
  859.   /* cleanup */
  860.   free_STRING(string(&sc)) ; free_STRING(string(&tc)) ;
  861.   repl_destroy(sp+1) ;
  862.  
  863.   sp->type = C_DOUBLE ;
  864.   sp->dval = (double) repl_cnt ;
  865.   return sp ;
  866. }
  867.