Newsgroups: comp.sources.unix From: dbell@canb.auug.org.au (David I. Bell) Subject: v27i131: calc-2.9.0 - arbitrary precision C-like programmable calculator, Part04/19 References: <1.755316719.21314@gw.home.vix.com> Sender: unix-sources-moderator@gw.home.vix.com Approved: vixie@gw.home.vix.com Submitted-By: dbell@canb.auug.org.au (David I. Bell) Posting-Number: Volume 27, Issue 131 Archive-Name: calc-2.9.0/part04 #!/bin/sh # this is part 4 of a multipart archive # do not concatenate these parts, unpack them in order with /bin/sh # file calc2.9.0/config.c continued # CurArch=4 if test ! -r s2_seq_.tmp then echo "Please unpack part 1 first!" exit 1; fi ( read Scheck if test "$Scheck" != $CurArch then echo "Please unpack part $Scheck next!" exit 1; else exit 0; fi ) < s2_seq_.tmp || exit 1 echo "x - Continuing file calc2.9.0/config.c" sed 's/^X//' << 'SHAR_EOF' >> calc2.9.0/config.c X maxprint = temp; X break; X X case CONFIG_MUL2: X if (vp->v_type != V_NUM) X math_error("Non-numeric for mul2"); X q = vp->v_num; X temp = qtoi(q); X if (qisfrac(q) || qisneg(q)) X temp = -1; X if (temp == 0) X temp = MUL_ALG2; X if (temp < 2) X math_error("Illegal mul2 value"); X _mul2_ = temp; X break; X X case CONFIG_SQ2: X if (vp->v_type != V_NUM) X math_error("Non-numeric for sq2"); X q = vp->v_num; X temp = qtoi(q); X if (qisfrac(q) || qisneg(q)) X temp = -1; X if (temp == 0) X temp = SQ_ALG2; X if (temp < 2) X math_error("Illegal sq2 value"); X _sq2_ = temp; X break; X X case CONFIG_POW2: X if (vp->v_type != V_NUM) X math_error("Non-numeric for pow2"); X q = vp->v_num; X temp = qtoi(q); X if (qisfrac(q) || qisneg(q)) X temp = -1; X if (temp == 0) X temp = POW_ALG2; X if (temp < 1) X math_error("Illegal pow2 value"); X _pow2_ = temp; X break; X X case CONFIG_REDC2: X if (vp->v_type != V_NUM) X math_error("Non-numeric for redc2"); X q = vp->v_num; X temp = qtoi(q); X if (qisfrac(q) || qisneg(q)) X temp = -1; X if (temp == 0) X temp = REDC_ALG2; X if (temp < 1) X math_error("Illegal redc2 value"); X _redc2_ = temp; X break; X X default: X math_error("Setting illegal config parameter"); X } X} X X X/* X * Get the current value of the specified configuration type. X * An error is generated if the type number is illegal. X */ Xvoid Xgetconfig(type, vp) X VALUE *vp; X{ X switch (type) { X case CONFIG_TRACE: X vp->v_type = V_NUM; X vp->v_num = itoq((long) traceflags); X break; X X case CONFIG_DISPLAY: X vp->v_type = V_NUM; X vp->v_num = itoq(_outdigits_); X break; X X case CONFIG_MODE: X vp->v_type = V_STR; X vp->v_subtype = V_STRLITERAL; X vp->v_str = modename(_outmode_); X break; X X case CONFIG_EPSILON: X vp->v_type = V_NUM; X vp->v_num = qlink(_epsilon_); X break; X X case CONFIG_MAXPRINT: X vp->v_type = V_NUM; X vp->v_num = itoq(maxprint); X break; X X case CONFIG_MUL2: X vp->v_type = V_NUM; X vp->v_num = itoq(_mul2_); X break; X X case CONFIG_SQ2: X vp->v_type = V_NUM; X vp->v_num = itoq(_sq2_); X break; X X case CONFIG_POW2: X vp->v_type = V_NUM; X vp->v_num = itoq(_pow2_); X break; X X case CONFIG_REDC2: X vp->v_type = V_NUM; X vp->v_num = itoq(_redc2_); X break; X X default: X math_error("Getting illegal config parameter"); X } X} X X/* END CODE */ SHAR_EOF echo "File calc2.9.0/config.c is complete" chmod 0644 calc2.9.0/config.c || echo "restore of calc2.9.0/config.c fails" set `wc -c calc2.9.0/config.c`;Sum=$1 if test "$Sum" != "5922" then echo original size 5922, current size $Sum;fi echo "x - extracting calc2.9.0/const.c (Text)" sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/const.c && X/* X * Copyright (c) 1993 David I. Bell X * Permission is granted to use, distribute, or modify this source, X * provided that this copyright notice remains intact. X * X * Constant number storage module. X */ X X#include "calc.h" X X#define CONSTALLOCSIZE 400 /* number of constants to allocate */ X X Xstatic long constcount; /* number of constants defined */ Xstatic long constavail; /* number of constants available */ Xstatic NUMBER **consttable; /* table of constants */ X X X/* X * Read in a constant number and add it to the table of constant numbers, X * creating a new entry if necessary. The incoming number is a string X * value which must have a correct format, otherwise an undefined number X * will result. Returns the index of the number in the constant table. X * Returns zero if the number could not be saved. X */ Xlong Xaddnumber(str) X char *str; /* string representation of number */ X{ X NUMBER *q; X X q = atoq(str); X if (q == NULL) X return 0; X return addqconstant(q); X} X X X/* X * Add a particular number to the constant table. X * Returns the index of the number in the constant table, or zero X * if the number could not be saved. The incoming number if freed X * if it is already in the table. X */ Xlong Xaddqconstant(q) X register NUMBER *q; /* number to be added */ X{ X register NUMBER **tp; /* pointer to current number */ X register NUMBER *t; /* number being tested */ X long index; /* index into constant table */ X long numlen; /* numerator length */ X long denlen; /* denominator length */ X HALF numlow; /* bottom value of numerator */ X HALF denlow; /* bottom value of denominator */ X X numlen = q->num.len; X denlen = q->den.len; X numlow = q->num.v[0]; X denlow = q->den.v[0]; X tp = &consttable[1]; X for (index = 1; index <= constcount; index++) { X t = *tp++; X if ((numlen != t->num.len) || (numlow != t->num.v[0])) X continue; X if ((denlen != t->den.len) || (denlow != t->den.v[0])) X continue; X if (q->num.sign != t->num.sign) X continue; X if (qcmp(q, t) == 0) { X qfree(q); X return index; X } X } X if (constavail <= 0) { X if (consttable == NULL) { X tp = (NUMBER **) X malloc(sizeof(NUMBER *) * (CONSTALLOCSIZE + 1)); X *tp = NULL; X } else X tp = (NUMBER **) realloc((char *) consttable, X sizeof(NUMBER *) * (constcount+CONSTALLOCSIZE + 1)); X if (tp == NULL) X return 0; X consttable = tp; X constavail = CONSTALLOCSIZE; X } X constavail--; X constcount++; X consttable[constcount] = q; X return constcount; X} X X X/* X * Return the value of a constant number given its index. X * Returns address of the number, or NULL if the index is illegal. X */ XNUMBER * Xconstvalue(index) X long index; X{ X if ((index <= 0) || (index > constcount)) X return NULL; X return consttable[index]; X} X X/* END CODE */ SHAR_EOF chmod 0644 calc2.9.0/const.c || echo "restore of calc2.9.0/const.c fails" set `wc -c calc2.9.0/const.c`;Sum=$1 if test "$Sum" != "2709" then echo original size 2709, current size $Sum;fi echo "x - extracting calc2.9.0/endian.c (Text)" sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/endian.c && X/* X * endian - Determine the byte order of a long on your machine. X * X * Big Endian: Amdahl, 68k, Pyramid, Mips, Sparc, ... X * Little Endian: Vax, 32k, Spim (Dec Mips), i386, i486, ... X */ X/* X * Copyright (c) 1993 by Landon Curt Noll. All Rights Reserved. X * X * Permission to use, copy, modify, and distribute this software and X * its documentation for any purpose and without fee is hereby granted, X * provided that the above copyright, this permission notice and text X * this comment, and the disclaimer below appear in all of the following: X * X * supporting documentation X * source copies X * source works derived from this source X * binaries derived from this source or from derived source X * X * LANDON CURT NOLL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, X * INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO X * EVENT SHALL LANDON CURT NOLL BE LIABLE FOR ANY SPECIAL, INDIRECT OR X * CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF X * USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR X * OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X * PERFORMANCE OF THIS SOFTWARE. X * X * chongo was here /\../\ X */ X X#include X X/* byte order array */ Xchar byte[8] = { (char)0x12, (char)0x36, (char)0x48, (char)0x59, X (char)0x01, (char)0x23, (char)0x45, (char)0x67 }; X Xmain() X{ X /* pointers into the byte order array */ X int *intp = (int *)byte; X#if defined(DEBUG) X short *shortp = (short *)byte; X long *longp = (long *)byte; X X printf("byte: %02x %02x %02x %02x %02x %02x %02x %02x\n", X byte[0], byte[1], byte[2], byte[3], X byte[4], byte[5], byte[6], byte[7]); X printf("short: %04x %04x %04x %04x\n", X shortp[0], shortp[1], shortp[2], shortp[3]); X printf("int: %08x %08x\n", X intp[0], intp[1]); X printf("long: %08x %08x\n", X longp[0], longp[1]); X#endif X X /* Print the standard defines */ X printf("#define BIG_ENDIAN\t4321\n"); X printf("#define LITTLE_ENDIAN\t1234\n"); X X /* Determine byte order */ X if (intp[0] == 0x12364859) { X /* Most Significant Byte first */ X printf("#define BYTE_ORDER\tBIG_ENDIAN\n"); X } else if (intp[0] == 0x59483612) { X /* Least Significant Byte first */ X printf("#define BYTE_ORDER\tLITTLE_ENDIAN\n"); X } else { X fprintf(stderr, "Unknown int Byte Order, set BYTE_ORDER in Makefile\n"); X exit(1); X } X exit(0); X} SHAR_EOF chmod 0444 calc2.9.0/endian.c || echo "restore of calc2.9.0/endian.c fails" set `wc -c calc2.9.0/endian.c`;Sum=$1 if test "$Sum" != "2412" then echo original size 2412, current size $Sum;fi echo "x - extracting calc2.9.0/file.c (Text)" sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/file.c && X/* X * Copyright (c) 1993 David I. Bell X * Permission is granted to use, distribute, or modify this source, X * provided that this copyright notice remains intact. X * X * File I/O routines callable by users. X */ X X#include "stdarg.h" X#include "calc.h" X X X#define READSIZE 1024 /* buffer size for reading */ X X/* X * Definition of opened files. X */ Xtypedef struct { X FILEID id; /* id to identify this file */ X FILE *fp; /* real file structure for I/O */ X char *name; /* file name */ X BOOL reading; /* TRUE if opened for reading */ X BOOL writing; /* TRUE if opened for writing */ X char *mode; /* open mode */ X} FILEIO; X X X/* X * Table of opened files. X * The first three entries always correspond to stdin, stdout, and stderr, X * and cannot be closed. Their file ids are always 0, 1, and 2. X */ Xstatic FILEIO files[MAXFILES] = { X FILEID_STDIN, stdin, "(stdin)", TRUE, FALSE, "reading", X FILEID_STDOUT, stdout, "(stdout)", FALSE, TRUE, "writing", X FILEID_STDERR, stderr, "(stderr)", FALSE, TRUE, "writing" X}; X Xstatic FILEID lastid = FILEID_STDERR; /* last allocated file id */ X X X X/* X * Open the specified file name for reading or writing as determined by X * the specified mode ("r", "w", or "a"). Returns a file id which can be X * used to do I/O to the file, or else FILEID_NONE if the open failed. X * Aborts with an error if too many files are opened or the mode is illegal. X */ XFILEID Xopenid(name, mode) X char *name; /* file name */ X char *mode; /* open mode */ X{ X FILEIO *fiop; /* file structure */ X FILEID id; /* new file id */ X int count; X X if (((*mode != 'r') && (*mode != 'w') && (*mode != 'a')) || mode[1]) X math_error("Illegal mode for fopen"); X X count = MAXFILES; X do { X if (--count < 0) X math_error("Too many open files"); X id = ++lastid; X fiop = &files[id % MAXFILES]; X X } while (fiop->reading || fiop->writing); X X fiop->name = (char *)malloc(strlen(name) + 1); X if (fiop->name == NULL) { X lastid--; X math_error("No memory for filename"); X } X strcpy(fiop->name, name); X X fiop->fp = f_open(name, mode); X if (fiop->fp == NULL) { X free(fiop->name); X fiop->name = NULL; X lastid--; X return FILEID_NONE; X } X X switch (*mode) { X case 'r': X fiop->mode = "reading"; X fiop->reading = TRUE; X break; X case 'w': X fiop->mode = "writing"; X fiop->writing = TRUE; X break; X case 'a': X fiop->mode = "appending"; X fiop->writing = TRUE; X break; X } X X fiop->id = id; X X return id; X} X X X/* X * Find the file I/O structure for the specified file id, and verify that X * it is opened in the required manner ('r' for reading or 'w' for writing). X * If mode is 0, then no open checks are made at all, and NULL is then X * returned if the id represents a closed file. X */ Xstatic FILEIO * Xfindid(id, mode) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X char *msg; X BOOL flag; X X if ((id < 0) || (id > lastid)) X math_error("Illegal file id"); X X fiop = &files[id % MAXFILES]; X X switch (mode) { X case 'r': X msg = "Reading from"; X flag = fiop->reading; X break; X case 'w': X msg = "Writing to"; X flag = fiop->writing; X break; X case 0: X msg = NULL; X break; X default: X math_error("Unknown findid mode"); X } X X if (fiop->id != id) { X if (msg) X math_error("%s closed file", msg); X return NULL; X } X X if (msg && !flag) X math_error("%s file not opened that way", msg); X X return fiop; X} X X X/* X * Return whether or not a file id is valid. This is used for if tests. X */ XBOOL Xvalidid(id) X FILEID id; X{ X return (findid(id, 0) != NULL); X} X X X/* X * Return the file id for the entry in the file table at the specified index. X * Returns FILEID_NONE if the index is illegal or the file is closed. X */ XFILEID Xindexid(index) X long index; X{ X FILEIO *fiop; /* file structure */ X X if ((index < 0) || (index >= MAXFILES)) X return FILEID_NONE; X X fiop = &files[index]; X if (fiop->reading || fiop->writing) X return fiop->id; X X return FILEID_NONE; X} X X X/* X * Close the specified file id. Returns TRUE if there was an error. X * Closing of stdin, stdout, or stderr is illegal, but closing of already X * closed files is allowed. X */ XBOOL Xcloseid(id) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X int err; X X if ((id == FILEID_STDIN) || (id == FILEID_STDOUT) || X (id == FILEID_STDERR)) X math_error("Cannot close stdin, stdout, or stderr"); X X fiop = findid(id, 0); X if (fiop == NULL) X return FALSE; X X fiop->id = FILEID_NONE; X if (!fiop->reading && !fiop->writing) X math_error("Closing non-opened file"); X fiop->reading = FALSE; X fiop->writing = FALSE; X X if (fiop->name) X free(fiop->name); X fiop->name = NULL; X X err = ferror(fiop->fp); X err |= fclose(fiop->fp); X fiop->fp = NULL; X X return (err != 0); X} X X X/* X * Return whether or not an error occurred to a file. X */ XBOOL Xerrorid(id) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X X fiop = findid(id, 0); X if (fiop == NULL) X math_error("Closed file for ferror"); X return (ferror(fiop->fp) != 0); X} X X X/* X * Return whether or not end of file occurred to a file. X */ XBOOL Xeofid(id) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X X fiop = findid(id, 0); X if (fiop == NULL) X math_error("Closed file for feof"); X return (feof(fiop->fp) != 0); X} X X X/* X * Flush output to an opened file. X */ Xvoid Xflushid(id) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X X fiop = findid(id, 'w'); X fflush(fiop->fp); X} X X X/* X * Read the next line from an opened file. X * Returns a pointer to an allocated string holding the null-terminated X * line (without any terminating newline), or else a NULL pointer on an X * end of file or error. X */ Xvoid Xreadid(id, retptr) X FILEID id; /* file to read from */ X char **retptr; /* returned pointer to string */ X{ X FILEIO *fiop; /* file structure */ X char *str; /* current string */ X int len; /* current length of string */ X int totlen; /* total length of string */ X char buf[READSIZE]; /* temporary buffer */ X X totlen = 0; X str = NULL; X X fiop = findid(id, 'r'); X X while (fgets(buf, READSIZE, fiop->fp) && buf[0]) { X len = strlen(buf); X if (totlen) X str = (char *)realloc(str, totlen + len + 1); X else X str = (char *)malloc(len + 1); X if (str == NULL) X math_error("No memory in freadline"); X strcpy(&str[totlen], buf); X totlen += len; X if (buf[len - 1] == '\n') { X str[totlen - 1] = '\0'; X *retptr = str; X return; X } X } X if (totlen && ferror(fiop->fp)) { X free(str); X str = NULL; X } X *retptr = str; X} X X X/* X * Return the next character from an opened file. X * Returns EOF if there was an error or end of file. X */ Xint Xgetcharid(id) X FILEID id; X{ X return fgetc(findid(id, 'r')->fp); X} X X X/* X * Print out the name of an opened file. X * If the file has been closed, a null name is printed. X * If flags contain PRINT_UNAMBIG then extra information is printed X * identifying the output as a file and some data about it. X */ Xvoid Xprintid(id, flags) X FILEID id; X{ X FILEIO *fiop; /* file structure */ X FILE *fp; X X fiop = findid(id, 0); X if (fiop == NULL) { X math_str((flags & PRINT_UNAMBIG) ? "FILE (closed)" : "\"\""); X return; X } X if ((flags & PRINT_UNAMBIG) == 0) { X math_chr('"'); X math_str(fiop->name); X math_chr('"'); X return; X } X X fp = fiop->fp; X math_fmt("FILE \"%s\" (%s, pos %ld", fiop->name, fiop->mode, X ftell(fp)); X if (ferror(fp)) X math_str(", error"); X if (feof(fp)) X math_str(", eof"); X math_chr(')'); X} X X X/* X * Print a formatted string similar to printf. Various formats of output X * are possible, depending on the format string AND the actual types of the X * values. Mismatches do not cause errors, instead something reasonable is X * printed instead. The output goes to the file with the specified id. X */ Xvoid Xidprintf(id, fmt, count, vals) X FILEID id; /* file id to print to */ X char *fmt; /* standard format string */ X VALUE **vals; /* table of values to print */ X{ X FILEIO *fiop; X VALUE *vp; X char *str; X int ch, len; X int oldmode, newmode; X long olddigits, newdigits; X long width, precision; X BOOL didneg, didprecision; X X fiop = findid(id, 'w'); X X math_setfp(fiop->fp); X X while ((ch = *fmt++) != '\0') { X if (ch == '\\') { X ch = *fmt++; X switch (ch) { X case 'n': ch = '\n'; break; X case 'r': ch = '\r'; break; X case 't': ch = '\t'; break; X case 'f': ch = '\f'; break; X case 'v': ch = '\v'; break; X case 'b': ch = '\b'; break; X case 0: X math_setfp(stdout); X return; X } X math_chr(ch); X continue; X } X X if (ch != '%') { X math_chr(ch); X continue; X } X X /* X * Here to handle formats. X */ X didneg = FALSE; X didprecision = FALSE; X width = 0; X precision = 0; X X ch = *fmt++; X if (ch == '-') { X didneg = TRUE; X ch = *fmt++; X } X while ((ch >= '0') && (ch <= '9')) { X width = width * 10 + (ch - '0'); X ch = *fmt++; X } X if (ch == '.') { X didprecision = TRUE; X ch = *fmt++; X while ((ch >= '0') && (ch <= '9')) { X precision = precision * 10 + (ch - '0'); X ch = *fmt++; X } X } X if (ch == 'l') X ch = *fmt++; X X oldmode = _outmode_; X newmode = oldmode; X olddigits = _outdigits_; X newdigits = olddigits; X if (didprecision) X newdigits = precision; X X switch (ch) { X case 'd': X case 's': X case 'c': X break; X case 'f': X newmode = MODE_REAL; X break; X case 'e': X newmode = MODE_EXP; X break; X case 'r': X newmode = MODE_FRAC; X break; X case 'o': X newmode = MODE_OCTAL; X break; X case 'x': X newmode = MODE_HEX; X break; X case 'b': X newmode = MODE_BINARY; X break; X case 0: X math_setfp(stdout); X return; X default: X math_chr(ch); X continue; X } X X if (--count < 0) X math_error("Not enough arguments for fprintf"); X vp = *vals++; X X math_setdigits(newdigits); X math_setmode(newmode); X X /* X * If there is no width specification, or if the type of X * value requires multiple lines, then just output the X * value directly. X */ X if ((width == 0) || X (vp->v_type == V_MAT) || (vp->v_type == V_LIST)) X { X printvalue(vp, PRINT_NORMAL); X math_setmode(oldmode); X math_setdigits(olddigits); X continue; X } X X /* X * There is a field width. Collect the output in a string, X * print it padded appropriately with spaces, and free it. X * However, if the output contains a newline, then ignore X * the field width. X */ X math_divertio(); X printvalue(vp, PRINT_NORMAL); X str = math_getdivertedio(); X if (strchr(str, '\n')) X width = 0; X len = strlen(str); X while (!didneg && (width > len)) { X width--; X math_chr(' '); X } X math_str(str); X free(str); X while (didneg && (width > len)) { X width--; X math_chr(' '); X } X math_setmode(oldmode); X math_setdigits(olddigits); X } X math_setfp(stdout); X} X X/* END CODE */ SHAR_EOF chmod 0644 calc2.9.0/file.c || echo "restore of calc2.9.0/file.c fails" set `wc -c calc2.9.0/file.c`;Sum=$1 if test "$Sum" != "10532" then echo original size 10532, current size $Sum;fi echo "x - extracting calc2.9.0/func.c (Text)" sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/func.c && X/* X * Copyright (c) 1993 David I. Bell X * Permission is granted to use, distribute, or modify this source, X * provided that this copyright notice remains intact. X * X * Built-in functions implemented here X */ X X#include X#include X#include X X#include "calc.h" X#include "opcodes.h" X#include "token.h" X#include "func.h" X#include "string.h" X#include "symbol.h" X X X/* if HZ & CLK_TCK are not defined, pick typical values, hope for the best */ X#if !defined(HZ) X# define HZ 60 X#endif X#if !defined(CLK_TCK) X# undef CLK_TCK X# define CLK_TCK HZ X#endif X Xextern int errno; X X X/* X * Totally numeric functions. X */ Xstatic NUMBER *f_cfsim(); /* simplify number using continued fractions */ Xstatic NUMBER *f_ilog(); /* return log of one number to another */ Xstatic NUMBER *f_faccnt(); /* count of divisions */ Xstatic NUMBER *f_min(); /* minimum of several arguments */ Xstatic NUMBER *f_max(); /* maximum of several arguments */ Xstatic NUMBER *f_hmean(); /* harmonic mean */ Xstatic NUMBER *f_trunc(); /* truncate number to specified decimal places */ Xstatic NUMBER *f_btrunc(); /* truncate number to specified binary places */ Xstatic NUMBER *f_gcd(); /* greatest common divisor */ Xstatic NUMBER *f_lcm(); /* least common multiple */ Xstatic NUMBER *f_xor(); /* xor of several arguments */ Xstatic NUMBER *f_ceil(); /* ceiling of a fraction */ Xstatic NUMBER *f_floor(); /* floor of a fraction */ Xstatic NUMBER *f_meq(); /* numbers are same modular value */ Xstatic NUMBER *f_isrel(); /* two numbers are relatively prime */ Xstatic NUMBER *f_ismult(); /* whether one number divides another */ Xstatic NUMBER *f_mne(); /* whether a and b are not equal modulo c */ Xstatic NUMBER *f_isset(); /* tests if a bit of a num (base 2) is set */ Xstatic NUMBER *f_highbit(); /* high bit number in base 2 representation */ Xstatic NUMBER *f_lowbit(); /* low bit number in base 2 representation */ Xstatic NUMBER *f_near(); /* whether two numbers are near each other */ Xstatic NUMBER *f_legtoleg(); /* positive form of leg to leg */ Xstatic NUMBER *f_ilog10(); /* integer log of number base 10 */ Xstatic NUMBER *f_ilog2(); /* integer log of number base 2 */ Xstatic NUMBER *f_digits(); /* number of digits of number */ Xstatic NUMBER *f_digit(); /* digit at specified decimal place of number */ Xstatic NUMBER *f_places(); /* number of decimal places of number */ Xstatic NUMBER *f_primetest(); /* primality test */ Xstatic NUMBER *f_issquare(); /* whether number is a square */ Xstatic NUMBER *f_runtime(); /* user runtime in seconds */ X X X/* X * General functions. X */ Xstatic VALUE f_hash(); /* produce hash from values */ Xstatic VALUE f_bround(); /* round number to specified binary places */ Xstatic VALUE f_round(); /* round number to specified decimal places */ Xstatic VALUE f_det(); /* determinant of matrix */ Xstatic VALUE f_mattrans(); /* return transpose of matrix */ Xstatic VALUE f_matdim(); /* dimension of matrix */ Xstatic VALUE f_matmax(); /* maximum index of matrix dimension */ Xstatic VALUE f_matmin(); /* minimum index of matrix dimension */ Xstatic VALUE f_matfill(); /* fill matrix with values */ Xstatic VALUE f_listpush(); /* push element onto front of list */ Xstatic VALUE f_listpop(); /* pop element from front of list */ Xstatic VALUE f_listappend(); /* append element to end of list */ Xstatic VALUE f_listremove(); /* remove element from end of list */ Xstatic VALUE f_listinsert(); /* insert element into list */ Xstatic VALUE f_listdelete(); /* delete element from list */ Xstatic VALUE f_strlen(); /* length of string */ Xstatic VALUE f_char(); /* character value of integer */ Xstatic VALUE f_substr(); /* extract substring */ Xstatic VALUE f_strcat(); /* concatenate strings */ Xstatic VALUE f_ord(); /* get ordinal value for character */ Xstatic VALUE f_avg(); /* average of several arguments */ Xstatic VALUE f_ssq(); /* sum of squares */ Xstatic VALUE f_poly(); /* result of evaluating polynomial */ Xstatic VALUE f_sqrt(); /* square root of a number */ Xstatic VALUE f_root(); /* number taken to root of another */ Xstatic VALUE f_exp(); /* complex exponential */ Xstatic VALUE f_ln(); /* complex natural logarithm */ Xstatic VALUE f_power(); /* one value to another power */ Xstatic VALUE f_cos(); /* complex cosine */ Xstatic VALUE f_sin(); /* complex sine */ Xstatic VALUE f_polar(); /* polar representation of complex number */ Xstatic VALUE f_arg(); /* argument of complex number */ Xstatic VALUE f_list(); /* create a list */ Xstatic VALUE f_size(); /* number of elements in object */ Xstatic VALUE f_search(); /* search matrix or list for match */ Xstatic VALUE f_rsearch(); /* search matrix or list backwards for match */ Xstatic VALUE f_cp(); /* cross product of vectors */ Xstatic VALUE f_dp(); /* dot product of vectors */ Xstatic VALUE f_prompt(); /* prompt for input line */ Xstatic VALUE f_eval(); /* evaluate string into value */ Xstatic VALUE f_str(); /* convert value to string */ Xstatic VALUE f_fopen(); /* open file for reading or writing */ Xstatic VALUE f_fprintf(); /* print data to file */ Xstatic VALUE f_strprintf(); /* return printed data as a string */ Xstatic VALUE f_fgetline(); /* read next line from file */ Xstatic VALUE f_fgetc(); /* read next char from file */ Xstatic VALUE f_fflush(); /* flush output to file */ Xstatic VALUE f_printf(); /* print data to stdout */ Xstatic VALUE f_fclose(); /* close file */ Xstatic VALUE f_ferror(); /* whether error occurred */ Xstatic VALUE f_feof(); /* whether end of file reached */ Xstatic VALUE f_files(); /* return file handle or number of files */ Xstatic VALUE f_assoc(); /* return a new association value */ X X X#define IN 100 /* maximum number of arguments */ X#define FE 0x01 /* flag to indicate default epsilon argument */ X#define FA 0x02 /* preserve addresses of variables */ X X X/* X * List of primitive built-in functions X */ Xstatic struct builtin { X char *b_name; /* name of built-in function */ X short b_minargs; /* minimum number of arguments */ X short b_maxargs; /* maximum number of arguments */ X short b_flags; /* special handling flags */ X short b_opcode; /* opcode which makes the call quick */ X NUMBER *(*b_numfunc)(); /* routine to calculate numeric function */ X VALUE (*b_valfunc)(); /* routine to calculate general values */ X char *b_desc; /* description of function */ X} builtins[] = { X "abs", 1, 2, 0, OP_ABS, 0, 0, "absolute value within accuracy b", X "acos", 1, 2, FE, OP_NOP, qacos, 0, "arccosine of a within accuracy b", X "acosh", 1, 2, FE, OP_NOP, qacosh, 0, "hyperbolic arccosine of a within accuracy b", X "append", 2, 2, FA, OP_NOP, 0, f_listappend, "append value to end of list", X "appr", 1, 2, FE, OP_NOP, qbappr, 0, "approximate a with simpler fraction to within b", X "arg", 1, 2, 0, OP_NOP, 0, f_arg, "argument (the angle) of complex number", X "asin", 1, 2, FE, OP_NOP, qasin, 0, "arcsine of a within accuracy b", X "asinh", 1, 2, FE, OP_NOP, qasinh, 0, "hyperbolic arcsine of a within accuracy b", X "assoc", 0, 0, 0, OP_NOP, 0, f_assoc, "create new association array", X "atan", 1, 2, FE, OP_NOP, qatan, 0, "arctangent of a within accuracy b", X "atan2", 2, 3, FE, OP_NOP, qatan2, 0, "angle to point (b,a) within accuracy c", X "atanh", 1, 2, FE, OP_NOP, qatanh, 0, "hyperbolic arctangent of a within accuracy b", X "avg", 1, IN, 0, OP_NOP, 0, f_avg, "arithmetic mean of values", X "bround", 1, 2, 0, OP_NOP, 0, f_bround, "round value a to b number of binary places", X "btrunc", 1, 2, 0, OP_NOP, f_btrunc, 0, "truncate a to b number of binary places", X "ceil", 1, 1, 0, OP_NOP, f_ceil, 0, "smallest integer greater than or equal to number", X "cfappr", 1, 2, FE, OP_NOP, qcfappr, 0, "approximate a within accuracy b using continued fractions", X "cfsim", 1, 1, 0, OP_NOP, f_cfsim, 0, "simplify number using continued fractions", X "char", 1, 1, 0, OP_NOP, 0, f_char, "character corresponding to integer value", X "cmp", 2, 2, 0, OP_CMP, 0, 0, "compare values returning -1, 0, or 1", X "comb", 2, 2, 0, OP_NOP, qcomb, 0, "combinatorial number a!/b!(a-b)!", X "config", 1, 2, 0, OP_SETCONFIG, 0, 0, "set or read configuration value", X "conj", 1, 1, 0, OP_CONJUGATE, 0, 0, "complex conjugate of value", X "cos", 1, 2, 0, OP_NOP, 0, f_cos, "cosine of value a within accuracy b", X "cosh", 1, 2, FE, OP_NOP, qcosh, 0, "hyperbolic cosine of a within accuracy b", X "cp", 2, 2, 0, OP_NOP, 0, f_cp, "Cross product of two vectors", X "delete", 2, 2, FA, OP_NOP, 0, f_listdelete, "delete element from list a at position b", X "den", 1, 1, 0, OP_DENOMINATOR, qden, 0, "denominator of fraction", X "det", 1, 1, 0, OP_NOP, 0, f_det, "determinant of matrix", X "digit", 2, 2, 0, OP_NOP, f_digit, 0, "digit at specified decimal place of number", X "digits", 1, 1, 0, OP_NOP, f_digits, 0, "number of digits in number", X "dp", 2, 2, 0, OP_NOP, 0, f_dp, "Dot product of two vectors", X "epsilon", 0, 1, 0, OP_SETEPSILON, 0, 0, "set or read allowed error for real calculations", X "eval", 1, 1, 0, OP_NOP, 0, f_eval, "Evaluate expression from string to value", X "exp", 1, 2, 0, OP_NOP, 0, f_exp, "exponential of value a within accuracy b", X "fcnt", 2, 2, 0, OP_NOP, f_faccnt, 0, "count of times one number divides another", X "fib", 1, 1, 0, OP_NOP, qfib, 0, "fibonacci number F(n)", X "frem", 2, 2, 0, OP_NOP, qfacrem, 0, "number with all occurances of factor removed", X "fact", 1, 1, 0, OP_NOP, qfact, 0, "factorial", X "fclose", 1, 1, 0, OP_NOP, 0, f_fclose, "close file", X "feof", 1, 1, 0, OP_NOP, 0, f_feof, "whether EOF reached for file", X "ferror", 1, 1, 0, OP_NOP, 0, f_ferror, "whether error occurred for file", X "fflush", 1, 1, 0, OP_NOP, 0, f_fflush, "flush output to file", X "fgetc", 1, 1, 0, OP_NOP, 0, f_fgetc, "read next char from file", X "fgetline", 1, 1, 0, OP_NOP, 0, f_fgetline, "read next line from file", X "files", 0, 1, 0, OP_NOP, 0, f_files, "return opened file or max number of opened files", X "floor", 1, 1, 0, OP_NOP, f_floor, 0, "greatest integer less than or equal to number", X "fopen", 2, 2, 0, OP_NOP, 0, f_fopen, "open file name a in mode b", X "fprintf", 2, IN, 0, OP_NOP, 0, f_fprintf, "print formatted output to opened file", X "frac", 1, 1, 0, OP_FRAC, qfrac, 0, "fractional part of value", X "gcd", 1, IN, 0, OP_NOP, f_gcd, 0, "greatest common divisor", X "gcdrem", 2, 2, 0, OP_NOP, qgcdrem, 0, "a divided repeatedly by gcd with b", X "hash", 1, IN, 0, OP_NOP, 0, f_hash, "return non-negative hash value for one or more values", X "highbit", 1, 1, 0, OP_NOP, f_highbit, 0, "high bit number in base 2 representation", X "hmean", 1, IN, 0, OP_NOP, f_hmean, 0, "harmonic mean of values", X "hypot", 2, 3, FE, OP_NOP, qhypot, 0, "hypotenuse of right triangle within accuracy c", X "ilog", 2, 2, 0, OP_NOP, f_ilog, 0, "integral log of one number with another", X "ilog10", 1, 1, 0, OP_NOP, f_ilog10, 0, "integral log of a number base 10", X "ilog2", 1, 1, 0, OP_NOP, f_ilog2, 0, "integral log of a number base 2", X "im", 1, 1, 0, OP_IM, 0, 0, "imaginary part of complex number", X "insert", 3, 3, FA, OP_NOP, 0, f_listinsert, "insert value c into list a at position b", X "int", 1, 1, 0, OP_INT, qint, 0, "integer part of value", X "inverse", 1, 1, 0, OP_INVERT, 0, 0, "multiplicative inverse of value", X "iroot", 2, 2, 0, OP_NOP, qiroot, 0, "integer b'th root of a", X "isassoc", 1, 1, 0, OP_ISASSOC, 0, 0, "whether a value is an association", X "iseven", 1, 1, 0, OP_ISEVEN, 0, 0, "whether a value is an even integer", X "isfile", 1, 1, 0, OP_ISFILE, 0, 0, "whether a value is a file", X "isint", 1, 1, 0, OP_ISINT, 0, 0, "whether a value is an integer", X "islist", 1, 1, 0, OP_ISLIST, 0, 0, "whether a value is a list", X "ismat", 1, 1, 0, OP_ISMAT, 0, 0, "whether a value is a matrix", X "ismult", 2, 2, 0, OP_NOP, f_ismult, 0, "whether a is a multiple of b", X "isnull", 1, 1, 0, OP_ISNULL, 0, 0, "whether a value is the null value", X "isnum", 1, 1, 0, OP_ISNUM, 0, 0, "whether a value is a number", X "isobj", 1, 1, 0, OP_ISOBJ, 0, 0, "whether a value is an object", X "isodd", 1, 1, 0, OP_ISODD, 0, 0, "whether a value is an odd integer", X "isqrt", 1, 1, 0, OP_NOP, qisqrt, 0, "integer part of square root", X "isreal", 1, 1, 0, OP_ISREAL, 0, 0, "whether a value is a real number", X "isset", 2, 2, 0, OP_NOP, f_isset, 0, "whether bit b of abs(a) (in base 2) is set", X "isstr", 1, 1, 0, OP_ISSTR, 0, 0, "whether a value is a string", X "isrel", 2, 2, 0, OP_NOP, f_isrel, 0, "whether two numbers are relatively prime", X "issimple", 1, 1, 0, OP_ISSIMPLE, 0, 0, "whether value is a simple type", X "issq", 1, 1, 0, OP_NOP, f_issquare, 0, "whether or not number is a square", X "istype", 2, 2, 0, OP_ISTYPE, 0, 0, "whether the type of a is same as the type of b", X "jacobi", 2, 2, 0, OP_NOP, qjacobi, 0, "-1 => a is not quadratic residue mod b\n\t\t 1 => b is composite, or a is quad residue of b", X "lcm", 1, IN, 0, OP_NOP, f_lcm, 0, "least common multiple", X "lcmfact", 1, 1, 0, OP_NOP, qlcmfact, 0, "lcm of all integers up till number", X "lfactor", 2, 2, 0, OP_NOP, qlowfactor, 0, "lowest prime factor of a in first b primes", X "list", 0, IN, 0, OP_NOP, 0, f_list, "create list of specified values", X "ln", 1, 2, 0, OP_NOP, 0, f_ln, "natural logarithm of value a within accuracy b", X "lowbit", 1, 1, 0, OP_NOP, f_lowbit, 0, "low bit number in base 2 representation", X "ltol", 1, 2, FE, OP_NOP, f_legtoleg, 0, "leg-to-leg of unit right triangle (sqrt(1 - a^2))", X "matdim", 1, 1, 0, OP_NOP, 0, f_matdim, "number of dimensions of matrix", X "matfill", 2, 3, FA, OP_NOP, 0, f_matfill, "fill matrix with value b (value c on diagonal)", X "matmax", 2, 2, 0, OP_NOP, 0, f_matmax, "maximum index of matrix a dim b", X "matmin", 2, 2, 0, OP_NOP, 0, f_matmin, "minimum index of matrix a dim b", X "mattrans", 1, 1, 0, OP_NOP, 0, f_mattrans, "transpose of matrix", X "max", 1, IN, 0, OP_NOP, f_max, 0, "maximum value", X "meq", 3, 3, 0, OP_NOP, f_meq, 0, "whether a and b are equal modulo c", X "min", 1, IN, 0, OP_NOP, f_min, 0, "minimum value", X "minv", 2, 2, 0, OP_NOP, qminv, 0, "inverse of a modulo b", X "mmin", 2, 2, 0, OP_NOP, qminmod, 0, "a mod b value with smallest abs value", X "mne", 3, 3, 0, OP_NOP, f_mne, 0, "whether a and b are not equal modulo c", X "near", 2, 3, 0, OP_NOP, f_near, 0, "sign of (abs(a-b) - c)", X "norm", 1, 1, 0, OP_NORM, 0, 0, "norm of a value (square of absolute value)", X "null", 0, 0, 0, OP_UNDEF, 0, 0, "null value", X "num", 1, 1, 0, OP_NUMERATOR, qnum, 0, "numerator of fraction", X "ord", 1, 1, 0, OP_NOP, 0, f_ord, "integer corresponding to character value", X "param", 1, 1, 0, OP_ARGVALUE, 0, 0, "value of parameter n (or parameter count if n is zero)", X "perm", 2, 2, 0, OP_NOP, qperm, 0, "permutation number a!/(a-b)!", X "pfact", 1, 1, 0, OP_NOP, qpfact, 0, "product of primes up till number", X "pi", 0, 1, FE, OP_NOP, qpi, 0, "value of pi accurate to within epsilon", X "places", 1, 1, 0, OP_NOP, f_places, 0, "places after decimal point (-1 if infinite)", X "pmod", 3, 3, 0, OP_NOP, qpowermod,0, "mod of a power (a ^ b (mod c))", X "polar", 2, 3, 0, OP_NOP, 0, f_polar, "complex value of polar coordinate (a * exp(b*1i))", X "poly", 2, IN, 0, OP_NOP, 0, f_poly, "(a1,a2,...,an,x) = a1*x^n+a2*x^(n-1)+...+an", X "pop", 1, 1, FA, OP_NOP, 0, f_listpop, "pop value from front of list", X "power", 2, 3, 0, OP_NOP, 0, f_power, "value a raised to the power b within accuracy c", X "ptest", 2, 2, 0, OP_NOP, f_primetest, 0, "probabilistic primality test", X "printf", 1, IN, 0, OP_NOP, 0, f_printf, "print formatted output to stdout", X "prompt", 1, 1, 0, OP_NOP, 0, f_prompt, "prompt for input line using value a", X "push", 2, 2, FA, OP_NOP, 0, f_listpush, "push value onto front of list", X "quomod", 4, 4, 0, OP_QUOMOD, 0, 0, "set c and d to quotient and remainder of a divided by b", X "rcin", 2, 2, 0, OP_NOP, qredcin, 0, "convert normal number a to REDC number mod b", X "rcmul", 3, 3, 0, OP_NOP, qredcmul, 0, "multiply REDC numbers a and b mod c", X "rcout", 2, 2, 0, OP_NOP, qredcout, 0, "convert REDC number a mod b to normal number", X "rcpow", 3, 3, 0, OP_NOP, qredcpower, 0, "raise REDC number a to power b mod c", X "rcsq", 2, 2, 0, OP_NOP, qredcsquare, 0, "square REDC number a mod b", X "re", 1, 1, 0, OP_RE, 0, 0, "real part of complex number", X "remove", 1, 1, FA, OP_NOP, 0, f_listremove, "remove value from end of list", X "root", 2, 3, 0, OP_NOP, 0, f_root, "value a taken to the b'th root within accuracy c", X "round", 1, 2, 0, OP_NOP, 0, f_round, "round value a to b number of decimal places", X "rsearch", 2, 3, 0, OP_NOP, 0, f_rsearch, "reverse search matrix or list for value b starting at index c", X "runtime", 0, 0, 0, OP_NOP, f_runtime, 0, "user mode cpu time in seconds", X "scale", 2, 2, 0, OP_SCALE, 0, 0, "scale value up or down by a power of two", X "search", 2, 3, 0, OP_NOP, 0, f_search, "search matrix or list for value b starting at index c", X "sgn", 1, 1, 0, OP_SGN, qsign, 0, "sign of value (-1, 0, 1)", X "sin", 1, 2, 0, OP_NOP, 0, f_sin, "sine of value a within accuracy b", X "sinh", 1, 2, FE, OP_NOP, qsinh, 0, "hyperbolic sine of a within accuracy b", X "size", 1, 1, 0, OP_NOP, 0, f_size, "total number of elements in value", X "sqrt", 1, 2, 0, OP_NOP, 0, f_sqrt, "square root of value a within accuracy b", X "ssq", 1, IN, 0, OP_NOP, 0, f_ssq, "sum of squares of values", X "str", 1, 1, 0, OP_NOP, 0, f_str, "simple value converted to string", X "strcat", 1,IN, 0, OP_NOP, 0, f_strcat, "concatenate strings together", X "strlen", 1, 1, 0, OP_NOP, 0, f_strlen, "length of string", X "strprintf", 1, IN, 0, OP_NOP, 0, f_strprintf, "return formatted output as a string", X "substr", 3, 3, 0, OP_NOP, 0, f_substr, "substring of a from position b for c chars", X "swap", 2, 2, 0, OP_SWAP, 0, 0, "swap values of variables a and b (can be dangerous)", X "tan", 1, 2, FE, OP_NOP, qtan, 0, "tangent of a within accuracy b", X "tanh", 1, 2, FE, OP_NOP, qtanh, 0, "hyperbolic tangent of a within accuracy b", X "trunc", 1, 2, 0, OP_NOP, f_trunc, 0, "truncate a to b number of decimal places", X "xor", 1, IN, 0, OP_NOP, f_xor, 0, "logical xor", X NULL, 0, 0, 0, OP_NOP, 0, 0, NULL /* end of table */ X}; X X X/* X * Call a built-in function. X * Arguments to the function are on the stack, but are not removed here. X * Functions are either purely numeric, or else can take any value type. X */ XVALUE Xbuiltinfunc(index, argcount, stck) X long index; X VALUE *stck; /* arguments on the stack */ X{ X VALUE *sp; /* pointer to stack entries */ X VALUE **vpp; /* pointer to current value address */ X struct builtin *bp; /* builtin function to be called */ X long i; /* index */ X NUMBER *numargs[IN]; /* numeric arguments for function */ X VALUE *valargs[IN]; /* addresses of actual arguments */ X VALUE result; /* general result of function */ X X if ((unsigned long)index >= (sizeof(builtins) / sizeof(builtins[0])) - 1) X math_error("Bad built-in function index"); X bp = &builtins[index]; X if (argcount < bp->b_minargs) X math_error("Too few arguments for builtin function \"%s\"", bp->b_name); X if ((argcount > bp->b_maxargs) || (argcount > IN)) X math_error("Too many arguments for builtin function \"%s\"", bp->b_name); X /* X * If an address was passed, then point at the real variable, X * otherwise point at the stack value itself (unless the function X * is very special). X */ X sp = stck - argcount + 1; X vpp = valargs; X for (i = argcount; i > 0; i--) { X if ((sp->v_type != V_ADDR) || (bp->b_flags & FA)) X *vpp = sp; X else X *vpp = sp->v_addr; X sp++; X vpp++; X } X /* X * Handle general values if the function accepts them. X */ X if (bp->b_valfunc) { X vpp = valargs; X if ((bp->b_minargs == 1) && (bp->b_maxargs == 1)) X result = (*bp->b_valfunc)(vpp[0]); X else if ((bp->b_minargs == 2) && (bp->b_maxargs == 2)) X result = (*bp->b_valfunc)(vpp[0], vpp[1]); X else if ((bp->b_minargs == 3) && (bp->b_maxargs == 3)) X result = (*bp->b_valfunc)(vpp[0], vpp[1], vpp[2]); X else X result = (*bp->b_valfunc)(argcount, vpp); X return result; X } X /* X * Function must be purely numeric, so handle that. X */ X vpp = valargs; X for (i = 0; i < argcount; i++) { X if ((*vpp)->v_type != V_NUM) X math_error("Non-real argument for builtin function %s", bp->b_name); X numargs[i] = (*vpp)->v_num; X vpp++; X } X result.v_type = V_NUM; X if (!(bp->b_flags & FE) && (bp->b_minargs != bp->b_maxargs)) { X result.v_num = (*bp->b_numfunc)(argcount, numargs); X return result; X } X if ((bp->b_flags & FE) && (argcount < bp->b_maxargs)) X numargs[argcount++] = _epsilon_; X X switch (argcount) { X case 0: X result.v_num = (*bp->b_numfunc)(); X break; X case 1: X result.v_num = (*bp->b_numfunc)(numargs[0]); X break; X case 2: X result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1]); X break; X case 3: X result.v_num = (*bp->b_numfunc)(numargs[0], numargs[1], numargs[2]); X break; X default: X math_error("Bad builtin function call"); X } X return result; X} X X Xstatic VALUE Xf_eval(vp) X VALUE *vp; X{ X FUNC *oldfunc; X FUNC *newfunc; X VALUE result; X X if (vp->v_type != V_STR) X math_error("Evaluating non-string argument"); X (void) openstring(vp->v_str); X oldfunc = curfunc; X enterfilescope(); X if (evaluate(TRUE)) { X exitfilescope(); X freevalue(stack--); X newfunc = curfunc; X curfunc = oldfunc; X result = newfunc->f_savedvalue; X newfunc->f_savedvalue.v_type = V_NULL; X if (newfunc != oldfunc) X free(newfunc); X return result; X } X exitfilescope(); X newfunc = curfunc; X curfunc = oldfunc; X freevalue(&newfunc->f_savedvalue); X newfunc->f_savedvalue.v_type = V_NULL; X if (newfunc != oldfunc) X free(newfunc); X math_error("Evaluation error"); X /*NOTREACHED*/ X} X X Xstatic VALUE Xf_prompt(vp) X VALUE *vp; X{ X VALUE result; X char *cp; X char *newcp; X X if (inputisterminal()) { X printvalue(vp, PRINT_SHORT); X math_flush(); X } X cp = nextline(); X if (cp == NULL) X math_error("End of file while prompting"); X if (*cp == '\0') { X result.v_type = V_STR; X result.v_subtype = V_STRLITERAL; X result.v_str = ""; X return result; X } X newcp = (char *)malloc(strlen(cp) + 1); X if (newcp == NULL) X math_error("Cannot allocate string"); X strcpy(newcp, cp); X result.v_str = newcp; X result.v_type = V_STR; X result.v_subtype = V_STRALLOC; X return result; X} X X Xstatic VALUE Xf_str(vp) X VALUE *vp; X{ X VALUE result; X char *cp; X X switch (vp->v_type) { X case V_STR: X copyvalue(vp, &result); X return result; X case V_NULL: X result.v_str = ""; X result.v_type = V_STR; X result.v_subtype = V_STRLITERAL; X return result; X case V_NUM: X math_divertio(); X qprintnum(vp->v_num, MODE_DEFAULT); X cp = math_getdivertedio(); X break; X case V_COM: X math_divertio(); X comprint(vp->v_com); X cp = math_getdivertedio(); X break; X default: X math_error("Non-simple type for string conversion"); X } X result.v_str = cp; X result.v_type = V_STR; X result.v_subtype = V_STRALLOC; X return result; X} X X Xstatic VALUE Xf_poly(count, vals) X VALUE **vals; X{ X VALUE *x; X VALUE result, tmp; X X x = vals[--count]; X copyvalue(*vals++, &result); X while (--count > 0) { X mulvalue(&result, x, &tmp); X freevalue(&result); X addvalue(*vals++, &tmp, &result); X freevalue(&tmp); X } X return result; X} X X Xstatic NUMBER * Xf_mne(val1, val2, val3) X NUMBER *val1, *val2, *val3; X{ X return itoq((long) qcmpmod(val1, val2, val3)); X} X X Xstatic NUMBER * Xf_isrel(val1, val2) X NUMBER *val1, *val2; X{ X if (qisfrac(val1) || qisfrac(val2)) X math_error("Non-integer for isrel"); X return itoq((long) zrelprime(val1->num, val2->num)); X} X X Xstatic NUMBER * Xf_issquare(vp) X NUMBER *vp; X{ X return itoq((long) qissquare(vp)); X} X X Xstatic NUMBER * Xf_primetest(val1, val2) X NUMBER *val1, *val2; X{ X return itoq((long) qprimetest(val1, val2)); X} X X Xstatic NUMBER * Xf_isset(val1, val2) X NUMBER *val1, *val2; X{ X if (qisfrac(val2)) X math_error("Non-integral bit position"); X if (qiszero(val1) || (qisint(val1) && qisneg(val2))) X return qlink(&_qzero_); X if (zisbig(val2->num)) { X if (qisneg(val2)) X math_error("Very large bit position"); X return qlink(&_qzero_); X } X return itoq((long) qisset(val1, qtoi(val2))); X} X X Xstatic NUMBER * Xf_digit(val1, val2) X NUMBER *val1, *val2; X{ X if (qisfrac(val2)) X math_error("Non-integral digit position"); X if (qiszero(val1) || (qisint(val1) && qisneg(val2))) X return qlink(&_qzero_); X if (zisbig(val2->num)) { X if (qisneg(val2)) X math_error("Very large digit position"); X return qlink(&_qzero_); X } X return itoq((long) qdigit(val1, qtoi(val2))); X} X X Xstatic NUMBER * Xf_digits(val) X NUMBER *val; X{ X return itoq((long) qdigits(val)); X} X X Xstatic NUMBER * Xf_places(val) X NUMBER *val; X{ X return itoq((long) qplaces(val)); X} X X Xstatic NUMBER * Xf_xor(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp; X X val = qlink(*vals); X while (--count > 0) { X tmp = qxor(val, *++vals); X qfree(val); X val = tmp; X } X return val; X} X X Xstatic NUMBER * Xf_min(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp; X X val = qlink(*vals); X while (--count > 0) { X tmp = qmin(val, *++vals); X qfree(val); X val = tmp; X } X return val; X} X X Xstatic NUMBER * Xf_max(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp; X X val = qlink(*vals); X while (--count > 0) { X tmp = qmax(val, *++vals); X qfree(val); X val = tmp; X } X return val; X} X X Xstatic NUMBER * Xf_gcd(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp; X X val = qlink(*vals); X while (--count > 0) { X tmp = qgcd(val, *++vals); X qfree(val); X val = tmp; X if (qisunit(val)) X break; X } X return val; X} X X Xstatic NUMBER * Xf_lcm(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp; X X val = qlink(*vals); X while (--count > 0) { X tmp = qlcm(val, *++vals); X qfree(val); X val = tmp; X } X return val; X} X X Xstatic VALUE Xf_hash(count, vals) X VALUE **vals; X{ X HASH hash; X long lhash; X VALUE result; X X hash = 0; X while (count-- > 0) X hash = hash * 947369 + hashvalue(*vals++); X lhash = (long) hash; X if (lhash < 0) X lhash = -lhash; X if (lhash < 0) X lhash = 0; X result.v_num = itoq(lhash); X result.v_type = V_NUM; X return result; X} X X Xstatic VALUE Xf_avg(count, vals) X VALUE **vals; X{ X int i; X VALUE result; X VALUE tmp; X VALUE div; X X result.v_num = qlink(&_qzero_); X result.v_type = V_NUM; X for (i = count; i > 0; i--) { X addvalue(&result, *vals++, &tmp); X freevalue(&result); X result = tmp; X } X if (count <= 1) X return result; X div.v_num = itoq((long) count); X div.v_type = V_NUM; X divvalue(&result, &div, &tmp); X qfree(div.v_num); X return tmp; X} X X Xstatic NUMBER * Xf_hmean(count, vals) X NUMBER **vals; X{ X NUMBER *val, *tmp, *tmp2; X X val = qinv(*vals); X while (--count > 0) { X tmp2 = qinv(*++vals); X tmp = qadd(val, tmp2); X qfree(tmp2); X qfree(val); X val = tmp; X } X tmp = qinv(val); X qfree(val); X return tmp; X} X X Xstatic VALUE Xf_ssq(count, vals) X VALUE **vals; X{ X VALUE result, tmp1, tmp2; X X squarevalue(*vals++, &result); X while (--count > 0) { X squarevalue(*vals++, &tmp1); X addvalue(&tmp1, &result, &tmp2); X freevalue(&tmp1); X freevalue(&result); X result = tmp2; X } X return result; X} X X Xstatic NUMBER * Xf_ismult(val1, val2) X NUMBER *val1, *val2; X{ X return itoq((long) qdivides(val1, val2)); X} X X Xstatic NUMBER * Xf_meq(val1, val2, val3) X NUMBER *val1, *val2, *val3; X{ X NUMBER *tmp, *res; X X tmp = qsub(val1, val2); X res = itoq((long) qdivides(tmp, val3)); X qfree(tmp); X return res; X} X X Xstatic VALUE Xf_exp(count, vals) X VALUE **vals; X{ X VALUE result; X NUMBER *err; X X err = _epsilon_; X if (count == 2) { X if (vals[1]->v_type != V_NUM) X math_error("Non-real epsilon value for exp"); X err = vals[1]->v_num; X } X switch (vals[0]->v_type) { X case V_NUM: X result.v_num = qexp(vals[0]->v_num, err); X result.v_type = V_NUM; X break; X case V_COM: X result.v_com = cexp(vals[0]->v_com, err); X result.v_type = V_COM; X break; X default: X math_error("Bad argument type for exp"); X } X return result; X} X X Xstatic VALUE Xf_ln(count, vals) X VALUE **vals; X{ X VALUE result; X COMPLEX ctmp; X NUMBER *err; X X err = _epsilon_; X if (count == 2) { X if (vals[1]->v_type != V_NUM) X math_error("Non-real epsilon value for ln"); X err = vals[1]->v_num; X } X switch (vals[0]->v_type) { X case V_NUM: X if (!qisneg(vals[0]->v_num) && !qiszero(vals[0]->v_num)) { X result.v_num = qln(vals[0]->v_num, err); X result.v_type = V_NUM; X break; X } X ctmp.real = vals[0]->v_num; X ctmp.imag = &_qzero_; X ctmp.links = 1; X result.v_com = cln(&ctmp, err); X result.v_type = V_COM; X break; X case V_COM: X result.v_com = cln(vals[0]->v_com, err); X result.v_type = V_COM; X break; X default: X math_error("Bad argument type for ln"); X } X return result; X} X X Xstatic VALUE Xf_cos(count, vals) X VALUE **vals; X{ X VALUE result; X COMPLEX *c; X NUMBER *err; X X err = _epsilon_; X if (count == 2) { X if (vals[1]->v_type != V_NUM) X math_error("Non-real epsilon value for cos"); X err = vals[1]->v_num; X } X switch (vals[0]->v_type) { X case V_NUM: X result.v_num = qcos(vals[0]->v_num, err); X result.v_type = V_NUM; X break; X case V_COM: X c = ccos(vals[0]->v_com, err); X result.v_com = c; X result.v_type = V_COM; X if (cisreal(c)) { X result.v_num = qlink(c->real); X result.v_type = V_NUM; X comfree(c); X } X break; X default: X math_error("Bad argument type for cos"); X } X return result; X} X X Xstatic VALUE Xf_sin(count, vals) X VALUE **vals; X{ X VALUE result; X COMPLEX *c; X NUMBER *err; X X err = _epsilon_; X if (count == 2) { X if (vals[1]->v_type != V_NUM) X math_error("Non-real epsilon value for sin"); X err = vals[1]->v_num; X } X switch (vals[0]->v_type) { X case V_NUM: X result.v_num = qsin(vals[0]->v_num, err); X result.v_type = V_NUM; X break; X case V_COM: X c = csin(vals[0]->v_com, err); X result.v_com = c; X result.v_type = V_COM; X if (cisreal(c)) { X result.v_num = qlink(c->real); X result.v_type = V_NUM; X comfree(c); X } X break; X default: X math_error("Bad argument type for sin"); X } X return result; X} X X Xstatic VALUE Xf_arg(count, vals) X VALUE **vals; X{ X VALUE result; X COMPLEX *c; X NUMBER *err; X X err = _epsilon_; X if (count == 2) { X if (vals[1]->v_type != V_NUM) X math_error("Non-real epsilon value for arg"); X err = vals[1]->v_num; X } X result.v_type = V_NUM; X switch (vals[0]->v_type) { X case V_NUM: X if (qisneg(vals[0]->v_num)) X result.v_num = qpi(err); X else X result.v_num = qlink(&_qzero_); X break; X case V_COM: X c = vals[0]->v_com; X if (ciszero(c)) X result.v_num = qlink(&_qzero_); X else X result.v_num = qatan2(c->imag, c->real, err); X break; X default: X math_error("Bad argument type for arg"); X } X return result; X} X X Xstatic NUMBER * Xf_legtoleg(val1, val2) X NUMBER *val1, *val2; X{ X return qlegtoleg(val1, val2, FALSE); X} X X Xstatic NUMBER * Xf_trunc(count, vals) X NUMBER **vals; X{ X NUMBER *val; X X val = &_qzero_; X if (count == 2) X val = vals[1]; X return qtrunc(*vals, val); X} X X Xstatic VALUE Xf_bround(count, vals) X VALUE **vals; X{ X VALUE *vp, tmp, res; X X if (count > 1) X vp = vals[1]; X else { X tmp.v_type = V_INT; X tmp.v_num = 0; X vp = &tmp; X } X broundvalue(vals[0], vp, &res); X return res; X} X X Xstatic VALUE Xf_round(count, vals) X VALUE **vals; X{ X VALUE *vp, tmp, res; X X if (count > 1) X vp = vals[1]; X else { X tmp.v_type = V_INT; X tmp.v_num = 0; X vp = &tmp; X } X roundvalue(vals[0], vp, &res); X return res; X} X X Xstatic NUMBER * Xf_btrunc(count, vals) X NUMBER **vals; X{ X NUMBER *val; X X val = &_qzero_; X if (count == 2) X val = vals[1]; X return qbtrunc(*vals, val); X} X X Xstatic NUMBER * Xf_near(count, vals) X NUMBER **vals; X{ X NUMBER *val; X X val = _epsilon_; X if (count == 3) X val = vals[2]; X return itoq((long) qnear(vals[0], vals[1], val)); X} X X Xstatic NUMBER * Xf_cfsim(val) X NUMBER *val; X{ X return qcfappr(val, NULL); X} X X Xstatic NUMBER * Xf_ceil(val) X NUMBER *val; X{ X NUMBER *val2; X X if (qisint(val)) X return qlink(val); X val2 = qint(val); X if (qisneg(val2)) X return val2; X val = qinc(val2); X qfree(val2); X return val; X} X X Xstatic NUMBER * Xf_floor(val) X NUMBER *val; X{ X NUMBER *val2; X X if (qisint(val)) X return qlink(val); X val2 = qint(val); X if (!qisneg(val2)) X return val2; X val = qdec(val2); X qfree(val2); X return val; X} X X Xstatic NUMBER * Xf_highbit(val) X NUMBER *val; X{ X if (qiszero(val)) X math_error("Highbit of zero"); X if (qisfrac(val)) X math_error("Highbit of non-integer"); X return itoq(zhighbit(val->num)); X} X X Xstatic NUMBER * Xf_lowbit(val) X NUMBER *val; X{ X if (qiszero(val)) X math_error("Lowbit of zero"); X if (qisfrac(val)) X math_error("Lowbit of non-integer"); X return itoq(zlowbit(val->num)); X} X X Xstatic VALUE Xf_sqrt(count, vals) X VALUE **vals; X{ X VALUE *vp, err, result; X X if (count > 1) X vp = vals[1]; X else { X err.v_num = _epsilon_; X err.v_type = V_NUM; X vp = &err; X } X sqrtvalue(vals[0], vp, &result); X return result; X} X X Xstatic VALUE Xf_root(count, vals) X VALUE **vals; X{ X VALUE *vp, err, result; X X if (count > 2) X vp = vals[3]; X else { X err.v_num = _epsilon_; X err.v_type = V_NUM; X vp = &err; X } X rootvalue(vals[0], vals[1], vp, &result); X return result; X} X X Xstatic VALUE Xf_power(count, vals) X VALUE **vals; X{ X VALUE *vp, err, result; X X if (count > 2) X vp = vals[2]; X else { X err.v_num = _epsilon_; X err.v_type = V_NUM; X vp = &err; X } X powervalue(vals[0], vals[1], vp, &result); X return result; X} X X Xstatic VALUE Xf_polar(count, vals) X VALUE **vals; X{ X VALUE *vp, err, result; X COMPLEX *c; X X if (count > 2) X vp = vals[2]; X else { X err.v_num = _epsilon_; X err.v_type = V_NUM; X vp = &err; X } X if ((vals[0]->v_type != V_NUM) || (vals[1]->v_type != V_NUM)) X math_error("Non-real argument for polar"); X if ((vp->v_type != V_NUM) || qisneg(vp->v_num) || qiszero(vp->v_num)) X math_error("Bad epsilon value for polar"); X c = cpolar(vals[0]->v_num, vals[1]->v_num, vp->v_num); X result.v_com = c; X result.v_type = V_COM; X if (cisreal(c)) { X result.v_num = qlink(c->real); X result.v_type = V_NUM; X comfree(c); X } X return result; X} X X Xstatic NUMBER * Xf_ilog(val1, val2) X NUMBER *val1, *val2; X{ X return itoq(qilog(val1, val2)); X} X X Xstatic NUMBER * Xf_ilog2(val) X NUMBER *val; X{ X return itoq(qilog2(val)); X} X X Xstatic NUMBER * Xf_ilog10(val) X NUMBER *val; X{ X return itoq(qilog10(val)); X} X X Xstatic NUMBER * Xf_faccnt(val1, val2) X NUMBER *val1, *val2; X{ X return itoq(qdivcount(val1, val2)); X} X X Xstatic VALUE Xf_matfill(count, vals) X VALUE **vals; X{ X VALUE *v1, *v2, *v3; X VALUE result; X X v1 = vals[0]; X v2 = vals[1]; X v3 = (count == 3) ? vals[2] : NULL; X if (v1->v_type != V_ADDR) X math_error("Non-variable argument for matfill"); X v1 = v1->v_addr; X if (v1->v_type != V_MAT) X math_error("Non-matrix for matfill"); X if (v2->v_type == V_ADDR) X v2 = v2->v_addr; X if (v3 && (v3->v_type == V_ADDR)) X v3 = v3->v_addr; X matfill(v1->v_mat, v2, v3); X result.v_type = V_NULL; X return result; X} X X Xstatic VALUE Xf_mattrans(vp) X VALUE *vp; X{ X VALUE result; X X if (vp->v_type != V_MAT) X math_error("Non-matrix argument for mattrans"); X result.v_type = V_MAT; X result.v_mat = mattrans(vp->v_mat); X return result; X} X X Xstatic VALUE Xf_det(vp) X VALUE *vp; X{ X if (vp->v_type != V_MAT) X math_error("Non-matrix argument for det"); X return matdet(vp->v_mat); X} X X Xstatic VALUE Xf_matdim(vp) X VALUE *vp; X{ X VALUE result; X X if (vp->v_type != V_MAT) X math_error("Non-matrix argument for matdim"); X result.v_type = V_NUM; X result.v_num = itoq((long) vp->v_mat->m_dim); X return result; X} X X Xstatic VALUE Xf_matmin(v1, v2) X VALUE *v1, *v2; X{ X VALUE result; X NUMBER *q; X long i; X X if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM)) X math_error("Bad argument type for matmin"); X q = v2->v_num; X i = qtoi(q); X if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim)) X math_error("Bad dimension value for matmin"); X result.v_type = V_NUM; X result.v_num = itoq(v1->v_mat->m_min[i - 1]); X return result; X} X X Xstatic VALUE Xf_matmax(v1, v2) X VALUE *v1, *v2; X{ X VALUE result; X NUMBER *q; X long i; X X if ((v1->v_type != V_MAT) || (v2->v_type != V_NUM)) X math_error("Bad argument type for matmax"); X q = v2->v_num; X i = qtoi(q); X if (qisfrac(q) || qisneg(q) || (i <= 0) || (i > v1->v_mat->m_dim)) X math_error("Bad dimension value for matmax"); X result.v_type = V_NUM; X result.v_num = itoq(v1->v_mat->m_max[i - 1]); X return result; X} X X Xstatic VALUE Xf_cp(v1, v2) X VALUE *v1, *v2; X{ X VALUE result; X X if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) X math_error("Non-matrix argument for cross product"); X result.v_type = V_MAT; X result.v_mat = matcross(v1->v_mat, v2->v_mat); X return result; X} X X Xstatic VALUE Xf_dp(v1, v2) X VALUE *v1, *v2; X{ X if ((v1->v_type != V_MAT) || (v2->v_type != V_MAT)) X math_error("Non-matrix argument for dot product"); X return matdot(v1->v_mat, v2->v_mat); X} X X Xstatic VALUE Xf_strlen(vp) X VALUE *vp; X{ X VALUE result; X X if (vp->v_type != V_STR) X math_error("Non-string argument for strlen"); X result.v_type = V_NUM; X result.v_num = itoq((long) strlen(vp->v_str)); X return result; X} X X Xstatic VALUE Xf_strcat(count, vals) X VALUE **vals; X{ X register VALUE **vp; X register char *cp; X int i; X long len; X long lengths[IN]; X VALUE result; X X len = 1; X vp = vals; X for (i = 0; i < count; i++) { X if ((*vp)->v_type != V_STR) X math_error("Non-string argument for strcat"); X lengths[i] = strlen((*vp)->v_str); X len += lengths[i]; X vp++; X } X cp = (char *)malloc(len); X if (cp == NULL) X math_error("No memory for strcat"); X result.v_str = cp; X result.v_type = V_STR; X result.v_subtype = V_STRALLOC; X i = 0; X for (vp = vals; count-- > 0; vp++) { X strcpy(cp, (*vp)->v_str); X cp += lengths[i++]; X } X return result; X} X X Xstatic VALUE Xf_substr(v1, v2, v3) X VALUE *v1, *v2, *v3; X{ X NUMBER *q1, *q2; X long i1, i2, len; X char *cp; X VALUE result; X X if (v1->v_type != V_STR) X math_error("Non-string argument for substr"); X if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM)) SHAR_EOF echo "End of part 4" echo "File calc2.9.0/func.c is continued in part 5" echo "5" > s2_seq_.tmp exit 0