Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/unix/volume27/calc-2.9.0/part02

Text File | 1993-12-07 | 61KB | 2,429 lines

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

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

#!/bin/sh
# this is part 2 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc2.9.0/alloc.c continued
#
CurArch=2
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/alloc.c"
sed 's/^X//' << 'SHAR_EOF' >> calc2.9.0/alloc.c
X
X    assert(bucket >= QUANTUM_NBITS, 1);
X    assert(bucket < NBUCKETS, 2);
X    assert(!nextf[bucket], 3);
X#ifndef NO_SBRK
X    /*
X     * Insure memory is allocated on a page boundary.
X     * Should make getpageize() call?
X     */
X#define PAGE_SIZE (1<<10)
X    siz = (u_int)sbrk(0);
X    if(siz & (PAGE_SIZE-1))
X        sbrk(PAGE_SIZE - (siz & (PAGE_SIZE-1)));
X#endif
X
X    /* take 2k unless the block is bigger than that */
X    rnu = (bucket <= 11) ? 11 : bucket;
X    assert(rnu >= bucket, 4);
X    nblks = 1L << (rnu - bucket); /* how many blocks to get */
X    siz = 1L << rnu;
X
X#ifndef NO_SBRK
X    op = (union overhead *)sbrk(siz);
X    /* no more room! */
X    if ((int)op == -1)
X        return;
X    /*
X     * Round up to minimum allocation size boundary
X     * and deduct from block count to reflect.
X     */
X    if((int)op & (QUANTUM-1))
X    {
X        op = (union overhead *)(((int)op + QUANTUM) &~ (QUANTUM-1));
X        nblks--;
X    }
X#else
X    op = (union overhead *)malloc(siz);
X    /* no more room! */
X    if (!op)
X        return;
X#endif
X    /*
X     * Add new memory allocated to the
X     * free list for this hash bucket.
X     */
X    nextf[bucket] = op;
X    siz = 1L << bucket;
X    while (--nblks)
X    {
X        op->ov_next = (union overhead *)((caddr_t)op + siz);
X        op = op->ov_next;
X    }
X}
X
X
X/*
X * NAME
X *    mem_alloc - memory allocator
X *
X * SYNOPSIS
X *    char *
X *    mem_alloc()
X *
X * DESCRIPTION
X *    Mem_alloc is used to allocate memory large enought to fit the requested
X *    size, and on a boundary suitable for placing any value.
X *
X * RETURNS
X *    char *, pointer to base of dynamic memory allocated
X *
X * CAVEAT
X *    Use mem_free() when you are finished with the space.
X */
Xchar *
Xmem_alloc(nbytes)
X    register unsigned long int nbytes;
X{
X    register union overhead *p;
X    register int    bucket;
X    register unsigned long int shiftr;
X
X    if (nbytes > ((unsigned int) -1))
X        return NULL;
X    assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 12);
X    /*
X     * Convert amount of memory requested into
X     * closest block size stored in hash buckets
X     * which satisfies request.  Account for
X     * space used per block for accounting.
X     */
X    nbytes = (nbytes + sizeof (union overhead) + RSLOP + (QUANTUM-1)) &~ (QUANTUM-1);
X    shiftr = (nbytes - 1) >> QUANTUM_NBITS;
X    /* apart from this loop, this is O(1) */
X    bucket = QUANTUM_NBITS;
X    while(shiftr)
X    {
X        shiftr >>= 1;
X        bucket++;
X    }
X
X    /*
X     * If nothing in hash bucket right now,
X     * request more memory from the system.
X     */
X    if (!nextf[bucket])
X        morecore(bucket);
X    if (!(p = nextf[bucket]))
X        return (char*)0;
X    /* remove from linked list */
X    nextf[bucket] = p->ov_next;
X    p->ov_magic = MAGIC;
X    p->ov_index = bucket;
X#ifdef MSTATS
X    nmalloc[bucket]++;
X#endif
X#ifdef RCHECK
X    /*
X     * Record allocated size of block and
X     * bound space with magic numbers
X     */
X    if (nbytes <= (1L<<16))
X        p->ov_size = nbytes - 1;
X    p->ov_rmagic = RMAGIC;
X    *((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
X#endif
X    return ((char *)(p + 1));
X}
X
X
X/*
X * NAME
X *    mem_free - free memory
X *
X * SYNOPSIS
X *    int
X *    mem_free(cp)
X *    char * cp;
X *
X * DESCRIPTION
X *    Mem_free is used to release space allocated by mem_alloc
X *    or mem_realloc.
X *
X * RETURNS
X *    int
X *
X * CAVEAT
X *    do not pass mem_free() an argument that was returned by mem_alloc()
X *    or mem_realloc().
X */
Xint
Xmem_free(cp)
X    char *    cp;
X{
X    register u_int    bucket;
X    register union overhead *op;
X
X    assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 13);
X    if (!cp)
X        return;
X    op = (union overhead *)cp - 1;
X    assert(op->ov_magic == MAGIC, 5);    /* make sure it was in use */
X    assert(op->ov_index < NBUCKETS, 6);
X    assert(op->ov_index >= QUANTUM_NBITS, 7);
X#ifdef RCHECK
X    assert(op->ov_index > 16 || op->ov_size == (1L<<op->ov_index)-1, 8);
X    assert(op->ov_rmagic == RMAGIC, 9);
X    assert(op->ov_index > 16 || *(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC, 10);
X#endif
X#ifndef DEBUG
X    if(op->ov_magic != MAGIC)
X        return;        /* sanity */
X#endif
X    bucket = op->ov_index;
X    op->ov_next = nextf[bucket];
X    nextf[bucket] = op;
X#ifdef MSTATS
X    nmalloc[bucket]--;
X#endif
X}
X
X
X/*
X * NAME
X *    findbucket - find a bucket
X *
X * SYNOPSIS
X *    int
X *    findbucket(freep, srchlen)
X *    union overhead * freep;
X *    int srchlen;
X *
X * DESCRIPTION
X *    Findbucket is used to find the bucket a free block is in.
X *    Search ``srchlen'' elements of each free list for a block whose
X *    header starts at ``freep''.  If srchlen is -1 search the whole list.
X *
X * RETURNS
X *    bucket number, or -1 if not found.
X */
Xstatic int
Xfindbucket(freep, srchlen)
X    union overhead *    freep;
X    int    srchlen;
X{
X    register union overhead *p;
X    register int    i, j;
X
X    for (i = 0; i < NBUCKETS; i++)
X    {
X        j = 0;
X        for (p = nextf[i]; p && j != srchlen; p = p->ov_next)
X        {
X            if (p == freep)
X                return i;
X            j++;
X        }
X    }
X    return -1;
X}
X
X
X/*
X * When a program attempts "storage compaction" as mentioned in the
X * old malloc man page, it realloc's an already freed block.  Usually
X * this is the last block it freed; occasionally it might be farther
X * back.  We have to search all the free lists for the block in order
X * to determine its bucket: first we make one pass thru the lists
X * checking only the first block in each; if that fails we search
X * ``realloc_srchlen'' blocks in each list for a match (the variable
X * is extern so the caller can modify it).  If that fails we just copy
X * however many bytes was given to realloc() and hope it's not huge.
X */
X
Xstatic int realloc_srchlen = 4;    /* 4 should be plenty, -1 =>'s whole list */
X
X/*
X * NAME
X *    mem_realloc - change size
X *
X * SYNOPSIS
X *    char
X *    mem_realloc(cp, nbytes)
X *    char * cp;
X *    u_int nbytes;
X *
X * DESCRIPTION
X *    Mem_realloc is used to enlarge a chunk of memory
X *    returned by mem_alloc() or mem_realloc().
X *
X * RETURNS
X *    char *, pointer to base of dynamic memory allocated
X *
X * CAVEAT
X *    Use mem_free() when you are finished with the space.
X */
Xchar *
Xmem_realloc(cp, nbytes)
X    char *cp;
X    unsigned long    nbytes;
X{
X    register u_int    old_nbytes;
X    register union overhead *op;
X    char *    res;
X    register u_int    old_bucket;
X    short    was_alloced = 0;
X
X    if (nbytes > ((unsigned int) -1))
X        return NULL;
X    assert((watchloc == NULL) || (watchloc->ov_magic == MAGIC), 14);
X    if (!cp)
X        return mem_alloc(nbytes);
X    op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
X    if (op->ov_magic == MAGIC)
X    {
X        was_alloced++;
X        old_bucket = op->ov_index;
X    }
X    else
X    {
X        /*
X         * Already free, doing "compaction".
X         *
X         * Search for the old block of memory on the
X         * free list. First, check the most common
X         * case (last element free'd), then (this failing)
X         * the last ``realloc_srchlen'' items free'd.
X         * If all lookups fail, then assume the size of
X         * the memory block being realloc'd is the
X         * smallest possible.
X         */
X        if
X        (
X            (old_bucket = findbucket(op, 1)) == -1
X        &&
X            (old_bucket = findbucket(op, realloc_srchlen)) == -1
X        )
X            old_bucket = QUANTUM_NBITS;
X    }
X    old_nbytes = (1L << old_bucket) - sizeof(union overhead) - RSLOP;
X
X    /*
X     * avoid the copy if same size block
X     */
X    if
X    (
X        was_alloced
X    &&
X        nbytes <= old_nbytes
X    &&
X        nbytes > (old_nbytes >> 1) - sizeof(union overhead) - RSLOP
X    )
X        return cp;
X
X    /*
X     * grab another chunk
X     */
X    if(!(res = mem_alloc(nbytes)))
X        return (char*)0;
X    assert(cp != res, 11);
X    memcpy(res, cp, (nbytes < old_nbytes) ? nbytes : old_nbytes);
X    if(was_alloced)
X        mem_free(cp);
X    return res;
X}
X
X#else /*CALC_MALLOC*/
X
X#undef MSTATS
X
X#endif /*CALC_MALLOC*/
X
X
X
X/*
X * Allocate a new item from the specified free list.
X * Returns NULL if no item can be allocated.
X */
XALLOCITEM *
Xallocitem(fp)
X    FREELIST *fp;        /* free list header */
X{
X    FREEITEM *ip;        /* allocated item */
X
X    if (fp->curfree > 0) {
X        fp->curfree--;
X        ip = fp->freelist;
X        fp->freelist = ip->next;
X        return (ALLOCITEM *) ip;
X    }
X    ip = (FREEITEM *) malloc(fp->itemsize);
X    if (ip == NULL)
X        return NULL;
X    return (ALLOCITEM *) ip;
X}
X
X
X/*
X * Free an item by placing it back on a free list.
X * If too many items are on the list, it is really freed.
X */
Xvoid
Xfreeitem(fp, ip)
X    FREELIST *fp;        /* freelist header */
X    FREEITEM *ip;        /* item to be freed */
X{
X    if (ip == NULL)
X        return;
X    if (fp->curfree >= fp->maxfree) {
X        free((char *) ip);
X        return;
X    }
X    ip->next = fp->freelist;
X    fp->freelist = ip;
X    fp->curfree++;
X}
X
X
X/*
X * NAME
X *    mem_stats - print memory statistics
X *
X * SYNOPSIS
X *    void
X *    mem_stats(s)
X *    char * s;
X *
X * DESCRIPTION
X *    Mem_stats is used to print out statistics about current memory usage.
X *    ``s'' is the title string
X *
X *    Prints two lines of numbers, one showing the length of the free list
X *    for each size category, the second showing the number of mallocs -
X *    frees for each size category.
X *
X * RETURNS
X *    void
X */
X/*ARGSUSED*/
Xvoid
Xmem_stats(s)
X    char *    s;
X{
X#ifdef MSTATS
X    register int    i, j;
X    register union overhead *p;
X    int    totfree = 0;
X    int    totused = 0;
X
X    fprintf(stderr, "Memory allocation statistics %s\n", s);
X    fprintf(stderr, "%11s:%12s%12s%12s\n", "Bucket", "In Use", "Free", "Sum");
X    for (i = 0; i < NBUCKETS; i++)
X    {
X        for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
X            ;
X        if(!j && !nmalloc[i])
X            continue;
X        fprintf(stderr, "%11d:%12d%12d%12d\n", (1L<<i), nmalloc[i], j, j+nmalloc[i]);
X        totfree += j * (1L << i);
X        totused += nmalloc[i] * (1L << i);
X    }
X    fprintf(stderr, "%11s:%12d%12d%12d\n", "Totals", totused, totfree, totused+totfree);
X#else
X    fprintf(stderr,
X        "Memory allocation stats were not compiled into calc\n");
X#endif
X}
X
X#ifdef DEBUG
Xvoid
Xassertfailed(n)
X{
X    printf("Assertion %d failed\n", n);
X    exit(1);
X}
X#endif
X
X/* END CODE */
SHAR_EOF
echo "File calc2.9.0/alloc.c is complete"
chmod 0644 calc2.9.0/alloc.c || echo "restore of calc2.9.0/alloc.c fails"
set `wc -c calc2.9.0/alloc.c`;Sum=$1
if test "$Sum" != "13393"
then echo original size 13393, current size $Sum;fi
echo "x - extracting calc2.9.0/alloc.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/alloc.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 * Allocator definitions (fast malloc and free)
X */
X
X#if !defined(CALC_MALLOC)
X
X#include "have_malloc.h"
X#ifdef HAVE_MALLOC_H
X# include <malloc.h>
X#else
X# if defined(__STDC__)
X   extern void *malloc();
X   extern void *realloc();
X   extern void free();
X# else
X   extern char *malloc();
X   extern char *realloc();
X   extern void free();
X# endif
X#endif
X
X#include "have_string.h"
X
X#ifdef HAVE_STRING_H
X# include <string.h>
X
X#else
X
X# ifdef OLD_BSD
Xextern void bcopy();
Xextern void bfill();
Xextern char *index();
X# else /* OLD_BSD */
Xextern void memcpy();
Xextern void memset();
X#  if defined(__STDC__)
Xextern void *strchr();
X#  else
Xextern char *strchr();
X#  endif
X# endif /* OLD_BSD */
Xextern void strcpy();
Xextern void strncpy();
Xextern void strcat();
Xextern int strcmp();
Xextern long strlen();    /* should be size_t, but old systems don't have it */
X
X#endif
X
X#ifdef OLD_BSD
X#undef memcpy
X#define memcpy(s1, s2, n) bcopy(s2, s1, n)
X#undef memset
X#define memset(s, c, n) bfill(s, n, c)
X#undef strchr
X#define strchr(s, c) index(s, c)
X#endif
X
X#ifdef DONT_HAVE_VSPRINTF
X/*
X * XXX - hack aleart
X *
X * Systems that do not have vsprintf() need something.  In some cases
X * the sprintf function will deal correctly with the va_alist 3rd arg.
X * Hope for the best!
X */
X#define vsprintf sprintf
X#endif
X
X#define mem_alloc malloc
X#define mem_realloc realloc
X#define mem_free free
X
X#else /*!CALC_MALLOC*/
X
X#define malloc(a) mem_alloc((long) a)
X#define realloc(a,b) mem_realloc((char *) a, (long) b)
X#define free(a) mem_free((char *) a)
Xextern char *mem_alloc();
Xextern char *mem_realloc();
Xextern int mem_free();        /* MUST be int even though no return value */
X
X#endif /*!CALC_MALLOC*/
X
X
X/*
X * An item to be placed on a free list.
X * These items are overlayed on top of the actual item being managed.
X * Therefore, the managed items must be at least this size!
X * Also, all items on a single free list must be the same size.
X */
Xstruct free_item {
X    struct free_item *next;            /* next item on free list */
X};
Xtypedef struct free_item FREEITEM;
X
X
X/*
X * The actual free list header.
X */
Xtypedef struct {
X    long        itemsize;    /* size of an item being managed */
X    long        maxfree;    /* maximum number of free items */
X    long        curfree;    /* current number of free items */
X    FREEITEM    *freelist;    /* the free list */
X} FREELIST;
X
X#if defined(__STDC__)
Xtypedef void ALLOCITEM;
X#else
Xtypedef char ALLOCITEM;
X#endif
Xextern ALLOCITEM * allocitem( /* FREELIST * */ );
Xextern void freeitem( /* FREELIST *, char * */ );
Xextern void mem_stats();
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/alloc.h || echo "restore of calc2.9.0/alloc.h fails"
set `wc -c calc2.9.0/alloc.h`;Sum=$1
if test "$Sum" != "2678"
then echo original size 2678, current size $Sum;fi
echo "x - extracting calc2.9.0/assocfunc.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/assocfunc.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 * Association table routines.
X * An association table is a type of value which can be "indexed" by
X * one or more arbitrary values.  Each element in the table is thus an
X * association between a particular set of index values and a result value.
X * The elements in an association table are stored in a hash table for
X * quick access.
X */
X
X#include "value.h"
X
X
X#define    MINHASHSIZE    31    /* minimum size of hash tables */
X#define    GROWHASHSIZE    50    /* approximate growth for hash tables */
X#define    CHAINLENGTH    10    /* desired number of elements on a hash chain */
X#define    ELEMSIZE(n)    (sizeof(ASSOCELEM) + (sizeof(VALUE) * ((n) - 1)))
X
X
Xstatic ASSOCELEM *elemindex MATH_PROTO((ASSOC *ap, long index));
Xstatic BOOL compareindices MATH_PROTO((VALUE *v1, VALUE *v2, long dim));
Xstatic void resize MATH_PROTO((ASSOC *ap, long newsize));
Xstatic void elemfree MATH_PROTO((ASSOCELEM *ep));
Xstatic long nextprime MATH_PROTO((long n));
X
X
X/*
X * Return the address of the value specified by normal indexing of
X * an association.  The create flag is TRUE if a value is going to be
X * assigned into the specified indexing location.  If create is FALSE and
X * the index value doesn't exist, a pointer to a NULL value is returned.
X */
XVALUE *
Xassocindex(ap, create, dim, indices)
X    ASSOC *ap;        /* association to index into */
X    BOOL create;        /* whether to create the index value */
X    long dim;        /* dimension of the indexing */
X    VALUE *indices;        /* table of values being indexed by */
X{
X    ASSOCELEM **listhead;
X    ASSOCELEM *ep;
X    static VALUE val;
X    HASH hash;
X    int i;
X
X    if (dim <= 0)
X        math_error("No dimensions for indexing association");
X
X    /*
X     * Calculate the hash value to use for this set of indices
X     * so that we can first select the correct hash chain, and
X     * also so we can quickly compare each element for a match.
X     */
X    hash = 0;
X    for (i = 0; i < dim; i++)
X        hash = hash * 67319821 + hashvalue(&indices[i]);
X
X    /*
X     * Search the correct hash chain for the specified set of indices.
X     * If found, return the address of the found element's value.
X     */
X    listhead = &ap->a_table[hash % ap->a_size];
X    for (ep = *listhead; ep; ep = ep->e_next) {
X        if ((ep->e_hash != hash) || (ep->e_dim != dim))
X            continue;
X        if (compareindices(ep->e_indices, indices, dim))
X            return &ep->e_value;
X    }
X
X    /*
X     * The set of indices was not found.
X     * Either return a pointer to a NULL value for a read reference,
X     * or allocate a new element in the list for a write reference.
X     */
X    if (!create) {
X        val.v_type = V_NULL;
X        return &val;
X    }
X
X    ep = (ASSOCELEM *) malloc(ELEMSIZE(dim));
X    if (ep == NULL)
X        math_error("Cannot allocate association element");
X    ep->e_dim = dim;
X    ep->e_hash = hash;
X    ep->e_value.v_type = V_NULL;
X    for (i = 0; i < dim; i++)
X        copyvalue(&indices[i], &ep->e_indices[i]);
X    ep->e_next = *listhead;
X    *listhead = ep;
X    ap->a_count++;
X
X    resize(ap, ap->a_count / CHAINLENGTH);
X
X    return &ep->e_value;
X}
X
X
X/*
X * Search an association for the specified value starting at the
X * specified index.  Returns the element number (zero based) of the
X * found value, or -1 if the value was not found.
X */
Xlong
Xassocsearch(ap, vp, index)
X    ASSOC *ap;
X    VALUE *vp;
X    long index;
X{
X    ASSOCELEM *ep;
X
X    if (index < 0)
X        index = 0;
X    while (TRUE) {
X        ep = elemindex(ap, index);
X        if (ep == NULL)
X            return -1;
X        if (!comparevalue(&ep->e_value, vp))
X            return index;
X        index++;
X    }
X}
X
X
X/*
X * Search an association backwards for the specified value starting at the
X * specified index.  Returns the element number (zero based) of the
X * found value, or -1 if the value was not found.
X */
Xlong
Xassocrsearch(ap, vp, index)
X    ASSOC *ap;
X    VALUE *vp;
X    long index;
X{
X    ASSOCELEM *ep;
X
X    if (index >= ap->a_count)
X        index = ap->a_count - 1;
X    while (TRUE) {
X        ep = elemindex(ap, index);
X        if (ep == NULL)
X            return -1;
X        if (!comparevalue(&ep->e_value, vp))
X            return index;
X        index--;
X    }
X}
X
X
X/*
X * Return the address of an element of an association indexed by the
X * double-bracket operation.
X */
Xstatic ASSOCELEM *
Xelemindex(ap, index)
X    ASSOC *ap;        /* association to index into */
X    long index;        /* index of desired element */
X{
X    ASSOCELEM *ep;
X    int i;
X
X    if ((index < 0) || (index > ap->a_count))
X        return NULL;
X
X    /*
X     * This loop should be made more efficient by remembering
X     * previously requested locations within the association.
X     */
X    for (i = 0; i < ap->a_size; i++) {
X        for (ep = ap->a_table[i]; ep; ep = ep->e_next) {
X            if (index-- == 0)
X                return ep;
X        }
X    }
X    return NULL;
X}
X
X
X/*
X * Return the address of the value specified by double-bracket indexing
X * of an association.  Returns NULL if there is no such element.
X */
XVALUE *
Xassocfindex(ap, index)
X    ASSOC *ap;        /* association to index into */
X    long index;        /* index of desired element */
X{
X    ASSOCELEM *ep;
X
X    ep = elemindex(ap, index);
X    if (ep == NULL)
X        return NULL;
X    return &ep->e_value;
X}
X
X
X/*
X * Compare two associations to see if they are identical.
X * Returns TRUE if they are different.
X */
XBOOL
Xassoccmp(ap1, ap2)
X    ASSOC *ap1, *ap2;
X{
X    ASSOCELEM **table1;
X    ASSOCELEM *ep1;
X    ASSOCELEM *ep2;
X    long size1;
X    long size2;
X    HASH hash;
X    long dim;
X
X    if (ap1 == ap2)
X        return FALSE;
X    if (ap1->a_count != ap2->a_count)
X        return TRUE;
X
X    table1 = ap1->a_table;
X    size1 = ap1->a_size;
X    size2 = ap2->a_size;
X    while (size1-- > 0) {
X        for (ep1 = *table1++; ep1; ep1 = ep1->e_next) {
X            hash = ep1->e_hash;
X            dim = ep1->e_dim;
X            for (ep2 = ap2->a_table[hash % size2]; ;
X                ep2 = ep2->e_next)
X            {
X                if (ep2 == NULL)
X                    return TRUE;
X                if (ep2->e_hash != hash)
X                    continue;
X                if (ep2->e_dim != dim)
X                    continue;
X                if (compareindices(ep1->e_indices,
X                    ep2->e_indices, dim))
X                        break;
X            }
X            if (comparevalue(&ep1->e_value, &ep2->e_value))
X                return TRUE;
X        }
X    }
X    return FALSE;
X}
X
X
X/*
X * Copy an association value.
X */
XASSOC *
Xassoccopy(oldap)
X    ASSOC *oldap;
X{
X    ASSOC *ap;
X    ASSOCELEM *oldep;
X    ASSOCELEM *ep;
X    ASSOCELEM **listhead;
X    int oldhi;
X    int i;
X
X    ap = assocalloc(oldap->a_count / CHAINLENGTH);
X    ap->a_count = oldap->a_count;
X
X    for (oldhi = 0; oldhi < oldap->a_size; oldhi++) {
X        for (oldep = oldap->a_table[oldhi]; oldep;
X            oldep = oldep->e_next)
X        {
X            ep = (ASSOCELEM *) malloc(ELEMSIZE(oldep->e_dim));
X            if (ep == NULL)
X                math_error("Cannot allocate association element");
X            ep->e_dim = oldep->e_dim;
X            ep->e_hash = oldep->e_hash;
X            ep->e_value.v_type = V_NULL;
X            for (i = 0; i < ep->e_dim; i++)
X                copyvalue(&oldep->e_indices[i], &ep->e_indices[i]);
X            copyvalue(&oldep->e_value, &ep->e_value);
X            listhead = &ap->a_table[ep->e_hash % ap->a_size];
X            ep->e_next = *listhead;
X            *listhead = ep;
X        }
X    }
X    return ap;
X}
X
X
X/*
X * Resize the hash table for an association to be the specified size.
X * This is only actually done if the growth from the previous size is
X * enough to make this worthwhile.
X */
Xstatic void
Xresize(ap, newsize)
X    ASSOC *ap;
X    long newsize;
X{
X    ASSOCELEM **oldtable;
X    ASSOCELEM **newtable;
X    ASSOCELEM **oldlist;
X    ASSOCELEM **newlist;
X    ASSOCELEM *ep;
X    int i;
X
X    if (newsize < ap->a_size + GROWHASHSIZE)
X        return;
X
X    newsize = nextprime(newsize);
X    newtable = (ASSOCELEM **) malloc(sizeof(ASSOCELEM *) * newsize);
X    if (newtable == NULL)
X        math_error("No memory to grow association");
X    for (i = 0; i < newsize; i++)
X        newtable[i] = NULL;
X
X    oldtable = ap->a_table;
X    oldlist = oldtable;
X    for (i = 0; i < ap->a_size; i++) {
X        while (*oldlist) {
X            ep = *oldlist;
X            *oldlist = ep->e_next;
X            newlist = &newtable[ep->e_hash % newsize];
X            ep->e_next = *newlist;
X            *newlist = ep;
X        }
X        oldlist++;
X    }
X
X    ap->a_table = newtable;
X    ap->a_size = newsize;
X    free((char *) oldtable);
X}
X
X
X/*
X * Free an association element, along with any contained values.
X */
Xstatic void
Xelemfree(ep)
X    ASSOCELEM *ep;
X{
X    int i;
X
X    for (i = 0; i < ep->e_dim; i++)
X        freevalue(&ep->e_indices[i]);
X    freevalue(&ep->e_value);
X    ep->e_dim = 0;
X    ep->e_next = NULL;
X    free((char *) ep);
X}
X
X
X/*
X * Allocate a new association value with an initial hash table.
X * The hash table size is set at specified (but at least a minimum size).
X */
XASSOC *
Xassocalloc(initsize)
X    long initsize;
X{
X    register ASSOC *ap;
X    int i;
X
X    if (initsize < MINHASHSIZE)
X        initsize = MINHASHSIZE;
X    ap = (ASSOC *) malloc(sizeof(ASSOC));
X    if (ap == NULL)
X        math_error("No memory for association");
X    ap->a_count = 0;
X    ap->a_size = initsize;
X    ap->a_table = (ASSOCELEM **) malloc(sizeof(ASSOCELEM *) * initsize);
X    if (ap->a_table == NULL) {
X        free((char *) ap);
X        math_error("No memory for association");
X    }
X    for (i = 0; i < initsize; i++)
X        ap->a_table[i] = NULL;
X    return ap;
X}
X
X
X/*
X * Free an association value, along with all of its elements.
X */
Xvoid
Xassocfree(ap)
X    register ASSOC *ap;
X{
X    ASSOCELEM **listhead;
X    ASSOCELEM *ep;
X    ASSOCELEM *nextep;
X    int i;
X
X    listhead = ap->a_table;
X    for (i = 0; i < ap->a_size; i++) {
X        nextep = *listhead;
X        *listhead = NULL;
X        while (nextep) {
X            ep = nextep;
X            nextep = ep->e_next;
X            elemfree(ep);
X        }
X        listhead++;
X    }
X    free((char *) ap->a_table);
X    ap->a_table = NULL;
X    free((char *) ap);
X}
X
X
X/*
X * Print out an association along with the specified number of
X * its elements.  The elements are printed out in shortened form.
X */
Xvoid
Xassocprint(ap, max_print)
X    ASSOC *ap;
X    long max_print;
X{
X    ASSOCELEM *ep;
X    long index;
X    long i;
X    int savemode;
X
X    if (max_print <= 0) {
X        math_fmt("assoc (%ld element%s)", ap->a_count,
X            ((ap->a_count == 1) ? "" : "s"));
X        return;
X    }
X    math_fmt("\n  assoc (%ld element%s):\n", ap->a_count,
X        ((ap->a_count == 1) ? "" : "s"));
X
X    for (index = 0; ((index < max_print) && (index < ap->a_count));
X        index++)
X    {
X        ep = elemindex(ap, index);
X        if (ep == NULL)
X            continue;
X        math_str("  [");
X        for (i = 0; i < ep->e_dim; i++) {
X            if (i)
X                math_chr(',');
X            savemode = math_setmode(MODE_FRAC);
X            printvalue(&ep->e_indices[i],
X                (PRINT_SHORT | PRINT_UNAMBIG));
X            math_setmode(savemode);
X        }
X        math_str("] = ");
X        printvalue(&ep->e_value, PRINT_SHORT | PRINT_UNAMBIG);
X        math_chr('\n');
X    }
X    if (max_print < ap->a_count)
X        math_str("  ...\n");
X}
X
X
X/*
X * Return a trivial hash value for an association.
X */
XHASH
Xassochash(ap)
X    ASSOC *ap;
X{
X    return ap->a_count * 700001;
X}
X
X
X/*
X * Compare two lists of index values to see if they are identical.
X * Returns TRUE if they are the same.
X */
Xstatic BOOL
Xcompareindices(v1, v2, dim)
X    VALUE *v1;
X    VALUE *v2;
X    long dim;
X{
X    int i;
X
X    for (i = 0; i < dim; i++)
X        if (v1[i].v_type != v2[i].v_type)
X            return FALSE;
X
X    while (dim-- > 0)
X        if (comparevalue(v1++, v2++))
X            return FALSE;
X
X    return TRUE;
X}
X
X
X/*
X * Return the next prime number up from the specified value.
X * This is used to pick a good hash table size.
X */
Xstatic long
Xnextprime(n)
X    long n;
X{
X    long i;
X
X    if ((n & 0x01) == 0)
X        n++;
X    while (TRUE) {
X        for (i = 3; n % i; i += 2) {
X            if (i * i > n)
X                return n;
X        }
X        n += 2;
X    }
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/assocfunc.c || echo "restore of calc2.9.0/assocfunc.c fails"
set `wc -c calc2.9.0/assocfunc.c`;Sum=$1
if test "$Sum" != "10842"
then echo original size 10842, current size $Sum;fi
echo "x - extracting calc2.9.0/calc.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/calc.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 * Arbitrary precision calculator.
X */
X
X#include <signal.h>
X#include <pwd.h>
X#include <sys/types.h>
X
X#include "calc.h"
X#include "hist.h"
X#include "func.h"
X#include "opcodes.h"
X#include "config.h"
X#include "token.h"
X#include "symbol.h"
X
X
X/*
X * Common definitions
X */
Xlong maxprint;        /* number of elements to print */
Xint abortlevel;        /* current level of aborts */
XBOOL inputwait;        /* TRUE if in a terminal input wait */
Xjmp_buf jmpbuf;        /* for errors */
X
Xstatic int q_flag = FALSE;    /* TRUE => don't execute rc files */
X
Xchar *calcpath;        /* $CALCPATH or default */
Xchar *calcrc;        /* $CALCRC or default */
Xchar *calcbindings;    /* $CALCBINDINGS or default */
Xchar *home;        /* $HOME or default */
Xstatic char *pager;    /* $PAGER or default */
Xchar *shell;        /* $SHELL or default */
X
Xstatic void intint();    /* interrupt routine */
Xstatic void initenv();    /* initialize/default special environment vars */
X
X#if defined(__STDC__)
X#include <unistd.h>
X#include <stdlib.h>
X#else
Xextern struct passwd *getpwuid();
X#if defined (UID_T)
Xtypedef unsigned short uid_t;
X#endif
Xextern char *getenv();
Xextern uid_t geteuid();
X#endif
X
X
X/*
X * Top level calculator routine.
X */
Xmain(argc, argv)
X    char **argv;
X{
X    char *str;        /* current option string or expression */
X    char cmdbuf[MAXCMD+1];    /* command line expression */
X
X    initenv();
X    argc--;
X    argv++;
X    while ((argc > 0) && (**argv == '-')) {
X        for (str = &argv[0][1]; *str; str++) switch (*str) {
X            case 'h':
X                givehelp(DEFAULTCALCHELP);
X                exit(0);
X                break;
X            case 'q':
X                q_flag = TRUE;
X                break;
X            default:
X                printf("Unknown option\n");
X                exit(1);
X        }
X        argc--;
X        argv++;
X    }
X    str = cmdbuf;
X    *str = '\0';
X    while (--argc >= 0) {
X        *str++ = ' ';
X        strcpy(str, *argv++);
X        str += strlen(str);
X        str[0] = '\n';
X        str[1] = '\0';
X    }
X    str = cmdbuf;
X    if (*str == '\0') {
X        str = NULL;
X        version(stdout);
X        printf("[Type \"exit\" to exit, or \"help\" for help.]\n\n");
X
X        switch (hist_init(calcbindings)) {
X        case HIST_NOFILE:
X            fprintf(stderr,
X                "Cannot open key bindings file \"%s\", fancy editing disabled.\n",
X                calcbindings);
X            break;
X
X        case HIST_NOTTY:
X            fprintf(stderr,
X                "Cannot set terminal modes, fancy editing disabled.\n");
X            break;
X        }
X    }
X    if (setjmp(jmpbuf) == 0) {
X        initmasks();
X        inittokens();
X        initglobals();
X        initfunctions();
X        initstack();
X        resetinput();
X        math_cleardiversions();
X        math_setfp(stdout);
X        math_setmode(MODE_INITIAL);
X        math_setdigits((long)DISPLAY_DEFAULT);
X        maxprint = MAXPRINT_DEFAULT;
X        _epsilon_ = atoq(EPSILON_DEFAULT);
X        _epsilonprec_ = qprecision(_epsilon_);
X        if (str) {
X            if (q_flag == FALSE) {
X                runrcfiles();
X                q_flag = TRUE;
X            }
X            (void) openstring(str);
X            getcommands(FALSE);
X            exit(0);
X        }
X    }
X    if (str)
X        exit(1);
X    abortlevel = 0;
X    _math_abort_ = FALSE;
X    inputwait = FALSE;
X    (void) signal(SIGINT, intint);
X    math_cleardiversions();
X    math_setfp(stdout);
X    resetscopes();
X    resetinput();
X    if (q_flag == FALSE) {
X        runrcfiles();
X        q_flag = TRUE;
X    }
X    (void) openterminal();
X    getcommands(TRUE);
X    exit(0);
X    /*NOTREACHED*/
X}
X
X
X/*
X * initenv - obtain $CALCPATH, $CALCRC, $CALCBINDINGS, $HOME, $PAGER
X * and $SHELL values
X *
X * If $CALCPATH, $CALCRC, $CALCBINDINGS, $PAGER or $SHELL do not exist,
X * use the default values.  If $PAGER or $SHELL is an empty string, also
X * use a default value. If $HOME does not exist, or is empty, use the home
X * directory information from the password file.
X */
Xstatic void
Xinitenv()
X{
X    struct passwd *ent;        /* our password entry */
X
X    /* determine the $CALCPATH value */
X    calcpath = getenv(CALCPATH);
X    if (calcpath == NULL)
X        calcpath = DEFAULTCALCPATH;
X
X    /* determine the $CALCRC value */
X    calcrc = getenv(CALCRC);
X    if (calcrc == NULL) {
X        calcrc = DEFAULTCALCRC;
X    }
X
X    /* determine the $CALCBINDINGS value */
X    calcbindings = getenv(CALCBINDINGS);
X    if (calcbindings == NULL) {
X        calcbindings = DEFAULTCALCBINDINGS;
X    }
X
X    /* determine the $HOME value */
X    home = getenv(HOME);
X    if (home == NULL || home[0] == '\0') {
X        ent = getpwuid(geteuid());
X        if (ent == NULL) {
X            /* just assume . is home if all else fails */
X            home = ".";
X        }
X        home = (char *)malloc(strlen(ent->pw_dir)+1);
X        strcpy(home, ent->pw_dir);
X    }
X
X    /* determine the $PAGER value */
X    pager = getenv(PAGER);
X    if (pager == NULL || *pager == '\0') {
X        pager = DEFAULTCALCPAGER;
X    }
X
X    /* determine the $SHELL value */
X    shell = getenv(SHELL);
X    if (shell == NULL)
X        shell = DEFAULTSHELL;
X}
X
X
Xvoid
Xgivehelp(type)
X    char *type;        /* the type of help to give, NULL => index */
X{
X    char *helpcmd;        /* what to execute to print help */
X
X    /* catch the case where we just print the index */
X    if (type == NULL) {
X        type = DEFAULTCALCHELP;        /* the help index file */
X    }
X
X    /* form the help command name */
X    helpcmd = (char *)malloc(
X        sizeof("if [ ! -d \"")+sizeof(HELPDIR)+1+strlen(type)+
X        sizeof("\" ];then ")+
X        strlen(pager)+1+1+sizeof(HELPDIR)+1+strlen(type)+1+1+
X        sizeof(";else echo no such help;fi"));
X    sprintf(helpcmd,
X        "if [ -r \"%s/%s\" ];then %s \"%s/%s\";else echo no such help;fi",
X        HELPDIR, type, pager, HELPDIR, type);
X
X    /* execute the help command */
X    system(helpcmd);
X    free(helpcmd);
X}
X
X
X/*
X * Interrupt routine.
X */
X/*ARGSUSED*/
Xstatic void
Xintint(arg)
X    int arg;    /* to keep ANSI C happy */
X{
X    (void) signal(SIGINT, intint);
X    if (inputwait || (++abortlevel >= ABORT_NOW))
X        math_error("\nABORT");
X    if (abortlevel >= ABORT_MATH)
X        _math_abort_ = TRUE;
X    printf("\n[Abort level %d]\n", abortlevel);
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/calc.c || echo "restore of calc2.9.0/calc.c fails"
set `wc -c calc2.9.0/calc.c`;Sum=$1
if test "$Sum" != "5576"
then echo original size 5576, current size $Sum;fi
echo "x - extracting calc2.9.0/calc.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/calc.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 * Definitions for calculator program.
X */
X
X#ifndef    CALC_H
X#define    CALC_H
X
X
X#include <stdio.h>
X#include <setjmp.h>
X#include "value.h"
X
X
X/*
X * Configuration definitions
X */
X#define    CALCPATH    "CALCPATH"    /* environment variable for files */
X#define    CALCRC        "CALCRC"    /* environment variable for startup */
X#define    CALCBINDINGS    "CALCBINDINGS"    /* environment variable for hist bindings */
X#define    HOME        "HOME"        /* environment variable for home dir */
X#define    PAGER        "PAGER"        /* environment variable for help */
X#define    SHELL        "SHELL"        /* environment variable for shell */
X#define DEFAULTCALCHELP    "help"        /* help file that -h prints */
X#define DEFAULTSHELL    "sh"        /* default shell to use */
X#define    CALCEXT        ".cal"    /* extension for files read in */
X#define    PATHSIZE    1024    /* maximum length of path name */
X#define    HOMECHAR    '~'    /* char which indicates home directory */
X#define DOTCHAR        '.'    /* char which indicates current directory */
X#define    PATHCHAR    '/'    /* char which separates path components */
X#define    LISTCHAR    ':'    /* char which separates paths in a list */
X#define    MAXCMD        1024    /* maximum length of command invocation */
X#define    MAXERROR    512    /* maximum length of error message string */
X
X#define    SYMBOLSIZE    256    /* maximum symbol name size */
X#define    MAXINDICES    20    /* maximum number of indices for objects */
X#define    MAXLABELS    100    /* maximum number of user labels in function */
X#define    MAXOBJECTS    10    /* maximum number of object types */
X#define    MAXSTRING    1024    /* maximum size of string constant */
X#define    MAXSTACK    1000    /* maximum depth of evaluation stack */
X#define    MAXFILES    20    /* maximum number of opened files */
X#define PROMPT1        "> "    /* normal prompt */
X#define PROMPT2        ">> "    /* prompt when inside multi-line input */
X
X
X#define    TRACE_NORMAL    0x00    /* normal trace flags */
X#define    TRACE_OPCODES    0x01    /* trace every opcode */
X#define    TRACE_NODEBUG    0x02    /* suppress debugging opcodes */
X#define    TRACE_MAX    0x03    /* maximum value for trace flag */
X
X#define DISPLAY_DEFAULT 20    /* default digits for float display */
X#define EPSILON_DEFAULT "1e-20"    /* allowed error for float calculations */
X#define MAXPRINT_DEFAULT 16    /* default number of elements printed */
X
X#define ABORT_NONE    0    /* abort not needed yet */
X#define ABORT_STATEMENT    1    /* abort on statement boundary */
X#define ABORT_OPCODE    2    /* abort on any opcode boundary */
X#define ABORT_MATH    3    /* abort on any math operation */
X#define ABORT_NOW    4    /* abort right away */
X
X#define CONFIG_MODE    1    /* types of configuration parameters */
X#define CONFIG_DISPLAY    2
X#define CONFIG_EPSILON    3
X#define CONFIG_TRACE    4
X#define CONFIG_MAXPRINT    5
X#define    CONFIG_MUL2    6
X#define    CONFIG_SQ2    7
X#define    CONFIG_POW2    8
X#define    CONFIG_REDC2    9
X
X
X/*
X * File ids corresponding to standard in, out, error, and when not in use.
X */
X#define    FILEID_STDIN    ((FILEID) 0)
X#define    FILEID_STDOUT    ((FILEID) 1)
X#define    FILEID_STDERR    ((FILEID) 2)
X#define    FILEID_NONE    ((FILEID) -1)
X
X
X/*
X * File I/O routines.
X */
Xextern FILEID openid MATH_PROTO((char *name, char *mode));
Xextern FILEID indexid MATH_PROTO((long index));
Xextern BOOL validid MATH_PROTO((FILEID id));
Xextern BOOL errorid MATH_PROTO((FILEID id));
Xextern BOOL eofid MATH_PROTO((FILEID id));
Xextern BOOL closeid MATH_PROTO((FILEID id));
Xextern int getcharid MATH_PROTO((FILEID id));
Xextern void idprintf MATH_PROTO((FILEID id, char *fmt, int count, VALUE **vals));
Xextern void printid MATH_PROTO((FILEID id, int flags));
Xextern void flushid MATH_PROTO((FILEID id));
Xextern void readid MATH_PROTO((FILEID id, char **retptr));
X
X
X/*
X * Input routines.
X */
Xextern FILE *f_open MATH_PROTO((char *name, char *mode));
Xextern int openstring MATH_PROTO((char *str));
Xextern int openterminal MATH_PROTO((void));
Xextern int opensearchfile MATH_PROTO((char *name, char *pathlist, char *exten));
Xextern char *nextline MATH_PROTO((void));
Xextern int nextchar MATH_PROTO((void));
Xextern void reread MATH_PROTO((void));
Xextern void resetinput MATH_PROTO((void));
Xextern void setprompt MATH_PROTO((char *));
Xextern BOOL inputisterminal MATH_PROTO((void));
Xextern char *inputname MATH_PROTO((void));
Xextern long linenumber MATH_PROTO((void));
Xextern void runrcfiles MATH_PROTO((void));
X
X
X/*
X * Other routines.
X */
Xextern NUMBER *constvalue MATH_PROTO((long index));
Xextern long addnumber MATH_PROTO((char *str));
Xextern long addqconstant MATH_PROTO((NUMBER *q));
Xextern void initstack MATH_PROTO((void));
Xextern void version MATH_PROTO((FILE *stream));
Xextern void getcommands MATH_PROTO((BOOL toplevel));
Xextern void givehelp MATH_PROTO((char *type));
X
Xextern void getconfig MATH_PROTO((int type, VALUE *vp));
Xextern void setconfig MATH_PROTO((int type, VALUE *vp));
Xextern int configtype MATH_PROTO((char *name));
X
X
X/*
X * Global data definitions.
X */
Xextern long maxprint;        /* number of elements to print */
Xextern int abortlevel;        /* current level of aborts */
Xextern BOOL inputwait;        /* TRUE if in a terminal input wait */
Xextern FLAG traceflags;        /* tracing flags */
Xextern VALUE *stack;        /* execution stack */
Xextern jmp_buf jmpbuf;        /* for errors */
X
Xextern char *calcpath;        /* $CALCPATH or default */
Xextern char *calcrc;        /* $CALCRC or default */
Xextern char *calcbindings;    /* $CALCBINDINGS or default */
Xextern char *home;        /* $HOME or default */
Xextern char *shell;        /* $SHELL or default */
X
X#endif
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/calc.h || echo "restore of calc2.9.0/calc.h fails"
set `wc -c calc2.9.0/calc.h`;Sum=$1
if test "$Sum" != "5443"
then echo original size 5443, current size $Sum;fi
echo "x - extracting calc2.9.0/calc.man (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/calc.man &&
X.\"
X.\" Copyright (c) 1993 David I. Bell and Landon Curt Noll
X.\" Permission is granted to use, distribute, or modify this source,
X.\" provided that this copyright notice remains intact.
X.\"
X.\" calculator by David I. Bell
X.\" man page by Landon Noll
X.TH calc 1 "^..^" "15nov93"
X.SH NAME
X\f4calc\f1 \- arbitrary precision calculator
X.SH SYNOPSIS
X\f4calc\fP
X[
X\f4\-h\fP
X] [
X\f4\-q\fP
X] [
X.I calc_cmd
X\&.\|.\|.
X]
X.SH DESCRIPTION
X\&
X.br
XCALC COMMAND LINE
X.PP
X.TP
X\f4 \-h\f1
XPrint a help message.
XThis option implies \f4 \-q\f1.
XThis is equivalent to the calc command \f4help help\fP.
X.TP
X\f4 \-q\f1
XDisable the use of the \f4$CALCRC\f1 startup library scripts.
X.PP
XWithout \f4calc_cmd\fPs, \f4calc\fP operates interactively.
XIf one or more \f4calc_cmd\fPs are given on the command line,
X\f4calc\fP will execute them and exit.
X.PP
XNormally on startup, \f4calc\fP attempts to execute a collection
Xof library scripts.
XThe environment variable \f4$CALCRC\f1 (if non-existent then
Xa compiled in value) contains a \f4:\fP separated list of
Xstartup library scripts.
XNo error conditions are produced if these startup library scripts
Xare not found.
X.PP
XFilenames are subject to ``~'' expansion (see below).
XThe environment variable \f4$CALCPATH\fP (if non-existent then
Xa compiled in value) contains a \f4:\fP separated list of search
Xdirectories.
XIf a file does not begin with \f4/\fP, \f4~\fP or \f4./\fP,
Xthen it is searched for under each directory listed in the \f4$CALCPATH\fP.
XIt is an error if no such readable file is found.
X.PP
XFor more information use the following calc commands:
X.PP
X.in 1.0i
Xhelp usage
X.br
Xhelp help
X.br
Xhelp environment
X.in -1.0i
X.PP
XOVERVIEW
X.PP
X\f4Calc\fP is arbitrary precision arithmetic system that uses
Xa C-like language.
X\f4Calc\fP is useful as a calculator, an algorithm prototyped
Xand as a mathematical research tool.
XMore importantly, \f4calc\fP provides one with a machine
Xindependent means of computation.
X.PP
X\f4Calc\fP comes with a rich set of builtin mathematical
Xand programmatic functions.
X.PP
X\f4Calc\fP is distributed with library of scripts.
XWritten in the same C-like language, library scripts may be
Xread in and executed during a \f4calc\fP session.
XThese library scripts are also provided because they are
Xuseful and to serve as examples of the \f4calc\fP language.
XOne may further extend \f4calc\fP thru the
Xuse of user defined scripts.
X.PP
XInternally calc represents numeric values as fractions reduced to their
Xlowest terms.
XThe numerators and denominators of these factions may grow to
Xarbitrarily large values.
XNumeric values read in are automatically converted into rationals.
XThe user need not be aware of this internal representation.
X.PP
XFor more information use the following calc commands:
X.PP
X.in 1.0i
Xhelp intro
X.br
Xhelp builtin
X.br
Xhelp stdlib
X.br
Xhelp define
X.br
Xshow builtins
X.br
Xshow functions
X.in -1.0i
X.PP
XDATA TYPES
X.PP
XFundamental builtin data types include integers, real numbers,
Xrational numbers, complex numbers and strings.
X.PP
XBy use of an object, one may define an arbitrarily complex
Xdata types.
XOne may define how such objects behave a wide range of
Xoperations such as addition, subtraction,
Xmultiplication, division, negation, squaring, modulus,
Xrounding, exponentiation, equality, comparison, printing
Xand so on.
X.PP
XFor more information use the following calc commands:
X.PP
X.in 1.0i
Xhelp types
X.br
Xhelp obj
X.br
Xshow objfuncs
X.in -1.0i
X.PP
XVARIABLES
X.PP
XVariables in \f4calc\fP are typeless.
XIn other words, the fundamental type of a variable is determined by its content.
XBefore a variable is assigned a value it has the value of zero.
X.PP
XThe scope of a variable may be global, local to a file, or local to a
Xprocedure.
XValues may be grouped together in a matrix, or into a
Xa list that permits stack and queue style operations.
X.PP
XFor more information use the following calc commands:
X.PP
X.in 1.0i
Xhelp variable
X.br
Xhelp mat
X.br
Xhelp list
X.br
Xshow globals
X.in -1.0i
X.PP
XINPUT/OUTPUT
X.PP
XA leading ``0x'' implies a hexadecimal value,
Xa leading ``0b'' implies a binary value,
Xand a ``0'' followed by a digit implies an octal value.
XComplex numbers are indicated by a trailing ``i'' such as in ``3+4i''.
XStrings may be delimited by either a pair of single or double quotes.
XBy default, \f4calc\fP prints values as if they were floating point numbers.
XOne may change the default to print values in a number of modes
Xincluding fractions, integers and exponentials.
X.PP
XA number of stdio-like file I/O operations are provided.
XOne may open, read, write, seek and close files.
XFilenames are subject to ``\~'' expansion to home directories
Xin a way similar to that of the Korn or C-Shell.
X.PP
XFor example:
X.PP
X.in 1.0i
X~/.calcrc
X.br
X~chongo/lib/fft_multiply.cal
X.in -1.0i
X.PP
XFor more information use the following calc command:
X.PP
X.in 1.0i
Xhelp file
X.in -1.0i
X.PP
XCALC LANGUAGE
X.PP
XThe \f4calc\fP language is a C-like language.
XThe language includes commands such as variable declarations,
Xexpressions, tests, labels, loops, file operations, function calls.
XThese commands are very similar to their counterparts in C.
X.PP
XThe language also include a number of commands particular
Xto \f4calc\fP itself.
XThese include commands such as function definition, help,
Xreading in library scripts, dump files to a file, error notification,
Xconfiguration control and status.
X.PP
XFor more information use the following calc command:
X.PP
X.in 1.0i
Xhelp command
X.br
Xhelp statement
X.br
Xhelp expression
X.br
Xhelp operator
X.br
Xhelp config
X.in -1.0i
X.PP
X.SH FILES
X\&
X.br
X.PD 0
X.TP 20
X${LIBDIR}/*.cal
Xlibrary scripts shipped with calc
X.br
X.sp
X.TP 20
X${LIBDIR}/help/*
Xhelp files
X.br
X.sp
X.TP 20
X${LIBDIR}/bindings
Xcommand line editor bindings
X.sp
X.SH ENVIRONMENT
X\&
X.br
X.PD 0
X.TP 5
XCALCPATH
XA :-separated list of directories used to search for
Xscripts filenames that do not begin with /, ./ or ~.
X.br
X.sp
XDefault value: .:./lib:~/lib:${LIBDIR}
X.br
X.sp
X.TP 5
XCALCRC
XOn startup (unless \-h or \-q was given on the command
Xline), calc searches for files along this :-separated
Xenvironment variable.
X.br
X.sp
XDefault value: ${LIBDIR}/startup:~/.calcrc
X.br
X.sp
X.TP 5
XCALCBINDINGS
XOn startup (unless \-h or \-q was given on the command
Xline), calc reads key bindings from the filename specified
Xby this environment variable.
X.br
X.sp
XDefault value: ${LIBDIR}/bindings
X.sp
X.SH CREDIT
X\&
X.br
XWritten by David I. Bell.
X.sp
XThanks for suggestions and encouragement from Peter Miller,
XNeil Justusson, and Landon Noll.
X.sp
XPortions of this program are derived from an earlier set of
Xpublic domain arbitrarily precision routines which was posted
Xto the net around 1984.  By now, there is almost no recognizable
Xcode left from that original source.
X.sp
XMost of this source and binary is:
X.sp
X.PP
X.in 1.0i
XCopyright (c) 1993 David I. Bell
X.sp
X.in -1.0i
X.PP
XSome files are a copyrighted David I. Bell and Landon Noll.
X.sp
XPermission is granted to use, distribute, or modify this source,
Xprovided that this copyright notice remains intact.
X.sp
XSend calc comments, suggestions, bug fixes, enhancements
Xand interesting calc scripts that you would like you see included
Xin future distributions to:
X.sp
X.PP
X.in 1.0i
[e-mail]
[e-mail]
X.sp
X.in -1.0i
X.PP
X.sp
XEnjoy!
SHAR_EOF
chmod 0644 calc2.9.0/calc.man || echo "restore of calc2.9.0/calc.man fails"
set `wc -c calc2.9.0/calc.man`;Sum=$1
if test "$Sum" != "7218"
then echo original size 7218, current size $Sum;fi
echo "x - extracting calc2.9.0/cmath.h (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/cmath.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 * Data structure declarations for extended precision complex arithmetic.
X */
X
X#ifndef    CMATH_H
X#define    CMATH_H
X
X#include "qmath.h"
X
X
X/*
X * Complex arithmetic definitions.
X */
Xtypedef struct {
X    NUMBER *real;        /* real part of number */
X    NUMBER *imag;        /* imaginary part of number */
X    long links;        /* link count */
X} COMPLEX;
X
X
X/*
X * Input, output, and conversion routines.
X */
Xextern COMPLEX *comalloc MATH_PROTO((void));
Xextern COMPLEX *qqtoc MATH_PROTO((NUMBER *q1, NUMBER *q2));
Xextern void comfree MATH_PROTO((COMPLEX *c));
Xextern void comprint MATH_PROTO((COMPLEX *c));
Xextern void cprintfr MATH_PROTO((COMPLEX *c));
X
X
X/*
X * Basic numeric routines.
X */
Xextern COMPLEX *cadd MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
Xextern COMPLEX *csub MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
Xextern COMPLEX *cmul MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
Xextern COMPLEX *cdiv MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
Xextern COMPLEX *caddq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *csubq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *cmulq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *cdivq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *cmodq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *cquoq MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern COMPLEX *cscale MATH_PROTO((COMPLEX *c, long i));
Xextern COMPLEX *cshift MATH_PROTO((COMPLEX *c, long i));
Xextern COMPLEX *cround MATH_PROTO((COMPLEX *c, long i));
Xextern COMPLEX *cbround MATH_PROTO((COMPLEX *c, long i));
Xextern COMPLEX *csquare MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cconj MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *creal MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cimag MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cneg MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cinv MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cint MATH_PROTO((COMPLEX *c));
Xextern COMPLEX *cfrac MATH_PROTO((COMPLEX *c));
Xextern BOOL ccmp MATH_PROTO((COMPLEX *c1, COMPLEX *c2));
X
X
X/*
X * More complicated functions.
X */
Xextern COMPLEX *cpowi MATH_PROTO((COMPLEX *c, NUMBER *q));
Xextern HASH chash MATH_PROTO((COMPLEX *c));
X
X
X/*
X * Transcendental routines.  These all take an epsilon argument to
X * specify how accurately these are to be calculated.
X */
Xextern COMPLEX *cpower MATH_PROTO((COMPLEX *c1, COMPLEX *c2, NUMBER *epsilon));
Xextern COMPLEX *csqrt MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
Xextern COMPLEX *croot MATH_PROTO((COMPLEX *c, NUMBER *q, NUMBER *epsilon));
Xextern COMPLEX *cexp MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
Xextern COMPLEX *cln MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
Xextern COMPLEX *ccos MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
Xextern COMPLEX *csin MATH_PROTO((COMPLEX *c, NUMBER *epsilon));
Xextern COMPLEX *cpolar MATH_PROTO((NUMBER *q1, NUMBER *q2, NUMBER *epsilon));
X
X
X/*
X * macro expansions to speed this thing up
X */
X#define cisreal(c)    (qiszero((c)->imag))
X#define cisimag(c)    (qiszero((c)->real) && !cisreal(c))
X#define ciszero(c)    (cisreal(c) && qiszero((c)->real))
X#define cisone(c)    (cisreal(c) && qisone((c)->real))
X#define cisnegone(c)    (cisreal(c) && qisnegone((c)->real))
X#define cisrunit(c)    (cisreal(c) && qisunit((c)->real))
X#define cisiunit(c)    (qiszero((c)->real) && qisunit((c)->imag))
X#define    cisunit(c)    (cisrunit(c) || cisiunit(c))
X#define cistwo(c)    (cisreal(c) && qistwo((c)->real))
X#define cisint(c)    (qisint((c)->real) && qisint((c)->imag))
X#define ciseven(c)    (qiseven((c)->real) && qiseven((c)->imag))
X#define cisodd(c)    (qisodd((c)->real) || qisodd((c)->imag))
X#define clink(c)    ((c)->links++, (c))
X
X
X/*
X * Pre-defined values.
X */
Xextern COMPLEX _czero_, _cone_, _conei_;
X
X#endif
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/cmath.h || echo "restore of calc2.9.0/cmath.h fails"
set `wc -c calc2.9.0/cmath.h`;Sum=$1
if test "$Sum" != "3758"
then echo original size 3758, current size $Sum;fi
echo "x - extracting calc2.9.0/codegen.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/codegen.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 * Module to generate opcodes from the input tokens.
X */
X
X#include "calc.h"
X#include "token.h"
X#include "symbol.h"
X#include "label.h"
X#include "opcodes.h"
X#include "string.h"
X#include "func.h"
X#include "config.h"
X
X
XFUNC *curfunc;
X
Xstatic BOOL getfilename(), getid();
Xstatic void getshowcommand(), getfunction(), getbody(), getdeclarations();
Xstatic void getstatement(), getobjdeclaration(), getobjvars();
Xstatic void getmatdeclaration(), getsimplebody(), getonedeclaration();
Xstatic void getcondition(), getmatargs(), getelement(), usesymbol();
Xstatic void definesymbol(), getcallargs();
Xstatic int getexprlist(), getassignment(), getaltcond(), getorcond();
Xstatic int getandcond(), getrelation(), getsum(), getproduct();
Xstatic int getorexpr(), getandexpr(), getshiftexpr(), getterm();
Xstatic int getidexpr();
Xstatic long getinitlist();
X
X
X/*
X * Read all the commands from an input file.
X * These are either declarations, or else are commands to execute now.
X * In general, commands are terminated by newlines or semicolons.
X * Exceptions are function definitions and escaped newlines.
X * Commands are read and executed until the end of file.
X * The toplevel flag indicates whether we are at the top interactive level.
X */
Xvoid
Xgetcommands(toplevel)
X    BOOL toplevel;
X{
X    char name[PATHSIZE+1];    /* program name */
X
X    if (!toplevel)
X        enterfilescope();
X    for (;;) {
X        (void) tokenmode(TM_NEWLINES);
X        switch (gettoken()) {
X
X        case T_DEFINE:
X            getfunction();
X            break;
X
X        case T_EOF:
X            if (!toplevel)
X                exitfilescope();
X            return;
X
X        case T_HELP:
X            if (!getfilename(name, FALSE)) {
X                strcpy(name, DEFAULTCALCHELP);
X            }
X            givehelp(name);
X            break;
X
X        case T_READ:
X            if (!getfilename(name, TRUE))
X                break;
X            if (opensearchfile(name, calcpath, CALCEXT) < 0) {
X                scanerror(T_NULL, "Cannot open \"%s\"\n", name);
X                break;
X            }
X            getcommands(FALSE);
X            break;
X
X        case T_WRITE:
X            if (!getfilename(name, TRUE))
X                break;
X            if (writeglobals(name))
X                scanerror(T_NULL, "Error writing \"%s\"\n", name);
X            break;
X
X        case T_SHOW:
X            rescantoken();
X            getshowcommand();
X            break;
X
X        case T_NEWLINE:
X        case T_SEMICOLON:
X            break;
X
X        default:
X            rescantoken();
X            initstack();
X            if (evaluate(FALSE))
X                updateoldvalue(curfunc);
X        }
X    }
X}
X
X
X/*
X * Evaluate a line of statements.
X * This is done by treating the current line as a function body,
X * compiling it, and then executing it.  Returns TRUE if the line
X * successfully compiled and executed.  The last expression result
X * is saved in the f_savedvalue element of the current function.
X * The nestflag variable should be FALSE for the outermost evaluation
X * level, and TRUE for all other calls (such as the 'eval' function).
X * The function name begins with an asterisk to indicate specialness.
X */
XBOOL
Xevaluate(nestflag)
X    BOOL nestflag;        /* TRUE if this is a nested evaluation */
X{
X    char *funcname;
X    BOOL gotstatement;
X
X    funcname = (nestflag ? "**" : "*");
X    beginfunc(funcname, nestflag);
X    gotstatement = FALSE;
X    for (;;) {
X        switch (gettoken()) {
X            case T_SEMICOLON:
X                break;
X
X            case T_NEWLINE:
X            case T_EOF:
X                goto done;
X
X            case T_GLOBAL:
X            case T_LOCAL:
X            case T_STATIC:
X                if (gotstatement) {
X                    scanerror(T_SEMICOLON, "Declarations must be used before code");
X                    return FALSE;
X                }
X                rescantoken();
X                getdeclarations();
X                break;
X
X            default:
X                rescantoken();
X                getstatement(NULL_LABEL, NULL_LABEL,
X                    NULL_LABEL, NULL_LABEL);
X                gotstatement = TRUE;
X        }
X    }
X
Xdone:
X    addop(OP_UNDEF);
X    addop(OP_RETURN);
X    checklabels();
X    if (errorcount)
X        return FALSE;
X    calculate(curfunc, 0);
X    return TRUE;
X}
X
X
X/*
X * Get a function declaration.
X * func = name '(' '' | name [ ',' name] ... ')' simplebody
X *    | name '(' '' | name [ ',' name] ... ')' body.
X */
Xstatic void
Xgetfunction()
X{
X    char *name;        /* parameter name */
X    int type;        /* type of token read */
X
X    (void) tokenmode(TM_DEFAULT);
X    if (gettoken() != T_SYMBOL) {
X        scanerror(T_NULL, "Function name expected");
X        return;
X    }
X    beginfunc(tokenstring(), FALSE);
X    enterfuncscope();
X    if (gettoken() != T_LEFTPAREN) {
X        scanerror(T_SEMICOLON, "Left parenthesis expected for function");
X        return;
X    }
X    for (;;) {
X        type = gettoken();
X        if (type == T_RIGHTPAREN)
X            break;
X        if (type != T_SYMBOL) {
X            scanerror(T_COMMA, "Bad function definition");
X            return;
X        }
X        name = tokenstring();
X        switch (symboltype(name)) {
X            case SYM_UNDEFINED:
X            case SYM_GLOBAL:
X            case SYM_STATIC:
X                (void) addparam(name);
X                break;
X            default:
X                scanerror(T_NULL, "Parameter \"%s\" is already defined", name);
X        }
X        type = gettoken();
X        if (type == T_RIGHTPAREN)
X            break;
X        if (type != T_COMMA) {
X            scanerror(T_COMMA, "Bad function definition");
X            return;
X        }
X    }
X    switch (gettoken()) {
X        case T_ASSIGN:
X            rescantoken();
X            getsimplebody();
X            break;
X        case T_LEFTBRACE:
X            rescantoken();
X            getbody(NULL_LABEL, NULL_LABEL, NULL_LABEL,
X                NULL_LABEL, TRUE);
X            break;
X        default:
X            scanerror(T_NULL,
X                "Left brace or equals sign expected for function");
X            return;
X    }
X    addop(OP_UNDEF);
X    addop(OP_RETURN);
X    endfunc();
X    exitfuncscope();
X}
X
X
X/*
X * Get a simple assignment style body for a function declaration.
X * simplebody = '=' assignment '\n'.
X */
Xstatic void
Xgetsimplebody()
X{
X    if (gettoken() != T_ASSIGN) {
X        scanerror(T_SEMICOLON, "Missing equals for simple function body");
X        return;
X    }
X    (void) tokenmode(TM_NEWLINES);
X    (void) getexprlist();
X    addop(OP_RETURN);
X    if (gettoken() != T_SEMICOLON)
X        rescantoken();
X    if (gettoken() != T_NEWLINE)
X        scanerror(T_NULL, "Illegal function definition");
X}
X
X
X/*
X * Get the body of a function, or a subbody of a function.
X * body = '{' [ declarations ] ... [ statement ] ... '}'
X *    | [ declarations ] ... [statement ] ... '\n'
X */
Xstatic void
Xgetbody(contlabel, breaklabel, nextcaselabel, defaultlabel, toplevel)
X    LABEL *contlabel, *breaklabel, *nextcaselabel, *defaultlabel;
X    BOOL toplevel;
X{
X    BOOL gotstatement;    /* TRUE if seen a real statement yet */
X    int oldmode;
X
X    if (gettoken() != T_LEFTBRACE) {
X        scanerror(T_SEMICOLON, "Missing left brace for function body");
X        return;
X    }
X    oldmode = tokenmode(TM_DEFAULT);
X    gotstatement = FALSE;
X    while (TRUE) {
X        switch (gettoken()) {
X        case T_RIGHTBRACE:
X            (void) tokenmode(oldmode);
X            return;
X
X        case T_GLOBAL:
X        case T_LOCAL:
X        case T_STATIC:
X            if (!toplevel) {
X                scanerror(T_SEMICOLON, "Declarations must be at the top of the function");
X                return;
X            }
X            if (gotstatement) {
X                scanerror(T_SEMICOLON, "Declarations must be used before code");
X                return;
X            }
X            rescantoken();
X            getdeclarations();
X            break;
X
X        default:
X            rescantoken();
X            getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
X            gotstatement = TRUE;
X        }
X    }
X}
X
X
X/*
X * Get a line of possible local, global, or static variable declarations.
X * declarations = { LOCAL | GLOBAL | STATIC } onedeclaration
X *    [ ',' onedeclaration ] ... ';'.
X */
Xstatic void
Xgetdeclarations()
X{
X    int type;
X
X    type = gettoken();
X
X    if ((type != T_LOCAL) && (type != T_GLOBAL) && (type != T_STATIC)) {
X        rescantoken();
X        return;
X    }
X
X    while (TRUE) {
X        getonedeclaration(type);
X
X        switch (gettoken()) {
X            case T_COMMA:
X                continue;
X
X            case T_NEWLINE:
X            case T_SEMICOLON:
X                return;
X
X            default:
X                scanerror(T_SEMICOLON, "Bad syntax in declaration statement");
X                return;
X        }
X    }
X}
X
X
X/*
X * Get a single declaration of a symbol of the specified type.
X * onedeclaration = name [ '=' getassignment ]
X *    | 'obj' type name [ '=' objvalues ]
X *    | 'mat' name '[' matargs ']' [ '=' matvalues ].
X */
Xstatic void
Xgetonedeclaration(type)
X{
X    char *name;        /* name of symbol seen */
X    int symtype;        /* type of symbol */
X    int vartype;        /* type of variable being defined */
X    LABEL label;
X
X    switch (type) {
X        case T_LOCAL:
X            symtype = SYM_LOCAL;
X            break;
X        case T_GLOBAL:
X            symtype = SYM_GLOBAL;
X            break;
X        case T_STATIC:
X            symtype = SYM_STATIC;
X            clearlabel(&label);
X            addoplabel(OP_INITSTATIC, &label);
X            break;
X    }
X
X    vartype = gettoken();
X    switch (vartype) {
X        case T_SYMBOL:
X            name = tokenstring();
X            definesymbol(name, symtype);
X            break;
X
X        case T_MAT:
X            addopone(OP_DEBUG, linenumber());
X            getmatdeclaration(symtype);
X            if (symtype == SYM_STATIC)
X                setlabel(&label);
X            return;
X
X        case T_OBJ:
X            addopone(OP_DEBUG, linenumber());
X            getobjdeclaration(symtype);
X            if (symtype == SYM_STATIC)
X                setlabel(&label);
X            return;
X
X        default:
X            scanerror(T_COMMA, "Bad syntax for declaration");
X            return;
X    }
X
X    if (gettoken() != T_ASSIGN) {
X        rescantoken();
X        if (symtype == SYM_STATIC)
X            setlabel(&label);
X        return;
X    }
X
X    /*
X     * Initialize the variable with the expression.  If the variable is
X     * static, arrange for the initialization to only be done once.
X     */
X    addopone(OP_DEBUG, linenumber());
X    usesymbol(name, FALSE);
X    getassignment();
X    addop(OP_ASSIGNPOP);
X    if (symtype == SYM_STATIC)
X        setlabel(&label);
X}
X
X
X/*
X * Get a statement.
X * statement = IF condition statement [ELSE statement]
X *    | FOR '(' [assignment] ';' [assignment] ';' [assignment] ')' statement
X *    | WHILE condition statement
X *    | DO statement WHILE condition ';'
X *    | SWITCH condition '{' [caseclause] ... '}'
X *    | CONTINUE ';'
X *    | BREAK ';'
X *    | RETURN assignment ';'
X *    | GOTO label ';'
X *    | MAT name '[' value [ ':' value ] [',' value [ ':' value ] ] ']' ';'
X *    | OBJ type '{' arg [ ',' arg ] ... '}' ] ';'
X *    | OBJ type name [ ',' name ] ';'
X *    | PRINT assignment [, assignment ] ... ';'
X *    | QUIT [ string ] ';'
X *    | SHOW item ';'
X *    | body
X *    | assignment ';'
X *    | label ':' statement
X *    | ';'.
X */
Xstatic void
Xgetstatement(contlabel, breaklabel, nextcaselabel, defaultlabel)
X    LABEL *contlabel;    /* label for continue statement */
X    LABEL *breaklabel;    /* label for break statement */
X    LABEL *nextcaselabel;    /* label for next case statement */
X    LABEL *defaultlabel;    /* label for default case */
X{
X    LABEL label1, label2, label3, label4;    /* locations for jumps */
X    int type;
X    BOOL printeol;
X
X    addopone(OP_DEBUG, linenumber());
X    switch (gettoken()) {
X    case T_NEWLINE:
X    case T_SEMICOLON:
X        return;
X
X    case T_RIGHTBRACE:
X        scanerror(T_NULL, "Extraneous right brace");
X        return;
X
X    case T_CONTINUE:
X        if (contlabel == NULL_LABEL) {
X            scanerror(T_SEMICOLON, "CONTINUE not within FOR, WHILE, or DO");
SHAR_EOF
echo "End of part 2"
echo "File calc2.9.0/codegen.c is continued in part 3"
echo "3" > s2_seq_.tmp
exit 0