bi_funct.c

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