Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume27/calc-2.9.0/part04

Text File | 1993-12-07 | 58.3 KB | 2,311 lines

Newsgroups: comp.sources.unix
From: [e-mail] (David I. Bell)
Subject: v27i131: calc-2.9.0 - arbitrary precision C-like programmable calculator, Part04/19
References: <[e-mail]>
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (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 <stdio.h>
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 <machine/endian.h> 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 <sys/types.h>
X#include <sys/times.h>
X#include <time.h>
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