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