Source Code 1994 March/Source_Code_CD-ROM_Walnut_Creek_March_1994.iso/compsrcs/unix/volume26/calc/part04

Text File | 1992-05-09 | 50.0 KB | 1,523 lines

Newsgroups: comp.sources.unix
From: [e-mail] (David I. Bell)
Subject: v26i030: CALC - An arbitrary precision C-like calculator, Part04/21
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (David I. Bell)
Posting-Number: Volume 26, Issue 30
Archive-Name: calc/part04

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 4 (of 21)."
# Contents:  addop.c help/file help/overview help/statement
#   lib/lucas_tbl.cal symbol.c
# Wrapped by dbell@elm on Tue Feb 25 15:20:58 1992
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'addop.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'addop.c'\"
else
echo shar: Extracting \"'addop.c'\" \(9489 characters\)
sed "s/^X//" >'addop.c' <<'END_OF_FILE'
X/*
X * Copyright (c) 1992 David I. Bell
X * Permission is granted to use, distribute, or modify this source,
X * provided that this copyright notice remains intact.
X *
X * Add opcodes to a function being compiled.
X */
X
X#include "calc.h"
X#include "opcodes.h"
X#include "string.h"
X#include "func.h"
X#include "token.h"
X#include "label.h"
X#include "symbol.h"
X
X
X#define    FUNCALLOCSIZE    20    /* reallocate size for functions */
X#define    OPCODEALLOCSIZE    100    /* reallocate size for opcodes in functions */
X
X
Xstatic long maxopcodes;        /* number of opcodes available */
Xstatic long newindex;        /* index of new function */
Xstatic long oldop;        /* previous opcode */
Xstatic long debugline;        /* line number of latest debug opcode */
Xstatic long funccount;        /* number of functions */
Xstatic long funcavail;        /* available number of functions */
Xstatic FUNC *functemplate;    /* function definition template */
Xstatic FUNC **functions;    /* table of functions */
Xstatic STRINGHEAD funcnames;    /* function names */
Xstatic int codeflag;
X
XNUMBER *constvalue();
X
X
X/*
X * Initialize the table of user defined functions.
X */
Xvoid
Xinitfunctions()
X{
X    initstr(&funcnames);
X    maxopcodes = OPCODEALLOCSIZE;
X    functemplate = (FUNC *) malloc(funcsize(maxopcodes));
X    if (functemplate == NULL)
X        error("Cannot allocate function template");
X    functions = (FUNC **) malloc(sizeof(FUNC *) * FUNCALLOCSIZE);
X    if (functions == NULL)
X        error("Cannot allocate function table");
X    funccount = 0;
X    funcavail = FUNCALLOCSIZE;
X}
X
X
X/*
X * Show the list of user defined functions.
X */
Xvoid
Xshowfunctions()
X{
X    FUNC **fpp;        /* pointer into function table */
X    FUNC *fp;        /* current function */
X
X    if (funccount == 0) {
X        printf("No user functions defined.\n");
X        return;
X    }
X    printf("Name Arguments\n");
X    printf("---- ---------\n");
X    for (fpp = &functions[funccount - 1]; fpp >= functions; fpp--) {
X        fp = *fpp;
X        if (fp == NULL)
X            continue;
X        printf("%-12s %-2d\n", fp->f_name, fp->f_paramcount);
X    }
X    printf("\n");
X}
X
X
X/*
X * Initialize a function for definition.
X * Newflag is TRUE if we should allocate a new function structure,
X * instead of the usual overwriting of the template function structure.
X * The new structure is returned in the global curfunc variable.
X */
Xvoid
Xbeginfunc(name, newflag)
X    char *name;            /* name of function */
X    BOOL newflag;            /* TRUE if need new structure */
X{
X    register FUNC *fp;        /* current function */
X
X    newindex = adduserfunc(name);
X    maxopcodes = OPCODEALLOCSIZE;
X    fp = functemplate;
X    if (newflag) {
X        fp = (FUNC *) malloc(funcsize(maxopcodes));
X        if (fp == NULL)
X            error("Cannot allocate temporary function");
X    }
X    fp->f_next = NULL;
X    fp->f_localcount = 0;
X    fp->f_opcodecount = 0;
X    fp->f_savedvalue.v_type = V_NULL;
X    fp->f_name = namestr(&funcnames, newindex);
X    curfunc = fp;
X    initlocals();
X    initlabels();
X    oldop = OP_NOP;
X    debugline = 0;
X    errorcount = 0;
X}
X
X
X/*
X * Commit the just defined function for use.
X * This replaces any existing definition for the function.
X * This should only be called for normal user-defined functions.
X */
Xvoid
Xendfunc()
X{
X    register FUNC *fp;        /* function just finished */
X    long size;            /* size of just created function */
X
X    checklabels();
X    if (errorcount) {
X        printf("\"%s\": %ld error%s\n", curfunc->f_name, errorcount,
X            ((errorcount == 1) ? "" : "s"));
X        return;
X    }
X    size = funcsize(curfunc->f_opcodecount);
X    fp = (FUNC *) malloc(size);
X    if (fp == NULL)
X        error("Cannot commit function");
X    memcpy((char *) fp, (char *) curfunc, size);
X    if (curfunc != functemplate)
X        free(curfunc);
X    if (codeflag) {
X        for (size = 0; size < fp->f_opcodecount; ) {
X            printf("%ld: ", (long)size);
X            size += dumpop(&fp->f_opcodes[size]);
X        }
X    }
X    if (functions[newindex])
X        free(functions[newindex]);
X    functions[newindex] = fp;
X    objuncache();
X    if (inputisterminal())
X        printf("\"%s\" defined\n", fp->f_name);
X}
X
X
X/*
X * Find the user function with the specified name, and return its index.
X * If the function does not exist, its name is added to the function table
X * and an error will be generated when it is called if it is still undefined.
X */
Xlong
Xadduserfunc(name)
X    char *name;        /* name of function */
X{
X    long index;        /* index of function */
X
X    index = findstr(&funcnames, name);
X    if (index >= 0)
X        return index;
X    if (funccount >= funcavail) {
X        functions = (FUNC **) realloc(functions,
X            sizeof(FUNC *) * (funcavail + FUNCALLOCSIZE));
X        if (functions == NULL)
X            error("Failed to reallocate function table");
X        funcavail += FUNCALLOCSIZE;
X    }
X    if (addstr(&funcnames, name) == NULL)
X        error("Cannot save function name");
X    index = funccount++;
X    functions[index] = NULL;
X    return index;
X}
X
X
X/*
X * Clear any optimization that may be done for the next opcode.
X * This is used when defining a label.
X */
Xvoid
Xclearopt()
X{
X    oldop = OP_NOP;
X    debugline = 0;
X}
X
X
X/*
X * Find a function structure given its index.
X */
XFUNC *
Xfindfunc(index)
X    long index;
X{
X    if ((unsigned long) index >= funccount)
X        error("Undefined function");
X    return functions[index];
X}
X
X
X/*
X * Return the name of a function given its index.
X */
Xchar *
Xnamefunc(index)
X    long index;
X{
X    return namestr(&funcnames, index);
X}
X
X
X/*
X * Add an opcode to the current function being compiled.
X * Note: This can change the curfunc global variable when the
X * function needs expanding.
X */
Xvoid
Xaddop(op)
X    long op;
X{
X    register FUNC *fp;        /* current function */
X    NUMBER *q;
X
X    fp = curfunc;
X    if ((fp->f_opcodecount + 5) >= maxopcodes) {
X        maxopcodes += OPCODEALLOCSIZE;
X        fp = (FUNC *) malloc(funcsize(maxopcodes));
X        if (fp == NULL)
X            error("cannot reallocate function");
X        memcpy((char *) fp, (char *) curfunc,
X            funcsize(curfunc->f_opcodecount));
X        if (curfunc != functemplate)
X            free(curfunc);
X        curfunc = fp;
X    }
X    /*
X     * Check the current opcode against the previous opcode and try to
X     * slightly optimize the code depending on the various combinations.
X     */
X    if (op == OP_GETVALUE) {
X        switch (oldop) {
X
X        case OP_NUMBER: case OP_ZERO: case OP_ONE: case OP_IMAGINARY:
X        case OP_GETEPSILON: case OP_SETEPSILON: case OP_STRING:
X        case OP_UNDEF: case OP_GETCONFIG: case OP_SETCONFIG:
X            return;
X        case OP_DUPLICATE:
X            fp->f_opcodes[fp->f_opcodecount - 1] = OP_DUPVALUE;
X            oldop = OP_DUPVALUE;
X            return;
X        case OP_INDEXADDR:
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_INDEXVALUE;
X            oldop = OP_INDEXVALUE;
X            return;
X        case OP_FIADDR:
X            fp->f_opcodes[fp->f_opcodecount - 1] = OP_FIVALUE;
X            oldop = OP_FIVALUE;
X            return;
X        case OP_GLOBALADDR:
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_GLOBALVALUE;
X            oldop = OP_GLOBALVALUE;
X            return;
X        case OP_LOCALADDR:
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_LOCALVALUE;
X            oldop = OP_LOCALVALUE;
X            return;
X        case OP_PARAMADDR:
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_PARAMVALUE;
X            oldop = OP_PARAMVALUE;
X            return;
X        case OP_ELEMADDR:
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_ELEMVALUE;
X            oldop = OP_ELEMVALUE;
X            return;
X        }
X    }
X    if ((op == OP_NEGATE) && (oldop == OP_NUMBER)) {
X        q = constvalue(fp->f_opcodes[fp->f_opcodecount - 1]);
X        fp->f_opcodes[fp->f_opcodecount - 1] = addqconstant(qneg(q));
X        oldop = OP_NUMBER;
X        return;
X    }
X    if ((op == OP_POWER) && (oldop == OP_NUMBER)) {
X        if (qcmpi(constvalue(fp->f_opcodes[fp->f_opcodecount - 1]), 2L) == 0) {
X            fp->f_opcodecount--;
X            fp->f_opcodes[fp->f_opcodecount - 1] = OP_SQUARE;
X            oldop = OP_SQUARE;
X            return;
X        }
X        if (qcmpi(constvalue(fp->f_opcodes[fp->f_opcodecount - 1]), 4L) == 0) {
X            fp->f_opcodes[fp->f_opcodecount - 2] = OP_SQUARE;
X            fp->f_opcodes[fp->f_opcodecount - 1] = OP_SQUARE;
X            oldop = OP_SQUARE;
X            return;
X        }
X    }
X    if ((op == OP_POP) && (oldop == OP_ASSIGN)) {    /* optimize */
X        fp->f_opcodes[fp->f_opcodecount - 1] = OP_ASSIGNPOP;
X        oldop = OP_ASSIGNPOP;
X        return;
X    }
X    /*
X     * No optimization possible, so store the opcode.
X     */
X    fp->f_opcodes[fp->f_opcodecount] = op;
X    fp->f_opcodecount++;
X    oldop = op;
X}
X
X
X/*
X * Add an opcode and an index to the current function being compiled.
X */
Xvoid
Xaddopindex(op, index)
X    long op;
X    long index;
X{
X    NUMBER *q;
X
X    switch (op) {
X    case OP_NUMBER:
X        q = constvalue(index);
X        if (qiszero(q)) {
X            addop(OP_ZERO);
X            return;
X        }
X        if (qisone(q)) {
X            addop(OP_ONE);
X            return;
X        }
X        break;
X
X    case OP_DEBUG:
X        if ((traceflags & TRACE_NODEBUG) || (index == debugline))
X            return;
X        debugline = index;
X        if (oldop == OP_DEBUG) {
X            curfunc->f_opcodes[curfunc->f_opcodecount - 1] = index;
X            return;
X        }
X        break;
X    }
X    addop(op);
X    curfunc->f_opcodes[curfunc->f_opcodecount] = index;
X    curfunc->f_opcodecount++;
X}
X
X
X/*
X * Add an opcode and a character pointer to the function being compiled.
X */
Xvoid
Xaddopptr(op, ptr)
X    long op;
X    char *ptr;
X{
X    char **ptraddr;
X
X    addop(op);
X    ptraddr = (char **) &curfunc->f_opcodes[curfunc->f_opcodecount];
X    *ptraddr = ptr;
X    curfunc->f_opcodecount += PTR_SIZE;
X}
X
X
X/*
X * Add an opcode and an index and an argument count for a function call.
X */
Xvoid
Xaddopfunction(op, index, count)
X    long op;
X    long index;
X{
X    long newop;
X
X    if ((op == OP_CALL) && ((newop = builtinopcode(index)) != OP_NOP)) {
X        if ((newop == OP_SETCONFIG) && (count == 1))
X            newop = OP_GETCONFIG;
X        if ((newop == OP_SETEPSILON) && (count == 0))
X            newop = OP_GETEPSILON;
X        if ((newop == OP_ABS) && (count == 1))
X            addop(OP_GETEPSILON);
X        addop(newop);
X        return;
X    }
X    addop(op);
X    curfunc->f_opcodes[curfunc->f_opcodecount++] = index;
X    curfunc->f_opcodes[curfunc->f_opcodecount++] = count;
X}
X
X
X/*
X * Add a jump-type opcode and a label to the function being compiled.
X */
Xvoid
Xaddoplabel(op, label)
X    long op;
X    LABEL *label;        /* label to be added */
X{
X    addop(op);
X    uselabel(label);
X}
X
X/* END CODE */
END_OF_FILE
if test 9489 -ne `wc -c <'addop.c'`; then
    echo shar: \"'addop.c'\" unpacked with wrong size!
fi
# end of 'addop.c'
fi
if test -f 'help/file' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'help/file'\"
else
echo shar: Extracting \"'help/file'\" \(7229 characters\)
sed "s/^X//" >'help/file' <<'END_OF_FILE'
XUsing files
X
X    The calculator provides some functions which allow the program to
X    read or write text files.  These functions use stdio internally,
X    and the functions appear similar to some of the stdio functions.
X    Some differences do occur, as will be explained here.
X
X    Names of files are subject to ~ expansion just like the C or
X    Korn shell.  For example, the file name:
X
X        ~/.rc.cal
X
X    refers to the file '.rc.cal' under your home directory.  The
X    file name:
X
X        ~chongo/.rc.cal
X
X    refers to the a file 'rc.cal' under the home directory of 'chongo'.
X
X    A file can be opened for either reading, writing, or appending.
X    To do this, the 'fopen' function is used, which accepts a filename
X    and an open mode, both as strings.  You use 'r' for reading, 'w'
X    for writing, and 'a' for appending.  For example, to open the file
X    'foo' for reading, the following could be used:
X
X        fd = fopen('foo', 'r');
X
X    If the open is unsuccessful, the numeric value of errno is returned.
X    If the open is successful, a value of type 'file' will be returned.
X    You can use the 'isfile' function to test the return value to see
X    if the open succeeded.  You should assign the return value of fopen
X    to a variable for later use.  File values can be copied to more than
X    one variable, and using any of the variables with the same file value
X    will produce the same results.
X
X    If you overwrite a variable containing a file value or don't save the
X    result of an 'fopen', the opened file still remains open.  Such 'lost'
X    files can be recovered by using the 'files' function.  This function
X    either takes no arguments or else takes one integer argument.  If no
X    arguments are given, then 'files' returns the maximum number of opened
X    files.  If an argument is given, then the 'files' function uses it as
X    an index into an internal table of open files, and returns a value
X    referring to one the open files.  If that entry in the table is not
X    in use, then the null value is returned instead.  Index 0 always
X    refers to standard input, index 1 always refers to standard output,
X    and index 2 always refers to standard error.  These three files are
X    already open by the calculator and cannot be closed.  As an example
X    of using 'files', if you wanted to assign a file value which is
X    equivalent to stdout, you could use:
X
X        stdout = files(1);
X
X    The 'fclose' function is used to close a file which had been opened.
X    When this is done, the file value associated with the file remains
X    a file value, but appears 'closed', and cannot be used in further
X    file-related calls (except fclose) without causing errors.  This same
X    action occurs to all copies of the file value.  You do not need to
X    explicitly close all the copies of a file value.  The 'fclose'
X    function returns the numeric value of errno if there had been an
X    error using the file, or the null value if there was no error.
X
X    File values can be printed.  When this is done, the filename of the
X    opened file is printed inside of quote marks.  If the file value had
X    been closed, then the null string is printed.  If a file value is the
X    result of a top-level expression, then in addition to the filename,
X    the open mode, file position, and possible EOF, error, and closed
X    status is also displayed.
X
X    File values can be used inside of 'if' tests.  When this is done,
X    an opened file is TRUE, and a closed file is FALSE.  As an example
X    of this, the following loop will print the names of all the currently
X    opened non-standard files with their indexes, and then close them:
X
X        for (i = 3; i < files(); i++) {
X            if (files(i)) {
X                print i, files(i);
X                fclose(files(i));
X            }
X        }
X
X    The functions to read from files are 'fgetline' and 'fgetc'.
X    The 'fgetline' function accepts a file value, and returns the next
X    input line from a file.  The line is returned as a string value, and
X    does not contain the end of line character.  Empty lines return the
X    null string.  When the end of file is reached, fgetline returns the
X    null value.  (Note the distinction between a null string and a null
X    value.)  If the line contained a numeric value, then the 'eval'
X    function can then be used to convert the string to a numeric value.
X    Care should be used when doing this, however, since eval will
X    generate an error if the string doesn't represent a valid expression.
X    The 'fgetc' function returns the next character from a file as a
X    single character string.  It returns the null value when end of file
X    is reached.
X
X    The 'printf' and 'fprintf' functions are used to print results to a
X    file (which could be stdout or stderr).  The 'fprintf' function
X    accepts a file variable, whereas the 'printf' function assumes the
X    use of 'files(1)' (stdout).  They both require a format string, which
X    is used in almost the same way as in normal C.  The differences come
X    in the interpretation of values to be printed for various formats.
X    Unlike in C, where an unmatched format type and value will cause
X    problems, in the calculator nothing bad will happen.  This is because
X    the calculator knows the types of all values, and will handle them
X    all reasonably.  What this means is that you can (for example), always
X    use %s or %d in your format strings, even if you are printing a non-
X    string or non-numeric value.  For example, the following is valid:
X
X        printf("Two values are %d and %s\n", "fred", 4567);
X
X    and will print "Two values are fred and 4567".
X
X    Using particular format characters, however, is still useful if
X    you wish to use width or precision arguments in the format, or if
X    you wish to print numbers in a particular format.  The following
X    is a list of the possible numeric formats:
X
X        %d        print in currently defined numeric format
X        %f        print as floating point
X        %e        print as exponential
X        %r        print as decimal fractions
X        %x        print as hex fractions
X        %o        print as octal fractions
X        %b        print as binary fractions
X
X    Note then, that using %d in the format makes the output configurable
X    by using the 'config' function to change the output mode, whereas
X    the other formats override the mode and force the output to be in
X    the specified format.
X
X    Using the precision argument will override the 'config' function
X    to set the number of decimal places printed.  For example:
X
X        printf("The number is %.100f\n", 1/3);
X
X    will print 100 decimal places no matter what the display configuration
X    value is set to.
X
X    The %s and %c formats are identical, and will print out the string
X    representation of the value.  In these cases, the precision argument
X    will truncate the output the same way as in standard C.
X
X    If a matrix or list is printed, then the output mode and precision
X    affects the printing of each individual element.  However, field
X    widths are ignored since these values print using multiple lines.
X    Field widths are also ignored if an object value prints on multiple
X    lines.
X
X    The final file-related functions are 'fflush', 'ferror', and 'feof'.
X    The 'fflush' function forces buffered output to a file.  The 'ferror'
X    function returns nonzero if an error had occurred to a file.  The
X    'feof' function returns nonzero if end of file has been reached
X    while reading a file.
X
X    The 'strprintf' function formats output similarly to 'printf',
X    but the output is returned as a string value instead of being
X    printed.
END_OF_FILE
if test 7229 -ne `wc -c <'help/file'`; then
    echo shar: \"'help/file'\" unpacked with wrong size!
fi
# end of 'help/file'
fi
if test -f 'help/overview' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'help/overview'\"
else
echo shar: Extracting \"'help/overview'\" \(6768 characters\)
sed "s/^X//" >'help/overview' <<'END_OF_FILE'
X            CALC - An arbitrary precision calculator.
X                by David I. Bell
X
X
X    This is a calculator program with arbitrary precision arithmetic.
X    All numbers are represented as fractions with arbitrarily large
X    numerators and denominators which are always reduced to lowest terms.
X    Real or exponential format numbers can be input and are converted
X    to the equivalent fraction.  Hex, binary, or octal numbers can be
X    input by using numbers with leading '0x', '0b' or '0' characters.
X    Complex numbers can be input using a trailing 'i', as in '2+3i'.
X    Strings and characters are input by using single or double quotes.
X
X    Commands are statements in a C-like language, where each input
X    line is treated as the body of a procedure.  Thus the command
X    line can contain variable declarations, expressions, labels,
X    conditional tests, and loops.  Assignments to any variable name
X    will automatically define that name as a global variable.  The
X    other important thing to know is that all non-assignment expressions
X    which are evaluated are automatically printed.  Thus, you can evaluate
X    an expression's value by simply typing it in.
X
X    Many useful built-in mathematical functions are available.  Use
X    the 'show builtins' command to list them.  You can also define
X    your own functions by using the 'define' keyword, followed by a
X    function declaration very similar to C.  Functions which only
X    need to return a simple expression can be defined using an
X    equals sign, as in the example 'define sc(a,b) = a^3 + b^3'.
X    Variables in functions can be defined as either 'global' or
X    'local'.  Global variables are common to all functions and the
X    command line, whereas local variables are unique to each
X    function level, and are destroyed when the function returns.
X    Variables are not typed at definition time, but dynamically
X    change as they are used.  So you must supply the correct type
X    of variable to those functions and operators which only work
X    for a subset of types.
X
X    By default, arguments to functions are passed by value (even
X    matrices).  For speed, you can put an ampersand before any
X    variable argument in a function call, and that variable will be
X    passed by reference instead.  However, if the function changes
X    its argument, the variable will change.  Arguments to built-in
X    functions and object manipulation functions are always called
X    by reference.  If a user-defined function takes more arguments
X    than are passed, the undefined arguments have the null value.
X    The 'param' function returns function arguments by argument
X    number, and also returns the number of arguments passed.  Thus
X    functions can be written to handle an arbitrary number of
X    arguments.
X
X    The mat statement is used to create a matrix.  It takes a
X    variable name, followed by the bounds of the matrix in square
X    brackets.  The lower bounds are zero by default, but colons can
X    be used to change them.  For example 'mat foo[3, 1:10]' defines
X    a two dimensional matrix, with the first index ranging from 0
X    to 3, and the second index ranging from 1 to 10.  The bounds of
X    a matrix can be an expression calculated at runtime.
X
X    Lists of values are created using the 'list' function, and values can
X    be inserted or removed from either the front or the end of the list.
X    List elements can be indexed directly using double square brackets.
X
X    The obj statement is used to create an object.  Objects are
X    user-defined values for which user-defined routines are
X    implicitly called to perform simple actions such as add,
X    multiply, compare, and print. Objects types are defined as in
X    the example 'obj complex {real, imag}', where 'complex' is the
X    name of the object type, and 'real' and 'imag' are element
X    names used to define the value of the object (very much like
X    structures).  Variables of an object type are created as in the
X    example 'obj complex x,y', where 'x' and 'y' are variables.
X    The elements of an object are referenced using a dot, as in the
X    example 'x.real'. All user-defined routines have names composed
X    of the object type and the action to perform separated by an
X    underscore, as in the example 'complex_add'.  The command 'show
X    objfuncs' lists all the definable routines.  Object routines
X    which accept two arguments should be prepared to handle cases
X    in which either one of the arguments is not of the expected
X    object type.
X
X    These are the differences between the normal C operators and
X    the ones defined by the calculator.  The '/' operator divides
X    fractions, so that '7 / 2' evaluates to 7/2. The '//' operator
X    is an integer divide, so that '7 // 2' evaluates to 3.  The '^'
X    operator is a integral power function, so that 3^4 evaluates to
X    81.  Matrices of any dimension can be treated as a zero based
X    linear array using double square brackets, as in 'foo[[3]]'.
X    Matrices can be indexed by using commas between the indices, as
X    in foo[3,4].  Object and list elements can be referenced by
X    using double square brackets.
X
X    The print statement is used to print values of expressions.
X    Separating values by a comma puts one space between the output
X    values, whereas separating values by a colon concatenates the
X    output values.  A trailing colon suppresses printing of the end
X    of line.  An example of printing is 'print \"The square of\",
X    x, \"is\", x^2\'.
X
X    The 'config' function is used to modify certain parameters that
X    affect calculations or the display of values.  For example, the
X    output display mode can be set using 'config(\"mode\", type)',
X    where 'type' is one of 'frac', 'int', 'real', 'exp', 'hex',
X    'oct', or 'bin'.  The default output mode is real.  For the
X    integer, real, or exponential formats, a leading '~' indicates
X    that the number was truncated to the number of decimal places
X    specified by the default precision.  If the '~' does not
X    appear, then the displayed number is the exact value.
X
X    The number of decimal places printed is set by using
X    'config(\"display\", n)'.  The default precision for
X    real-valued functions can be set by using 'epsilon(x)', where x
X    is the required precision (such as 1e-50).
X
X    There is a command stack feature so that you can easily
X    re-execute previous commands and expressions from the terminal.
X    Each command is labeled with a two digit number. To execute a
X    command again, type '`n', where n is the number for the command
X    to be executed.  Using '`-n' re-execute the command which is
X    the n'th command back.  Using '``' re-executes the previous
X    command, and is a shortcut for typing '`-1'.  The '`h n'
X    command just displays the previous n commands (20 if n is not
X    given).
X
X    Files can be read in by using the 'read filename' command.
X    These can contain both functions to be defined, and expressions
X    to be calculated.  Global variables which are numbers can be
X    saved to a file by using the 'write filename' command.
END_OF_FILE
if test 6768 -ne `wc -c <'help/overview'`; then
    echo shar: \"'help/overview'\" unpacked with wrong size!
fi
# end of 'help/overview'
fi
if test -f 'help/statement' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'help/statement'\"
else
echo shar: Extracting \"'help/statement'\" \(8631 characters\)
sed "s/^X//" >'help/statement' <<'END_OF_FILE'
XStatements
X
X    Statements are very much like C statements.  Most statements act
X    identically to those in C, but there are minor differences and
X    some additions.  The following is a list of the statement types,
X    with explanation of the non-C statements.  In this list, upper
X    case words identify the keywords which are actually in lower case.
X    Statements are generally terminated with semicolons, except if the
X    statement is the compound one formed by matching braces.  Various
X    expressions are optional and may be omitted (as in RETURN).
X
X
X    NOTE: Calc commands are in lower case.   UPPER case is used below
X          for emphasis only, and should be considered in lower case.
X
X
X    IF (expr) statement
X    IF (expr) statement ELSE statement
X    FOR (optionalexpr ; optionalexpr ; optionalexpr) statement
X    WHILE (expr) statement
X    DO statement WHILE (expr)
X    CONTINUE
X    BREAK
X    GOTO label
X        These all work like in normal C.
X
X    RETURN optionalexpr
X        This returns a value from a function.  Functions always
X        have a return value, even if this statement is not used.
X        If no return statement is executed, or if no expression
X        is specified in the return statement, then the return
X        value from the function is the null type.
X
X    SWITCH (expr) { caseclauses }
X        Switch statements work similarly to C, except for the
X        following.  A switch can be done on any type of value,
X        and the case statements can be of any type of values.
X        The case statements can also be expressions calculated
X        at runtime.  The calculator compares the switch value
X        with each case statement in the order specified, and
X        selects the first case which matches.  The default case
X        is the exception, and only matches once all other cases
X        have been tested.
X
X    { statements }
X        This is a normal list of statements, each one ended by
X        a semicolon.  Unlike the C language, no declarations are
X        permitted within an inner-level compound statement.
X        Declarations are only permitted at the beginning of a
X        function definition, or at the beginning of an expression
X        sequence.
X
X    MAT variable [dimension] [dimension] ...
X    MAT variable [dimension, dimension, ...]
X
X        This creates a matrix variable with the specified dimensions.
X        Matrices can have from 1 to 4 dimensions.  When specifying
X        multiple dimensions, you can use either the standard C syntax,
X        or else you can use commas for separating the dimensions.
X        For example, the following two statements are equivalent,
X        and so will create the same two dimensional matrix:
X
X            mat foo[3][6];
X            mat foo[3,6];
X
X        By default, each dimension is indexed starting at zero,
X        as in normal C, and contains the specified number of
X        elements.  However, this can be changed if a colon is
X        used to separate two values.  If this is done, then the
X        two values become the lower and upper bounds for indexing.
X        This is convenient, for example, to create matrices whose
X        first row and column begin at 1.  Examples of matrix
X        definitions are:
X
X            mat x[3]    one dimension, bounds are 0-2
X            mat foo[4][5]    two dimensions, bounds are 0-3 and 0-4
X            mat a[-7:7]    one dimension, bounds are (-7)-7
X            mat s[1:9,1:9]    two dimensions, bounds are 1-9 and 1-9
X
X        Note that the MAT statement is not a declaration, but is
X        executed at runtime.  Within a function, the specified
X        variable must already be defined, and is just converted to
X        a matrix of the specified size, and all elements are set
X        to the value of zero.  For convenience, at the top level
X        command level, the MAT command automatically defines a
X        global variable of the specified name if necessary.
X
X        Since the MAT statement is executed, the bounds on the
X        matrix can be full expressions, and so matrices can be
X        dynamically allocated.  For example:
X
X            size = 20;
X            mat data[size*2];
X
X        allocates a matrix which can be indexed from 0 to 39.
X
X    OBJ type { elementnames } optionalvariables
X    OBJ type variables
X
X        These create a new object type, or create one or more
X        variables of the specified type.  For this calculator,
X        an object is just a structure which is implicitly acted
X        on by user defined routines.  The user defined routines
X        implement common operations for the object, such as plus
X        and minus, multiply and divide, comparison and printing.
X        The calculator will automatically call these routines in
X        order to perform many operations.
X
X        To create an object type, the data elements used in
X        implementing the object are specified within a pair
X        of braces, separated with commas.  For example, to
X        define an object will will represent points in 3-space,
X        whose elements are the three coordinate values, the
X        following could be used:
X
X            obj point {x, y, z};
X
X        This defines an object type called point, whose elements
X        have the names x, y, and z.  The elements are accessed
X        similarly to structure element accesses, by using a period.
X        For example, given a variable 'v' which is a point object,
X        the three coordinates of the point can be referenced by:
X
X            v.x
X            v.y
X            v.z
X
X        A particular object type can only be defined once, and
X        is global throughout all functions.  However, different
X        object types can be used at the same time.
X
X        In order to create variables of an object type, they
X        can either be named after the right brace of the object
X        creation statement, or else can be defined later with
X        another obj statement.  To create two points using the
X        second (and most common) method, the following is used:
X
X            obj point p1, p2;
X
X        This statement is executed, and is not a declaration.
X        Thus within a function, the variables p1 and p2 must have
X        been previously defined, and are just changed to be the
X        new object type.  For convenience, at the top level command
X        level, object variables are automatically defined as being
X        global when necessary.
X
X    EXIT string
X    QUIT string
X
X        This command is used in two cases.  At the top command
X        line level, quit will exit from the calculator.  This
X        is the normal way to leave the calculator.  In any other
X        use, quit will abort the current calculation as if an
X        error had occurred.  If a string is given, then the string
X        is printed as the reason for quitting, otherwise a general
X        quit message is printed.  The routine name and line number
X        which executed the quit is also printed in either case.
X
X        Quit is useful when a routine detects invalid arguments,
X        in order to stop a calculation cleanly.  For example,
X        for a square root routine, an error can be given if the
X        supplied parameter was a negative number, as in:
X
X            define mysqrt(n)
X            {
X                if (n < 0)
X                    quit "Negative argument";
X                ...
X            }
X
X        Exit is an alias for quit.
X
X
X    PRINT exprs
X
X        For interactive expression evaluation, the values of all
X        typed-in expressions are automatically displayed to the
X        user.  However, within a function or loop, the printing of
X        results must be done explicitly.  This can be done using
X        the 'printf' or 'fprintf' functions, as in standard C, or
X        else by using the built-in 'print' statement.  The advantage
X        of the print statement is that a format string is not needed.
X        Instead, the given values are simply printed with zero or one
X        spaces between each value.
X
X        Print accepts a list of expressions, separated either by
X        commas or colons.  Each expression is evaluated in order
X        and printed, with no other output, except for the following
X        special cases.  The comma which separates expressions prints
X        a single space, and a newline is printed after the last
X        expression unless the statement ends with a colon.  As
X        examples:
X
X            print 3, 4;        prints "3 4" and newline.
X            print 5:;        prints "5" with no newline.
X            print 'a' : 'b' , 'c';    prints "ab c" and newline.
X            print;            prints a newline.
X
X        For numeric values, the format of the number depends on the
X        current "mode" configuration parameter.  The initial mode
X        is to print real numbers, but it can be changed to other
X        modes such as exponential, decimal fractions, or hex.
X
X        If a matrix or list is printed, then the elements contained
X        within the matrix or list will also be printed, up to the
X        maximum number specified by the "maxprint" configuration
X        parameter.  If an element is also a matrix or a list, then
X        their values are not recursively printed.  Objects are printed
X        using their user-defined routine.  Printing a file value
X        prints the name of the file that was opened.
X
X
X    SHOW item
X
X        This command displays some information.
X        The following is a list of the various items:
X
X            builtins    built in functions
X            globals        global variables
X            functions    user-defined functions
X            objfuncs    possible object functions
X            memory        memory usage
X
X
X    Also see the help topic:
X
X        command         top level commands
END_OF_FILE
if test 8631 -ne `wc -c <'help/statement'`; then
    echo shar: \"'help/statement'\" unpacked with wrong size!
fi
# end of 'help/statement'
fi
if test -f 'lib/lucas_tbl.cal' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'lib/lucas_tbl.cal'\"
else
echo shar: Extracting \"'lib/lucas_tbl.cal'\" \(6758 characters\)
sed "s/^X//" >'lib/lucas_tbl.cal' <<'END_OF_FILE'
X/*
X * Copyright (c) 1992 Landon Curt Noll
X * Permission is granted to use, distribute, or modify this source,
X * provided that this copyright notice remains intact.
X *
X * By: Landon Curt Noll
X *     [e-mail]  -or-  ...!{pyramid,sun,uunet}!sun!hoptoad!chongo
X *
X *
X * Lucasian criteria for primality
X *
X * The following table is taken from:
X *
X *    "Lucasian Criteria for the Primality of N=h*2^n-1", by Hans Riesel,
X *    Mathematics of Computation, Vol 23 #108, p 872.
X *
X * The index of the *_val[] arrays correspond to the v(1) values found
X * in the table.  That is, for v(1) == x:
X *
X *    D == d_val[x]
X *    a == a_val[x]
X *    b == b_val[x]
X *    r == r_val[x]        (r == abs(a^2 - b^2*D))
X *
X *
X * Note that when *_val[i] is not a number, the related v(1) value
X * is not found in Table 1.
X */
X
Xtrymax = 100;
Xmat d_val[trymax+1];
Xmat a_val[trymax+1];
Xmat b_val[trymax+1];
Xmat r_val[trymax+1];
X/* v1= 0        INVALID */
X/* v1= 1        INVALID */
X/* v1= 2        INVALID */
Xd_val[ 3]=   5;  a_val[ 3]= 1;  b_val[ 3]=1;  r_val[ 3]=4;
Xd_val[ 4]=   3;  a_val[ 4]= 1;  b_val[ 4]=1;  r_val[ 4]=2;
Xd_val[ 5]=  21;  a_val[ 5]= 3;  b_val[ 5]=1;  r_val[ 5]=12;
Xd_val[ 6]=   2;  a_val[ 6]= 1;  b_val[ 6]=1;  r_val[ 6]=1;
X/* v1= 7        INVALID */
Xd_val[ 8]=  15;  a_val[ 8]= 3;  b_val[ 8]=1;  r_val[ 8]=6;
Xd_val[ 9]=  77;  a_val[ 9]= 7;  b_val[ 9]=1;  r_val[ 9]=28;
Xd_val[10]=   6;  a_val[10]= 2;  b_val[10]=1;  r_val[10]=2;
Xd_val[11]=  13;  a_val[11]= 3;  b_val[11]=1;  r_val[11]=4;
Xd_val[12]=  35;  a_val[12]= 5;  b_val[12]=1;  r_val[12]=10;
Xd_val[13]= 165;  a_val[13]=11;  b_val[13]=1;  r_val[13]=44;
X/* v1=14        INVALID */
Xd_val[15]= 221;  a_val[15]=13;  b_val[15]=1;  r_val[15]=52;
Xd_val[16]=   7;  a_val[16]= 3;  b_val[16]=1;  r_val[16]=2;
Xd_val[17]= 285;  a_val[17]=15;  b_val[17]=1;  r_val[17]=60;
X/* v1=18        INVALID */
Xd_val[19]= 357;  a_val[19]=17;  b_val[19]=1;  r_val[19]=68;
Xd_val[20]=  11;  a_val[20]= 3;  b_val[20]=1;  r_val[20]=2;
Xd_val[21]= 437;  a_val[21]=19;  b_val[21]=1;  r_val[21]=76;
Xd_val[22]=  30;  a_val[22]= 5;  b_val[22]=1;  r_val[22]=5;
X/* v1=23        INVALID */
Xd_val[24]= 143;  a_val[24]=11;  b_val[24]=1;  r_val[24]=22;
Xd_val[25]=  69;  a_val[25]= 9;  b_val[25]=1;  r_val[25]=12;
Xd_val[26]=  42;  a_val[26]= 6;  b_val[26]=1;  r_val[26]=6;
Xd_val[27]=  29;  a_val[27]= 5;  b_val[27]=1;  r_val[27]=4;
Xd_val[28]= 195;  a_val[28]=13;  b_val[28]=1;  r_val[28]=26;
Xd_val[29]=  93;  a_val[29]= 9;  b_val[29]=1;  r_val[29]=12;
Xd_val[30]=  14;  a_val[30]= 4;  b_val[30]=1;  r_val[30]=2;
Xd_val[31]= 957;  a_val[31]=29;  b_val[31]=1;  r_val[31]=116;
Xd_val[32]= 255;  a_val[32]=15;  b_val[32]=1;  r_val[32]=30;
Xd_val[33]=1085;  a_val[33]=31;  b_val[33]=1;  r_val[33]=124;
X/* v1=34        INVALID */
Xd_val[35]=1221;  a_val[35]=33;  b_val[35]=1;  r_val[35]=132;
Xd_val[36]= 323;  a_val[36]=17;  b_val[36]=1;  r_val[36]=34;
Xd_val[37]=1365;  a_val[37]=35;  b_val[37]=1;  r_val[37]=140;
Xd_val[38]=  10;  a_val[38]= 3;  b_val[38]=1;  r_val[38]=1;
Xd_val[39]=1517;  a_val[39]=37;  b_val[39]=1;  r_val[39]=148;
Xd_val[40]= 399;  a_val[40]=19;  b_val[40]=1;  r_val[40]=38;
Xd_val[41]=1677;  a_val[41]=39;  b_val[41]=1;  r_val[41]=156;
Xd_val[42]= 110;  a_val[42]=10;  b_val[42]=1;  r_val[42]=10;
Xd_val[43]= 205;  a_val[43]=15;  b_val[43]=1;  r_val[43]=20;
Xd_val[44]= 483;  a_val[44]=21;  b_val[44]=1;  r_val[44]=42;
Xd_val[45]=2021;  a_val[45]=43;  b_val[45]=1;  r_val[45]=172;
Xd_val[46]=  33;  a_val[46]= 6;  b_val[46]=1;  r_val[46]=3;
X/* v1=47        INVALID */
Xd_val[48]=  23;  a_val[48]= 5;  b_val[48]=1;  r_val[48]=2;
Xd_val[49]=2397;  a_val[49]=47;  b_val[49]=1;  r_val[49]=188;
Xd_val[50]=  39;  a_val[50]= 6;  b_val[50]=1;  r_val[50]=3;
Xd_val[51]=  53;  a_val[51]= 7;  b_val[51]=1;  r_val[51]=4;
X/* v1=52        INVALID */
Xd_val[53]=2805;  a_val[53]=51;  b_val[53]=1;  r_val[53]=204;
Xd_val[54]= 182;  a_val[54]=13;  b_val[54]=1;  r_val[54]=13;
Xd_val[55]=3021;  a_val[55]=53;  b_val[55]=1;  r_val[55]=212;
Xd_val[56]=  87;  a_val[56]= 9;  b_val[56]=1;  r_val[56]=6;
Xd_val[57]=3245;  a_val[57]=55;  b_val[57]=1;  r_val[57]=220;
Xd_val[58]= 210;  a_val[58]=14;  b_val[58]=1;  r_val[58]=14;
Xd_val[59]=3477;  a_val[59]=57;  b_val[59]=1;  r_val[59]=228;
Xd_val[60]= 899;  a_val[60]=29;  b_val[60]=1;  r_val[60]=58;
Xd_val[61]= 413;  a_val[61]=21;  b_val[61]=1;  r_val[61]=28;
X/* v1=62        INVALID */
Xd_val[63]=3965;  a_val[63]=61;  b_val[63]=1;  r_val[63]=244;
Xd_val[64]=1023;  a_val[64]=31;  b_val[64]=1;  r_val[64]=62;
Xd_val[65]= 469;  a_val[65]=21;  b_val[65]=1;  r_val[65]=28;
Xd_val[66]=  17;  a_val[66]= 4;  b_val[66]=1;  r_val[66]=1;
Xd_val[67]=4485;  a_val[67]=65;  b_val[67]=1;  r_val[67]=260;
Xd_val[68]=1155;  a_val[68]=33;  b_val[68]=1;  r_val[68]=66;
Xd_val[69]=4757;  a_val[69]=67;  b_val[69]=1;  r_val[69]=268;
Xd_val[70]=  34;  a_val[70]= 6;  b_val[70]=1;  r_val[70]=2;
Xd_val[71]=5037;  a_val[71]=69;  b_val[71]=1;  r_val[71]=276;
Xd_val[72]=1295;  a_val[72]=35;  b_val[72]=1;  r_val[72]=70;
Xd_val[73]= 213;  a_val[73]=15;  b_val[73]=1;  r_val[73]=12;
Xd_val[74]=  38;  a_val[74]= 6;  b_val[74]=1;  r_val[74]=2;
Xd_val[75]=5621;  a_val[75]=73;  b_val[75]=1;  r_val[75]=292;
Xd_val[76]=1443;  a_val[76]=37;  b_val[76]=1;  r_val[76]=74;
Xd_val[77]= 237;  a_val[77]=15;  b_val[77]=1;  r_val[77]=12;
Xd_val[78]=  95;  a_val[78]=10;  b_val[78]=1;  r_val[78]=5;
X/* v1=79        INVALID */
Xd_val[80]=1599;  a_val[80]=39;  b_val[80]=1;  r_val[80]=78;
Xd_val[81]=6557;  a_val[81]=79;  b_val[81]=1;  r_val[81]=316;
Xd_val[82]= 105;  a_val[82]=10;  b_val[82]=1;  r_val[82]=5;
Xd_val[83]=  85;  a_val[83]= 9;  b_val[83]=1;  r_val[83]=4;
Xd_val[84]=1763;  a_val[84]=41;  b_val[84]=1;  r_val[84]=82;
Xd_val[85]=7221;  a_val[85]=83;  b_val[85]=1;  r_val[85]=332;
Xd_val[86]= 462;  a_val[86]=21;  b_val[86]=1;  r_val[86]=21;
Xd_val[87]=7565;  a_val[87]=85;  b_val[87]=1;  r_val[87]=340;
Xd_val[88]= 215;  a_val[88]=15;  b_val[88]=1;  r_val[88]=10;
Xd_val[89]=7917;  a_val[89]=87;  b_val[89]=1;  r_val[89]=348;
Xd_val[90]= 506;  a_val[90]=22;  b_val[90]=1;  r_val[90]=22;
Xd_val[91]=8277;  a_val[91]=89;  b_val[91]=1;  r_val[91]=356;
Xd_val[92]= 235;  a_val[92]=15;  b_val[92]=1;  r_val[92]=10;
Xd_val[93]=8645;  a_val[93]=91;  b_val[93]=1;  r_val[93]=364;
Xd_val[94]= 138;  a_val[94]=12;  b_val[94]=1;  r_val[94]=6;
Xd_val[95]=9021;  a_val[95]=93;  b_val[95]=1;  r_val[95]=372;
Xd_val[96]=  47;  a_val[96]= 7;  b_val[96]=1;  r_val[96]=2;
Xd_val[97]=1045;  a_val[97]=33;  b_val[97]=1;  r_val[97]=44;
X/* v1=98        INVALID */
Xd_val[99]=9797;  a_val[99]=97;  b_val[99]=1;  r_val[99]=388;
Xd_val[100]=  51; a_val[100]= 7; b_val[100]=1; r_val[100]=2;
X
Xglobal lib_debug;
Xif (!isnum(lib_debug) || lib_debug>0) print "d_val[100] defined"
Xif (!isnum(lib_debug) || lib_debug>0) print "a_val[100] defined"
Xif (!isnum(lib_debug) || lib_debug>0) print "b_val[100] defined"
Xif (!isnum(lib_debug) || lib_debug>0) print "r_val[100] defined"
END_OF_FILE
if test 6758 -ne `wc -c <'lib/lucas_tbl.cal'`; then
    echo shar: \"'lib/lucas_tbl.cal'\" unpacked with wrong size!
fi
# end of 'lib/lucas_tbl.cal'
fi
if test -f 'symbol.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'symbol.c'\"
else
echo shar: Extracting \"'symbol.c'\" \(7254 characters\)
sed "s/^X//" >'symbol.c' <<'END_OF_FILE'
X/*
X * Copyright (c) 1992 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 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();
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 HASH(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}
X
X
X/*
X * Define a possibly new global variable.
X * If it did not already exist, it is created with an undefined value.
X * The address of the global symbol structure is returned.
X */
XGLOBAL *
Xaddglobal(name)
X    char *name;        /* name of global variable */
X{
X    GLOBAL *sp;        /* current symbol pointer */
X    GLOBAL **hp;        /* hash table head address */
X    long len;        /* length of string */
X
X    len = strlen(name);
X    if (len <= 0)
X        return NULL;
X    hp = &globalhash[HASH(name, len)];
X    for (sp = *hp; sp; sp = sp->g_next) {
X        if ((sp->g_len == len) && (strcmp(sp->g_name, name) == 0))
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_value.v_type = V_NULL;
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 * Returns NULL if the symbol was not found.
X */
XGLOBAL *
Xfindglobal(name)
X    char *name;        /* name of global variable */
X{
X    GLOBAL *sp;        /* current symbol pointer */
X    long len;        /* length of string */
X
X    len = strlen(name);
X    sp = globalhash[HASH(name, len)];
X    while (sp) {
X        if ((sp->g_len == len) && (strcmp(sp->g_name, name) == 0))
X            return sp;
X        sp = sp->g_next;
X    }
X    return sp;
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.
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 (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    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 = _outmode_;
X            _outmode_ = MODE_HEX;
X            printvalue(&sp->g_value, PRINT_UNAMBIG);
X            _outmode_ = savemode;
X            math_str(";\n");
X        }
X    }
X    setfp(stdout);
X    if (fclose(fp))
X        return 1;
X    return 0;
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, or undefined.
X */
Xsymboltype(name)
X    char *name;        /* variable name to find */
X{
X    if (findlocal(name) >= 0)
X        return SYM_LOCAL;
X    if (findparam(name) >= 0)
X        return SYM_PARAM;
X    if (findglobal(name))
X        return SYM_GLOBAL;
X    return SYM_UNDEFINED;
X}
X
X/* END CODE */
END_OF_FILE
if test 7254 -ne `wc -c <'symbol.c'`; then
    echo shar: \"'symbol.c'\" unpacked with wrong size!
fi
# end of 'symbol.c'
fi
echo shar: End of archive 4 \(of 21\).
cp /dev/null ark4isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 21 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0