git.maemo.org Git - gnuplot/blob - src/internal.c

   1 #ifndef lint
   2 static char *RCSid() { return RCSid("$Id: internal.c,v 1.40.2.4 2008/09/25 19:50:57 sfeam Exp $"); }
   3 #endif
   4
   5 /* GNUPLOT - internal.c */
   6
   7 /*[
   8  * Copyright 1986 - 1993, 1998, 2004   Thomas Williams, Colin Kelley
   9  *
  10  * Permission to use, copy, and distribute this software and its
  11  * documentation for any purpose with or without fee is hereby granted,
  12  * provided that the above copyright notice appear in all copies and
  13  * that both that copyright notice and this permission notice appear
  14  * in supporting documentation.
  15  *
  16  * Permission to modify the software is granted, but not the right to
  17  * distribute the complete modified source code.  Modifications are to
  18  * be distributed as patches to the released version.  Permission to
  19  * distribute binaries produced by compiling modified sources is granted,
  20  * provided you
  21  *   1. distribute the corresponding source modifications from the
  22  *    released version in the form of a patch file along with the binaries,
  23  *   2. add special version identification to distinguish your version
  24  *    in addition to the base release version number,
  25  *   3. provide your name and address as the primary contact for the
  26  *    support of your modified version, and
  27  *   4. retain our contact information in regard to use of the base
  28  *    software.
  29  * Permission to distribute the released version of the source code along
  30  * with corresponding source modifications in the form of a patch file is
  31  * granted with same provisions 2 through 4 for binary distributions.
  32  *
  33  * This software is provided "as is" without express or implied warranty
  34  * to the extent permitted by applicable law.
  35 ]*/
  36
  37
  38 #include "internal.h"
  39
  40 #include "stdfn.h"
  41 #include "alloc.h"
  42 #include "util.h"               /* for int_error() */
  43 #ifdef GP_STRING_VARS
  44 # include "gp_time.h"           /* for str(p|f)time */
  45 #endif
  46 #include "command.h"            /* for do_system_func */
  47
  48 #include <math.h>
  49
  50 /*
  51  * Excerpt from the Solaris man page for matherr():
  52  *
  53  *   The The System V Interface Definition, Third Edition (SVID3)
  54  *   specifies  that  certain  libm functions call matherr() when
  55  *   exceptions are detected. Users may define their own  mechan-
  56  *   isms  for handling exceptions, by including a function named
  57  *   matherr() in their programs.
  58  */
  59
  60 #ifdef GP_STRING_VARS
  61 static enum DATA_TYPES sprintf_specifier __PROTO((const char *format));
  62 #endif
  63
  64
  65 int
  66 GP_MATHERR( STRUCT_EXCEPTION_P_X )
  67 {
  68 #if (defined(ATARI) || defined(MTOS)) && defined(__PUREC__)
  69     char *c;
  70     switch (e->type) {
  71     case DOMAIN:
  72         c = "domain error";
  73         break;
  74     case SING:
  75         c = "argument singularity";
  76         break;
  77     case OVERFLOW:
  78         c = "overflow range";
  79         break;
  80     case UNDERFLOW:
  81         c = "underflow range";
  82         break;
  83     default:
  84         c = "(unknown error)";
  85         break;
  86     }
  87     fprintf(stderr, "\
  88 math exception : %s\n\
  89     name : %s\n\
  90     arg 1: %e\n\
  91     arg 2: %e\n\
  92     ret  : %e\n",
  93             c,
  94             e->name,
  95             e->arg1,
  96             e->arg2,
  97             e->retval);
  98
  99     return 1;
 100 #else
 101     return (undefined = TRUE);  /* don't print error message */
 102 #endif
 103 }
 104
 105 #define BAD_DEFAULT default: int_error(NO_CARET, "internal error : type neither INT or CMPLX"); return;
 106
 107 void
 108 f_push(union argument *x)
 109 {
 110     struct udvt_entry *udv;
 111
 112     udv = x->udv_arg;
 113     if (udv->udv_undef) {       /* undefined */
 114         int_error(NO_CARET, "undefined variable: %s", udv->udv_name);
 115     }
 116     push(&(udv->udv_value));
 117 }
 118
 119 void
 120 f_pushc(union argument *x)
 121 {
 122     push(&(x->v_arg));
 123 }
 124
 125
 126 void
 127 f_pushd1(union argument *x)
 128 {
 129     push(&(x->udf_arg->dummy_values[0]));
 130 }
 131
 132
 133 void
 134 f_pushd2(union argument *x)
 135 {
 136     push(&(x->udf_arg->dummy_values[1]));
 137 }
 138
 139
 140 void
 141 f_pushd(union argument *x)
 142 {
 143     struct value param;
 144     (void) pop(&param);
 145     push(&(x->udf_arg->dummy_values[param.v.int_val]));
 146 }
 147
 148
 149 /* execute a udf */
 150 void
 151 f_call(union argument *x)
 152 {
 153     struct udft_entry *udf;
 154     struct value save_dummy;
 155
 156     udf = x->udf_arg;
 157     if (!udf->at) {             /* undefined */
 158         int_error(NO_CARET, "undefined function: %s", udf->udf_name);
 159     }
 160     save_dummy = udf->dummy_values[0];
 161     (void) pop(&(udf->dummy_values[0]));
 162
 163     if (udf->dummy_num != 1)
 164         int_error(NO_CARET, "function %s requires %d variables", udf->udf_name, udf->dummy_num);
 165
 166     execute_at(udf->at);
 167     gpfree_string(&udf->dummy_values[0]);
 168     udf->dummy_values[0] = save_dummy;
 169 }
 170
 171
 172 /* execute a udf of n variables */
 173 void
 174 f_calln(union argument *x)
 175 {
 176     struct udft_entry *udf;
 177     struct value save_dummy[MAX_NUM_VAR];
 178
 179     int i;
 180     int num_pop;
 181     struct value num_params;
 182
 183     udf = x->udf_arg;
 184     if (!udf->at)               /* undefined */
 185         int_error(NO_CARET, "undefined function: %s", udf->udf_name);
 186     for (i = 0; i < MAX_NUM_VAR; i++)
 187         save_dummy[i] = udf->dummy_values[i];
 188
 189     (void) pop(&num_params);
 190
 191     if (num_params.v.int_val != udf->dummy_num)
 192         int_error(NO_CARET, "function %s requires %d variable%c",
 193             udf->udf_name, udf->dummy_num, (udf->dummy_num == 1)?'\0':'s');
 194
 195     /* if there are more parameters than the function is expecting */
 196     /* simply ignore the excess */
 197     if (num_params.v.int_val > MAX_NUM_VAR) {
 198         /* pop and discard the dummies that there is no room for */
 199         num_pop = num_params.v.int_val - MAX_NUM_VAR;
 200         for (i = 0; i < num_pop; i++)
 201             (void) pop(&(udf->dummy_values[0]));
 202
 203         num_pop = MAX_NUM_VAR;
 204     } else {
 205         num_pop = num_params.v.int_val;
 206     }
 207
 208     /* pop parameters we can use */
 209     for (i = num_pop - 1; i >= 0; i--)
 210         (void) pop(&(udf->dummy_values[i]));
 211
 212     execute_at(udf->at);
 213     for (i = 0; i < MAX_NUM_VAR; i++) {
 214         gpfree_string(&udf->dummy_values[i]);
 215         udf->dummy_values[i] = save_dummy[i];
 216     }
 217 }
 218
 219
 220 void
 221 f_lnot(union argument *arg)
 222 {
 223     struct value a;
 224
 225     (void) arg;                 /* avoid -Wunused warning */
 226     int_check(pop(&a));
 227     push(Ginteger(&a, !a.v.int_val));
 228 }
 229
 230
 231 void
 232 f_bnot(union argument *arg)
 233 {
 234     struct value a;
 235
 236     (void) arg;                 /* avoid -Wunused warning */
 237     int_check(pop(&a));
 238     push(Ginteger(&a, ~a.v.int_val));
 239 }
 240
 241
 242 void
 243 f_lor(union argument *arg)
 244 {
 245     struct value a, b;
 246
 247     (void) arg;                 /* avoid -Wunused warning */
 248     int_check(pop(&b));
 249     int_check(pop(&a));
 250     push(Ginteger(&a, a.v.int_val || b.v.int_val));
 251 }
 252
 253 void
 254 f_land(union argument *arg)
 255 {
 256     struct value a, b;
 257
 258     (void) arg;                 /* avoid -Wunused warning */
 259     int_check(pop(&b));
 260     int_check(pop(&a));
 261     push(Ginteger(&a, a.v.int_val && b.v.int_val));
 262 }
 263
 264
 265 void
 266 f_bor(union argument *arg)
 267 {
 268     struct value a, b;
 269
 270     (void) arg;                 /* avoid -Wunused warning */
 271     int_check(pop(&b));
 272     int_check(pop(&a));
 273     push(Ginteger(&a, a.v.int_val | b.v.int_val));
 274 }
 275
 276
 277 void
 278 f_xor(union argument *arg)
 279 {
 280     struct value a, b;
 281
 282     (void) arg;                 /* avoid -Wunused warning */
 283     int_check(pop(&b));
 284     int_check(pop(&a));
 285     push(Ginteger(&a, a.v.int_val ^ b.v.int_val));
 286 }
 287
 288
 289 void
 290 f_band(union argument *arg)
 291 {
 292     struct value a, b;
 293
 294     (void) arg;                 /* avoid -Wunused warning */
 295     int_check(pop(&b));
 296     int_check(pop(&a));
 297     push(Ginteger(&a, a.v.int_val & b.v.int_val));
 298 }
 299
 300
 301 #if (GP_STRING_VARS > 1)
 302 /*
 303  * Make all the following internal routines perform autoconversion
 304  * from string to numeric value.
 305  */
 306 #define pop(x) pop_or_convert_from_string(x)
 307 #endif
 308
 309 void
 310 f_uminus(union argument *arg)
 311 {
 312     struct value a;
 313
 314     (void) arg;                 /* avoid -Wunused warning */
 315     (void) pop(&a);
 316     switch (a.type) {
 317     case INTGR:
 318         a.v.int_val = -a.v.int_val;
 319         break;
 320     case CMPLX:
 321         a.v.cmplx_val.real =
 322             -a.v.cmplx_val.real;
 323         a.v.cmplx_val.imag =
 324             -a.v.cmplx_val.imag;
 325         break;
 326         BAD_DEFAULT
 327     }
 328     push(&a);
 329 }
 330
 331
 332 void
 333 f_eq(union argument *arg)
 334 {
 335     /* note: floating point equality is rare because of roundoff error! */
 336     struct value a, b;
 337     int result = 0;
 338
 339     (void) arg;                 /* avoid -Wunused warning */
 340     (void) pop(&b);
 341     (void) pop(&a);
 342
 343     switch (a.type) {
 344     case INTGR:
 345         switch (b.type) {
 346         case INTGR:
 347             result = (a.v.int_val ==
 348                       b.v.int_val);
 349             break;
 350         case CMPLX:
 351             result = (a.v.int_val ==
 352                       b.v.cmplx_val.real &&
 353                       b.v.cmplx_val.imag == 0.0);
 354             break;
 355             BAD_DEFAULT
 356         }
 357         break;
 358     case CMPLX:
 359         switch (b.type) {
 360         case INTGR:
 361             result = (b.v.int_val == a.v.cmplx_val.real &&
 362                       a.v.cmplx_val.imag == 0.0);
 363             break;
 364         case CMPLX:
 365             result = (a.v.cmplx_val.real ==
 366                       b.v.cmplx_val.real &&
 367                       a.v.cmplx_val.imag ==
 368                       b.v.cmplx_val.imag);
 369             break;
 370             BAD_DEFAULT
 371         }
 372         break;
 373         BAD_DEFAULT
 374     }
 375     push(Ginteger(&a, result));
 376 }
 377
 378
 379 void
 380 f_ne(union argument *arg)
 381 {
 382     struct value a, b;
 383     int result = 0;
 384
 385     (void) arg;                 /* avoid -Wunused warning */
 386     (void) pop(&b);
 387     (void) pop(&a);
 388     switch (a.type) {
 389     case INTGR:
 390         switch (b.type) {
 391         case INTGR:
 392             result = (a.v.int_val !=
 393                       b.v.int_val);
 394             break;
 395         case CMPLX:
 396             result = (a.v.int_val !=
 397                       b.v.cmplx_val.real ||
 398                       b.v.cmplx_val.imag != 0.0);
 399             break;
 400             BAD_DEFAULT
 401         }
 402         break;
 403     case CMPLX:
 404         switch (b.type) {
 405         case INTGR:
 406             result = (b.v.int_val !=
 407                       a.v.cmplx_val.real ||
 408                       a.v.cmplx_val.imag != 0.0);
 409             break;
 410         case CMPLX:
 411             result = (a.v.cmplx_val.real !=
 412                       b.v.cmplx_val.real ||
 413                       a.v.cmplx_val.imag !=
 414                       b.v.cmplx_val.imag);
 415             break;
 416             BAD_DEFAULT
 417         }
 418         break;
 419         BAD_DEFAULT
 420     }
 421     push(Ginteger(&a, result));
 422 }
 423
 424
 425 void
 426 f_gt(union argument *arg)
 427 {
 428     struct value a, b;
 429     int result = 0;
 430
 431     (void) arg;                 /* avoid -Wunused warning */
 432     (void) pop(&b);
 433     (void) pop(&a);
 434     switch (a.type) {
 435     case INTGR:
 436         switch (b.type) {
 437         case INTGR:
 438             result = (a.v.int_val >
 439                       b.v.int_val);
 440             break;
 441         case CMPLX:
 442             result = (a.v.int_val >
 443                       b.v.cmplx_val.real);
 444             break;
 445             BAD_DEFAULT
 446         }
 447         break;
 448     case CMPLX:
 449         switch (b.type) {
 450         case INTGR:
 451             result = (a.v.cmplx_val.real >
 452                       b.v.int_val);
 453             break;
 454         case CMPLX:
 455             result = (a.v.cmplx_val.real >
 456                       b.v.cmplx_val.real);
 457             break;
 458             BAD_DEFAULT
 459         }
 460         break;
 461         BAD_DEFAULT
 462     }
 463     push(Ginteger(&a, result));
 464 }
 465
 466
 467 void
 468 f_lt(union argument *arg)
 469 {
 470     struct value a, b;
 471     int result = 0;
 472
 473     (void) arg;                 /* avoid -Wunused warning */
 474     (void) pop(&b);
 475     (void) pop(&a);
 476     switch (a.type) {
 477     case INTGR:
 478         switch (b.type) {
 479         case INTGR:
 480             result = (a.v.int_val <
 481                       b.v.int_val);
 482             break;
 483         case CMPLX:
 484             result = (a.v.int_val <
 485                       b.v.cmplx_val.real);
 486             break;
 487             BAD_DEFAULT
 488         }
 489         break;
 490     case CMPLX:
 491         switch (b.type) {
 492         case INTGR:
 493             result = (a.v.cmplx_val.real <
 494                       b.v.int_val);
 495             break;
 496         case CMPLX:
 497             result = (a.v.cmplx_val.real <
 498                       b.v.cmplx_val.real);
 499             break;
 500             BAD_DEFAULT
 501         }
 502         break;
 503         BAD_DEFAULT
 504     }
 505     push(Ginteger(&a, result));
 506 }
 507
 508
 509 void
 510 f_ge(union argument *arg)
 511 {
 512     struct value a, b;
 513     int result = 0;
 514
 515     (void) arg;                 /* avoid -Wunused warning */
 516     (void) pop(&b);
 517     (void) pop(&a);
 518     switch (a.type) {
 519     case INTGR:
 520         switch (b.type) {
 521         case INTGR:
 522             result = (a.v.int_val >=
 523                       b.v.int_val);
 524             break;
 525         case CMPLX:
 526             result = (a.v.int_val >=
 527                       b.v.cmplx_val.real);
 528             break;
 529             BAD_DEFAULT
 530         }
 531         break;
 532     case CMPLX:
 533         switch (b.type) {
 534         case INTGR:
 535             result = (a.v.cmplx_val.real >=
 536                       b.v.int_val);
 537             break;
 538         case CMPLX:
 539             result = (a.v.cmplx_val.real >=
 540                       b.v.cmplx_val.real);
 541             break;
 542             BAD_DEFAULT
 543         }
 544         break;
 545         BAD_DEFAULT
 546     }
 547     push(Ginteger(&a, result));
 548 }
 549
 550
 551 void
 552 f_le(union argument *arg)
 553 {
 554     struct value a, b;
 555     int result = 0;
 556
 557     (void) arg;                 /* avoid -Wunused warning */
 558     (void) pop(&b);
 559     (void) pop(&a);
 560     switch (a.type) {
 561     case INTGR:
 562         switch (b.type) {
 563         case INTGR:
 564             result = (a.v.int_val <=
 565                       b.v.int_val);
 566             break;
 567         case CMPLX:
 568             result = (a.v.int_val <=
 569                       b.v.cmplx_val.real);
 570             break;
 571             BAD_DEFAULT
 572         }
 573         break;
 574     case CMPLX:
 575         switch (b.type) {
 576         case INTGR:
 577             result = (a.v.cmplx_val.real <=
 578                       b.v.int_val);
 579             break;
 580         case CMPLX:
 581             result = (a.v.cmplx_val.real <=
 582                       b.v.cmplx_val.real);
 583             break;
 584             BAD_DEFAULT
 585         }
 586         break;
 587         BAD_DEFAULT
 588     }
 589     push(Ginteger(&a, result));
 590 }
 591
 592
 593 void
 594 f_plus(union argument *arg)
 595 {
 596     struct value a, b, result;
 597
 598     (void) arg;                 /* avoid -Wunused warning */
 599     (void) pop(&b);
 600     (void) pop(&a);
 601     switch (a.type) {
 602     case INTGR:
 603         switch (b.type) {
 604         case INTGR:
 605             (void) Ginteger(&result, a.v.int_val +
 606                             b.v.int_val);
 607             break;
 608         case CMPLX:
 609             (void) Gcomplex(&result, a.v.int_val +
 610                             b.v.cmplx_val.real,
 611                             b.v.cmplx_val.imag);
 612             break;
 613             BAD_DEFAULT
 614         }
 615         break;
 616     case CMPLX:
 617         switch (b.type) {
 618         case INTGR:
 619             (void) Gcomplex(&result, b.v.int_val +
 620                             a.v.cmplx_val.real,
 621                             a.v.cmplx_val.imag);
 622             break;
 623         case CMPLX:
 624             (void) Gcomplex(&result, a.v.cmplx_val.real +
 625                             b.v.cmplx_val.real,
 626                             a.v.cmplx_val.imag +
 627                             b.v.cmplx_val.imag);
 628             break;
 629             BAD_DEFAULT
 630         }
 631         break;
 632         BAD_DEFAULT
 633     }
 634     push(&result);
 635 }
 636
 637
 638 void
 639 f_minus(union argument *arg)
 640 {
 641     struct value a, b, result;
 642
 643     (void) arg;                 /* avoid -Wunused warning */
 644     (void) pop(&b);
 645     (void) pop(&a);             /* now do a - b */
 646     switch (a.type) {
 647     case INTGR:
 648         switch (b.type) {
 649         case INTGR:
 650             (void) Ginteger(&result, a.v.int_val -
 651                             b.v.int_val);
 652             break;
 653         case CMPLX:
 654             (void) Gcomplex(&result, a.v.int_val -
 655                             b.v.cmplx_val.real,
 656                             -b.v.cmplx_val.imag);
 657             break;
 658             BAD_DEFAULT
 659         }
 660         break;
 661     case CMPLX:
 662         switch (b.type) {
 663         case INTGR:
 664             (void) Gcomplex(&result, a.v.cmplx_val.real -
 665                             b.v.int_val,
 666                             a.v.cmplx_val.imag);
 667             break;
 668         case CMPLX:
 669             (void) Gcomplex(&result, a.v.cmplx_val.real -
 670                             b.v.cmplx_val.real,
 671                             a.v.cmplx_val.imag -
 672                             b.v.cmplx_val.imag);
 673             break;
 674             BAD_DEFAULT
 675         }
 676         break;
 677         BAD_DEFAULT
 678     }
 679     push(&result);
 680 }
 681
 682
 683 void
 684 f_mult(union argument *arg)
 685 {
 686     struct value a, b, result;
 687
 688     (void) arg;                 /* avoid -Wunused warning */
 689     (void) pop(&b);
 690     (void) pop(&a);             /* now do a*b */
 691
 692     switch (a.type) {
 693     case INTGR:
 694         switch (b.type) {
 695         case INTGR:
 696             (void) Ginteger(&result, a.v.int_val *
 697                             b.v.int_val);
 698             break;
 699         case CMPLX:
 700             (void) Gcomplex(&result, a.v.int_val *
 701                             b.v.cmplx_val.real,
 702                             a.v.int_val *
 703                             b.v.cmplx_val.imag);
 704             break;
 705             BAD_DEFAULT
 706         }
 707         break;
 708     case CMPLX:
 709         switch (b.type) {
 710         case INTGR:
 711             (void) Gcomplex(&result, b.v.int_val *
 712                             a.v.cmplx_val.real,
 713                             b.v.int_val *
 714                             a.v.cmplx_val.imag);
 715             break;
 716         case CMPLX:
 717             (void) Gcomplex(&result, a.v.cmplx_val.real *
 718                             b.v.cmplx_val.real -
 719                             a.v.cmplx_val.imag *
 720                             b.v.cmplx_val.imag,
 721                             a.v.cmplx_val.real *
 722                             b.v.cmplx_val.imag +
 723                             a.v.cmplx_val.imag *
 724                             b.v.cmplx_val.real);
 725             break;
 726             BAD_DEFAULT
 727         }
 728         break;
 729         BAD_DEFAULT
 730     }
 731     push(&result);
 732 }
 733
 734
 735 void
 736 f_div(union argument *arg)
 737 {
 738     struct value a, b, result;
 739     double square;
 740
 741     (void) arg;                 /* avoid -Wunused warning */
 742     (void) pop(&b);
 743     (void) pop(&a);             /* now do a/b */
 744
 745     switch (a.type) {
 746     case INTGR:
 747         switch (b.type) {
 748         case INTGR:
 749             if (b.v.int_val)
 750                 (void) Ginteger(&result, a.v.int_val /
 751                                 b.v.int_val);
 752             else {
 753                 (void) Ginteger(&result, 0);
 754                 undefined = TRUE;
 755             }
 756             break;
 757         case CMPLX:
 758             square = b.v.cmplx_val.real *
 759                 b.v.cmplx_val.real +
 760                 b.v.cmplx_val.imag *
 761                 b.v.cmplx_val.imag;
 762             if (square)
 763                 (void) Gcomplex(&result, a.v.int_val *
 764                                 b.v.cmplx_val.real / square,
 765                                 -a.v.int_val *
 766                                 b.v.cmplx_val.imag / square);
 767             else {
 768                 (void) Gcomplex(&result, 0.0, 0.0);
 769                 undefined = TRUE;
 770             }
 771             break;
 772             BAD_DEFAULT
 773         }
 774         break;
 775     case CMPLX:
 776         switch (b.type) {
 777         case INTGR:
 778             if (b.v.int_val)
 779                 (void) Gcomplex(&result, a.v.cmplx_val.real /
 780                                 b.v.int_val,
 781                                 a.v.cmplx_val.imag /
 782                                 b.v.int_val);
 783             else {
 784                 (void) Gcomplex(&result, 0.0, 0.0);
 785                 undefined = TRUE;
 786             }
 787             break;
 788         case CMPLX:
 789             square = b.v.cmplx_val.real *
 790                 b.v.cmplx_val.real +
 791                 b.v.cmplx_val.imag *
 792                 b.v.cmplx_val.imag;
 793             if (square)
 794                 (void) Gcomplex(&result, (a.v.cmplx_val.real *
 795                                           b.v.cmplx_val.real +
 796                                           a.v.cmplx_val.imag *
 797                                           b.v.cmplx_val.imag) / square,
 798                                 (a.v.cmplx_val.imag *
 799                                  b.v.cmplx_val.real -
 800                                  a.v.cmplx_val.real *
 801                                  b.v.cmplx_val.imag) /
 802                                 square);
 803             else {
 804                 (void) Gcomplex(&result, 0.0, 0.0);
 805                 undefined = TRUE;
 806             }
 807             break;
 808             BAD_DEFAULT
 809         }
 810         break;
 811         BAD_DEFAULT
 812     }
 813     push(&result);
 814 }
 815
 816
 817 void
 818 f_mod(union argument *arg)
 819 {
 820     struct value a, b;
 821
 822     (void) arg;                 /* avoid -Wunused warning */
 823     (void) pop(&b);
 824     (void) pop(&a);             /* now do a%b */
 825
 826     if (a.type != INTGR || b.type != INTGR)
 827         int_error(NO_CARET, "can only mod ints");
 828     if (b.v.int_val)
 829         push(Ginteger(&a, a.v.int_val % b.v.int_val));
 830     else {
 831         push(Ginteger(&a, 0));
 832         undefined = TRUE;
 833     }
 834 }
 835
 836
 837 void
 838 f_power(union argument *arg)
 839 {
 840     struct value a, b, result;
 841     int i, t, count;
 842     double mag, ang;
 843
 844     (void) arg;                 /* avoid -Wunused warning */
 845     (void) pop(&b);
 846     (void) pop(&a);             /* now find a**b */
 847
 848     switch (a.type) {
 849     case INTGR:
 850         switch (b.type) {
 851         case INTGR:
 852             count = abs(b.v.int_val);
 853             t = 1;
 854             /* this ought to use bit-masks and squares, etc */
 855             for (i = 0; i < count; i++)
 856                 t *= a.v.int_val;
 857             if (b.v.int_val >= 0)
 858                 (void) Ginteger(&result, t);
 859             else if (t != 0)
 860                 (void) Gcomplex(&result, 1.0 / t, 0.0);
 861             else {
 862                 undefined = TRUE;
 863                 (void) Gcomplex(&result, 0.0, 0.0);
 864             }
 865             break;
 866         case CMPLX:
 867             if (a.v.int_val == 0) {
 868                 if (b.v.cmplx_val.imag != 0 || b.v.cmplx_val.real < 0) {
 869                     undefined = TRUE;
 870                 }
 871                 /* return 1.0 for 0**0 */
 872                 Gcomplex(&result, b.v.cmplx_val.real == 0 ? 1.0 : 0.0, 0.0);
 873             } else {
 874                 mag =
 875                     pow(magnitude(&a), fabs(b.v.cmplx_val.real));
 876                 if (b.v.cmplx_val.real < 0.0) {
 877                     if (mag != 0.0)
 878                         mag = 1.0 / mag;
 879                     else
 880                         undefined = TRUE;
 881                 }
 882                 mag *= gp_exp(-b.v.cmplx_val.imag * angle(&a));
 883                 ang = b.v.cmplx_val.real * angle(&a) +
 884                     b.v.cmplx_val.imag * log(magnitude(&a));
 885                 (void) Gcomplex(&result, mag * cos(ang),
 886                                 mag * sin(ang));
 887             }
 888             break;
 889             BAD_DEFAULT
 890         }
 891         break;
 892     case CMPLX:
 893         switch (b.type) {
 894         case INTGR:
 895             if (a.v.cmplx_val.imag == 0.0) {
 896                 mag = pow(a.v.cmplx_val.real, (double) abs(b.v.int_val));
 897                 if (b.v.int_val < 0) {
 898                     if (mag != 0.0)
 899                         mag = 1.0 / mag;
 900                     else
 901                         undefined = TRUE;
 902                 }
 903                 (void) Gcomplex(&result, mag, 0.0);
 904             } else {
 905                 /* not so good, but...! */
 906                 mag = pow(magnitude(&a), (double) abs(b.v.int_val));
 907                 if (b.v.int_val < 0) {
 908                     if (mag != 0.0)
 909                         mag = 1.0 / mag;
 910                     else
 911                         undefined = TRUE;
 912                 }
 913                 ang = angle(&a) * b.v.int_val;
 914                 (void) Gcomplex(&result, mag * cos(ang),
 915                                 mag * sin(ang));
 916             }
 917             break;
 918         case CMPLX:
 919             if (a.v.cmplx_val.real == 0 && a.v.cmplx_val.imag == 0) {
 920                 if (b.v.cmplx_val.imag != 0 || b.v.cmplx_val.real < 0) {
 921                     undefined = TRUE;
 922                 }
 923                 /* return 1.0 for 0**0 */
 924                 Gcomplex(&result, b.v.cmplx_val.real == 0 ? 1.0 : 0.0, 0.0);
 925             } else {
 926                 mag = pow(magnitude(&a), fabs(b.v.cmplx_val.real));
 927                 if (b.v.cmplx_val.real < 0.0) {
 928                     if (mag != 0.0)
 929                         mag = 1.0 / mag;
 930                     else
 931                         undefined = TRUE;
 932                 }
 933                 mag *= gp_exp(-b.v.cmplx_val.imag * angle(&a));
 934                 ang = b.v.cmplx_val.real * angle(&a) +
 935                     b.v.cmplx_val.imag * log(magnitude(&a));
 936                 (void) Gcomplex(&result, mag * cos(ang),
 937                                 mag * sin(ang));
 938             }
 939             break;
 940             BAD_DEFAULT
 941         }
 942         break;
 943         BAD_DEFAULT
 944     }
 945     push(&result);
 946 }
 947
 948
 949 void
 950 f_factorial(union argument *arg)
 951 {
 952     struct value a;
 953     int i;
 954     double val = 0.0;
 955
 956     (void) arg;                 /* avoid -Wunused warning */
 957     (void) pop(&a);             /* find a! (factorial) */
 958
 959     switch (a.type) {
 960     case INTGR:
 961         val = 1.0;
 962         for (i = a.v.int_val; i > 1; i--)       /*fpe's should catch overflows */
 963             val *= i;
 964         break;
 965     default:
 966         int_error(NO_CARET, "factorial (!) argument must be an integer");
 967         return;                 /* avoid gcc -Wall warning about val */
 968     }
 969
 970     push(Gcomplex(&a, val, 0.0));
 971
 972 }
 973
 974 #ifdef GP_STRING_VARS
 975 /*
 976  * Terminate the autoconversion from string to numeric values
 977  */
 978 #undef pop
 979
 980 void
 981 f_concatenate(union argument *arg)
 982 {
 983     struct value a, b, result;
 984
 985     (void) arg;                 /* avoid -Wunused warning */
 986     (void) pop(&b);
 987     (void) pop(&a);
 988
 989     if (b.type == INTGR) {
 990         int i = b.v.int_val;
 991         b.type = STRING;
 992         b.v.string_val = (char *)gp_alloc(32,"str_const");
 993 #ifdef HAVE_SNPRINTF
 994         snprintf(b.v.string_val,32,"%d",i);
 995 #else
 996         sprintf(b.v.string_val,"%d",i);
 997 #endif
 998     }
 999
1000     if (a.type != STRING || b.type != STRING)
1001         int_error(NO_CARET, "internal error : STRING operator applied to non-STRING type");
1002
1003     (void) Gstring(&result, gp_stradd(a.v.string_val, b.v.string_val));
1004     gpfree_string(&a);
1005     gpfree_string(&b);
1006     push(&result);
1007     gpfree_string(&result); /* free string allocated within gp_stradd() */
1008 }
1009
1010 void
1011 f_eqs(union argument *arg)
1012 {
1013     struct value a, b, result;
1014
1015     (void) arg;                 /* avoid -Wunused warning */
1016     (void) pop(&b);
1017     (void) pop(&a);
1018
1019     if(a.type != STRING || b.type != STRING)
1020         int_error(NO_CARET, "internal error : STRING operator applied to non-STRING type");
1021
1022     (void) Ginteger(&result, !strcmp(a.v.string_val, b.v.string_val));
1023     gpfree_string(&a);
1024     gpfree_string(&b);
1025     push(&result);
1026 }
1027
1028 void
1029 f_nes(union argument *arg)
1030 {
1031     struct value a, b, result;
1032
1033     (void) arg;                 /* avoid -Wunused warning */
1034     (void) pop(&b);
1035     (void) pop(&a);
1036
1037     if(a.type != STRING || b.type != STRING)
1038         int_error(NO_CARET, "internal error : STRING operator applied to non-STRING type");
1039
1040     (void) Ginteger(&result, (int)(strcmp(a.v.string_val, b.v.string_val)!=0));
1041     gpfree_string(&a);
1042     gpfree_string(&b);
1043     push(&result);
1044 }
1045
1046 void
1047 f_strlen(union argument *arg)
1048 {
1049     struct value a, result;
1050
1051     (void) arg;
1052     (void) pop(&a);
1053
1054     if (a.type != STRING)
1055         int_error(NO_CARET, "internal error : strlen of non-STRING argument");
1056
1057     (void) Ginteger(&result, (int)strlen(a.v.string_val));
1058     gpfree_string(&a);
1059     push(&result);
1060 }
1061
1062 void
1063 f_strstrt(union argument *arg)
1064 {
1065     struct value needle, haystack, result;
1066     char *start;
1067
1068     (void) arg;
1069     (void) pop(&needle);
1070     (void) pop(&haystack);
1071
1072     if (needle.type != STRING || haystack.type != STRING)
1073         int_error(NO_CARET, "internal error : non-STRING argument to strstrt");
1074
1075     start = strstr(haystack.v.string_val, needle.v.string_val);
1076     (void) Ginteger(&result, (int)(start ? (start-haystack.v.string_val)+1 : 0));
1077     gpfree_string(&needle);
1078     gpfree_string(&haystack);
1079     push(&result);
1080 }
1081
1082 void
1083 f_range(union argument *arg)
1084 {
1085     struct value beg, end, full;
1086     struct value substr = {0};
1087
1088     (void) arg;                 /* avoid -Wunused warning */
1089     (void) pop(&end);
1090     (void) pop(&beg);
1091     (void) pop(&full);
1092
1093     if (end.type != INTGR || beg.type != INTGR)
1094         int_error(NO_CARET, "internal error: substring range specifiers must have integer values");
1095
1096     if (full.type != STRING)
1097         int_error(NO_CARET, "internal error: substring range operator applied to non-STRING type");
1098
1099     FPRINTF((stderr,"f_range( \"%s\", %d, %d)\n", full.v.string_val, beg.v.int_val, end.v.int_val));
1100
1101     if (end.v.int_val > strlen(full.v.string_val))
1102         end.v.int_val = strlen(full.v.string_val);
1103     if (beg.v.int_val < 1)
1104         beg.v.int_val = 1;
1105     if (beg.v.int_val > end.v.int_val)
1106         beg.v.int_val = strlen(full.v.string_val)+1;
1107
1108     full.v.string_val[end.v.int_val] = '\0';
1109     push(Gstring(&substr, &full.v.string_val[beg.v.int_val-1]));
1110     gpfree_string(&full);
1111 }
1112
1113 void
1114 f_words(union argument *arg)
1115 {
1116     struct value a, b, result;
1117     int nwords = 0;
1118     int ntarget;
1119     char *s;
1120
1121     (void) arg;
1122     if (pop(&b)->type != INTGR)
1123         int_error(NO_CARET, "internal error : non-INTGR argument");
1124     ntarget = b.v.int_val;
1125
1126     if (pop(&a)->type != STRING)
1127         int_error(NO_CARET, "internal error : non-STRING argument");
1128     s = a.v.string_val;
1129
1130     Gstring(&result, "");
1131     while (*s) {
1132         while (isspace(*s)) s++;
1133         if (!*s)
1134             break;
1135         nwords++;
1136         if (nwords == ntarget) { /* Found the one we wanted */
1137             Gstring(&result,s);
1138             s = result.v.string_val;
1139         }
1140         while (*s && !isspace(*s)) s++;
1141         if (nwords == ntarget) { /* Terminate this word cleanly */
1142             *s = '\0';
1143             break;
1144         }
1145     }
1146
1147     if (ntarget < 0)
1148         /* words(s) = word(s,-1) = # of words in string */
1149         Ginteger(&result, nwords);
1150
1151     push(&result);
1152     gpfree_string(&a);
1153 }
1154
1155 /* EAM July 2004  (revised to dynamic buffer July 2005)
1156  * There are probably an infinite number of things that can
1157  * go wrong if the user mis-matches arguments and format strings
1158  * in the call to sprintf, but I hope none will do worse than
1159  * result in a garbage output string.
1160  */
1161 void
1162 f_sprintf(union argument *arg)
1163 {
1164     struct value a[10], *args;
1165     struct value num_params;
1166     struct value result;
1167     char *buffer;
1168     int bufsize;
1169     char *next_start, *outpos, tempchar;
1170     int next_length;
1171     char *prev_start;
1172     int prev_pos;
1173     int i, remaining;
1174     int nargs = 0;
1175     enum DATA_TYPES spec_type;
1176
1177     /* Retrieve number of parameters from top of stack */
1178     pop(&num_params);
1179     nargs = num_params.v.int_val;
1180     if (nargs > 10) {   /* Fall back to slow but sure allocation */
1181         args = gp_alloc(sizeof(struct value)*nargs, "sprintf args");
1182     } else
1183         args = a;
1184
1185     for (i=0; i<nargs; i++)
1186         pop(&args[i]);  /* pop next argument */
1187
1188     /* Make sure we got a format string of some sort */
1189     if (args[nargs-1].type != STRING)
1190         int_error(NO_CARET,"First parameter to sprintf must be a format string");
1191
1192     /* Allocate space for the output string. If this isn't */
1193     /* long enough we can reallocate a larger space later. */
1194     bufsize = 80 + strlen(args[nargs-1].v.string_val);
1195     buffer = gp_alloc(bufsize, "f_sprintf");
1196
1197     /* Copy leading fragment of format into output buffer */
1198     outpos = buffer;
1199     next_start  = args[nargs-1].v.string_val;
1200     next_length = strcspn(next_start,"%");
1201     strncpy(outpos, next_start, next_length);
1202
1203     next_start += next_length;
1204     outpos += next_length;
1205
1206     /* Format the remaining sprintf() parameters one by one */
1207     prev_start = next_start;
1208     prev_pos = next_length;
1209     remaining = nargs - 1;
1210
1211     /* Each time we start this loop we are pointing to a % character */
1212     while (remaining-->0 && next_start[0] && next_start[1]) {
1213         struct value *next_param = &args[remaining];
1214
1215         /* Check for %%; print as literal and don't consume a parameter */
1216         if (!strncmp(next_start,"%%",2)) {
1217             next_start++;
1218             do {
1219                 *outpos++ = *next_start++;
1220             } while(*next_start && *next_start != '%');
1221             remaining++;
1222             continue;
1223         }
1224
1225         next_length = strcspn(next_start+1,"%") + 1;
1226         tempchar = next_start[next_length];
1227         next_start[next_length] = '\0';
1228
1229         spec_type = sprintf_specifier(next_start);
1230
1231         /* string value <-> numerical value check */
1232         if ( spec_type == STRING && next_param->type != STRING )
1233             int_error(NO_CARET,"f_sprintf: attempt to print numeric value with string format");
1234         if ( spec_type != STRING && next_param->type == STRING )
1235             int_error(NO_CARET,"f_sprintf: attempt to print string value with numeric format");
1236
1237 #ifdef HAVE_SNPRINTF
1238         /* Use the format to print next arg */
1239         switch(spec_type) {
1240         case INTGR:
1241             snprintf(outpos,bufsize-(outpos-buffer),
1242                      next_start, (int)real(next_param));
1243             break;
1244         case CMPLX:
1245             snprintf(outpos,bufsize-(outpos-buffer),
1246                      next_start, real(next_param));
1247             break;
1248         case STRING:
1249             snprintf(outpos,bufsize-(outpos-buffer),
1250                 next_start, next_param->v.string_val);
1251             break;
1252         default:
1253             int_error(NO_CARET,"internal error: invalid spec_type");
1254         }
1255 #else
1256         /* FIXME - this is bad; we should dummy up an snprintf equivalent */
1257         switch(spec_type) {
1258         case INTGR:
1259             sprintf(outpos, next_start, (int)real(next_param));
1260             break;
1261         case CMPLX:
1262             sprintf(outpos, next_start, real(next_param));
1263             break;
1264         case STRING:
1265             sprintf(outpos, next_start, next_param->v.string_val);
1266             break;
1267         default:
1268             int_error(NO_CARET,"internal error: invalid spec_type");
1269         }
1270 #endif
1271
1272         next_start[next_length] = tempchar;
1273         next_start += next_length;
1274         outpos = &buffer[strlen(buffer)];
1275
1276         /* Check whether previous parameter output hit the end of the buffer */
1277         /* If so, reallocate a larger buffer, go back and try it again.      */
1278         if (strlen(buffer) >= bufsize-2) {
1279             bufsize *= 2;
1280             buffer = gp_realloc(buffer, bufsize, "f_sprintf");
1281             next_start = prev_start;
1282             outpos = buffer + prev_pos;
1283             remaining++;
1284             continue;
1285         } else {
1286             prev_start = next_start;
1287             prev_pos = outpos - buffer;
1288         }
1289
1290     }
1291
1292     /* Copy the trailing portion of the format, if any */
1293     /* We could just call snprintf(), but it doesn't check for */
1294     /* whether there really are more variables to handle.      */
1295     i = bufsize - (outpos-buffer);
1296     while (*next_start && --i > 0) {
1297         if (*next_start == '%' && *(next_start+1) == '%')
1298             next_start++;
1299         *outpos++ = *next_start++;
1300     }
1301     *outpos = '\0';
1302
1303     FPRINTF((stderr," snprintf result = \"%s\"\n",buffer));
1304     push(Gstring(&result, buffer));
1305     free(buffer);
1306
1307     /* Free any strings from parameters we have now used */
1308     for (i=0; i<nargs; i++)
1309         gpfree_string(&args[i]);
1310
1311     if (args != a)
1312         free(args);
1313 }
1314
1315 /* EAM July 2004 - Gnuplot's own string formatting conventions.
1316  * Currently this routine assumes base 10 representation, because
1317  * it is not clear where it could be specified to be anything else.
1318  */
1319 void
1320 f_gprintf(union argument *arg)
1321 {
1322     struct value fmt, val, result;
1323     char *buffer;
1324     int length;
1325     double base;
1326
1327     /* Retrieve parameters from top of stack */
1328     pop(&val);
1329     pop(&fmt);
1330
1331 #ifdef DEBUG
1332     fprintf(stderr,"----------\nGot gprintf parameters\nfmt: ");
1333         disp_value(stderr, &fmt, TRUE);
1334     fprintf(stderr,"\nval: ");
1335         disp_value(stderr, &val, TRUE);
1336     fprintf(stderr,"\n----------\n");
1337 #endif
1338
1339     /* Make sure parameters are of the correct type */
1340     if (fmt.type != STRING)
1341         int_error(NO_CARET,"First parameter to gprintf must be a format string");
1342
1343     /* EAM FIXME - I have no idea where we would learn another base is wanted */
1344     base = 10.;
1345
1346     /* Make sure we have at least as much space in the output as the format itself */
1347     length = 80 + strlen(fmt.v.string_val);
1348     buffer = gp_alloc(length, "f_gprintf");
1349
1350     /* Call the old internal routine */
1351     gprintf(buffer, length, fmt.v.string_val, base, real(&val));
1352
1353     FPRINTF((stderr," gprintf result = \"%s\"\n",buffer));
1354     push(Gstring(&result, buffer));
1355
1356     gpfree_string(&fmt);
1357     free(buffer);
1358 }
1359
1360
1361 /* Output time given in seconds from year 2000 into string */
1362 void
1363 f_strftime(union argument *arg)
1364 {
1365     struct value fmt, val;
1366     char *fmtstr, *buffer;
1367     int fmtlen, buflen, length;
1368
1369     (void) arg; /* Avoid compiler warnings */
1370
1371     /* Retrieve parameters from top of stack */
1372     pop(&val);
1373     pop(&fmt);
1374     if ( fmt.type != STRING )
1375         int_error(NO_CARET,
1376                   "First parameter to strftime must be a format string");
1377
1378     /* Prepare format string.
1379      * Make sure the resulting string not empty by adding a space.
1380      * Otherwise, the return value of gstrftime doesn't give enough
1381      * information.
1382      */
1383     fmtlen = strlen(fmt.v.string_val) + 1;
1384     fmtstr = gp_alloc(fmtlen + 1, "f_strftime: fmt");
1385     strncpy(fmtstr, fmt.v.string_val, fmtlen);
1386     strncat(fmtstr, " ", fmtlen);
1387     buflen = 80 + 2*fmtlen;
1388     buffer = gp_alloc(buflen, "f_strftime: buffer");
1389
1390     /* Get time_str */
1391     length = gstrftime(buffer, buflen, fmtstr, real(&val));
1392     if (length == 0 || length >= buflen)
1393         int_error(NO_CARET, "Resulting string is too long");
1394
1395     /* Remove trailing space */
1396     assert(buffer[length-1] == ' ');
1397     buffer[length-1] = NUL;
1398
1399     gpfree_string(&val);
1400     gpfree_string(&fmt);
1401     free(fmtstr);
1402
1403     push(Gstring(&val, buffer));
1404     free(buffer);
1405 }
1406
1407 /* Convert string into seconds from year 2000 */
1408 void
1409 f_strptime(union argument *arg)
1410 {
1411     struct value fmt, val;
1412     struct tm time_tm;
1413     double result;
1414
1415     (void) arg; /* Avoid compiler warnings */
1416
1417     pop(&val);
1418     pop(&fmt);
1419
1420     if ( fmt.type != STRING || val.type != STRING )
1421         int_error(NO_CARET,
1422                   "Both parameters to strptime must be strings");
1423     if ( !fmt.v.string_val || !val.v.string_val )
1424         int_error(NO_CARET, "Internal error: string not allocated");
1425
1426
1427     /* string -> time_tm */
1428     gstrptime(val.v.string_val, fmt.v.string_val, &time_tm);
1429
1430     /* time_tm -> result */
1431     result = gtimegm(&time_tm);
1432     FPRINTF((stderr," strptime result = %g seconds \n", result));
1433
1434     gpfree_string(&val);
1435     gpfree_string(&fmt);
1436     push(Gcomplex(&val, result, 0.0));
1437 }
1438
1439
1440 /* Return which argument type sprintf will need for this format string:
1441  *   char*       STRING
1442  *   int         INTGR
1443  *   double      CMPLX
1444  * Should call int_err for any other type.
1445  * format is expected to start with '%'
1446  */
1447 static enum DATA_TYPES
1448 sprintf_specifier(const char* format)
1449 {
1450     const char string_spec[]  = "s";
1451     const char real_spec[]    = "aAeEfFgG";
1452     const char int_spec[]     = "cdiouxX";
1453     /* The following characters are used for use of invalid types */
1454     const char illegal_spec[] = "hlLqjzZtCSpn";
1455
1456     int string_pos, real_pos, int_pos, illegal_pos;
1457
1458     /* check if really format specifier */
1459     if (format[0] != '%')
1460         int_error(NO_CARET,
1461                   "internal error: sprintf_specifier called without '%'\n");
1462
1463     string_pos  = strcspn(format, string_spec);
1464     real_pos    = strcspn(format, real_spec);
1465     int_pos     = strcspn(format, int_spec);
1466     illegal_pos = strcspn(format, illegal_spec);
1467
1468     if ( illegal_pos < int_pos && illegal_pos < real_pos
1469          && illegal_pos < string_pos )
1470         int_error(NO_CARET,
1471                   "sprintf_specifier: used with invalid format specifier\n");
1472     else if ( string_pos < real_pos && string_pos < int_pos )
1473         return STRING;
1474     else if ( real_pos < int_pos )
1475         return CMPLX;
1476     else if ( int_pos < strlen(format) )
1477         return INTGR;
1478     else
1479         int_error(NO_CARET,
1480                   "sprintf_specifier: no format specifier\n");
1481
1482     return INTGR; /* Can't happen, but the compiler doesn't realize that */
1483 }
1484
1485
1486 /* execute a system call and return stream from STDOUT */
1487 void
1488 f_system(union argument *arg)
1489 {
1490     struct value val, result;
1491     struct udvt_entry *errno_var;
1492     char *output;
1493     int output_len, ierr;
1494
1495     /* Retrieve parameters from top of stack */
1496     pop(&val);
1497
1498     /* Make sure parameters are of the correct type */
1499     if (val.type != STRING)
1500         int_error(NO_CARET, "non-string argument to system()");
1501
1502     FPRINTF((stderr," f_system input = \"%s\"\n", val.v.string_val));
1503
1504     ierr = do_system_func(val.v.string_val, &output);
1505     if ((errno_var = add_udv_by_name("ERRNO"))) {
1506         errno_var->udv_undef = FALSE;
1507         Ginteger(&errno_var->udv_value, ierr);
1508     }
1509     output_len = strlen(output);
1510
1511     /* chomp result */
1512     if ( output_len > 0 && output[output_len-1] == '\n' )
1513         output[output_len-1] = NUL;
1514
1515     FPRINTF((stderr," f_system result = \"%s\"\n", output));
1516
1517     push(Gstring(&result, output));
1518
1519     gpfree_string(&result); /* free output */
1520     gpfree_string(&val);    /* free command string */
1521 }
1522 #endif