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