![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to internal.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / gnuplot|
Return to internal.c CVS log | Up to [local] / OpenXM_contrib / gnuplot |
1.1 ! maekawa 1: #ifndef lint
! 2: static char *RCSid = "$Id: internal.c,v 1.23 1998/04/14 00:15:44 drd Exp $";
! 3: #endif
! 4:
! 5: /* GNUPLOT - internal.c */
! 6:
! 7: /*[
! 8: * Copyright 1986 - 1993, 1998 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 "plot.h"
! 39: #include "fnproto.h"
! 40:
! 41: /* some machines have trouble with exp(-x) for large x
! 42: * if MINEXP is defined at compile time, use gp_exp(x) instead,
! 43: * which returns 0 for exp(x) with x < MINEXP
! 44: * exp(x) will already have been defined as gp_exp(x) in plot.h
! 45: */
! 46:
! 47: #ifdef MINEXP
! 48: double gp_exp(x)
! 49: double x;
! 50: {
! 51: return (x < (MINEXP)) ? 0.0 : exp(x);
! 52: }
! 53: #endif
! 54:
! 55: TBOOLEAN undefined;
! 56:
! 57: static void int_check __PROTO((struct value * v));
! 58:
! 59: struct value stack[STACK_DEPTH];
! 60:
! 61: int s_p = -1; /* stack pointer */
! 62:
! 63:
! 64: /*
! 65: * System V and MSC 4.0 call this when they wants to print an error message.
! 66: * Don't!
! 67: */
! 68: #ifndef _CRAY
! 69: # ifdef AMIGA_SC_6_1
! 70: # define matherr __matherr
! 71: # define exception __exception
! 72: # endif /* AMIGA_SC_6_1 */
! 73: # if defined(__BORLANDC__) && __BORLANDC__ >= 0x450
! 74: # define matherr _matherr
! 75: # endif /* __BORLANDC__ >= 0x450 */
! 76: # if (defined(MSDOS) || defined(DOS386)) && defined(__TURBOC__) || defined(VMS)
! 77: int matherr()
! 78: #else
! 79: int matherr(x)
! 80: struct exception *x;
! 81: # endif /* (MSDOS || DOS386) && __TURBOC__ */
! 82: {
! 83: return (undefined = TRUE); /* don't print error message */
! 84: }
! 85: #endif /* not _CRAY */
! 86:
! 87:
! 88: void reset_stack()
! 89: {
! 90: s_p = -1;
! 91: }
! 92:
! 93:
! 94: void check_stack()
! 95: { /* make sure stack's empty */
! 96: if (s_p != -1)
! 97: fprintf(stderr, "\n\
! 98: warning: internal error--stack not empty!\n\
! 99: (function called with too many parameters?)\n");
! 100: }
! 101:
! 102: #define BAD_DEFAULT default: int_error("interal error : type neither INT or CMPLX", NO_CARET); return;
! 103:
! 104: struct value *pop(x)
! 105: struct value *x;
! 106: {
! 107: if (s_p < 0)
! 108: int_error("stack underflow (function call with missing parameters?)", NO_CARET);
! 109: *x = stack[s_p--];
! 110: return (x);
! 111: }
! 112:
! 113:
! 114: void push(x)
! 115: struct value *x;
! 116: {
! 117: if (s_p == STACK_DEPTH - 1)
! 118: int_error("stack overflow", NO_CARET);
! 119: stack[++s_p] = *x;
! 120: }
! 121:
! 122:
! 123: #define ERR_VAR "undefined variable: "
! 124:
! 125: void f_push(x)
! 126: union argument *x; /* contains pointer to value to push; */
! 127: {
! 128: static char err_str[sizeof(ERR_VAR) + MAX_ID_LEN] = ERR_VAR;
! 129: struct udvt_entry *udv;
! 130:
! 131: udv = x->udv_arg;
! 132: if (udv->udv_undef) { /* undefined */
! 133: (void) strcpy(&err_str[sizeof(ERR_VAR) - 1], udv->udv_name);
! 134: int_error(err_str, NO_CARET);
! 135: }
! 136: push(&(udv->udv_value));
! 137: }
! 138:
! 139:
! 140: void f_pushc(x)
! 141: union argument *x;
! 142: {
! 143: push(&(x->v_arg));
! 144: }
! 145:
! 146:
! 147: void f_pushd1(x)
! 148: union argument *x;
! 149: {
! 150: push(&(x->udf_arg->dummy_values[0]));
! 151: }
! 152:
! 153:
! 154: void f_pushd2(x)
! 155: union argument *x;
! 156: {
! 157: push(&(x->udf_arg->dummy_values[1]));
! 158: }
! 159:
! 160:
! 161: void f_pushd(x)
! 162: union argument *x;
! 163: {
! 164: struct value param;
! 165: (void) pop(¶m);
! 166: push(&(x->udf_arg->dummy_values[param.v.int_val]));
! 167: }
! 168:
! 169:
! 170: #define ERR_FUN "undefined function: "
! 171:
! 172: void f_call(x) /* execute a udf */
! 173: union argument *x;
! 174: {
! 175: static char err_str[sizeof(ERR_FUN) + MAX_ID_LEN] = ERR_FUN;
! 176: register struct udft_entry *udf;
! 177: struct value save_dummy;
! 178:
! 179: udf = x->udf_arg;
! 180: if (!udf->at) { /* undefined */
! 181: (void) strcpy(&err_str[sizeof(ERR_FUN) - 1],
! 182: udf->udf_name);
! 183: int_error(err_str, NO_CARET);
! 184: }
! 185: save_dummy = udf->dummy_values[0];
! 186: (void) pop(&(udf->dummy_values[0]));
! 187:
! 188: execute_at(udf->at);
! 189: udf->dummy_values[0] = save_dummy;
! 190: }
! 191:
! 192:
! 193: void f_calln(x) /* execute a udf of n variables */
! 194: union argument *x;
! 195: {
! 196: static char err_str[sizeof(ERR_FUN) + MAX_ID_LEN] = ERR_FUN;
! 197: register struct udft_entry *udf;
! 198: struct value save_dummy[MAX_NUM_VAR];
! 199:
! 200: int i;
! 201: int num_pop;
! 202: struct value num_params;
! 203:
! 204: udf = x->udf_arg;
! 205: if (!udf->at) { /* undefined */
! 206: (void) strcpy(&err_str[sizeof(ERR_FUN) - 1],
! 207: udf->udf_name);
! 208: int_error(err_str, NO_CARET);
! 209: }
! 210: for (i = 0; i < MAX_NUM_VAR; i++)
! 211: save_dummy[i] = udf->dummy_values[i];
! 212:
! 213: /* if there are more parameters than the function is expecting */
! 214: /* simply ignore the excess */
! 215: (void) pop(&num_params);
! 216:
! 217: if (num_params.v.int_val > MAX_NUM_VAR) {
! 218: /* pop the dummies that there is no room for */
! 219: num_pop = num_params.v.int_val - MAX_NUM_VAR;
! 220: for (i = 0; i < num_pop; i++)
! 221: (void) pop(&(udf->dummy_values[i]));
! 222:
! 223: num_pop = MAX_NUM_VAR;
! 224: } else {
! 225: num_pop = num_params.v.int_val;
! 226: }
! 227:
! 228: /* pop parameters we can use */
! 229: for (i = num_pop - 1; i >= 0; i--)
! 230: (void) pop(&(udf->dummy_values[i]));
! 231:
! 232: execute_at(udf->at);
! 233: for (i = 0; i < MAX_NUM_VAR; i++)
! 234: udf->dummy_values[i] = save_dummy[i];
! 235: }
! 236:
! 237:
! 238: static void int_check(v)
! 239: struct value *v;
! 240: {
! 241: if (v->type != INTGR)
! 242: int_error("non-integer passed to boolean operator", NO_CARET);
! 243: }
! 244:
! 245:
! 246: void f_lnot()
! 247: {
! 248: struct value a;
! 249: int_check(pop(&a));
! 250: push(Ginteger(&a, !a.v.int_val));
! 251: }
! 252:
! 253:
! 254: void f_bnot()
! 255: {
! 256: struct value a;
! 257: int_check(pop(&a));
! 258: push(Ginteger(&a, ~a.v.int_val));
! 259: }
! 260:
! 261:
! 262: void f_bool()
! 263: { /* converts top-of-stack to boolean */
! 264: int_check(&top_of_stack);
! 265: top_of_stack.v.int_val = !!top_of_stack.v.int_val;
! 266: }
! 267:
! 268:
! 269: void f_lor()
! 270: {
! 271: struct value a, b;
! 272: int_check(pop(&b));
! 273: int_check(pop(&a));
! 274: push(Ginteger(&a, a.v.int_val || b.v.int_val));
! 275: }
! 276:
! 277: void f_land()
! 278: {
! 279: struct value a, b;
! 280: int_check(pop(&b));
! 281: int_check(pop(&a));
! 282: push(Ginteger(&a, a.v.int_val && b.v.int_val));
! 283: }
! 284:
! 285:
! 286: void f_bor()
! 287: {
! 288: struct value a, b;
! 289: int_check(pop(&b));
! 290: int_check(pop(&a));
! 291: push(Ginteger(&a, a.v.int_val | b.v.int_val));
! 292: }
! 293:
! 294:
! 295: void f_xor()
! 296: {
! 297: struct value a, b;
! 298: int_check(pop(&b));
! 299: int_check(pop(&a));
! 300: push(Ginteger(&a, a.v.int_val ^ b.v.int_val));
! 301: }
! 302:
! 303:
! 304: void f_band()
! 305: {
! 306: struct value a, b;
! 307: int_check(pop(&b));
! 308: int_check(pop(&a));
! 309: push(Ginteger(&a, a.v.int_val & b.v.int_val));
! 310: }
! 311:
! 312:
! 313: void f_uminus()
! 314: {
! 315: struct value a;
! 316: (void) pop(&a);
! 317: switch (a.type) {
! 318: case INTGR:
! 319: a.v.int_val = -a.v.int_val;
! 320: break;
! 321: case CMPLX:
! 322: a.v.cmplx_val.real =
! 323: -a.v.cmplx_val.real;
! 324: a.v.cmplx_val.imag =
! 325: -a.v.cmplx_val.imag;
! 326: break;
! 327: BAD_DEFAULT
! 328: }
! 329: push(&a);
! 330: }
! 331:
! 332:
! 333: void f_eq()
! 334: {
! 335: /* note: floating point equality is rare because of roundoff error! */
! 336: struct value a, b;
! 337: register int result = 0;
! 338: (void) pop(&b);
! 339: (void) pop(&a);
! 340: switch (a.type) {
! 341: case INTGR:
! 342: switch (b.type) {
! 343: case INTGR:
! 344: result = (a.v.int_val ==
! 345: b.v.int_val);
! 346: break;
! 347: case CMPLX:
! 348: result = (a.v.int_val ==
! 349: b.v.cmplx_val.real &&
! 350: b.v.cmplx_val.imag == 0.0);
! 351: break;
! 352: BAD_DEFAULT
! 353: }
! 354: break;
! 355: case CMPLX:
! 356: switch (b.type) {
! 357: case INTGR:
! 358: result = (b.v.int_val == a.v.cmplx_val.real &&
! 359: a.v.cmplx_val.imag == 0.0);
! 360: break;
! 361: case CMPLX:
! 362: result = (a.v.cmplx_val.real ==
! 363: b.v.cmplx_val.real &&
! 364: a.v.cmplx_val.imag ==
! 365: b.v.cmplx_val.imag);
! 366: break;
! 367: BAD_DEFAULT
! 368: }
! 369: break;
! 370: BAD_DEFAULT
! 371: }
! 372: push(Ginteger(&a, result));
! 373: }
! 374:
! 375:
! 376: void f_ne()
! 377: {
! 378: struct value a, b;
! 379: register int result = 0;
! 380: (void) pop(&b);
! 381: (void) pop(&a);
! 382: switch (a.type) {
! 383: case INTGR:
! 384: switch (b.type) {
! 385: case INTGR:
! 386: result = (a.v.int_val !=
! 387: b.v.int_val);
! 388: break;
! 389: case CMPLX:
! 390: result = (a.v.int_val !=
! 391: b.v.cmplx_val.real ||
! 392: b.v.cmplx_val.imag != 0.0);
! 393: break;
! 394: BAD_DEFAULT
! 395: }
! 396: break;
! 397: case CMPLX:
! 398: switch (b.type) {
! 399: case INTGR:
! 400: result = (b.v.int_val !=
! 401: a.v.cmplx_val.real ||
! 402: a.v.cmplx_val.imag != 0.0);
! 403: break;
! 404: case CMPLX:
! 405: result = (a.v.cmplx_val.real !=
! 406: b.v.cmplx_val.real ||
! 407: a.v.cmplx_val.imag !=
! 408: b.v.cmplx_val.imag);
! 409: break;
! 410: BAD_DEFAULT
! 411: }
! 412: break;
! 413: BAD_DEFAULT
! 414: }
! 415: push(Ginteger(&a, result));
! 416: }
! 417:
! 418:
! 419: void f_gt()
! 420: {
! 421: struct value a, b;
! 422: register int result = 0;
! 423: (void) pop(&b);
! 424: (void) pop(&a);
! 425: switch (a.type) {
! 426: case INTGR:
! 427: switch (b.type) {
! 428: case INTGR:
! 429: result = (a.v.int_val >
! 430: b.v.int_val);
! 431: break;
! 432: case CMPLX:
! 433: result = (a.v.int_val >
! 434: b.v.cmplx_val.real);
! 435: break;
! 436: BAD_DEFAULT
! 437: }
! 438: break;
! 439: case CMPLX:
! 440: switch (b.type) {
! 441: case INTGR:
! 442: result = (a.v.cmplx_val.real >
! 443: b.v.int_val);
! 444: break;
! 445: case CMPLX:
! 446: result = (a.v.cmplx_val.real >
! 447: b.v.cmplx_val.real);
! 448: break;
! 449: BAD_DEFAULT
! 450: }
! 451: break;
! 452: BAD_DEFAULT
! 453: }
! 454: push(Ginteger(&a, result));
! 455: }
! 456:
! 457:
! 458: void f_lt()
! 459: {
! 460: struct value a, b;
! 461: register int result = 0;
! 462: (void) pop(&b);
! 463: (void) pop(&a);
! 464: switch (a.type) {
! 465: case INTGR:
! 466: switch (b.type) {
! 467: case INTGR:
! 468: result = (a.v.int_val <
! 469: b.v.int_val);
! 470: break;
! 471: case CMPLX:
! 472: result = (a.v.int_val <
! 473: b.v.cmplx_val.real);
! 474: break;
! 475: BAD_DEFAULT
! 476: }
! 477: break;
! 478: case CMPLX:
! 479: switch (b.type) {
! 480: case INTGR:
! 481: result = (a.v.cmplx_val.real <
! 482: b.v.int_val);
! 483: break;
! 484: case CMPLX:
! 485: result = (a.v.cmplx_val.real <
! 486: b.v.cmplx_val.real);
! 487: break;
! 488: BAD_DEFAULT
! 489: }
! 490: break;
! 491: BAD_DEFAULT
! 492: }
! 493: push(Ginteger(&a, result));
! 494: }
! 495:
! 496:
! 497: void f_ge()
! 498: {
! 499: struct value a, b;
! 500: register int result = 0;
! 501: (void) pop(&b);
! 502: (void) pop(&a);
! 503: switch (a.type) {
! 504: case INTGR:
! 505: switch (b.type) {
! 506: case INTGR:
! 507: result = (a.v.int_val >=
! 508: b.v.int_val);
! 509: break;
! 510: case CMPLX:
! 511: result = (a.v.int_val >=
! 512: b.v.cmplx_val.real);
! 513: break;
! 514: BAD_DEFAULT
! 515: }
! 516: break;
! 517: case CMPLX:
! 518: switch (b.type) {
! 519: case INTGR:
! 520: result = (a.v.cmplx_val.real >=
! 521: b.v.int_val);
! 522: break;
! 523: case CMPLX:
! 524: result = (a.v.cmplx_val.real >=
! 525: b.v.cmplx_val.real);
! 526: break;
! 527: BAD_DEFAULT
! 528: }
! 529: break;
! 530: BAD_DEFAULT
! 531: }
! 532: push(Ginteger(&a, result));
! 533: }
! 534:
! 535:
! 536: void f_le()
! 537: {
! 538: struct value a, b;
! 539: register int result = 0;
! 540: (void) pop(&b);
! 541: (void) pop(&a);
! 542: switch (a.type) {
! 543: case INTGR:
! 544: switch (b.type) {
! 545: case INTGR:
! 546: result = (a.v.int_val <=
! 547: b.v.int_val);
! 548: break;
! 549: case CMPLX:
! 550: result = (a.v.int_val <=
! 551: b.v.cmplx_val.real);
! 552: break;
! 553: BAD_DEFAULT
! 554: }
! 555: break;
! 556: case CMPLX:
! 557: switch (b.type) {
! 558: case INTGR:
! 559: result = (a.v.cmplx_val.real <=
! 560: b.v.int_val);
! 561: break;
! 562: case CMPLX:
! 563: result = (a.v.cmplx_val.real <=
! 564: b.v.cmplx_val.real);
! 565: break;
! 566: BAD_DEFAULT
! 567: }
! 568: break;
! 569: BAD_DEFAULT
! 570: }
! 571: push(Ginteger(&a, result));
! 572: }
! 573:
! 574:
! 575: void f_plus()
! 576: {
! 577: struct value a, b, result;
! 578: (void) pop(&b);
! 579: (void) pop(&a);
! 580: switch (a.type) {
! 581: case INTGR:
! 582: switch (b.type) {
! 583: case INTGR:
! 584: (void) Ginteger(&result, a.v.int_val +
! 585: b.v.int_val);
! 586: break;
! 587: case CMPLX:
! 588: (void) Gcomplex(&result, a.v.int_val +
! 589: b.v.cmplx_val.real,
! 590: b.v.cmplx_val.imag);
! 591: break;
! 592: BAD_DEFAULT
! 593: }
! 594: break;
! 595: case CMPLX:
! 596: switch (b.type) {
! 597: case INTGR:
! 598: (void) Gcomplex(&result, b.v.int_val +
! 599: a.v.cmplx_val.real,
! 600: a.v.cmplx_val.imag);
! 601: break;
! 602: case CMPLX:
! 603: (void) Gcomplex(&result, a.v.cmplx_val.real +
! 604: b.v.cmplx_val.real,
! 605: a.v.cmplx_val.imag +
! 606: b.v.cmplx_val.imag);
! 607: break;
! 608: BAD_DEFAULT
! 609: }
! 610: break;
! 611: BAD_DEFAULT
! 612: }
! 613: push(&result);
! 614: }
! 615:
! 616:
! 617: void f_minus()
! 618: {
! 619: struct value a, b, result;
! 620: (void) pop(&b);
! 621: (void) pop(&a); /* now do a - b */
! 622: switch (a.type) {
! 623: case INTGR:
! 624: switch (b.type) {
! 625: case INTGR:
! 626: (void) Ginteger(&result, a.v.int_val -
! 627: b.v.int_val);
! 628: break;
! 629: case CMPLX:
! 630: (void) Gcomplex(&result, a.v.int_val -
! 631: b.v.cmplx_val.real,
! 632: -b.v.cmplx_val.imag);
! 633: break;
! 634: BAD_DEFAULT
! 635: }
! 636: break;
! 637: case CMPLX:
! 638: switch (b.type) {
! 639: case INTGR:
! 640: (void) Gcomplex(&result, a.v.cmplx_val.real -
! 641: b.v.int_val,
! 642: a.v.cmplx_val.imag);
! 643: break;
! 644: case CMPLX:
! 645: (void) Gcomplex(&result, a.v.cmplx_val.real -
! 646: b.v.cmplx_val.real,
! 647: a.v.cmplx_val.imag -
! 648: b.v.cmplx_val.imag);
! 649: break;
! 650: BAD_DEFAULT
! 651: }
! 652: break;
! 653: BAD_DEFAULT
! 654: }
! 655: push(&result);
! 656: }
! 657:
! 658:
! 659: void f_mult()
! 660: {
! 661: struct value a, b, result;
! 662: (void) pop(&b);
! 663: (void) pop(&a); /* now do a*b */
! 664:
! 665: switch (a.type) {
! 666: case INTGR:
! 667: switch (b.type) {
! 668: case INTGR:
! 669: (void) Ginteger(&result, a.v.int_val *
! 670: b.v.int_val);
! 671: break;
! 672: case CMPLX:
! 673: (void) Gcomplex(&result, a.v.int_val *
! 674: b.v.cmplx_val.real,
! 675: a.v.int_val *
! 676: b.v.cmplx_val.imag);
! 677: break;
! 678: BAD_DEFAULT
! 679: }
! 680: break;
! 681: case CMPLX:
! 682: switch (b.type) {
! 683: case INTGR:
! 684: (void) Gcomplex(&result, b.v.int_val *
! 685: a.v.cmplx_val.real,
! 686: b.v.int_val *
! 687: a.v.cmplx_val.imag);
! 688: break;
! 689: case CMPLX:
! 690: (void) Gcomplex(&result, a.v.cmplx_val.real *
! 691: b.v.cmplx_val.real -
! 692: a.v.cmplx_val.imag *
! 693: b.v.cmplx_val.imag,
! 694: a.v.cmplx_val.real *
! 695: b.v.cmplx_val.imag +
! 696: a.v.cmplx_val.imag *
! 697: b.v.cmplx_val.real);
! 698: break;
! 699: BAD_DEFAULT
! 700: }
! 701: break;
! 702: BAD_DEFAULT
! 703: }
! 704: push(&result);
! 705: }
! 706:
! 707:
! 708: void f_div()
! 709: {
! 710: struct value a, b, result;
! 711: register double square;
! 712: (void) pop(&b);
! 713: (void) pop(&a); /* now do a/b */
! 714:
! 715: switch (a.type) {
! 716: case INTGR:
! 717: switch (b.type) {
! 718: case INTGR:
! 719: if (b.v.int_val)
! 720: (void) Ginteger(&result, a.v.int_val /
! 721: b.v.int_val);
! 722: else {
! 723: (void) Ginteger(&result, 0);
! 724: undefined = TRUE;
! 725: }
! 726: break;
! 727: case CMPLX:
! 728: square = b.v.cmplx_val.real *
! 729: b.v.cmplx_val.real +
! 730: b.v.cmplx_val.imag *
! 731: b.v.cmplx_val.imag;
! 732: if (square)
! 733: (void) Gcomplex(&result, a.v.int_val *
! 734: b.v.cmplx_val.real / square,
! 735: -a.v.int_val *
! 736: b.v.cmplx_val.imag / square);
! 737: else {
! 738: (void) Gcomplex(&result, 0.0, 0.0);
! 739: undefined = TRUE;
! 740: }
! 741: break;
! 742: BAD_DEFAULT
! 743: }
! 744: break;
! 745: case CMPLX:
! 746: switch (b.type) {
! 747: case INTGR:
! 748: if (b.v.int_val)
! 749: (void) Gcomplex(&result, a.v.cmplx_val.real /
! 750: b.v.int_val,
! 751: a.v.cmplx_val.imag /
! 752: b.v.int_val);
! 753: else {
! 754: (void) Gcomplex(&result, 0.0, 0.0);
! 755: undefined = TRUE;
! 756: }
! 757: break;
! 758: case CMPLX:
! 759: square = b.v.cmplx_val.real *
! 760: b.v.cmplx_val.real +
! 761: b.v.cmplx_val.imag *
! 762: b.v.cmplx_val.imag;
! 763: if (square)
! 764: (void) Gcomplex(&result, (a.v.cmplx_val.real *
! 765: b.v.cmplx_val.real +
! 766: a.v.cmplx_val.imag *
! 767: b.v.cmplx_val.imag) / square,
! 768: (a.v.cmplx_val.imag *
! 769: b.v.cmplx_val.real -
! 770: a.v.cmplx_val.real *
! 771: b.v.cmplx_val.imag) /
! 772: square);
! 773: else {
! 774: (void) Gcomplex(&result, 0.0, 0.0);
! 775: undefined = TRUE;
! 776: }
! 777: break;
! 778: BAD_DEFAULT
! 779: }
! 780: break;
! 781: BAD_DEFAULT
! 782: }
! 783: push(&result);
! 784: }
! 785:
! 786:
! 787: void f_mod()
! 788: {
! 789: struct value a, b;
! 790: (void) pop(&b);
! 791: (void) pop(&a); /* now do a%b */
! 792:
! 793: if (a.type != INTGR || b.type != INTGR)
! 794: int_error("can only mod ints", NO_CARET);
! 795: if (b.v.int_val)
! 796: push(Ginteger(&a, a.v.int_val % b.v.int_val));
! 797: else {
! 798: push(Ginteger(&a, 0));
! 799: undefined = TRUE;
! 800: }
! 801: }
! 802:
! 803:
! 804: void f_power()
! 805: {
! 806: struct value a, b, result;
! 807: register int i, t, count;
! 808: register double mag, ang;
! 809: (void) pop(&b);
! 810: (void) pop(&a); /* now find a**b */
! 811:
! 812: switch (a.type) {
! 813: case INTGR:
! 814: switch (b.type) {
! 815: case INTGR:
! 816: count = abs(b.v.int_val);
! 817: t = 1;
! 818: /* this ought to use bit-masks and squares, etc */
! 819: for (i = 0; i < count; i++)
! 820: t *= a.v.int_val;
! 821: if (b.v.int_val >= 0)
! 822: (void) Ginteger(&result, t);
! 823: else if (t != 0)
! 824: (void) Gcomplex(&result, 1.0 / t, 0.0);
! 825: else {
! 826: undefined = TRUE;
! 827: (void) Gcomplex(&result, 0.0, 0.0);
! 828: }
! 829: break;
! 830: case CMPLX:
! 831: if (a.v.int_val == 0) {
! 832: if (b.v.cmplx_val.imag != 0 || b.v.cmplx_val.real < 0) {
! 833: undefined = TRUE;
! 834: }
! 835: /* return 1.0 for 0**0 */
! 836: Gcomplex(&result, b.v.cmplx_val.real == 0 ? 1.0 : 0.0, 0.0);
! 837: } else {
! 838: mag =
! 839: pow(magnitude(&a), fabs(b.v.cmplx_val.real));
! 840: if (b.v.cmplx_val.real < 0.0) {
! 841: if (mag != 0.0)
! 842: mag = 1.0 / mag;
! 843: else
! 844: undefined = TRUE;
! 845: }
! 846: mag *= gp_exp(-b.v.cmplx_val.imag * angle(&a));
! 847: ang = b.v.cmplx_val.real * angle(&a) +
! 848: b.v.cmplx_val.imag * log(magnitude(&a));
! 849: (void) Gcomplex(&result, mag * cos(ang),
! 850: mag * sin(ang));
! 851: }
! 852: break;
! 853: BAD_DEFAULT
! 854: }
! 855: break;
! 856: case CMPLX:
! 857: switch (b.type) {
! 858: case INTGR:
! 859: if (a.v.cmplx_val.imag == 0.0) {
! 860: mag = pow(a.v.cmplx_val.real, (double) abs(b.v.int_val));
! 861: if (b.v.int_val < 0) {
! 862: if (mag != 0.0)
! 863: mag = 1.0 / mag;
! 864: else
! 865: undefined = TRUE;
! 866: }
! 867: (void) Gcomplex(&result, mag, 0.0);
! 868: } else {
! 869: /* not so good, but...! */
! 870: mag = pow(magnitude(&a), (double) abs(b.v.int_val));
! 871: if (b.v.int_val < 0) {
! 872: if (mag != 0.0)
! 873: mag = 1.0 / mag;
! 874: else
! 875: undefined = TRUE;
! 876: }
! 877: ang = angle(&a) * b.v.int_val;
! 878: (void) Gcomplex(&result, mag * cos(ang),
! 879: mag * sin(ang));
! 880: }
! 881: break;
! 882: case CMPLX:
! 883: if (a.v.cmplx_val.real == 0 && a.v.cmplx_val.imag == 0) {
! 884: if (b.v.cmplx_val.imag != 0 || b.v.cmplx_val.real < 0) {
! 885: undefined = TRUE;
! 886: }
! 887: /* return 1.0 for 0**0 */
! 888: Gcomplex(&result, b.v.cmplx_val.real == 0 ? 1.0 : 0.0, 0.0);
! 889: } else {
! 890: mag = pow(magnitude(&a), fabs(b.v.cmplx_val.real));
! 891: if (b.v.cmplx_val.real < 0.0) {
! 892: if (mag != 0.0)
! 893: mag = 1.0 / mag;
! 894: else
! 895: undefined = TRUE;
! 896: }
! 897: mag *= gp_exp(-b.v.cmplx_val.imag * angle(&a));
! 898: ang = b.v.cmplx_val.real * angle(&a) +
! 899: b.v.cmplx_val.imag * log(magnitude(&a));
! 900: (void) Gcomplex(&result, mag * cos(ang),
! 901: mag * sin(ang));
! 902: }
! 903: break;
! 904: BAD_DEFAULT
! 905: }
! 906: break;
! 907: BAD_DEFAULT
! 908: }
! 909: push(&result);
! 910: }
! 911:
! 912:
! 913: void f_factorial()
! 914: {
! 915: struct value a;
! 916: register int i;
! 917: register double val = 0.0;
! 918:
! 919: (void) pop(&a); /* find a! (factorial) */
! 920:
! 921: switch (a.type) {
! 922: case INTGR:
! 923: val = 1.0;
! 924: for (i = a.v.int_val; i > 1; i--) /*fpe's should catch overflows */
! 925: val *= i;
! 926: break;
! 927: default:
! 928: int_error("factorial (!) argument must be an integer", NO_CARET);
! 929: return; /* avoid gcc -Wall warning about val */
! 930: }
! 931:
! 932: push(Gcomplex(&a, val, 0.0));
! 933:
! 934: }
! 935:
! 936:
! 937: int f_jump(x)
! 938: union argument *x;
! 939: {
! 940: return (x->j_arg);
! 941: }
! 942:
! 943:
! 944: int f_jumpz(x)
! 945: union argument *x;
! 946: {
! 947: struct value a;
! 948: int_check(&top_of_stack);
! 949: if (top_of_stack.v.int_val) { /* non-zero */
! 950: (void) pop(&a);
! 951: return 1; /* no jump */
! 952: } else
! 953: return (x->j_arg); /* leave the argument on TOS */
! 954: }
! 955:
! 956:
! 957: int f_jumpnz(x)
! 958: union argument *x;
! 959: {
! 960: struct value a;
! 961: int_check(&top_of_stack);
! 962: if (top_of_stack.v.int_val) /* non-zero */
! 963: return (x->j_arg); /* leave the argument on TOS */
! 964: else {
! 965: (void) pop(&a);
! 966: return 1; /* no jump */
! 967: }
! 968: }
! 969:
! 970:
! 971: int f_jtern(x)
! 972: union argument *x;
! 973: {
! 974: struct value a;
! 975:
! 976: int_check(pop(&a));
! 977: if (a.v.int_val)
! 978: return (1); /* no jump; fall through to TRUE code */
! 979: else
! 980: return (x->j_arg); /* go jump to FALSE code */
! 981: }