2 /********************************************
4 copyright 1991, Michael D. Brennan
6 This is a source file for mawk, an implementation of
7 the AWK programming language.
9 Mawk is distributed without warranty under the terms of
10 the GNU General Public License, version 2, 1991.
11 ********************************************/
13 /* $Log: bi_funct.c,v $
14 * Revision 1.9 1996/01/14 17:16:11 mike
15 * flush_all_output() before system()
17 * Revision 1.8 1995/08/27 18:13:03 mike
18 * fix random number generator to work with longs larger than 32bits
20 * Revision 1.7 1995/06/09 22:53:30 mike
21 * change a memcmp() to strncmp() to make purify happy
23 * Revision 1.6 1994/12/13 00:26:32 mike
24 * rt_nr and rt_fnr for run-time error messages
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.
30 * Revision 1.4 1994/12/10 21:44:12 mike
33 * Revision 1.3 1993/07/14 11:46:36 mike
36 * Revision 1.2 1993/07/14 01:22:27 mike
39 * Revision 1.1.1.1 1993/07/03 18:58:08 mike
42 * Revision 5.5 1993/02/13 21:57:18 mike
45 * Revision 5.4 1993/01/01 21:30:48 mike
46 * split new_STRING() into new_STRING and new_STRING0
48 * Revision 5.3.1.2 1993/01/27 01:04:06 mike
49 * minor tuning to str_str()
51 * Revision 5.3.1.1 1993/01/15 03:33:35 mike
52 * patch3: safer double to int conversion
54 * Revision 5.3 1992/12/17 02:48:01 mike
55 * 1.1.2d changes for DOS
57 * Revision 5.2 1992/07/08 15:43:41 brennan
58 * patch2: length returns. I am a wimp
60 * Revision 5.1 1991/12/05 07:55:35 brennan
80 static STRING *PROTO(gsub, (PTR, CELL *, char *, int)) ;
81 static void PROTO(fplib_err, (char *, double, char *)) ;
83 /* global for the disassembler */
85 { /* info to load builtins */
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},
106 {(char *) 0, (PF_CP) 0, 0, 0}} ;
109 /* load built-in functions in symbol table */
114 register SYMTAB *stp ;
116 /* length is special (posix bozo) */
117 stp = insert(bi_funct->name) ;
118 stp->type = ST_LENGTH ;
119 stp->stval.bip = bi_funct ;
121 for (p = bi_funct + 1; p->name; p++)
123 stp = insert(p->name) ;
124 stp->type = ST_BUILTIN ;
128 /* seed rand() off the clock */
132 c.type = 0 ; bi_srand(&c) ;
137 /**************************************************
138 string builtins (except split (in split.c) and [g]sub (at end))
139 **************************************************/
147 if (sp->type == 0) cellcpy(sp, field) ;
150 if (sp->type < C_STRING) cast1_to_s(sp) ;
151 len = string(sp)->len ;
153 free_STRING(string(sp)) ;
154 sp->type = C_DOUBLE ;
155 sp->dval = (double) len ;
161 str_str(target, key, key_len)
162 register char *target ;
166 register int k = key[0] ;
173 return strchr(target, k) ;
177 while ((target = strchr(target, k)))
178 if (target[1] == k1) return target ;
186 while ((target = strchr(target, k)))
188 if (strncmp(target + 1, key + 1, key_len) == 0) return target ;
206 if (TEST2(sp) != TWO_STRINGS) cast2_to_s(sp) ;
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 ;
212 else /* index of the empty string */
215 free_STRING(string(sp)) ;
216 free_STRING(string(sp + 1)) ;
217 sp->type = C_DOUBLE ;
218 sp->dval = (double) idx ;
223 if l = length(s) then get the characters
224 from max(1,i) to min(l,n-i-1) inclusive */
232 STRING *sval ; /* substr(sval->str, i, n) */
236 if (sp->type != C_STRING) cast1_to_s(sp) ;
237 /* don't use < C_STRING shortcut */
240 if ((len = sval->len) == 0) /* substr on null string */
242 if (n_args == 3) { cell_destroy(sp + 2) ; }
243 cell_destroy(sp + 1) ;
250 if (sp[1].type != C_DOUBLE) cast1_to_d(sp + 1) ;
254 if (TEST2(sp + 1) != TWO_DOUBLES) cast2_to_d(sp + 1) ;
255 n = d_to_i(sp[2].dval) ;
257 i = d_to_i(sp[1].dval) - 1 ; /* i now indexes into string */
259 if ( i < 0 ) { n += i ; i = 0 ; }
260 if (n > len - i) n = len - i ;
262 if (n <= 0) /* the null string */
264 sp->ptr = (PTR) & null_str ;
267 else /* got something */
269 sp->ptr = (PTR) new_STRING0(n) ;
270 memcpy(string(sp)->str, sval->str + i, n) ;
279 sp[0] holds r, sp[-1] holds s
289 if (sp->type != C_RE) cast_to_RE(sp) ;
290 if ((--sp)->type < C_STRING) cast1_to_s(sp) ;
292 cell_destroy(RSTART) ;
293 cell_destroy(RLENGTH) ;
294 RSTART->type = C_DOUBLE ;
295 RLENGTH->type = C_DOUBLE ;
297 p = REmatch(string(sp)->str, (sp + 1)->ptr, &length) ;
301 sp->dval = (double) (p - string(sp)->str + 1) ;
302 RLENGTH->dval = (double) length ;
307 RLENGTH->dval = -1.0 ; /* posix */
310 free_STRING(string(sp)) ;
311 sp->type = C_DOUBLE ;
313 RSTART->dval = sp->dval ;
323 register char *p, *q ;
325 if (sp->type != C_STRING) cast1_to_s(sp) ;
327 sp->ptr = (PTR) new_STRING0(old->len) ;
329 q = string(sp)->str ; p = old->str ;
333 if (*q >= 'a' && *q <= 'z') *q += 'A' - 'a' ;
345 register char *p, *q ;
347 if (sp->type != C_STRING) cast1_to_s(sp) ;
349 sp->ptr = (PTR) new_STRING0(old->len) ;
351 q = string(sp)->str ; p = old->str ;
355 if (*q >= 'A' && *q <= 'Z') *q += 'a' - 'A' ;
363 /************************************************
365 ************************************************/
368 fplib_err(fname, val, error)
373 rt_error("%s(%g) : %s", fname, val, error) ;
382 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
383 sp->dval = sin(sp->dval) ;
389 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
391 sp->dval = sin(sp->dval) ;
392 if (errno) fplib_err("sin", x, "loss of precision") ;
402 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
403 sp->dval = cos(sp->dval) ;
409 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
411 sp->dval = cos(sp->dval) ;
412 if (errno) fplib_err("cos", x, "loss of precision") ;
423 if (TEST2(sp) != TWO_DOUBLES) cast2_to_d(sp) ;
424 sp->dval = atan2(sp->dval, (sp + 1)->dval) ;
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") ;
442 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
443 sp->dval = log(sp->dval) ;
449 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
451 sp->dval = log(sp->dval) ;
452 if (errno) fplib_err("log", x, "domain error") ;
462 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
463 sp->dval = exp(sp->dval) ;
469 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
471 sp->dval = exp(sp->dval) ;
472 if (errno && sp->dval) fplib_err("exp", x, "overflow") ;
473 /* on underflow sp->dval==0, ignore */
482 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
483 sp->dval = sp->dval >= 0.0 ? floor(sp->dval) : ceil(sp->dval) ;
492 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
493 sp->dval = sqrt(sp->dval) ;
499 if (sp->type != C_DOUBLE) cast1_to_d(sp) ;
501 sp->dval = sqrt(sp->dval) ;
502 if (errno) fplib_err("sqrt", x, "domain error") ;
510 #include <sys/types.h>
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.
519 static long seed ; /* must be >=1 and < 2^31-1 */
520 static CELL cseed ; /* argument of last call to srand() */
522 #define M 0x7fffffff /* 2^31-1 */
523 #define MX 0xffffffff
525 #define Q 127773 /* M/A */
526 #define R 2836 /* M%A */
529 #define crank(s) s = A * (s % Q) - R * (s / Q) ;\
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 ;\
547 if (sp->type == 0) /* seed off clock */
549 cellcpy(sp, &cseed) ;
550 cell_destroy(&cseed) ;
551 cseed.type = C_DOUBLE ;
552 cseed.dval = (double) time((time_t *) 0) ;
557 /* swap cseed and *sp ; don't need to adjust ref_cnts */
558 c = *sp ; *sp = cseed ; cseed = c ;
561 /* The old seed is now in *sp ; move the value in cseed to
562 seed in range [1,M) */
564 cellcpy(&c, &cseed) ;
565 if (c.type == C_NOINIT) cast1_to_d(&c) ;
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 ;
573 /* crank it once so close seeds don't give a close
586 sp->type = C_DOUBLE ;
587 sp->dval = (double) seed / (double) M ;
597 /*************************************************
598 miscellaneous builtins
599 close, system and getline
601 *************************************************/
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 ;
624 if ( sp->type == 0 ) fflush(stdout) ;
628 if ( sp->type < C_STRING ) cast1_to_s(sp) ;
629 ret = file_flush(string(sp)) ;
630 free_STRING(string(sp)) ;
633 sp->type = C_DOUBLE ;
634 sp->dval = (double) ret ;
649 if (sp->type < C_STRING) cast1_to_s(sp) ;
652 switch (pid = fork())
654 case -1: /* fork failed */
656 errmsg(errno, "could not create a new process") ;
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) ;
667 default: /* wait for the child */
668 ret_val = wait_for(pid) ;
673 sp->type = C_DOUBLE ;
674 sp->dval = (double) ret_val ;
678 #endif /* HAVE_REAL_PIPES */
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 ;
704 /* if type == 0 : stack is 0 , target address
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)
724 if (!main_fin) open_main() ;
726 if (!(p = FINgets(main_fin, &len))) goto eof ;
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++ ;
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)) ;
741 if (!fin_p) goto open_failure ;
742 if (!(p = FINgets(fin_p, &len)))
744 FINsemi_close(fin_p) ;
747 cp = (CELL *) sp->ptr ;
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)) ;
756 if (!fin_p) goto open_failure ;
757 if (!(p = FINgets(fin_p, &len)))
759 FINsemi_close(fin_p) ;
761 /* reclaim process slot */
766 cp = (CELL *) (sp + 1)->ptr ;
770 bozo("type in bi_getline") ;
774 /* we've read a line , store it */
779 tc.ptr = (PTR) & null_str ;
785 tc.ptr = (PTR) new_STRING0(len) ;
786 memcpy(string(&tc)->str, p, len) ;
789 slow_cell_assign(cp, &tc) ;
793 sp->dval = 1.0 ; goto done ;
795 sp->dval = -1.0 ; goto done ;
797 sp->dval = 0.0 ; /* fall thru to done */
799 done:sp->type = C_DOUBLE;
803 /**********************************************
805 **********************************************/
807 /* entry: sp[0] = address of CELL to sub on
808 sp[-1] = substitution CELL
809 sp[-2] = regular expression to match
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 ;
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 */
830 if (sc.type < C_STRING) cast1_to_s(&sc) ;
831 front = string(&sc)->str ;
833 if ((middle = REmatch(front, sp->ptr, &middle_len)))
835 front_len = middle - front ;
836 back = middle + middle_len ;
837 back_len = string(&sc)->len - front_len - middle_len ;
839 if ((sp + 1)->type == C_REPLV)
841 STRING *sval = new_STRING0(middle_len) ;
843 memcpy(sval->str, middle, middle_len) ;
844 replv_to_repl(sp + 1, sval) ;
849 tc.ptr = (PTR) new_STRING0(
850 front_len + string(sp + 1)->len + back_len) ;
853 char *p = string(&tc)->str ;
857 memcpy(p, front, front_len) ;
860 if (string(sp + 1)->len)
862 memcpy(p, string(sp + 1)->str, string(sp + 1)->len) ;
863 p += string(sp + 1)->len ;
865 if (back_len) memcpy(p, back, back_len) ;
868 slow_cell_assign(cp, &tc) ;
870 free_STRING(string(&tc)) ;
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 ;
880 static unsigned repl_cnt ; /* number of global replacements */
882 /* recursive global subsitution
883 dealing with empty matches makes this mildly painful
887 gsub(re, repl, target, flag)
889 CELL *repl ; /* always of type REPL or REPLV,
890 destroyed by caller */
893 /* if on, match of empty string at front is OK */
896 char *front, *middle ;
898 unsigned front_len, middle_len ;
900 CELL xrepl ; /* a copy of repl so we can change repl */
902 if (!(middle = REmatch(target, re, &middle_len)))
903 return new_STRING(target) ;/* no match */
905 cellcpy(&xrepl, repl) ;
907 if (!flag && middle_len == 0 && middle == target)
908 { /* match at front that's not allowed */
910 if (*target == 0) /* target is empty string */
912 repl_destroy(&xrepl) ;
921 /* make new repl with target[0] */
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) ;
929 else /* a match that counts */
934 front_len = middle - target ;
936 if (*middle == 0) /* matched back of target */
941 else back = gsub(re, &xrepl, middle + middle_len, 0) ;
943 /* patch the &'s if needed */
944 if (repl->type == C_REPLV)
946 STRING *sval = new_STRING0(middle_len) ;
948 memcpy(sval->str, middle, middle_len) ;
949 replv_to_repl(repl, sval) ;
954 /* put the three pieces together */
955 ret_val = new_STRING0(front_len + string(repl)->len + back->len) ;
957 char *p = ret_val->str ;
961 memcpy(p, front, front_len) ;
965 if (string(repl)->len)
967 memcpy(p, string(repl)->str, string(repl)->len) ;
968 p += string(repl)->len ;
970 if (back->len) memcpy(p, back->str, back->len) ;
973 /* cleanup, repl is freed by the caller */
974 repl_destroy(&xrepl) ;
980 /* set up for call to gsub() */
985 CELL *cp ; /* pts at the replacement target */
986 CELL sc ; /* copy of replacement target */
987 CELL tc ; /* build the result here */
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) ;
994 cellcpy(&sc, cp = (CELL *) (sp + 2)->ptr) ;
995 if (sc.type < C_STRING) cast1_to_s(&sc) ;
998 tc.ptr = (PTR) gsub(sp->ptr, sp + 1, string(&sc)->str, 1) ;
1002 tc.type = C_STRING ;
1003 slow_cell_assign(cp, &tc) ;
1007 free_STRING(string(&sc)) ; free_STRING(string(&tc)) ;
1008 repl_destroy(sp + 1) ;
1010 sp->type = C_DOUBLE ;
1011 sp->dval = (double) repl_cnt ;