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

Text File | 1993-12-07 | 58.7 KB | 2,523 lines

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

Submitted-By: [e-mail] (David I. Bell)
Posting-Number: Volume 27, Issue 137
Archive-Name: calc-2.9.0/part10

#!/bin/sh
# this is part 10 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc2.9.0/string.c continued
#
CurArch=10
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/string.c"
sed 's/^X//' << 'SHAR_EOF' >> calc2.9.0/string.c
X
X    testlen = strlen(test);
X    index = 1;
X    while (*format) {
X        len = strlen(format);
X        if ((len == testlen) && (*format == *test) &&
X            (strcmp(format, test) == 0))
X                return index;
X        format += (len + 1);
X        index++;
X    }
X    return 0;
X}
X
X
X/*
X * Add a possibly new literal string to the literal string pool.
X * Returns the new string address which is guaranteed to be always valid.
X * Duplicate strings will repeatedly return the same address.
X */
Xchar *
Xaddliteral(str)
X    char *str;
X{
X    register char **table;    /* table of strings */
X    char *newstr;        /* newly allocated string */
X    long count;        /* number of strings */
X    long len;        /* length of string to allocate */
X
X    len = strlen(str);
X    if (len <= 1)
X        return charstr(*str);
X    /*
X     * See if the string is already in the table.
X     */
X    table = literals.l_table;
X    count = literals.l_count;
X    while (count-- > 0) {
X        if ((str[0] == table[0][0]) && (str[1] == table[0][1]) &&
X            (strcmp(str, table[0]) == 0))
X                return table[0];
X        table++;
X    }
X    /*
X     * Make the table of string pointers larger if necessary.
X     */
X    if (literals.l_count >= literals.l_maxcount) {
X        count = literals.l_maxcount + STR_TABLECHUNK;
X        if (literals.l_maxcount)
X            table = (char **) realloc(literals.l_table, count * sizeof(char *));
X        else
X            table = (char **) malloc(count * sizeof(char *));
X        if (table == NULL)
X            math_error("Cannot allocate string literal table");
X        literals.l_table = table;
X        literals.l_maxcount = count;
X    }
X    table = literals.l_table;
X    /*
X     * If the new string is very long, allocate it manually.
X     */
X    len = (len + 2) & ~1;    /* add room for null and round up to word */
X    if (len >= STR_UNIQUE) {
X        newstr = (char *)malloc(len);
X        if (newstr == NULL)
X            math_error("Cannot allocate large literal string");
X        strcpy(newstr, str);
X        table[literals.l_count++] = newstr;
X        return newstr;
X    }
X    /*
X     * If the remaining space in the allocate string is too small,
X     * then allocate a new one.
X     */
X    if (literals.l_avail < len) {
X        newstr = (char *)malloc(STR_CHUNK);
X        if (newstr == NULL)
X            math_error("Cannot allocate new literal string");
X        literals.l_alloc = newstr;
X        literals.l_avail = STR_CHUNK;
X    }
X    /*
X     * Allocate the new string from the allocate string.
X     */
X    newstr = literals.l_alloc;
X    literals.l_avail -= len;
X    literals.l_alloc += len;
X    table[literals.l_count++] = newstr;
X    strcpy(newstr, str);
X    return newstr;
X}
X
X
X/*
X * Calculate a trivial hash value for a string.
X */
XHASH
Xhashstr(cp)
X    char *cp;
X{
X    int len;
X    HASH hash;
X
X    len = strlen(cp);
X    hash = len * 300007;
X    while (len-- > 0)
X        hash = hash * 300017 + *cp++ + 300043;
X    return hash;
X}
X
X/* END CODE */
SHAR_EOF
echo "File calc2.9.0/string.c is complete"
chmod 0644 calc2.9.0/string.c || echo "restore of calc2.9.0/string.c fails"
set `wc -c calc2.9.0/string.c`;Sum=$1
if test "$Sum" != "6923"
then echo original size 6923, current size $Sum;fi
echo "x - extracting calc2.9.0/string.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/string.h &&
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
X#ifndef    CALCSTRING_H
X#define    CALCSTRING_H
X
X#include "zmath.h"
X
X
Xtypedef struct {
X    char *h_list;    /* list of strings separated by nulls */
X    long h_used;    /* characters used so far */
X    long h_avail;    /* characters available for use */
X    long h_count;    /* number of strings */
X} STRINGHEAD;
X
X
Xextern void initstr MATH_PROTO((STRINGHEAD *hp));
Xextern char *addstr MATH_PROTO((STRINGHEAD *hp, char *str));
Xextern char *namestr MATH_PROTO((STRINGHEAD *hp, long n));
Xextern long findstr MATH_PROTO((STRINGHEAD *hp, char *str));
Xextern char *charstr MATH_PROTO((int ch));
Xextern char *addliteral MATH_PROTO((char *str));
Xextern long stringindex MATH_PROTO((char *str1, char *str2));
Xextern HASH hashstr MATH_PROTO((char *cp));
X
X#endif
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/string.h || echo "restore of calc2.9.0/string.h fails"
set `wc -c calc2.9.0/string.h`;Sum=$1
if test "$Sum" != "905"
then echo original size 905, current size $Sum;fi
echo "x - extracting calc2.9.0/symbol.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/symbol.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 * Global and local symbol routines.
X */
X
X#include "calc.h"
X#include "token.h"
X#include "symbol.h"
X#include "string.h"
X#include "opcodes.h"
X#include "func.h"
X
X#define HASHSIZE    37    /* size of hash table */
X
X
Xstatic int filescope;        /* file scope level for static variables */
Xstatic int funcscope;        /* function scope level for static variables */
Xstatic STRINGHEAD localnames;    /* list of local variable names */
Xstatic STRINGHEAD globalnames;    /* list of global variable names */
Xstatic STRINGHEAD paramnames;    /* list of parameter variable names */
Xstatic GLOBAL *globalhash[HASHSIZE];    /* hash table for globals */
X
Xstatic void fitprint MATH_PROTO((NUMBER *num, long digits, long width));
Xstatic void unscope MATH_PROTO((void));
X
X
X/*
X * Hash a symbol name so we can find it in the hash table.
X * Args are the symbol name and the symbol name size.
X */
X#define HASHSYM(n, s) ((unsigned)((n)[0]*123 + (n)[s-1]*135 + (s)*157) % HASHSIZE)
X
X
X/*
X * Initialize the global symbol table.
X */
Xvoid
Xinitglobals()
X{
X    int i;        /* index counter */
X
X    for (i = 0; i < HASHSIZE; i++)
X        globalhash[i] = NULL;
X    initstr(&globalnames);
X    filescope = SCOPE_STATIC;
X    funcscope = 0;
X}
X
X
X/*
X * Define a possibly new global variable which may or may not be static.
X * If it did not already exist, it is created with a value of zero.
X * The address of the global symbol structure is returned.
X */
XGLOBAL *
Xaddglobal(name, isstatic)
X    char *name;        /* name of global variable */
X    BOOL isstatic;        /* TRUE if symbol is static */
X{
X    GLOBAL *sp;        /* current symbol pointer */
X    GLOBAL **hp;        /* hash table head address */
X    long len;        /* length of string */
X    int newfilescope;    /* file scope being looked for */
X    int newfuncscope;    /* function scope being looked for */
X
X    newfilescope = SCOPE_GLOBAL;
X    newfuncscope = 0;
X    if (isstatic) {
X        newfilescope = filescope;
X        newfuncscope = funcscope;
X    }
X    len = strlen(name);
X    if (len <= 0)
X        return NULL;
X    hp = &globalhash[HASHSYM(name, len)];
X    for (sp = *hp; sp; sp = sp->g_next) {
X        if ((sp->g_len == len) && (strcmp(sp->g_name, name) == 0)
X            && (sp->g_filescope == newfilescope)
X            && (sp->g_funcscope == newfuncscope))
X                return sp;
X    }
X    sp = (GLOBAL *) malloc(sizeof(GLOBAL));
X    if (sp == NULL)
X        return sp;
X    sp->g_name = addstr(&globalnames, name);
X    sp->g_len = len;
X    sp->g_filescope = newfilescope;
X    sp->g_funcscope = newfuncscope;
X    sp->g_value.v_num = qlink(&_qzero_);
X    sp->g_value.v_type = V_NUM;
X    sp->g_next = *hp;
X    *hp = sp;
X    return sp;
X}
X
X
X/*
X * Look up the name of a global variable and return its address.
X * Since the same variable may appear in different scopes, we search
X * for the one with the highest function scope value within the current
X * file scope level (or which is global).  Returns NULL if the symbol
X * was not found.
X */
XGLOBAL *
Xfindglobal(name)
X    char *name;        /* name of global variable */
X{
X    GLOBAL *sp;        /* current symbol pointer */
X    GLOBAL *bestsp;        /* found symbol with highest scope */
X    long len;        /* length of string */
X
X    bestsp = NULL;
X    len = strlen(name);
X    for (sp = globalhash[HASHSYM(name, len)]; sp; sp = sp->g_next) {
X        if ((sp->g_len != len) || strcmp(sp->g_name, name))
X            continue;
X        if (sp->g_filescope == SCOPE_GLOBAL) {
X            if (bestsp == NULL)
X                bestsp = sp;
X            continue;
X        }
X        if (sp->g_filescope != filescope)
X            continue;
X        if ((bestsp == NULL) || (sp->g_funcscope > bestsp->g_funcscope))
X            bestsp = sp;
X    }
X    return bestsp;
X}
X
X
X/*
X * Return the name of a global variable given its address.
X */
Xchar *
Xglobalname(sp)
X    GLOBAL *sp;        /* address of global pointer */
X{
X    if (sp)
X        return sp->g_name;
X    return "";
X}
X
X
X/*
X * Show the value of all global variables, typing only the head and
X * tail of very large numbers.  Only truly global symbols are shown.
X */
Xvoid
Xshowglobals()
X{
X    GLOBAL **hp;            /* hash table head address */
X    register GLOBAL *sp;        /* current global symbol pointer */
X    long count;            /* number of global variables shown */
X    NUMBER *num, *den;
X    long digits;
X
X    count = 0;
X    for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
X        for (sp = *hp; sp; sp = sp->g_next) {
X            if (sp->g_value.v_type != V_NUM)
X                continue;
X            if (sp->g_filescope != SCOPE_GLOBAL)
X                continue;
X            if (count++ == 0) {
X                printf("\nName    Digits  Value\n");
X                printf(  "----    ------  -----\n");
X            }
X            printf("%-8s ", sp->g_name);
X            num = qnum(sp->g_value.v_num);
X            digits = qdigits(num);
X            printf("%-7ld ", digits);
X            fitprint(num, digits, 60L);
X            qfree(num);
X            if (!qisint(sp->g_value.v_num)) {
X                den = qden(sp->g_value.v_num);
X                digits = qdigits(den);
X                printf("\n    %-6ld /", digits);
X                fitprint(den, digits, 60L);
X                qfree(den);
X            }
X            printf("\n");
X        }
X    }
X    printf(count ? "\n" : "No global variables defined.\n");
X}
X
X
X/*
X * Print an integer which is guaranteed to fit in the specified number
X * of columns, using imbedded '...' characters if it is too large.
X */
Xstatic void
Xfitprint(num, digits, width)
X    NUMBER *num;        /* number to print */
X    long digits, width;
X{
X    long show, used;
X    NUMBER *p, *t, *div, *val;
X
X    if (digits <= width) {
X        qprintf("%r", num);
X        return;
X    }
X    show = (width / 2) - 2;
X    t = itoq(10L);
X    p = itoq((long) (digits - show));
X    div = qpowi(t, p);
X    val = qquo(num, div);
X    qprintf("%r...", val);
X    qfree(p);
X    qfree(div);
X    qfree(val);
X    p = itoq(show);
X    div = qpowi(t, p);
X    val = qmod(num, div);
X    used = qdigits(val);
X    while (used++ < show) printf("0");
X    qprintf("%r", val);
X    qfree(p);
X    qfree(div);
X    qfree(val);
X    qfree(t);
X}
X
X
X/*
X * Write all normal global variables to an output file.
X * Note: Currently only simple types are saved.
X * Returns nonzero on error.
X */
Xwriteglobals(name)
X    char *name;
X{
X    FILE *fp;
X    GLOBAL **hp;            /* hash table head address */
X    register GLOBAL *sp;        /* current global symbol pointer */
X    int savemode;            /* saved output mode */
X
X    fp = f_open(name, "w");
X    if (fp == NULL)
X        return 1;
X    math_setfp(fp);
X    for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
X        for (sp = *hp; sp; sp = sp->g_next) {
X            switch (sp->g_value.v_type) {
X                case V_NUM:
X                case V_COM:
X                case V_STR:
X                    break;
X                default:
X                    continue;
X            }
X            math_fmt("%s = ", sp->g_name);
X            savemode = math_setmode(MODE_HEX);
X            printvalue(&sp->g_value, PRINT_UNAMBIG);
X            math_setmode(savemode);
X            math_str(";\n");
X        }
X    }
X    math_setfp(stdout);
X    if (fclose(fp))
X        return 1;
X    return 0;
X}
X
X
X/*
X * Reset the file and function scope levels back to the original values.
X * This is called on errors to forget any static variables which were being
X * defined.
X */
Xvoid
Xresetscopes()
X{
X    filescope = SCOPE_STATIC;
X    funcscope = 0;
X    unscope();
X}
X
X
X/*
X * Enter a new file scope level so that newly defined static variables
X * will have the appropriate scope, and so that previously defined static
X * variables will temporarily be unaccessible.  This should only be called
X * when the function scope level is zero.
X */
Xvoid
Xenterfilescope()
X{
X    filescope++;
X    funcscope = 0;
X}
X
X
X/*
X * Exit from a file scope level.  This deletes from the global symbol table
X * all of the static variables that were defined within this file scope level.
X * The function scope level is also reset to zero.
X */
Xvoid
Xexitfilescope()
X{
X    if (filescope > SCOPE_STATIC)
X        filescope--;
X    funcscope = 0;
X    unscope();
X}
X
X
X/*
X * Enter a new function scope level within the current file scope level.
X * This allows newly defined static variables to override previously defined
X * static variables in the same file scope level.
X */
Xvoid
Xenterfuncscope()
X{
X    funcscope++;
X}
X
X
X/*
X * Exit from a function scope level.  This deletes static symbols which were
X * defined within the current function scope level, and makes previously
X * defined symbols with the same name within the same file scope level
X * accessible again.
X */
Xvoid
Xexitfuncscope()
X{
X    if (funcscope > 0)
X        funcscope--;
X    unscope();
X}
X
X
X/*
X * Remove all the symbols from the global symbol table which have file or
X * function scopes larger than the current scope levels.  Their memory
X * remains allocated since their values still actually exist.
X */
Xstatic void
Xunscope()
X{
X    GLOBAL **hp;            /* hash table head address */
X    register GLOBAL *sp;        /* current global symbol pointer */
X    GLOBAL *prevsp;            /* previous kept symbol pointer */
X
X    for (hp = &globalhash[HASHSIZE-1]; hp >= globalhash; hp--) {
X        prevsp = NULL;
X        for (sp = *hp; sp; sp = sp->g_next) {
X            if ((sp->g_filescope == SCOPE_GLOBAL) ||
X                (sp->g_filescope < filescope) ||
X                ((sp->g_filescope == filescope) &&
X                    (sp->g_funcscope <= funcscope)))
X            {
X                prevsp = sp;
X                continue;
X            }
X
X            /*
X             * This symbol needs removing.
X             */
X            if (prevsp)
X                prevsp->g_next = sp->g_next;
X            else
X                *hp = sp->g_next;
X        }
X    }
X}
X
X
X/*
X * Initialize the local and parameter symbol table information.
X */
Xvoid
Xinitlocals()
X{
X    initstr(&localnames);
X    initstr(¶mnames);
X    curfunc->f_localcount = 0;
X    curfunc->f_paramcount = 0;
X}
X
X
X/*
X * Add a possibly new local variable definition.
X * Returns the index of the variable into the local symbol table.
X * Minus one indicates the symbol could not be added.
X */
Xlong
Xaddlocal(name)
X    char *name;        /* name of local variable */
X{
X    long index;        /* current symbol index */
X
X    index = findstr(&localnames, name);
X    if (index >= 0)
X        return index;
X    index = localnames.h_count;
X    (void) addstr(&localnames, name);
X    curfunc->f_localcount++;
X    return index;
X}
X
X
X/*
X * Find a local variable name and return its index.
X * Returns minus one if the variable name is not defined.
X */
Xlong
Xfindlocal(name)
X    char *name;        /* name of local variable */
X{
X    return findstr(&localnames, name);
X}
X
X
X/*
X * Return the name of a local variable.
X */
Xchar *
Xlocalname(n)
X    long n;
X{
X    return namestr(&localnames, n);
X}
X
X
X/*
X * Add a possibly new parameter variable definition.
X * Returns the index of the variable into the parameter symbol table.
X * Minus one indicates the symbol could not be added.
X */
Xlong
Xaddparam(name)
X    char *name;        /* name of parameter variable */
X{
X    long index;        /* current symbol index */
X
X    index = findstr(¶mnames, name);
X    if (index >= 0)
X        return index;
X    index = paramnames.h_count;
X    (void) addstr(¶mnames, name);
X    curfunc->f_paramcount++;
X    return index;
X}
X
X
X/*
X * Find a parameter variable name and return its index.
X * Returns minus one if the variable name is not defined.
X */
Xlong
Xfindparam(name)
X    char *name;        /* name of parameter variable */
X{
X    return findstr(¶mnames, name);
X}
X
X
X/*
X * Return the name of a parameter variable.
X */
Xchar *
Xparamname(n)
X    long n;
X{
X    return namestr(¶mnames, n);
X}
X
X
X/*
X * Return the type of a variable name.
X * This is either local, parameter, global, static, or undefined.
X */
Xsymboltype(name)
X    char *name;        /* variable name to find */
X{
X    GLOBAL *sp;
X
X    if (findlocal(name) >= 0)
X        return SYM_LOCAL;
X    if (findparam(name) >= 0)
X        return SYM_PARAM;
X    sp = findglobal(name);
X    if (sp) {
X        if (sp->g_filescope == SCOPE_GLOBAL)
X            return SYM_GLOBAL;
X        return SYM_STATIC;
X    }
X    return SYM_UNDEFINED;
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/symbol.c || echo "restore of calc2.9.0/symbol.c fails"
set `wc -c calc2.9.0/symbol.c`;Sum=$1
if test "$Sum" != "11019"
then echo original size 11019, current size $Sum;fi
echo "x - extracting calc2.9.0/symbol.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/symbol.h &&
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
X#ifndef    SYMBOL_H
X#define    SYMBOL_H
X
X#include "zmath.h"
X
X
X/*
X * Symbol Declarations.
X */
X#define SYM_UNDEFINED    0    /* undefined symbol */
X#define SYM_PARAM    1    /* parameter symbol */
X#define SYM_LOCAL    2    /* local symbol */
X#define SYM_GLOBAL    3    /* global symbol */
X#define    SYM_STATIC    4    /* static symbol */
X
X#define    SCOPE_GLOBAL    0    /* file scope level for global variables */
X#define    SCOPE_STATIC    1    /* lowest file scope for static variables */
X
X
Xtypedef struct global GLOBAL;
Xstruct global {
X    int g_len;        /* length of symbol name */
X    short g_filescope;    /* file scope level of symbol (0 if global) */
X    short g_funcscope;    /* function scope level of symbol */
X    char *g_name;        /* global symbol name */
X    VALUE g_value;        /* global symbol value */
X    GLOBAL *g_next;        /* next symbol in hash chain */
X};
X
X
X/*
X * Routines to search for global symbols.
X */
Xextern GLOBAL *addglobal MATH_PROTO((char *name, BOOL isstatic));
Xextern GLOBAL *findglobal MATH_PROTO((char *name));
X
X
X/*
X * Routines to return names of variables.
X */
Xextern char *localname MATH_PROTO((long n));
Xextern char *paramname MATH_PROTO((long n));
Xextern char *globalname MATH_PROTO((GLOBAL *sp));
X
X
X/*
X * Routines to handle entering and leaving of scope levels.
X */
Xextern void resetscopes MATH_PROTO((void));
Xextern void enterfilescope MATH_PROTO((void));
Xextern void exitfilescope MATH_PROTO((void));
Xextern void enterfuncscope MATH_PROTO((void));
Xextern void exitfuncscope MATH_PROTO((void));
X
X
X/*
X * Other routines.
X */
Xextern long addlocal MATH_PROTO((char *name));
Xextern long findlocal MATH_PROTO((char *name));
Xextern long addparam MATH_PROTO((char *name));
Xextern long findparam MATH_PROTO((char *name));
Xextern void initlocals MATH_PROTO((void));
Xextern void initglobals MATH_PROTO((void));
Xextern int writeglobals MATH_PROTO((char *name));
Xextern int symboltype MATH_PROTO((char *name));
Xextern void showglobals MATH_PROTO((void));
X
X#endif
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/symbol.h || echo "restore of calc2.9.0/symbol.h fails"
set `wc -c calc2.9.0/symbol.h`;Sum=$1
if test "$Sum" != "2081"
then echo original size 2081, current size $Sum;fi
echo "x - extracting calc2.9.0/token.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/token.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 * Read input file characters into tokens
X */
X
X#include "stdarg.h"
X#include "calc.h"
X#include "token.h"
X#include "string.h"
X
X
X#define isletter(ch)    ((((ch) >= 'a') && ((ch) <= 'z')) || \
X                (((ch) >= 'A') && ((ch) <= 'Z')))
X#define isdigit(ch)    (((ch) >= '0') && ((ch) <= '9'))
X#define issymbol(ch)    (isletter(ch) || isdigit(ch) || ((ch) == '_'))
X
X
X/*
X * Current token.
X */
Xstatic struct {
X    short t_type;        /* type of token */
X    char *t_str;        /* string value or symbol name */
X    long t_numindex;    /* index of numeric value */
X} curtoken;
X
X
Xstatic BOOL rescan;        /* TRUE to reread current token */
Xstatic BOOL newlines;        /* TRUE to return newlines as tokens */
Xstatic BOOL allsyms;        /* TRUE if always want a symbol token */
Xstatic STRINGHEAD strings;    /* list of constant strings */
Xstatic char *numbuf;        /* buffer for numeric tokens */
Xstatic long numbufsize;        /* current size of numeric buffer */
X
Xlong errorcount;        /* number of compilation errors */
X
X
X/*
X * Table of keywords
X */
Xstruct keyword {
X    char *k_name;    /* keyword name */
X    int k_token;    /* token number */
X};
X
Xstatic struct keyword keywords[] = {
X    "if",        T_IF,
X    "else",        T_ELSE,
X    "for",        T_FOR,
X    "while",    T_WHILE,
X    "do",        T_DO,
X    "continue",    T_CONTINUE,
X    "break",    T_BREAK,
X    "goto",        T_GOTO,
X    "return",    T_RETURN,
X    "local",    T_LOCAL,
X    "global",    T_GLOBAL,
X    "static",    T_STATIC,
X    "switch",    T_SWITCH,
X    "case",        T_CASE,
X    "default",    T_DEFAULT,
X    "quit",        T_QUIT,
X    "exit",        T_QUIT,
X    "define",    T_DEFINE,
X    "read",        T_READ,
X    "show",        T_SHOW,
X    "help",        T_HELP,
X    "write",    T_WRITE,
X    "mat",        T_MAT,
X    "obj",        T_OBJ,
X    "print",    T_PRINT,
X    NULL,        0
X};
X
X
Xstatic void eatcomment MATH_PROTO((void));
Xstatic void eatstring MATH_PROTO((int quotechar));
Xstatic int eatsymbol MATH_PROTO((void));
Xstatic int eatnumber MATH_PROTO((void));
X
X
X/*
X * Initialize all token information.
X */
Xvoid
Xinittokens()
X{
X    initstr(&strings);
X    newlines = FALSE;
X    allsyms = FALSE;
X    rescan = FALSE;
X    setprompt(PROMPT1);
X}
X
X
X/*
X * Set the new token mode according to the specified flag, and return the
X * previous value of the flag.
X */
Xint
Xtokenmode(flag)
X{
X    int    oldflag;
X
X    oldflag = TM_DEFAULT;
X    if (newlines)
X        oldflag |= TM_NEWLINES;
X    if (allsyms)
X        oldflag |= TM_ALLSYMS;
X    newlines = FALSE;
X    allsyms = FALSE;
X    if (flag & TM_NEWLINES)
X        newlines = TRUE;
X    if (flag & TM_ALLSYMS)
X        allsyms = TRUE;
X    setprompt(newlines ? PROMPT1 : PROMPT2);
X    return oldflag;
X}
X
X
X/*
X * Routine to read in the next token from the input stream.
X * The type of token is returned as a value.  If the token is a string or
X * symbol name, information is saved so that the value can be retrieved.
X */
Xint
Xgettoken()
X{
X    int ch;            /* current input character */
X    int type;        /* token type */
X
X    if (rescan) {        /* rescanning */
X        rescan = FALSE;
X        return curtoken.t_type;
X    }
X    curtoken.t_str = NULL;
X    curtoken.t_numindex = 0;
X    type = T_NULL;
X    while (type == T_NULL) {
X        ch = nextchar();
X        if (allsyms && ((ch!=' ') && (ch!=';') && (ch!='"') && (ch!='\n'))) {
X            reread();
X            type = eatsymbol();
X            break;
X        }
X        switch (ch) {
X        case ' ':
X        case '\t':
X        case '\0':
X            break;
X        case '\n':
X            if (newlines)
X                type = T_NEWLINE;
X            break;
X        case EOF: type = T_EOF; break;
X        case '{': type = T_LEFTBRACE; break;
X        case '}': type = T_RIGHTBRACE; break;
X        case '(': type = T_LEFTPAREN; break;
X        case ')': type = T_RIGHTPAREN; break;
X        case '[': type = T_LEFTBRACKET; break;
X        case ']': type = T_RIGHTBRACKET; break;
X        case ';': type = T_SEMICOLON; break;
X        case ':': type = T_COLON; break;
X        case ',': type = T_COMMA; break;
X        case '?': type = T_QUESTIONMARK; break;
X        case '"':
X        case '\'':
X            type = T_STRING;
X            eatstring(ch);
X            break;
X        case '^':
X            switch (nextchar()) {
X                case '=': type = T_POWEREQUALS; break;
X                default: type = T_POWER; reread();
X            }
X            break;
X        case '=':
X            switch (nextchar()) {
X                case '=': type = T_EQ; break;
X                default: type = T_ASSIGN; reread();
X            }
X            break;
X        case '+':
X            switch (nextchar()) {
X                case '+': type = T_PLUSPLUS; break;
X                case '=': type = T_PLUSEQUALS; break;
X                default: type = T_PLUS; reread();
X            }
X            break;
X        case '-':
X            switch (nextchar()) {
X                case '-': type = T_MINUSMINUS; break;
X                case '=': type = T_MINUSEQUALS; break;
X                default: type = T_MINUS; reread();
X            }
X            break;
X        case '*':
X            switch (nextchar()) {
X                case '=': type = T_MULTEQUALS; break;
X                case '*':
X                    switch (nextchar()) {
X                        case '=': type = T_POWEREQUALS; break;
X                        default: type = T_POWER; reread();
X                    }
X                    break;
X                default: type = T_MULT; reread();
X            }
X            break;
X        case '/':
X            switch (nextchar()) {
X                case '/':
X                    switch (nextchar()) {
X                        case '=': type = T_SLASHSLASHEQUALS; break;
X                        default: reread(); type = T_SLASHSLASH; break;
X                    }
X                    break;
X                case '=': type = T_DIVEQUALS; break;
X                case '*': eatcomment(); break;
X                default: type = T_DIV; reread();
X            }
X            break;
X        case '%':
X            switch (nextchar()) {
X                case '=': type = T_MODEQUALS; break;
X                default: type = T_MOD; reread();
X            }
X            break;
X        case '<':
X            switch (nextchar()) {
X                case '=': type = T_LE; break;
X                case '<':
X                    switch (nextchar()) {
X                        case '=': type = T_LSHIFTEQUALS; break;
X                        default:  reread(); type = T_LEFTSHIFT; break;
X                    }
X                    break;
X                default: type = T_LT; reread();
X            }
X            break;
X        case '>':
X            switch (nextchar()) {
X                case '=': type = T_GE; break;
X                case '>':
X                    switch (nextchar()) {
X                        case '=': type = T_RSHIFTEQUALS; break;
X                        default:  reread(); type = T_RIGHTSHIFT; break;
X                    }
X                    break;
X                default: type = T_GT; reread();
X            }
X            break;
X        case '&':
X            switch (nextchar()) {
X                case '&': type = T_ANDAND; break;
X                case '=': type = T_ANDEQUALS; break;
X                default: type = T_AND; reread(); break;
X            }
X            break;
X        case '|':
X            switch (nextchar()) {
X                case '|': type = T_OROR; break;
X                case '=': type = T_OREQUALS; break;
X                default: type = T_OR; reread(); break;
X            }
X            break;
X        case '!':
X            switch (nextchar()) {
X                case '=': type = T_NE; break;
X                default: type = T_NOT; reread(); break;
X            }
X            break;
X        case '\\':
X            switch (nextchar()) {
X                case '\n': setprompt(PROMPT2); break;
X                default: scanerror(T_NULL, "Unknown token character '%c'", ch);
X            }
X            break;
X        default:
X            if (isletter(ch)) {
X                reread();
X                type = eatsymbol();
X                break;
X            }
X            if (isdigit(ch) || (ch == '.')) {
X                reread();
X                type = eatnumber();
X                break;
X            }
X            scanerror(T_NULL, "Unknown token character '%c'", ch);
X        }
X    }
X    curtoken.t_type = (short)type;
X    return type;
X}
X
X
X/*
X * Continue to eat up a comment string.
X * The leading slash-asterisk has just been scanned at this point.
X */
Xstatic void
Xeatcomment()
X{
X    int ch;
X
X    for (;;) {
X        ch = nextchar();
X        if (ch == '*') {
X            ch = nextchar();
X            if (ch == '/')
X                return;
X            reread();
X        }
X        if ((ch == EOF) || (ch == '\0') ||
X            (newlines && (ch == '\n') && inputisterminal())) {
X                reread();
X                scanerror(T_NULL, "Unterminated comment");
X                return;
X        }
X    }
X}
X
X
X/*
X * Read in a string and add it to the literal string pool.
X * The leading single or double quote has been read in at this point.
X */
Xstatic void
Xeatstring(quotechar)
X{
X    register char *cp;    /* current character address */
X    int ch;            /* current character */
X    char buf[MAXSTRING+1];    /* buffer for string */
X
X    cp = buf;
X    for (;;) {
X        ch = nextchar();
X        switch (ch) {
X            case '\0':
X            case EOF:
X            case '\n':
X                reread();
X                scanerror(T_NULL, "Unterminated string constant");
X                *cp = '\0';
X                curtoken.t_str = addliteral(buf);
X                return;
X
X            case '\\':
X                ch = nextchar();
X                switch (ch) {
X                    case 'n': ch = '\n'; break;
X                    case 'r': ch = '\r'; break;
X                    case 't': ch = '\t'; break;
X                    case 'b': ch = '\b'; break;
X                    case 'f': ch = '\f'; break;
X                    case '\n':
X                        setprompt(PROMPT2);
X                        continue;
X                    case EOF:
X                        reread();
X                        continue;
X                }
X                *cp++ = (char)ch;
X                break;
X
X            case '"':
X            case '\'':
X                if (ch == quotechar) {
X                    *cp = '\0';
X                    curtoken.t_str = addliteral(buf);
X                    return;
X                }
X                /* fall into default case */
X
X            default:
X                *cp++ = (char)ch;
X        }
X    }
X}
X
X
X/*
X * Read in a symbol name which may or may not be a keyword.
X * If allsyms is set, keywords are not looked up and almost all chars
X * will be accepted for the symbol.  Returns the type of symbol found.
X */
Xstatic int
Xeatsymbol()
X{
X    register struct keyword *kp;    /* pointer to current keyword */
X    register char *cp;        /* current character pointer */
X    int ch;                /* current character */
X    int cc;                /* character count */
X    static char buf[SYMBOLSIZE+1];    /* temporary buffer */
X
X    cp = buf;
X    cc = SYMBOLSIZE;
X    if (allsyms) {
X        for (;;) {
X            ch = nextchar();
X            if ((ch == ' ') || (ch == ';') || (ch == '\n'))
X                break;
X            if (cc-- > 0)
X                *cp++ = (char)ch;
X        }
X        reread();
X        *cp = '\0';
X        if (cc < 0)
X            scanerror(T_NULL, "Symbol too long");
X        curtoken.t_str = buf;
X        return T_SYMBOL;
X    }
X    for (;;) {
X        ch = nextchar();
X        if (!issymbol(ch))
X            break;
X        if (cc-- > 0)
X            *cp++ = (char)ch;
X    }
X    reread();
X    *cp = '\0';
X    if (cc < 0)
X        scanerror(T_NULL, "Symbol too long");
X    for (kp = keywords; kp->k_name; kp++)
X        if (strcmp(kp->k_name, buf) == 0)
X            return kp->k_token;
X    curtoken.t_str = buf;
X    return T_SYMBOL;
X}
X
X
X/*
X * Read in and remember a possibly numeric constant value.
X * The constant is inserted into a constant table so further uses
X * of the same constant will not take more memory.  This can also
X * return just a period, which is used for element accesses and for
X * the old numeric value.
X */
Xstatic int
Xeatnumber()
X{
X    register char *cp;    /* current character pointer */
X    long len;        /* parsed size of number */
X    long res;        /* result of parsing number */
X
X    if (numbufsize == 0) {
X        numbuf = (char *)malloc(128+1);
X        if (numbuf == NULL)
X            math_error("Cannot allocate number buffer");
X        numbufsize = 128;
X    }
X    cp = numbuf;
X    len = 0;
X    for (;;) {
X        if (len >= numbufsize) {
X            cp = (char *)realloc(numbuf, numbufsize + 1001);
X            if (cp == NULL)
X                math_error("Cannot reallocate number buffer");
X            numbuf = cp;
X            numbufsize += 1000;
X            cp = &numbuf[len];
X        }
X        *cp = nextchar();
X        *(++cp) = '\0';
X        if ((numbuf[0] == '.') && isletter(numbuf[1])) {
X            reread();
X            return T_PERIOD;
X        }
X        res = qparse(numbuf, QPF_IMAG);
X        if (res < 0) {
X            reread();
X            scanerror(T_NULL, "Badly formatted number");
X            curtoken.t_numindex = addnumber("0");
X            return T_NUMBER;
X        }
X        if (res != ++len)
X            break;
X    }
X    cp[-1] = '\0';
X    reread();
X    if ((numbuf[0] == '.') && (numbuf[1] == '\0')) {
X        curtoken.t_numindex = 0;
X        return T_OLDVALUE;
X    }
X    cp -= 2;
X    res = T_NUMBER;
X    if ((*cp == 'i') || (*cp == 'I')) {
X        *cp = '\0';
X        res = T_IMAGINARY;
X    }
X    curtoken.t_numindex = addnumber(numbuf);
X    return res;
X}
X
X
X/*
X * Return the string value of the current token.
X */
Xchar *
Xtokenstring()
X{
X    return curtoken.t_str;
X}
X
X
X/*
X * Return the constant index of a numeric token.
X */
Xlong
Xtokennumber()
X{
X    return curtoken.t_numindex;
X}
X
X
X/*
X * Push back the token just read so that it will be seen again.
X */
Xvoid
Xrescantoken()
X{
X    rescan = TRUE;
X}
X
X
X/*
X * Describe an error message.
X * Then skip to the next specified token (or one more powerful).
X */
X#ifdef VARARGS
X# define VA_ALIST skip, fmt, va_alist
X# define VA_DCL int skip; char *fmt; va_dcl
X#else
X# ifdef __STDC__
X#  define VA_ALIST int skip, char *fmt, ...
X#  define VA_DCL
X# else
X#  define VA_ALIST skip, fmt
X#  define VA_DCL int skip; char *fmt;
X# endif
X#endif
X/*VARARGS*/
Xvoid
Xscanerror(VA_ALIST)
X    VA_DCL
X{
X    va_list ap;
X    char *name;        /* name of file with error */
X    char buf[MAXERROR+1];
X
X    errorcount++;
X    name = inputname();
X    if (name)
X        fprintf(stderr, "\"%s\", line %ld: ", name, linenumber());
X#ifdef VARARGS
X    va_start(ap);
X#else
X    va_start(ap, fmt);
X#endif
X    vsprintf(buf, fmt, ap);
X    va_end(ap);
X    fprintf(stderr, "%s\n", buf);
X    switch (skip) {
X        case T_NULL:
X            return;
X        case T_COMMA:
X            rescan = TRUE;
X            for (;;) {
X                switch (gettoken()) {
X                case T_NEWLINE:
X                case T_SEMICOLON:
X                case T_LEFTBRACE:
X                case T_RIGHTBRACE:
X                case T_EOF:
X                case T_COMMA:
X                    rescan = TRUE;
X                    return;
X                }
X            }
X        default:
X            fprintf(stderr, "Unknown skip token for scanerror\n");
X            /* fall into semicolon case */
X            /*FALLTHRU*/
X        case T_SEMICOLON:
X            rescan = TRUE;
X            for (;;) switch (gettoken()) {
X                case T_NEWLINE:
X                case T_SEMICOLON:
X                case T_LEFTBRACE:
X                case T_RIGHTBRACE:
X                case T_EOF:
X                    rescan = TRUE;
X                    return;
X            }
X    }
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/token.c || echo "restore of calc2.9.0/token.c fails"
set `wc -c calc2.9.0/token.c`;Sum=$1
if test "$Sum" != "12451"
then echo original size 12451, current size $Sum;fi
echo "x - extracting calc2.9.0/token.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/token.h &&
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
X#ifndef    TOKEN_H
X#define    TOKEN_H
X
X#include "zmath.h"
X
X
X/*
X * Token types
X */
X#define T_NULL            0    /* null token */
X#define T_LEFTPAREN        1    /* left parenthesis "(" */
X#define T_RIGHTPAREN        2    /* right parenthesis ")" */
X#define T_LEFTBRACE        3    /* left brace "{" */
X#define T_RIGHTBRACE        4    /* right brace "}" */
X#define T_SEMICOLON        5    /* end of statement ";" */
X#define T_EOF            6    /* end of file */
X#define T_COLON            7    /* label character ":" */
X#define T_ASSIGN        8    /* assignment "=" */
X#define T_PLUS            9    /* plus sign "+" */
X#define T_MINUS            10    /* minus sign "-" */
X#define T_MULT            11    /* multiply sign "*" */
X#define T_DIV            12    /* divide sign "/" */
X#define T_MOD            13    /* modulo sign "%" */
X#define T_POWER            14    /* power sign "^" or "**" */
X#define T_EQ            15    /* equality "==" */
X#define T_NE            16    /* notequal "!=" */
X#define T_LT            17    /* less than "<" */
X#define T_GT            18    /* greater than ">" */
X#define T_LE            19    /* less than or equals "<=" */
X#define T_GE            20    /* greater than or equals ">=" */
X#define T_LEFTBRACKET        21    /* left bracket "[" */
X#define T_RIGHTBRACKET        22    /* right bracket "]" */
X#define T_SYMBOL        23    /* symbol name */
X#define T_STRING        24    /* string value (double quotes) */
X#define T_NUMBER        25    /* numeric real constant */
X#define T_PLUSEQUALS        26    /* plus equals "+=" */
X#define T_MINUSEQUALS        27    /* minus equals "-=" */
X#define T_MULTEQUALS        28    /* multiply equals "*=" */
X#define T_DIVEQUALS        29    /* divide equals "/=" */
X#define T_MODEQUALS        30    /* modulo equals "%=" */
X#define T_PLUSPLUS        31    /* plusplus "++" */
X#define T_MINUSMINUS        32    /* minusminus "--" */
X#define T_COMMA            33    /* comma "," */
X#define T_ANDAND        34    /* logical and "&&" */
X#define T_OROR            35    /* logical or "||" */
X#define T_OLDVALUE        36    /* old value from previous calculation */
X#define T_SLASHSLASH        37    /* integer divide "//" */
X#define T_NEWLINE        38    /* newline character */
X#define T_SLASHSLASHEQUALS    39    /* integer divide equals "//=" */
X#define T_AND            40    /* arithmetic and "&" */
X#define T_OR            41    /* arithmetic or "|" */
X#define T_NOT            42    /* logical not "!" */
X#define T_LEFTSHIFT        43    /* left shift "<<" */
X#define T_RIGHTSHIFT        44    /* right shift ">>" */
X#define T_ANDEQUALS        45    /* and equals "&=" */
X#define T_OREQUALS        46    /* or equals "|= */
X#define T_LSHIFTEQUALS        47    /* left shift equals "<<=" */
X#define T_RSHIFTEQUALS        48    /* right shift equals ">>= */
X#define T_POWEREQUALS        49    /* power equals "^=" or "**=" */
X#define T_PERIOD        50    /* period "." */
X#define T_IMAGINARY        51    /* numeric imaginary constant */
X#define    T_AMPERSAND        52    /* ampersand "&" */
X#define    T_QUESTIONMARK        53    /* question mark "?" */
X
X
X/*
X * Keyword tokens
X */
X#define T_IF            101    /* if keyword */
X#define T_ELSE            102    /* else keyword */
X#define T_WHILE            103    /* while keyword */
X#define T_CONTINUE        104    /* continue keyword */
X#define T_BREAK            105    /* break keyword */
X#define T_GOTO            106    /* goto keyword */
X#define T_RETURN        107    /* return keyword */
X#define T_LOCAL            108    /* local keyword */
X#define T_GLOBAL        109    /* global keyword */
X#define    T_STATIC        110    /* static keyword */
X#define T_DO            111    /* do keyword */
X#define T_FOR            112    /* for keyword */
X#define T_SWITCH        113    /* switch keyword */
X#define T_CASE            114    /* case keyword */
X#define T_DEFAULT        115    /* default keyword */
X#define T_QUIT            116    /* quit keyword */
X#define T_DEFINE        117    /* define keyword */
X#define T_READ            118    /* read keyword */
X#define T_SHOW            119    /* show keyword */
X#define T_HELP            120    /* help keyword */
X#define T_WRITE            121    /* write keyword */
X#define T_MAT            122    /* mat keyword */
X#define T_OBJ            123    /* obj keyword */
X#define T_PRINT            124    /* print keyword */
X
X
X#define iskeyword(n) ((n) > 100)    /* TRUE if token is a keyword */
X
X
X/*
X * Flags returned describing results of expression parsing.
X */
X#define EXPR_RVALUE    0x0001        /* result is an rvalue */
X#define EXPR_CONST    0x0002        /* result is constant */
X#define EXPR_ASSIGN    0x0004        /* result is an assignment */
X
X#define isrvalue(n)    ((n) & EXPR_RVALUE)    /* TRUE if expression is rvalue */
X#define islvalue(n)    (((n) & EXPR_RVALUE) == 0)    /* TRUE if expr is lvalue */
X#define isconst(n)    ((n) & EXPR_CONST)    /* TRUE if expr is constant */
X#define isassign(n)    ((n) & EXPR_ASSIGN)    /* TRUE if expr is an assignment */
X
X
X/*
X * Flags for modes for tokenizing.
X */
X#define TM_DEFAULT    0x0        /* normal mode */
X#define TM_NEWLINES    0x1        /* treat any newline as a token */
X#define TM_ALLSYMS    0x2        /* treat almost everything as a symbol */
X
X
Xextern long errorcount;        /* number of errors found */
X
Xextern char *tokenstring MATH_PROTO((void));
Xextern long tokennumber MATH_PROTO((void));
Xextern void inittokens MATH_PROTO((void));
Xextern int tokenmode MATH_PROTO((int flag));
Xextern int gettoken MATH_PROTO((void));
Xextern void rescantoken MATH_PROTO((void));
X
X#ifdef VARARGS
Xextern void scanerror();
X#else
Xextern void scanerror MATH_PROTO((int, char *, ...));
X#endif
X
X#endif
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/token.h || echo "restore of calc2.9.0/token.h fails"
set `wc -c calc2.9.0/token.h`;Sum=$1
if test "$Sum" != "5031"
then echo original size 5031, current size $Sum;fi
echo "x - extracting calc2.9.0/value.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/value.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 * Generic value manipulation routines.
X */
X
X#include "value.h"
X#include "opcodes.h"
X#include "func.h"
X#include "symbol.h"
X#include "string.h"
X
X
X/*
X * Free a value and set its type to undefined.
X */
Xvoid
Xfreevalue(vp)
X    register VALUE *vp;    /* value to be freed */
X{
X    int type;        /* type of value being freed */
X
X    type = vp->v_type;
X    vp->v_type = V_NULL;
X    switch (type) {
X        case V_NULL:
X        case V_ADDR:
X        case V_FILE:
X            break;
X        case V_STR:
X            if (vp->v_subtype == V_STRALLOC)
X                free(vp->v_str);
X            break;
X        case V_NUM:
X            qfree(vp->v_num);
X            break;
X        case V_COM:
X            comfree(vp->v_com);
X            break;
X        case V_MAT:
X            matfree(vp->v_mat);
X            break;
X        case V_LIST:
X            listfree(vp->v_list);
X            break;
X        case V_ASSOC:
X            assocfree(vp->v_assoc);
X            break;
X        case V_OBJ:
X            objfree(vp->v_obj);
X            break;
X        default:
X            math_error("Freeing unknown value type");
X    }
X}
X
X
X/*
X * Copy a value from one location to another.
X * This overwrites the specified new value without checking it.
X */
Xvoid
Xcopyvalue(oldvp, newvp)
X    register VALUE *oldvp;        /* value to be copied from */
X    register VALUE *newvp;        /* value to be copied into */
X{
X    newvp->v_type = V_NULL;
X    switch (oldvp->v_type) {
X        case V_NULL:
X            break;
X        case V_FILE:
X            newvp->v_file = oldvp->v_file;
X            break;
X        case V_NUM:
X            newvp->v_num = qlink(oldvp->v_num);
X            break;
X        case V_COM:
X            newvp->v_com = clink(oldvp->v_com);
X            break;
X        case V_STR:
X            newvp->v_str = oldvp->v_str;
X            if (oldvp->v_subtype == V_STRALLOC) {
X                newvp->v_str = (char *)malloc(strlen(oldvp->v_str) + 1);
X                if (newvp->v_str == NULL)
X                    math_error("Cannot get memory for string copy");
X                strcpy(newvp->v_str, oldvp->v_str);
X            }
X            break;
X        case V_MAT:
X            newvp->v_mat = matcopy(oldvp->v_mat);
X            break;
X        case V_LIST:
X            newvp->v_list = listcopy(oldvp->v_list);
X            break;
X        case V_ASSOC:
X            newvp->v_assoc = assoccopy(oldvp->v_assoc);
X            break;
X        case V_ADDR:
X            newvp->v_addr = oldvp->v_addr;
X            break;
X        case V_OBJ:
X            newvp->v_obj = objcopy(oldvp->v_obj);
X            break;
X        default:
X            math_error("Copying unknown value type");
X    }
X    newvp->v_subtype = oldvp->v_subtype;
X    newvp->v_type = oldvp->v_type;
X
X}
X
X
X/*
X * Negate an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xnegvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qneg(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cneg(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matneg(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_NEG, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for negation");
X    }
X}
X
X
X/*
X * Add two arbitrary values together.
X * Result is placed in the indicated location.
X */
Xvoid
Xaddvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qadd(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = caddq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            vres->v_com = caddq(v2->v_com, v1->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cadd(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matadd(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                math_error("Non-compatible values for add");
X            *vres = objcall(OBJ_ADD, v1, v2, NULL_VALUE);
X            return;
X    }
X}
X
X
X/*
X * Subtract one arbitrary value from another one.
X * Result is placed in the indicated location.
X */
Xvoid
Xsubvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qsub(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = csubq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_NUM, V_COM):
X            c = csubq(v2->v_com, v1->v_num);
X            vres->v_com = cneg(c);
X            comfree(c);
X            vres->v_type = V_COM;
X            return;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = csub(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matsub(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                math_error("Non-compatible values for subtract");
X            *vres = objcall(OBJ_SUB, v1, v2, NULL_VALUE);
X            return;
X    }
X}
X
X
X/*
X * Multiply two arbitrary values together.
X * Result is placed in the indicated location.
X */
Xvoid
Xmulvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (TWOVAL(v1->v_type, v2->v_type)) {
X        case TWOVAL(V_NUM, V_NUM):
X            vres->v_num = qmul(v1->v_num, v2->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case TWOVAL(V_COM, V_NUM):
X            vres->v_com = cmulq(v1->v_com, v2->v_num);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_NUM, V_COM):
X            vres->v_com = cmulq(v2->v_com, v1->v_num);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_COM, V_COM):
X            vres->v_com = cmul(v1->v_com, v2->v_com);
X            vres->v_type = V_COM;
X            break;
X        case TWOVAL(V_MAT, V_MAT):
X            vres->v_mat = matmul(v1->v_mat, v2->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case TWOVAL(V_MAT, V_NUM):
X        case TWOVAL(V_MAT, V_COM):
X            vres->v_mat = matmulval(v1->v_mat, v2);
X            vres->v_type = V_MAT;
X            return;
X        case TWOVAL(V_NUM, V_MAT):
X        case TWOVAL(V_COM, V_MAT):
X            vres->v_mat = matmulval(v2->v_mat, v1);
X            vres->v_type = V_MAT;
X            return;
X        default:
X            if ((v1->v_type != V_OBJ) && (v2->v_type != V_OBJ))
X                math_error("Non-compatible values for multiply");
X            *vres = objcall(OBJ_MUL, v1, v2, NULL_VALUE);
X            return;
X    }
X    c = vres->v_com;
X    if (cisreal(c)) {
X        vres->v_num = qlink(c->real);
X        vres->v_type = V_NUM;
X        comfree(c);
X    }
X}
X
X
X/*
X * Square an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xsquarevalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qsquare(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = csquare(vp->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matsquare(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_SQUARE, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for squaring");
X    }
X}
X
X
X/*
X * Invert an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xinvertvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qinv(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cinv(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matinv(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INV, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for inverting");
X    }
X}
X
X
X/*
X * Round an arbitrary value to the specified number of decimal places.
X * Result is placed in the indicated location.
X */
Xvoid
Xroundvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long places;
X    NUMBER *q;
X    COMPLEX *c;
X
X    switch (v2->v_type) {
X        case V_NUM:
X            q = v2->v_num;
X            if (qisfrac(q) || zisbig(q->num))
X                math_error("Bad number of places for round");
X            places = qtoi(q);
X            break;
X        case V_INT:
X            places = v2->v_int;
X            break;
X        default:
X            math_error("Bad value type for places in round");
X    }
X    if (places < 0)
X        math_error("Negative number of places in round");
X    vres->v_type = V_NULL;
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisint(v1->v_num))
X                vres->v_num = qlink(v1->v_num);
X            else
X                vres->v_num = qround(v1->v_num, places);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(v1->v_com)) {
X                vres->v_com = clink(v1->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cround(v1->v_com, places);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matround(v1->v_mat, places);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_ROUND, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for round");
X    }
X}
X
X
X/*
X * Round an arbitrary value to the specified number of binary places.
X * Result is placed in the indicated location.
X */
Xvoid
Xbroundvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long places;
X    NUMBER *q;
X    COMPLEX *c;
X
X    switch (v2->v_type) {
X        case V_NUM:
X            q = v2->v_num;
X            if (qisfrac(q) || zisbig(q->num))
X                math_error("Bad number of places for bround");
X            places = qtoi(q);
X            break;
X        case V_INT:
X            places = v2->v_int;
X            break;
X        default:
X            math_error("Bad value type for places in bround");
X    }
X    if (places < 0)
X        math_error("Negative number of places in bround");
X    vres->v_type = V_NULL;
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisint(v1->v_num))
X                vres->v_num = qlink(v1->v_num);
X            else
X                vres->v_num = qbround(v1->v_num, places);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(v1->v_com)) {
X                vres->v_com = clink(v1->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cbround(v1->v_com, places);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matbround(v1->v_mat, places);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_BROUND, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for bround");
X    }
X}
X
X
X/*
X * Take the integer part of an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xintvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            if (qisint(vp->v_num))
X                vres->v_num = qlink(vp->v_num);
X            else
X                vres->v_num = qint(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(vp->v_com)) {
X                vres->v_com = clink(vp->v_com);
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_com = cint(vp->v_com);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (cisreal(c)) {
X                vres->v_num = qlink(c->real);
X                vres->v_type = V_NUM;
X                comfree(c);
X            }
X            return;
X        case V_MAT:
X            vres->v_mat = matint(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INT, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for int");
X    }
X}
X
X
X/*
X * Take the fractional part of an arbitrary value.
X * Result is placed in the indicated location.
X */
Xvoid
Xfracvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            if (qisint(vp->v_num))
X                vres->v_num = qlink(&_qzero_);
X            else
X                vres->v_num = qfrac(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            if (cisint(vp->v_com)) {
X                vres->v_num = clink(&_qzero_);
X                vres->v_type = V_NUM;
X                return;
X            }
X            vres->v_com = cfrac(vp->v_com);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matfrac(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_FRAC, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for frac function");
X    }
X}
X
X
X/*
X * Increment an arbitrary value by one.
X * Result is placed in the indicated location.
X */
Xvoid
Xincvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qinc(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = caddq(vp->v_com, &_qone_);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_INC, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for incrementing");
X    }
X}
X
X
X/*
X * Decrement an arbitrary value by one.
X * Result is placed in the indicated location.
X */
Xvoid
Xdecvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qdec(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = caddq(vp->v_com, &_qnegone_);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_DEC, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for decrementing");
X    }
X}
X
X
X/*
X * Produce the 'conjugate' of an arbitrary value.
X * Result is placed in the indicated location.
X * (Example: complex conjugate.)
X */
Xvoid
Xconjvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qlink(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = comalloc();
X            vres->v_com->real = qlink(vp->v_com->real);
X            vres->v_com->imag = qneg(vp->v_com->imag);
X            vres->v_type = V_COM;
X            return;
X        case V_MAT:
X            vres->v_mat = matconj(vp->v_mat);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_CONJ, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for conjugation");
X    }
X}
X
X
X/*
X * Take the square root of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xsqrtvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q, *tmp;
X    COMPLEX *c;
X
X    if (v2->v_type != V_NUM)
X        math_error("Non-real epsilon for sqrt");
X    q = v2->v_num;
X    if (qisneg(q) || qiszero(q))
X        math_error("Illegal epsilon value for sqrt");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (!qisneg(v1->v_num)) {
X                vres->v_num = qsqrt(v1->v_num, q);
X                vres->v_type = V_NUM;
X                return;
X            }
X            tmp = qneg(v1->v_num);
X            c = comalloc();
X            c->imag = qsqrt(tmp, q);
X            qfree(tmp);
X            vres->v_com = c;
X            vres->v_type = V_COM;
X            break;
X        case V_COM:
X            vres->v_com = csqrt(v1->v_com, q);
X            vres->v_type = V_COM;
X            break;
X        case V_OBJ:
X            *vres = objcall(OBJ_SQRT, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Bad value for taking square root");
X    }
X    c = vres->v_com;
X    if (cisreal(c)) {
X        vres->v_num = qlink(c->real);
X        vres->v_type = V_NUM;
X        comfree(c);
X    }
X}
X
X
X/*
X * Take the Nth root of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xrootvalue(v1, v2, v3, vres)
X    VALUE *v1;        /* value to take root of */
X    VALUE *v2;        /* value specifying root to take */
X    VALUE *v3;        /* value specifying error */
X    VALUE *vres;
X{
X    NUMBER *q1, *q2;
X    COMPLEX ctmp;
X
X    if ((v2->v_type != V_NUM) || (v3->v_type != V_NUM))
X        math_error("Non-real arguments for root");
X    q1 = v2->v_num;
X    q2 = v3->v_num;
X    if (qisneg(q1) || qiszero(q1) || qisfrac(q1))
X        math_error("Non-positive or non-integral root");
X    if (qisneg(q2) || qiszero(q2))
X        math_error("Non-positive epsilon for root");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (!qisneg(v1->v_num) || zisodd(q1->num)) {
X                vres->v_num = qroot(v1->v_num, q1, q2);
X                vres->v_type = V_NUM;
X                return;
X            }
X            ctmp.real = v1->v_num;
X            ctmp.imag = &_qzero_;
X            ctmp.links = 1;
X            vres->v_com = croot(&ctmp, q1, q2);
X            vres->v_type = V_COM;
X            return;
X        case V_COM:
X            vres->v_com = croot(v1->v_com, q1, q2);
X            vres->v_type = V_COM;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_ROOT, v1, v2, v3);
X            return;
X        default:
X            math_error("Taking root of bad value");
X    }
X}
X
X
X/*
X * Take the absolute value of an arbitrary value within the specified error.
X * Result is placed in the indicated location.
X */
Xvoid
Xabsvalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q, *epsilon;
X
X    if (v2->v_type != V_NUM)
X        math_error("Bad epsilon type for abs");
X    epsilon = v2->v_num;
X    if (qiszero(epsilon) || qisneg(epsilon))
X        math_error("Non-positive epsilon for abs");
X    switch (v1->v_type) {
X        case V_NUM:
X            if (qisneg(v1->v_num))
X                q = qneg(v1->v_num);
X            else
X                q = qlink(v1->v_num);
X            break;
X        case V_COM:
X            q = qhypot(v1->v_com->real, v1->v_com->imag, epsilon);
X            break;
X        case V_OBJ:
X            *vres = objcall(OBJ_ABS, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for absolute value");
X    }
X    vres->v_num = q;
X    vres->v_type = V_NUM;
X}
X
X
X/*
X * Calculate the norm of an arbitrary value.
X * Result is placed in the indicated location.
X * The norm is the square of the absolute value.
X */
Xvoid
Xnormvalue(vp, vres)
X    VALUE *vp, *vres;
X{
X    NUMBER *q1, *q2;
X
X    vres->v_type = V_NULL;
X    switch (vp->v_type) {
X        case V_NUM:
X            vres->v_num = qsquare(vp->v_num);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            q1 = qsquare(vp->v_com->real);
X            q2 = qsquare(vp->v_com->imag);
X            vres->v_num = qadd(q1, q2);
X            vres->v_type = V_NUM;
X            qfree(q1);
X            qfree(q2);
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_NORM, vp, NULL_VALUE, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for norm");
X    }
X}
X
X
X/*
X * Shift a value left or right by the specified number of bits.
X * Negative shift value means shift the direction opposite the selected dir.
X * Right shifts are defined to lose bits off the low end of the number.
X * Result is placed in the indicated location.
X */
Xvoid
Xshiftvalue(v1, v2, rightshift, vres)
X    VALUE *v1, *v2, *vres;
X    BOOL rightshift;    /* TRUE if shift right instead of left */
X{
X    COMPLEX *c;
X    long n;
X    VALUE tmp;
X
X    if (v2->v_type != V_NUM)
X        math_error("Non-real shift value");
X     if (qisfrac(v2->v_num))
X        math_error("Non-integral shift value");
X    if (v1->v_type != V_OBJ) {
X        if (zisbig(v2->v_num->num))
X            math_error("Very large shift value");
X        n = qtoi(v2->v_num);
X    }
X    if (rightshift)
X        n = -n;
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qshift(v1->v_num, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            c = cshift(v1->v_com, n);
X            if (!cisreal(c)) {
X                vres->v_com = c;
X                vres->v_type = V_COM;
X                return;
X            }
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matshift(v1->v_mat, n);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            if (!rightshift) {
X                *vres = objcall(OBJ_SHIFT, v1, v2, NULL_VALUE);
X                return;
X            }
X            tmp.v_num = qneg(v2->v_num);
X            tmp.v_type = V_NUM;
X            *vres = objcall(OBJ_SHIFT, v1, &tmp, NULL_VALUE);
X            qfree(tmp.v_num);
X            return;
X        default:
X            math_error("Bad value for shifting");
X    }
X}
X
X
X/*
X * Scale a value by a power of two.
X * Result is placed in the indicated location.
X */
Xvoid
Xscalevalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    long n;
X
X    if (v2->v_type != V_NUM)
X        math_error("Non-real scaling factor");
X    if (qisfrac(v2->v_num))
X        math_error("Non-integral scaling factor");
X    if (v1->v_type != V_OBJ) {
X        if (zisbig(v2->v_num->num))
X            math_error("Very large scaling factor");
X        n = qtoi(v2->v_num);
X    }
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qscale(v1->v_num, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cscale(v1->v_com, n);
X            vres->v_type = V_NUM;
X            return;
X        case V_MAT:
X            vres->v_mat = matscale(v1->v_mat, n);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_SCALE, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Bad value for scaling");
X    }
X}
X
X
X/*
X * Raise a value to an integral power.
X * Result is placed in the indicated location.
X */
Xvoid
Xpowivalue(v1, v2, vres)
X    VALUE *v1, *v2, *vres;
X{
X    NUMBER *q;
X    COMPLEX *c;
X
X    vres->v_type = V_NULL;
X    if (v2->v_type != V_NUM)
X        math_error("Raising value to non-real power");
X    q = v2->v_num;
X    if (qisfrac(q))
X        math_error("Raising value to non-integral power");
X    switch (v1->v_type) {
X        case V_NUM:
X            vres->v_num = qpowi(v1->v_num, q);
X            vres->v_type = V_NUM;
X            return;
X        case V_COM:
X            vres->v_com = cpowi(v1->v_com, q);
X            vres->v_type = V_COM;
X            c = vres->v_com;
X            if (!cisreal(c))
X                return;
X            vres->v_num = qlink(c->real);
X            vres->v_type = V_NUM;
X            comfree(c);
X            return;
X        case V_MAT:
X            vres->v_mat = matpowi(v1->v_mat, q);
X            vres->v_type = V_MAT;
X            return;
X        case V_OBJ:
X            *vres = objcall(OBJ_POW, v1, v2, NULL_VALUE);
X            return;
X        default:
X            math_error("Illegal value for raising to integer power");
X    }
X}
X
X
X/*
SHAR_EOF
echo "End of part 10"
echo "File calc2.9.0/value.c is continued in part 11"
echo "11" > s2_seq_.tmp
exit 0