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

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

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

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

#!/bin/sh
# this is part 3 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file calc2.9.0/codegen.c continued
#
CurArch=3
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/codegen.c"
sed 's/^X//' << 'SHAR_EOF' >> calc2.9.0/codegen.c
X            return;
X        }
X        addoplabel(OP_JUMP, contlabel);
X        break;
X
X    case T_BREAK:
X        if (breaklabel == NULL_LABEL) {
X            scanerror(T_SEMICOLON, "BREAK not within FOR, WHILE, or DO");
X            return;
X        }
X        addoplabel(OP_JUMP, breaklabel);
X        break;
X
X    case T_GOTO:
X        if (gettoken() != T_SYMBOL) {
X            scanerror(T_SEMICOLON, "Missing label in goto");
X            return;
X        }
X        addop(OP_JUMP);
X        addlabel(tokenstring());
X        break;
X
X    case T_RETURN:
X        switch (gettoken()) {
X            case T_NEWLINE:
X            case T_SEMICOLON:
X                addop(OP_UNDEF);
X                addop(OP_RETURN);
X                return;
X            default:
X                rescantoken();
X                (void) getexprlist();
X                if (curfunc->f_name[0] == '*')
X                    addop(OP_SAVE);
X                addop(OP_RETURN);
X        }
X        break;
X
X    case T_LEFTBRACE:
X        rescantoken();
X        getbody(contlabel, breaklabel, nextcaselabel, defaultlabel, FALSE);
X        return;
X
X    case T_IF:
X        clearlabel(&label1);
X        clearlabel(&label2);
X        getcondition();
X        addoplabel(OP_JUMPEQ, &label1);
X        getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
X        if (gettoken() != T_ELSE) {
X            setlabel(&label1);
X            rescantoken();
X            return;
X        }
X        addoplabel(OP_JUMP, &label2);
X        setlabel(&label1);
X        getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
X        setlabel(&label2);
X        return;
X
X    case T_FOR:    /* for (a; b; c) x */
X        clearlabel(&label1);
X        clearlabel(&label2);
X        clearlabel(&label3);
X        clearlabel(&label4);
X        contlabel = NULL_LABEL;
X        breaklabel = &label4;
X        if (gettoken() != T_LEFTPAREN) {
X            scanerror(T_SEMICOLON, "Left parenthesis expected");
X            return;
X        }
X        if (gettoken() != T_SEMICOLON) {    /* have 'a' part */
X            rescantoken();
X            (void) getexprlist();
X            addop(OP_POP);
X            if (gettoken() != T_SEMICOLON) {
X                scanerror(T_SEMICOLON, "Missing semicolon");
X                return;
X            }
X        }
X        if (gettoken() != T_SEMICOLON) {    /* have 'b' part */
X            setlabel(&label1);
X            contlabel = &label1;
X            rescantoken();
X            (void) getexprlist();
X            addoplabel(OP_JUMPNE, &label3);
X            addoplabel(OP_JUMP, breaklabel);
X            if (gettoken() != T_SEMICOLON) {
X                scanerror(T_SEMICOLON, "Missing semicolon");
X                return;
X            }
X        }
X        if (gettoken() != T_RIGHTPAREN) {    /* have 'c' part */
X            if (label1.l_offset <= 0)
X                addoplabel(OP_JUMP, &label3);
X            setlabel(&label2);
X            contlabel = &label2;
X            rescantoken();
X            (void) getexprlist();
X            addop(OP_POP);
X            if (label1.l_offset > 0)
X                addoplabel(OP_JUMP, &label1);
X            if (gettoken() != T_RIGHTPAREN) {
X                scanerror(T_SEMICOLON, "Right parenthesis expected");
X                return;
X            }
X        }
X        setlabel(&label3);
X        if (contlabel == NULL_LABEL)
X            contlabel = &label3;
X        getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
X        addoplabel(OP_JUMP, contlabel);
X        setlabel(breaklabel);
X        return;
X
X    case T_WHILE:
X        contlabel = &label1;
X        breaklabel = &label2;
X        clearlabel(contlabel);
X        clearlabel(breaklabel);
X        setlabel(contlabel);
X        getcondition();
X        addoplabel(OP_JUMPEQ, breaklabel);
X        getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
X        addoplabel(OP_JUMP, contlabel);
X        setlabel(breaklabel);
X        return;
X
X    case T_DO:
X        contlabel = &label1;
X        breaklabel = &label2;
X        clearlabel(contlabel);
X        clearlabel(breaklabel);
X        clearlabel(&label3);
X        setlabel(&label3);
X        getstatement(contlabel, breaklabel, NULL_LABEL, NULL_LABEL);
X        if (gettoken() != T_WHILE) {
X            scanerror(T_SEMICOLON, "WHILE keyword expected for DO statement");
X            return;
X        }
X        setlabel(contlabel);
X        getcondition();
X        addoplabel(OP_JUMPNE, &label3);
X        setlabel(breaklabel);
X        return;
X
X    case T_SWITCH:
X        breaklabel = &label1;
X        nextcaselabel = &label2;
X        defaultlabel = &label3;
X        clearlabel(breaklabel);
X        clearlabel(nextcaselabel);
X        clearlabel(defaultlabel);
X        getcondition();
X        if (gettoken() != T_LEFTBRACE) {
X            scanerror(T_SEMICOLON, "Missing left brace for switch statement");
X            return;
X        }
X        addoplabel(OP_JUMP, nextcaselabel);
X        rescantoken();
X        getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
X        addoplabel(OP_JUMP, breaklabel);
X        setlabel(nextcaselabel);
X        if (defaultlabel->l_offset > 0)
X            addoplabel(OP_JUMP, defaultlabel);
X        else
X            addop(OP_POP);
X        setlabel(breaklabel);
X        return;
X
X    case T_CASE:
X        if (nextcaselabel == NULL_LABEL) {
X            scanerror(T_SEMICOLON, "CASE not within SWITCH statement");
X            return;
X        }
X        clearlabel(&label1);
X        addoplabel(OP_JUMP, &label1);
X        setlabel(nextcaselabel);
X        clearlabel(nextcaselabel);
X        (void) getexprlist();
X        if (gettoken() != T_COLON) {
X            scanerror(T_SEMICOLON, "Colon expected after CASE expression");
X            return;
X        }
X        addoplabel(OP_CASEJUMP, nextcaselabel);
X        setlabel(&label1);
X        getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
X        return;
X
X    case T_DEFAULT:
X        if (gettoken() != T_COLON) {
X            scanerror(T_SEMICOLON, "Colon expected after DEFAULT keyword");
X            return;
X        }
X        if (defaultlabel == NULL_LABEL) {
X            scanerror(T_SEMICOLON, "DEFAULT not within SWITCH statement");
X            return;
X        }
X        if (defaultlabel->l_offset > 0) {
X            scanerror(T_SEMICOLON, "Multiple DEFAULT clauses in SWITCH");
X            return;
X        }
X        clearlabel(&label1);
X        addoplabel(OP_JUMP, &label1);
X        setlabel(defaultlabel);
X        addop(OP_POP);
X        setlabel(&label1);
X        getstatement(contlabel, breaklabel, nextcaselabel, defaultlabel);
X        return;
X
X    case T_ELSE:
X        scanerror(T_SEMICOLON, "ELSE without preceeding IF");
X        return;
X
X    case T_MAT:
X        getmatdeclaration(SYM_UNDEFINED);
X        break;
X
X    case T_OBJ:
X        getobjdeclaration(SYM_UNDEFINED);
X        break;
X
X    case T_PRINT:
X        printeol = TRUE;
X        for (;;) {
X            switch (gettoken()) {
X                case T_RIGHTBRACE:
X                case T_NEWLINE:
X                    rescantoken();
X                    /*FALLTHRU*/
X                case T_SEMICOLON:
X                    if (printeol)
X                        addop(OP_PRINTEOL);
X                    return;
X                case T_COLON:
X                    printeol = FALSE;
X                    break;
X                case T_COMMA:
X                    printeol = TRUE;
X                    addop(OP_PRINTSPACE);
X                    break;
X                case T_STRING:
X                    printeol = TRUE;
X                    addopptr(OP_PRINTSTRING, tokenstring());
X                    break;
X                default:
X                    printeol = TRUE;
X                    rescantoken();
X                    (void) getassignment();
X                    addopone(OP_PRINT, (long) PRINT_NORMAL);
X            }
X        }
X        break;
X
X    case T_QUIT:
X        switch (gettoken()) {
X            case T_STRING:
X                addopptr(OP_QUIT, tokenstring());
X                break;
X            default:
X                addopptr(OP_QUIT, NULL);
X                rescantoken();
X        }
X        break;
X
X    case T_SYMBOL:
X        if (nextchar() == ':') {    /****HACK HACK ****/
X            definelabel(tokenstring());
X            getstatement(contlabel, breaklabel,
X                NULL_LABEL, NULL_LABEL);
X            return;
X        }
X        reread();
X        /* fall into default case */
X
X    default:
X        rescantoken();
X        type = getexprlist();
X        if (contlabel || breaklabel || (curfunc->f_name[0] != '*')) {
X            addop(OP_POP);
X            break;
X        }
X        addop(OP_SAVE);
X        if (isassign(type) || (curfunc->f_name[1] != '\0')) {
X            addop(OP_POP);
X            break;
X        }
X        addop(OP_PRINTRESULT);
X        break;
X    }
X    switch (gettoken()) {
X        case T_RIGHTBRACE:
X        case T_NEWLINE:
X        case T_EOF:
X            rescantoken();
X            break;
X        case T_SEMICOLON:
X            break;
X        default:
X            scanerror(T_SEMICOLON, "Semicolon expected");
X            break;
X    }
X}
X
X
X/*
X * Read in an object declaration.
X * This is of the following form:
X *    OBJ type [ '{' id [ ',' id ] ... '}' ]  [ objlist ].
X * The OBJ keyword has already been read.  Symtype is SYM_UNDEFINED if this
X * is an OBJ statement, otherwise this is part of a declaration which will
X * define new symbols with the specified type.
X */
Xstatic void
Xgetobjdeclaration(symtype)
X{
X    char *name;            /* name of object type */
X    int count;            /* number of elements */
X    int index;            /* current index */
X    int i;                /* loop counter */
X    BOOL err;            /* error flag */
X    int indices[MAXINDICES];    /* indices for elements */
X
X    err = FALSE;
X    if (gettoken() != T_SYMBOL) {
X        scanerror(T_SEMICOLON, "Object type name missing");
X        return;
X    }
X    name = addliteral(tokenstring());
X    if (gettoken() != T_LEFTBRACE) {
X        rescantoken();
X        getobjvars(name, symtype);
X        return;
X    }
X    /*
X     * Read in the definition of the elements of the object.
X     */
X    count = 0;
X    for (;;) {
X        if (gettoken() != T_SYMBOL) {
X            scanerror(T_SEMICOLON, "Missing element name in OBJ statement");
X            return;
X        }
X        index = addelement(tokenstring());
X        for (i = 0; i < count; i++) {
X            if (indices[i] == index) {
X                scanerror(T_NULL, "Duplicate element name \"%s\"", tokenstring());
X                err = TRUE;
X                break;
X            }
X        }
X        indices[count++] = index;
X        switch (gettoken()) {
X            case T_RIGHTBRACE:
X                if (!err)
X                    (void) defineobject(name, indices, count);
X                switch (gettoken()) {
X                    case T_SEMICOLON:
X                    case T_NEWLINE:
X                        rescantoken();
X                        return;
X                }
X                rescantoken();
X                getobjvars(name, symtype);
X                return;
X            case T_COMMA:
X            case T_SEMICOLON:
X            case T_NEWLINE:
X                break;
X            default:
X                scanerror(T_SEMICOLON, "Bad object element definition");
X                return;
X        }
X    }
X}
X
X
X/*
X * Routine to collect a set of variables for the specified object type
X * and initialize them as being that type of object.
X * Here
X *    objlist = name initlist [ ',' name initlist ] ... ';'.
X * If symtype is SYM_UNDEFINED, then this is an OBJ statement where the
X * values can be any variable expression, and no symbols are to be defined.
X * Otherwise this is part of a declaration, and the variables must be raw
X * symbol names which are defined with the specified symbol type.
X */
Xstatic void
Xgetobjvars(name, symtype)
X    char *name;        /* object name */
X{
X    long index;        /* index for object */
X    char *symname;
X
X    index = checkobject(name);
X    if (index < 0) {
X        scanerror(T_SEMICOLON, "Object %s has not been defined yet", name);
X        return;
X    }
X    for (;;) {
X        if (symtype == SYM_UNDEFINED)
X            (void) getidexpr(TRUE, TRUE);
X        else {
X            if (gettoken() != T_SYMBOL) {
X                scanerror(T_SEMICOLON, "Missing object variable name");
X                return;
X            }
X            symname = tokenstring();
X            definesymbol(symname, symtype);
X            usesymbol(symname, FALSE);
X        }
X        addopone(OP_OBJCREATE, index);
X        (void) getinitlist();
X        switch (gettoken()) {
X            case T_COMMA:
X                break;
X            case T_SEMICOLON:
X            case T_NEWLINE:
X                rescantoken();
X                return;
X            default:
X                scanerror(T_SEMICOLON, "Bad OBJ statement");
X                return;
X        }
X    }
X}
X
X
X/*
X * Read a matrix definition declaration for a one or more dimensional matrix.
X * The MAT keyword has already been read.  This also handles an optional
X * matrix initialization list enclosed in braces.  Symtype is SYM_UNDEFINED
X * if this is part of a MAT statement which handles any variable expression.
X * Otherwise this is part of a declaration and only a symbol name is allowed.
X */
Xstatic void
Xgetmatdeclaration(symtype)
X{
X    long dim;
X    long index;
X    long count;
X    long patchpc;
X    char *name;
X
X    if (symtype == SYM_UNDEFINED)
X        (void) getidexpr(FALSE, TRUE);
X    else {
X        if (gettoken() != T_SYMBOL) {
X            scanerror(T_COMMA, "Missing matrix variable name");
X            return;
X        }
X        name = tokenstring();
X        definesymbol(name, symtype);
X        usesymbol(name, FALSE);
X    }
X
X    if (gettoken() != T_LEFTBRACKET) {
X        scanerror(T_SEMICOLON, "Missing left bracket for MAT");
X        return;
X    }
X    dim = 1;
X
X    /*
X     * If there are no bounds given for the matrix, then they must be
X     * implicitly defined by a list of initialization values.  Put in
X     * a dummy number in the opcode stream for the bounds and remember
X     * its location.  After we know how many values are in the list, we
X     * will patch the correct value back into the opcode.
X     */
X    if (gettoken() == T_RIGHTBRACKET) {
X        clearopt();
X        patchpc = curfunc->f_opcodecount + 1;
X        addopone(OP_NUMBER, (long) -1);
X        clearopt();
X        addop(OP_ZERO);
X        addopone(OP_MATCREATE, dim);
X        count = getinitlist();
X        if (count == 0) {
X            scanerror(T_NULL, "Initialization required for implicit matrix bounds");
X            return;
X        }
X        index = addqconstant(itoq(count - 1));
X        if (index < 0)
X            math_error("Cannot allocate constant");
X        curfunc->f_opcodes[patchpc] = index;
X        return;
X    }
X
X    /*
X     * This isn't implicit, so we expect expressions for the bounds.
X     */
X    rescantoken();
X    while (TRUE) {
X        (void) getassignment();
X        switch (gettoken()) {
X            case T_RIGHTBRACKET:
X            case T_COMMA:
X                rescantoken();
X                addop(OP_ONE);
X                addop(OP_SUB);
X                addop(OP_ZERO);
X                break;
X            case T_COLON:
X                (void) getassignment();
X                break;
X            default:
X                rescantoken();
X        }
X        switch (gettoken()) {
X            case T_RIGHTBRACKET:
X                if (gettoken() != T_LEFTBRACKET) {
X                    rescantoken();
X                    addopone(OP_MATCREATE, dim);
X                    (void) getinitlist();
X                    return;
X                }
X                /* proceed into comma case */
X                /*FALLTHRU*/
X            case T_COMMA:
X                if (++dim <= MAXDIM)
X                    break;
X                scanerror(T_SEMICOLON, "Only %ld dimensions allowed", MAXDIM);
X                return;
X            default:
X                scanerror(T_SEMICOLON, "Illegal matrix definition");
X                return;
X        }
X    }
X}
X
X
X/*
X * Get an optional initialization list for a matrix or object definition.
X * Returns the number of elements that are in the list, or -1 on parse error.
X * This assumes that the address of a matrix or object variable is on the
X * stack, and so this routine will pop it off when complete.
X *    initlist = [ '=' '{' assignment [ ',' assignment ] ... '}' ].
X */
Xstatic long
Xgetinitlist()
X{
X    long index;
X    int oldmode;
X
X    if (gettoken() != T_ASSIGN) {
X        rescantoken();
X        addop(OP_POP);
X        return 0;
X    }
X
X    oldmode = tokenmode(TM_DEFAULT);
X
X    if (gettoken() != T_LEFTBRACE) {
X        scanerror(T_SEMICOLON, "Missing brace for initialization list");
X        (void) tokenmode(oldmode);
X        return -1;
X    }
X
X    for (index = 0; ; index++) {
X        getassignment();
X        addopone(OP_ELEMINIT, index);
X        switch (gettoken()) {
X            case T_COMMA:
X                continue;
X
X            case T_RIGHTBRACE:
X                (void) tokenmode(oldmode);
X                addop(OP_POP);
X                return index + 1;
X
X            default:
X                scanerror(T_SEMICOLON, "Bad initialization list");
X                (void) tokenmode(oldmode);
X                return -1;
X        }
X    }
X}
X
X
X/*
X * Get a condition.
X * condition = '(' assignment ')'.
X */
Xstatic void
Xgetcondition()
X{
X    if (gettoken() != T_LEFTPAREN) {
X        scanerror(T_SEMICOLON, "Missing left parenthesis for condition");
X        return;
X    }
X    (void) getexprlist();
X    if (gettoken() != T_RIGHTPAREN) {
X        scanerror(T_SEMICOLON, "Missing right parenthesis for condition");
X        return;
X    }
X}
X
X
X/*
X * Get an expression list consisting of one or more expressions,
X * separated by commas.  The value of the list is that of the final expression.
X * This is the top level routine for parsing expressions.
X * Returns flags describing the type of assignment or expression found.
X * exprlist = assignment [ ',' assignment ] ...
X */
Xstatic int
Xgetexprlist()
X{
X    int    type;
X
X    type = getassignment();
X    while (gettoken() == T_COMMA) {
X        addop(OP_POP);
X        (void) getassignment();
X        type = EXPR_RVALUE;
X    }
X    rescantoken();
X    return type;
X}
X
X
X/*
X * Get an assignment (or possibly just an expression).
X * Returns flags describing the type of assignment or expression found.
X * assignment = lvalue '=' assignment
X *    | lvalue '+=' assignment
X *    | lvalue '-=' assignment
X *    | lvalue '*=' assignment
X *    | lvalue '/=' assignment
X *    | lvalue '%=' assignment
X *    | lvalue '//=' assignment
X *    | lvalue '&=' assignment
X *    | lvalue '|=' assignment
X *    | lvalue '<<=' assignment
X *    | lvalue '>>=' assignment
X *    | lvalue '^=' assignment
X *    | lvalue '**=' assignment
X *    | orcond.
X */
Xstatic int
Xgetassignment()
X{
X    int type;        /* type of expression */
X    long op;        /* opcode to generate */
X
X    type = getaltcond();
X    switch (gettoken()) {
X        case T_ASSIGN:        op = 0; break;
X        case T_PLUSEQUALS:    op = OP_ADD; break;
X        case T_MINUSEQUALS:    op = OP_SUB; break;
X        case T_MULTEQUALS:    op = OP_MUL; break;
X        case T_DIVEQUALS:    op = OP_DIV; break;
X        case T_SLASHSLASHEQUALS: op = OP_QUO; break;
X        case T_MODEQUALS:    op = OP_MOD; break;
X        case T_ANDEQUALS:    op = OP_AND; break;
X        case T_OREQUALS:    op = OP_OR; break;
X        case T_LSHIFTEQUALS:     op = OP_LEFTSHIFT; break;
X        case T_RSHIFTEQUALS:     op = OP_RIGHTSHIFT; break;
X        case T_POWEREQUALS:    op = OP_POWER; break;
X
X        case T_NUMBER:
X        case T_IMAGINARY:
X        case T_STRING:
X        case T_SYMBOL:
X        case T_OLDVALUE:
X        case T_LEFTPAREN:
X        case T_PLUSPLUS:
X        case T_MINUSMINUS:
X        case T_NOT:
X            scanerror(T_NULL, "Missing operator");
X            return type;
X
X        default:
X            rescantoken();
X            return type;
X    }
X    if (isrvalue(type)) {
X        scanerror(T_NULL, "Illegal assignment");
X        (void) getassignment();
X        return (EXPR_RVALUE | EXPR_ASSIGN);
X    }
X    writeindexop();
X    if (op)
X        addop(OP_DUPLICATE);
X    (void) getassignment();
X    if (op) {
X        addop(op);
X    }
X    addop(OP_ASSIGN);
X    return (EXPR_RVALUE | EXPR_ASSIGN);
X}
X
X
X/*
X * Get a possible conditional result expression (question mark).
X * Flags are returned indicating the type of expression found.
X * altcond = orcond [ '?' orcond ':' altcond ].
X */
Xstatic int
Xgetaltcond()
X{
X    int type;        /* type of expression */
X    LABEL donelab;        /* label for done */
X    LABEL altlab;        /* label for alternate expression */
X
X    type = getorcond();
X    if (gettoken() != T_QUESTIONMARK) {
X        rescantoken();
X        return type;
X    }
X    clearlabel(&donelab);
X    clearlabel(&altlab);
X    addoplabel(OP_JUMPEQ, &altlab);
X    (void) getorcond();
X    if (gettoken() != T_COLON) {
X        scanerror(T_SEMICOLON, "Missing colon for conditional expression");
X        return EXPR_RVALUE;
X    }
X    addoplabel(OP_JUMP, &donelab);
X    setlabel(&altlab);
X    (void) getaltcond();
X    setlabel(&donelab);
X    return EXPR_RVALUE;
X}
X
X
X/*
X * Get a possible conditional or expression.
X * Flags are returned indicating the type of expression found.
X * orcond = andcond [ '||' andcond ] ...
X */
Xstatic int
Xgetorcond()
X{
X    int type;        /* type of expression */
X    LABEL donelab;        /* label for done */
X
X    clearlabel(&donelab);
X    type = getandcond();
X    while (gettoken() == T_OROR) {
X        addoplabel(OP_CONDORJUMP, &donelab);
X        (void) getandcond();
X        type = EXPR_RVALUE;
X    }
X    rescantoken();
X    if (donelab.l_chain > 0)
X        setlabel(&donelab);
X    return type;
X}
X
X
X/*
X * Get a possible conditional and expression.
X * Flags are returned indicating the type of expression found.
X * andcond = relation [ '&&' relation ] ...
X */
Xstatic int
Xgetandcond()
X{
X    int type;        /* type of expression */
X    LABEL donelab;        /* label for done */
X
X    clearlabel(&donelab);
X    type = getrelation();
X    while (gettoken() == T_ANDAND) {
X        addoplabel(OP_CONDANDJUMP, &donelab);
X        (void) getrelation();
X        type = EXPR_RVALUE;
X    }
X    rescantoken();
X    if (donelab.l_chain > 0)
X        setlabel(&donelab);
X    return type;
X}
X
X
X/*
X * Get a possible relation (equality or inequality), or just an expression.
X * Flags are returned indicating the type of relation found.
X * relation = sum '==' sum
X *    | sum '!=' sum
X *    | sum '<=' sum
X *    | sum '>=' sum
X *    | sum '<' sum
X *    | sum '>' sum
X *    | sum.
X */
Xstatic int
Xgetrelation()
X{
X    int type;        /* type of expression */
X    long op;        /* opcode to generate */
X
X    type = getsum();
X    switch (gettoken()) {
X        case T_EQ: op = OP_EQ; break;
X        case T_NE: op = OP_NE; break;
X        case T_LT: op = OP_LT; break;
X        case T_GT: op = OP_GT; break;
X        case T_LE: op = OP_LE; break;
X        case T_GE: op = OP_GE; break;
X        default:
X            rescantoken();
X            return type;
X    }
X    (void) getsum();
X    addop(op);
X    return EXPR_RVALUE;
X}
X
X
X/*
X * Get an expression made up of sums of products.
X * Flags indicating the type of expression found are returned.
X * sum = product [ {'+' | '-'} product ] ...
X */
Xstatic int
Xgetsum()
X{
X    int type;        /* type of expression found */
X    long op;        /* opcode to generate */
X
X    type = getproduct();
X    for (;;) {
X        switch (gettoken()) {
X            case T_PLUS:    op = OP_ADD; break;
X            case T_MINUS:    op = OP_SUB; break;
X            default:
X                rescantoken();
X                return type;
X        }
X        (void) getproduct();
X        addop(op);
X        type = EXPR_RVALUE;
X    }
X}
X
X
X/*
X * Get the product of arithmetic or expressions.
X * Flags indicating the type of expression found are returned.
X * product = orexpr [ {'*' | '/' | '//' | '%'} orexpr ] ...
X */
Xstatic int
Xgetproduct()
X{
X    int type;        /* type of value found */
X    long op;        /* opcode to generate */
X
X    type = getorexpr();
X    for (;;) {
X        switch (gettoken()) {
X            case T_MULT:    op = OP_MUL; break;
X            case T_DIV:    op = OP_DIV; break;
X            case T_MOD:    op = OP_MOD; break;
X            case T_SLASHSLASH: op = OP_QUO; break;
X            default:
X                rescantoken();
X                return type;
X        }
X        (void) getorexpr();
X        addop(op);
X        type = EXPR_RVALUE;
X    }
X}
X
X
X/*
X * Get an expression made up of arithmetic or operators.
X * Flags indicating the type of expression found are returned.
X * orexpr = andexpr [ '|' andexpr ] ...
X */
Xstatic int
Xgetorexpr()
X{
X    int type;        /* type of value found */
X
X    type = getandexpr();
X    while (gettoken() == T_OR) {
X        (void) getandexpr();
X        addop(OP_OR);
X        type = EXPR_RVALUE;
X    }
X    rescantoken();
X    return type;
X}
X
X
X/*
X * Get an expression made up of arithmetic and operators.
X * Flags indicating the type of expression found are returned.
X * andexpr = shiftexpr [ '&' shiftexpr ] ...
X */
Xstatic int
Xgetandexpr()
X{
X    int type;        /* type of value found */
X
X    type = getshiftexpr();
X    while (gettoken() == T_AND) {
X        (void) getshiftexpr();
X        addop(OP_AND);
X        type = EXPR_RVALUE;
X    }
X    rescantoken();
X    return type;
X}
X
X
X/*
X * Get a shift or power expression.
X * Flags indicating the type of expression found are returned.
X * shift = term '^' shiftexpr
X *     | term '<<' shiftexpr
X *     | term '>>' shiftexpr
X *     | term.
X */
Xstatic int
Xgetshiftexpr()
X{
X    int type;        /* type of value found */
X    long op;        /* opcode to generate */
X
X    type = getterm();
X    switch (gettoken()) {
X        case T_POWER:        op = OP_POWER; break;
X        case T_LEFTSHIFT:    op = OP_LEFTSHIFT; break;
X        case T_RIGHTSHIFT:     op = OP_RIGHTSHIFT; break;
X        default:
X            rescantoken();
X            return type;
X    }
X    (void) getshiftexpr();
X    addop(op);
X    return EXPR_RVALUE;
X}
X
X
X/*
X * Get a single term.
X * Flags indicating the type of value found are returned.
X * term = lvalue
X *    | lvalue '[' assignment ']'
X *    | lvalue '++'
X *    | lvalue '--'
X *    | '++' lvalue
X *    | '--' lvalue
X *    | real_number
X *    | imaginary_number
X *    | '.'
X *    | string
X *    | '(' assignment ')'
X *    | function [ '(' [assignment  [',' assignment] ] ')' ]
X *    | '!' term
X *    | '+' term
X *    | '-' term.
X */
Xstatic int
Xgetterm()
X{
X    int type;        /* type of term found */
X
X    type = gettoken();
X    switch (type) {
X        case T_NUMBER:
X            addopone(OP_NUMBER, tokennumber());
X            type = (EXPR_RVALUE | EXPR_CONST);
X            break;
X
X        case T_IMAGINARY:
X            addopone(OP_IMAGINARY, tokennumber());
X            type = (EXPR_RVALUE | EXPR_CONST);
X            break;
X
X        case T_OLDVALUE:
X            addop(OP_OLDVALUE);
X            type = 0;
X            break;
X
X        case T_STRING:
X            addopptr(OP_STRING, tokenstring());
X            type = (EXPR_RVALUE | EXPR_CONST);
X            break;
X
X        case T_PLUSPLUS:
X            if (isrvalue(getterm()))
X                scanerror(T_NULL, "Bad ++ usage");
X            writeindexop();
X            addop(OP_PREINC);
X            type = (EXPR_RVALUE | EXPR_ASSIGN);
X            break;
X
X        case T_MINUSMINUS:
X            if (isrvalue(getterm()))
X                scanerror(T_NULL, "Bad -- usage");
X            writeindexop();
X            addop(OP_PREDEC);
X            type = (EXPR_RVALUE | EXPR_ASSIGN);
X            break;
X
X        case T_NOT:
X            (void) getterm();
X            addop(OP_NOT);
X            type = EXPR_RVALUE;
X            break;
X
X        case T_MINUS:
X            (void) getterm();
X            addop(OP_NEGATE);
X            type = EXPR_RVALUE;
X            break;
X
X        case T_PLUS:
X            (void) getterm();
X            type = EXPR_RVALUE;
X            break;
X
X        case T_LEFTPAREN:
X            type = getexprlist();
X            if (gettoken() != T_RIGHTPAREN)
X                scanerror(T_SEMICOLON, "Missing right parenthesis");
X            break;
X
X        case T_SYMBOL:
X            rescantoken();
X            type = getidexpr(TRUE, FALSE);
X            break;
X
X        case T_LEFTBRACKET:
X            scanerror(T_NULL, "Bad index usage");
X            type = 0;
X            break;
X
X        case T_PERIOD:
X            scanerror(T_NULL, "Bad element reference");
X            type = 0;
X            break;
X
X        default:
X            if (iskeyword(type)) {
X                scanerror(T_NULL, "Expression contains reserved keyword");
X                type = 0;
X                break;
X            }
X            rescantoken();
X            scanerror(T_NULL, "Missing expression");
X            type = 0;
X    }
X    switch (gettoken()) {
X        case T_PLUSPLUS:
X            if (isrvalue(type))
X                scanerror(T_NULL, "Bad ++ usage");
X            writeindexop();
X            addop(OP_POSTINC);
X            return (EXPR_RVALUE | EXPR_ASSIGN);
X        case T_MINUSMINUS:
X            if (isrvalue(type))
X                scanerror(T_NULL, "Bad -- usage");
X            writeindexop();
X            addop(OP_POSTDEC);
X            return (EXPR_RVALUE | EXPR_ASSIGN);
X        default:
X            rescantoken();
X            return type;
X    }
X}
X
X
X/*
X * Read in an identifier expressions.
X * This is a symbol name followed by parenthesis, or by square brackets or
X * element refernces.  The symbol can be a global or a local variable name.
X * Returns the type of expression found.
X */
Xstatic int
Xgetidexpr(okmat, autodef)
X    BOOL okmat, autodef;
X{
X    int type;
X    char name[SYMBOLSIZE+1];    /* symbol name */
X
X    type = 0;
X    if (!getid(name))
X        return type;
X    switch (gettoken()) {
X        case T_LEFTPAREN:
X            getcallargs(name);
X            type = EXPR_RVALUE;
X            break;
X        case T_ASSIGN:
X            autodef = TRUE;
X            /* fall into default case */
X        default:
X            rescantoken();
X            usesymbol(name, autodef);
X    }
X    /*
X     * Now collect as many element references and matrix index operations
X     * as there are following the id.
X     */
X    for (;;) {
X        switch (gettoken()) {
X            case T_LEFTBRACKET:
X                rescantoken();
X                if (!okmat)
X                    return type;
X                getmatargs();
X                type = 0;
X                break;
X            case T_PERIOD:
X                getelement();
X                type = 0;
X                break;
X            case T_LEFTPAREN:
X                scanerror(T_NULL, "Function calls not allowed as expressions");
X            default:
X                rescantoken();
X                return type;
X        }
X    }
X}
X
X
X/*
X * Read in a filename for a read or write command.
X * Both quoted and unquoted filenames are handled here.
X * The name must be terminated by an end of line or semicolon.
X * Returns TRUE if the filename was successfully parsed.
X */
Xstatic BOOL
Xgetfilename(name, msg_ok)
X    char name[PATHSIZE+1];
X    BOOL msg_ok;        /* TRUE => ok to print error messages */
X{
X    (void) tokenmode(TM_NEWLINES | TM_ALLSYMS);
X    switch (gettoken()) {
X        case T_STRING:
X        case T_SYMBOL:
X            break;
X        default:
X            if (msg_ok)
X                scanerror(T_SEMICOLON, "Filename expected");
X            return FALSE;
X    }
X    strcpy(name, tokenstring());
X    switch (gettoken()) {
X        case T_SEMICOLON:
X        case T_NEWLINE:
X        case T_EOF:
X            break;
X        default:
X            if (msg_ok)
X                scanerror(T_SEMICOLON,
X                    "Missing semicolon after filename");
X            return FALSE;
X    }
X    return TRUE;
X}
X
X
X/*
X * Read the show command and display useful information.
X */
Xstatic void
Xgetshowcommand()
X{
X    char name[SYMBOLSIZE+1];
X
X    if ((gettoken() != T_SHOW) || (gettoken() != T_SYMBOL)) {
X        scanerror(T_SEMICOLON, "Bad syntax for SHOW command");
X        return;
X    }
X    strcpy(name, tokenstring());
X    switch (gettoken()) {
X        case T_NEWLINE:
X        case T_SEMICOLON:
X            break;
X        default:
X            scanerror(T_SEMICOLON, "Bad syntax for SHOW command");
X    }
X    switch ((int) stringindex("builtins\0globals\0functions\0objfuncs\0memory\0", name)) {
X        case 1:
X            showbuiltins();
X            break;
X        case 2:
X            showglobals();
X            break;
X        case 3:
X            showfunctions();
X            break;
X        case 4:
X            showobjfuncs();
X            break;
X        case 5:
X            mem_stats("");
X            break;
X        default:
X            scanerror(T_NULL, "Unknown SHOW parameter \"%s\"", name);
X    }
X}
X
X
X/*
X * Read in a set of matrix index arguments, surrounded with square brackets.
X * This also handles double square brackets for 'fast indexing'.
X */
Xstatic void
Xgetmatargs()
X{
X    int dim;
X
X    if (gettoken() != T_LEFTBRACKET) {
X        scanerror(T_NULL, "Matrix indexing expected");
X        return;
X    }
X    /*
X     * Parse all levels of the array reference
X     * Look for the 'fast index' first.
X     */
X    if (gettoken() == T_LEFTBRACKET) {
X        (void) getassignment();
X        if ((gettoken() != T_RIGHTBRACKET) ||
X            (gettoken() != T_RIGHTBRACKET)) {
X                scanerror(T_NULL, "Bad fast index usage");
X                return;
X        }
X        addop(OP_FIADDR);
X        return;
X    }
X    rescantoken();
X    /*
X     * Normal indexing with the indexes separated by commas.
X     * Initialize the flag in the opcode to assume that the array
X     * element will only be referenced for reading.  If the parser
X     * finds that the element will be referenced for writing, then
X     * it will call writeindexop to change the flag in the opcode.
X     */
X    dim = 1;
X    for (;;) {
X        (void) getassignment();
X        switch (gettoken()) {
X            case T_RIGHTBRACKET:
X                if (gettoken() != T_LEFTBRACKET) {
X                    rescantoken();
X                    addoptwo(OP_INDEXADDR, (long) dim,
X                        (long) FALSE);
X                    return;
X                }
X                /* proceed into comma case */
X                /*FALLTHRU*/
X            case T_COMMA:
X                if (++dim > MAXDIM)
X                    scanerror(T_NULL, "Too many dimensions for array reference");
X                break;
X            default:
X                rescantoken();
X                scanerror(T_NULL, "Missing right bracket in array reference");
X                return;
X        }
X    }
X}
X
X
X/*
X * Get an element of an object reference.
X * The leading period which introduces the element has already been read.
X */
Xstatic void
Xgetelement()
X{
X    long index;
X    char name[SYMBOLSIZE+1];
X
X    if (!getid(name))
X        return;
X    index = findelement(name);
X    if (index < 0) {
X        scanerror(T_NULL, "Element \"%s\" is undefined", name);
X        return;
X    }
X    addopone(OP_ELEMADDR, index);
X}
X
X
X/*
X * Read in a single symbol name and copy its value into the given buffer.
X * Returns TRUE if a valid symbol id was found.
X */
Xstatic BOOL
Xgetid(buf)
X    char buf[SYMBOLSIZE+1];
X{
X    int type;
X
X    type = gettoken();
X    if (iskeyword(type)) {
X        scanerror(T_NULL, "Reserved keyword used as symbol name");
X        type = T_SYMBOL;
X    }
X    if (type != T_SYMBOL) {
X        rescantoken();
X        scanerror(T_NULL, "Symbol name expected");
X        *buf = '\0';
X        return FALSE;
X    }
X    strncpy(buf, tokenstring(), SYMBOLSIZE);
X    buf[SYMBOLSIZE] = '\0';
X    return TRUE;
X}
X
X
X/*
X * Define a symbol name to be of the specified symbol type.  This also checks
X * to see if the symbol was already defined in an incompatible manner.
X */
Xstatic void
Xdefinesymbol(name, symtype)
X    char *name;
X{
X    switch (symboltype(name)) {
X        case SYM_UNDEFINED:
X        case SYM_GLOBAL:
X        case SYM_STATIC:
X            if (symtype == SYM_LOCAL)
X                (void) addlocal(name);
X            else
X                (void) addglobal(name, (symtype == SYM_STATIC));
X            break;
X
X        case SYM_PARAM:
X        case SYM_LOCAL:
X            scanerror(T_COMMA, "Variable \"%s\" is already defined", name);
X            return;
X    }
X
X}
X
X
X/*
X * Check a symbol name to see if it is known and generate code to reference it.
X * The symbol can be either a parameter name, a local name, or a global name.
X * If autodef is true, we automatically define the name as a global symbol
X * if it is not yet known.
X */
Xstatic void
Xusesymbol(name, autodef)
X    char *name;        /* symbol name to be checked */
X    BOOL autodef;
X{
X    switch (symboltype(name)) {
X        case SYM_LOCAL:
X            addopone(OP_LOCALADDR, (long) findlocal(name));
X            return;
X        case SYM_PARAM:
X            addopone(OP_PARAMADDR, (long) findparam(name));
X            return;
X        case SYM_GLOBAL:
X        case SYM_STATIC:
X            addopptr(OP_GLOBALADDR, (char *) findglobal(name));
X            return;
X    }
X    /*
X     * The symbol is not yet defined.
X     * If we are at the top level and we are allowed to, then define it.
X     */
X    if ((curfunc->f_name[0] != '*') || !autodef) {
X        scanerror(T_NULL, "\"%s\" is undefined", name);
X        return;
X    }
X    (void) addglobal(name, FALSE);
X    addopptr(OP_GLOBALADDR, (char *) findglobal(name));
X}
X
X
X/*
X * Get arguments for a function call.
X * The name and beginning parenthesis has already been seen.
X * callargs = [ [ '&' ] assignment  [',' [ '&' ] assignment] ] ')'.
X */
Xstatic void
Xgetcallargs(name)
X    char *name;        /* name of function */
X{
X    long index;        /* function index */
X    long op;        /* opcode to add */
X    int argcount;        /* number of arguments */
X    int type;
X    BOOL addrflag;
X
X    op = OP_CALL;
X    index = getbuiltinfunc(name);
X    if (index < 0) {
X        op = OP_USERCALL;
X        index = adduserfunc(name);
X    }
X    if (gettoken() == T_RIGHTPAREN) {
X        if (op == OP_CALL)
X            builtincheck(index, 0);
X        addopfunction(op, index, 0);
X        return;
X    }
X    rescantoken();
X    argcount = 0;
X    for (;;) {
X        argcount++;
X        addrflag = (gettoken() == T_AND);
X        if (!addrflag)
X            rescantoken();
X        type = getassignment();
X        if (addrflag) {
X            if (isrvalue(type))
X                scanerror(T_NULL, "Taking address of non-variable");
X            writeindexop();
X        }
X        if (!addrflag && (op != OP_CALL))
X            addop(OP_GETVALUE);
X        switch (gettoken()) {
X            case T_RIGHTPAREN:
X                if (op == OP_CALL)
X                    builtincheck(index, argcount);
X                addopfunction(op, index, argcount);
X                return;
X            case T_COMMA:
X                break;
X            default:
X                scanerror(T_SEMICOLON, "Missing right parenthesis in function call");
X                return;
X        }
X    }
X}
X
X/* END CODE */
SHAR_EOF
echo "File calc2.9.0/codegen.c is complete"
chmod 0644 calc2.9.0/codegen.c || echo "restore of calc2.9.0/codegen.c fails"
set `wc -c calc2.9.0/codegen.c`;Sum=$1
if test "$Sum" != "41674"
then echo original size 41674, current size $Sum;fi
echo "x - extracting calc2.9.0/comfunc.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/comfunc.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 * Extended precision complex arithmetic non-primitive routines
X */
X
X#include "cmath.h"
X
X
X/*
X * Round a complex number to the specified number of decimal places.
X * This simply means to round each of the components of the number.
X * Zero decimal places means round to the nearest complex integer.
X */
XCOMPLEX *
Xcround(c, places)
X    COMPLEX *c;
X    long places;
X{
X    COMPLEX *res;        /* result */
X
X    res = comalloc();
X    res->real = qround(c->real, places);
X    res->imag = qround(c->imag, places);
X    return res;
X}
X
X
X/*
X * Round a complex number to the specified number of binary decimal places.
X * This simply means to round each of the components of the number.
X * Zero binary places means round to the nearest complex integer.
X */
XCOMPLEX *
Xcbround(c, places)
X    COMPLEX *c;
X    long places;
X{
X    COMPLEX *res;        /* result */
X
X    res = comalloc();
X    res->real = qbround(c->real, places);
X    res->imag = qbround(c->imag, places);
X    return res;
X}
X
X
X/*
X * Compute the result of raising a complex number to an integer power.
X */
XCOMPLEX *
Xcpowi(c, q)
X    COMPLEX *c;        /* complex number to be raised */
X    NUMBER *q;        /* power to raise it to */
X{
X    COMPLEX *tmp, *res;    /* temporary values */
X    long power;        /* power to raise to */
X    unsigned long bit;    /* current bit value */
X    int sign;
X
X    if (qisfrac(q))
X        math_error("Raising number to non-integral power");
X    if (zisbig(q->num))
X        math_error("Raising number to very large power");
X    power = (zistiny(q->num) ? z1tol(q->num) : z2tol(q->num));
X    if (ciszero(c) && (power == 0))
X        math_error("Raising zero to zeroth power");
X    sign = 1;
X    if (qisneg(q))
X        sign = -1;
X    /*
X     * Handle some low powers specially
X     */
X    if (power <= 4) {
X        switch ((int) (power * sign)) {
X            case 0:
X                return clink(&_cone_);
X            case 1:
X                return clink(c);
X            case -1:
X                return cinv(c);
X            case 2:
X                return csquare(c);
X            case -2:
X                tmp = csquare(c);
X                res = cinv(tmp);
X                comfree(tmp);
X                return res;
X            case 3:
X                tmp = csquare(c);
X                res = cmul(c, tmp);
X                comfree(tmp);
X                return res;
X            case 4:
X                tmp = csquare(c);
X                res = csquare(tmp);
X                comfree(tmp);
X                return res;
X        }
X    }
X    /*
X     * Compute the power by squaring and multiplying.
X     * This uses the left to right method of power raising.
X     */
X    bit = TOPFULL;
X    while ((bit & power) == 0)
X        bit >>= 1L;
X    bit >>= 1L;
X    res = csquare(c);
X    if (bit & power) {
X        tmp = cmul(res, c);
X        comfree(res);
X        res = tmp;
X    }
X    bit >>= 1L;
X    while (bit) {
X        tmp = csquare(res);
X        comfree(res);
X        res = tmp;
X        if (bit & power) {
X            tmp = cmul(res, c);
X            comfree(res);
X            res = tmp;
X        }
X        bit >>= 1L;
X    }
X    if (sign < 0) {
X        tmp = cinv(res);
X        comfree(res);
X        res = tmp;
X    }
X    return res;
X}
X
X
X/*
X * Calculate the square root of a complex number, with each component
X * within the specified error.  If the number is a square, then the error
X * is zero.  For sqrt(a + bi), this calculates:
X *    R = sqrt(a^2 + b^2)
X *    U = sqrt((R + abs(a))/2)
X *    V = b/(2 * U)
X *    then sqrt(a + bi) = U + Vi if a >= 0,
X *    or abs(V) + sgn(b) * U  if a < 0
X */
XCOMPLEX *
Xcsqrt(c, epsilon)
X    COMPLEX *c;
X    NUMBER *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *A, *B, *R, *U, *V, *tmp1, *tmp2, *epsilon2;
X    long m, n;
X
X    if (ciszero(c) || cisone(c))
X        return clink(c);
X    if (cisreal(c)) {
X        r = comalloc();
X        if (!qisneg(c->real)) {
X            r->real = qsqrt(c->real, epsilon);
X            return r;
X        }
X        tmp1 = qneg(c->real);
X        r->imag = qsqrt(tmp1, epsilon);
X        qfree(tmp1);
X        return r;
X    }
X
X    A = qlink(c->real);
X    B = qlink(c->imag);
X    n = zhighbit(B->num) - zhighbit(B->den);
X    if (!qiszero(A)) {
X        m = zhighbit(A->num) - zhighbit(A->den);
X        if (m > n)
X            n = m;
X    }
X    epsilon2 = qscale(epsilon, n/2);
X    R = qhypot(A, B, epsilon2);
X    qfree(epsilon2);
X    if (qisneg(A))
X        tmp1 = qsub(R, A);
X    else
X        tmp1 = qadd(R, A);
X    qfree(A);
X    tmp2 = qscale(tmp1, -1L);
X    qfree(tmp1);
X    U = qsqrt(tmp2, epsilon);
X    qfree(tmp2);
X    qfree(R);
X    if (qiszero(U)) {
X        qfree(B);
X        qfree(U);
X        return clink(&_czero_);
X    }
X    tmp1 = qdiv(B, U);
X    V = qscale(tmp1, -1L);
X    qfree(tmp1);
X    r = comalloc();
X    if (qisneg(c->real)) {
X        if (qisneg(B)) {
X            tmp1 = qneg(U);
X            qfree(U);
X            U = tmp1;
X            tmp2 = qabs(V);
X            qfree(V);
X            V = tmp2;
X        }
X        r->real = V;
X        r->imag = U;
X    } else {
X        r->real = U;
X        r->imag = V;
X    }
X    qfree(B);
X    return r;
X}
X
X
X/*
X * Take the Nth root of a complex number, where N is a positive integer.
X * Each component of the result is within the specified error.
X */
XCOMPLEX *
Xcroot(c, q, epsilon)
X    COMPLEX *c;
X    NUMBER *q, *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *a2pb2, *root, *tmp1, *tmp2, *epsilon2;
X
X    if (qisneg(q) || qiszero(q) || qisfrac(q))
X        math_error("Taking bad root of complex number");
X    if (cisone(c) || qisone(q))
X        return clink(c);
X    if (qistwo(q))
X        return csqrt(c, epsilon);
X    r = comalloc();
X    if (cisreal(c) && !qisneg(c->real)) {
X        r->real = qroot(c->real, q, epsilon);
X        return r;
X    }
X    /*
X     * Calculate the root using the formula:
X     *    croot(a + bi, n) =
X     *        cpolar(qroot(a^2 + b^2, 2 * n), qatan2(b, a) / n).
X     */
X    epsilon2 = qscale(epsilon, -8L);
X    tmp1 = qsquare(c->real);
X    tmp2 = qsquare(c->imag);
X    a2pb2 = qadd(tmp1, tmp2);
X    qfree(tmp1);
X    qfree(tmp2);
X    tmp1 = qscale(q, 1L);
X    root = qroot(a2pb2, tmp1, epsilon2);
X    qfree(a2pb2);
X    qfree(tmp1);
X    tmp1 = qatan2(c->imag, c->real, epsilon2);
X    qfree(epsilon2);
X    tmp2 = qdiv(tmp1, q);
X    qfree(tmp1);
X    r = cpolar(root, tmp2, epsilon);
X    qfree(root);
X    qfree(tmp2);
X    return r;
X}
X
X
X/*
X * Calculate the complex exponential function to the desired accuracy.
X * We use the formula:
X *    exp(a + bi) = exp(a) * (cos(b) + i * sin(b)).
X */
XCOMPLEX *
Xcexp(c, epsilon)
X    COMPLEX *c;
X    NUMBER *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *tmp1, *tmp2, *epsilon2;
X
X    if (ciszero(c))
X        return clink(&_cone_);
X    r = comalloc();
X    if (cisreal(c)) {
X        r->real = qexp(c->real, epsilon);
X        return r;
X    }
X    epsilon2 = qscale(epsilon, -2L);
X    r->real = qcos(c->imag, epsilon2);
X    r->imag = qlegtoleg(r->real, epsilon2, _sinisneg_);
X    if (qiszero(c->real)) {
X        qfree(epsilon2);
X        return r;
X    }
X    tmp1 = qexp(c->real, epsilon2);
X    qfree(epsilon2);
X    tmp2 = qmul(r->real, tmp1);
X    qfree(r->real);
X    r->real = tmp2;
X    tmp2 = qmul(r->imag, tmp1);
X    qfree(r->imag);
X    qfree(tmp1);
X    r->imag = tmp2;
X    return r;
X}
X
X
X/*
X * Calculate the natural logarithm of a complex number within the specified
X * error.  We use the formula:
X *    ln(a + bi) = ln(a^2 + b^2) / 2 + i * atan2(b, a).
X */
XCOMPLEX *
Xcln(c, epsilon)
X    COMPLEX *c;
X    NUMBER *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *a2b2, *tmp1, *tmp2;
X
X    if (ciszero(c))
X        math_error("Logarithm of zero");
X    if (cisone(c))
X        return clink(&_czero_);
X    r = comalloc();
X    if (cisreal(c) && !qisneg(c->real)) {
X        r->real = qln(c->real, epsilon);
X        return r;
X    }
X    tmp1 = qsquare(c->real);
X    tmp2 = qsquare(c->imag);
X    a2b2 = qadd(tmp1, tmp2);
X    qfree(tmp1);
X    qfree(tmp2);
X    tmp1 = qln(a2b2, epsilon);
X    qfree(a2b2);
X    r->real = qscale(tmp1, -1L);
X    qfree(tmp1);
X    r->imag = qatan2(c->imag, c->real, epsilon);
X    return r;
X}
X
X
X/*
X * Calculate the complex cosine within the specified accuracy.
X * This uses the formula:
X *    cos(a + bi) = cos(a) * cosh(b) - sin(a) * sinh(b) * i.
X */
XCOMPLEX *
Xccos(c, epsilon)
X    COMPLEX *c;
X    NUMBER *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *cosval, *coshval, *tmp1, *tmp2, *tmp3, *epsilon2;
X    int negimag;
X
X    if (ciszero(c))
X        return clink(&_cone_);
X    r = comalloc();
X    if (cisreal(c)) {
X        r->real = qcos(c->real, epsilon);
X        return r;
X    }
X    if (qiszero(c->real)) {
X        r->real = qcosh(c->imag, epsilon);
X        return r;
X    }
X    epsilon2 = qscale(epsilon, -2L);
X    coshval = qcosh(c->imag, epsilon2);
X    cosval = qcos(c->real, epsilon2);
X    negimag = !_sinisneg_;
X    if (qisneg(c->imag))
X        negimag = !negimag;
X    r->real = qmul(cosval, coshval);
X    /*
X     * Calculate the imaginary part using the formula:
X     *    sin(a) * sinh(b) = sqrt((1 - a^2) * (b^2 - 1)).
X     */
X    tmp1 = qsquare(cosval);
X    qfree(cosval);
X    tmp2 = qdec(tmp1);
X    qfree(tmp1);
X    tmp1 = qneg(tmp2);
X    qfree(tmp2);
X    tmp2 = qsquare(coshval);
X    qfree(coshval);
X    tmp3 = qdec(tmp2);
X    qfree(tmp2);
X    tmp2 = qmul(tmp1, tmp3);
X    qfree(tmp1);
X    qfree(tmp3);
X    r->imag = qsqrt(tmp2, epsilon2);
X    qfree(tmp2);
X    qfree(epsilon2);
X    if (negimag) {
X        tmp1 = qneg(r->imag);
X        qfree(r->imag);
X        r->imag = tmp1;
X    }
X    return r;
X}
X
X
X/*
X * Calculate the complex sine within the specified accuracy.
X * This uses the formula:
X *    sin(a + bi) = sin(a) * cosh(b) + cos(a) * sinh(b) * i.
X */
XCOMPLEX *
Xcsin(c, epsilon)
X    COMPLEX *c;
X    NUMBER *epsilon;
X{
X    COMPLEX *r;
X
X    NUMBER *cosval, *coshval, *tmp1, *tmp2, *epsilon2;
X
X    if (ciszero(c))
X        return clink(&_czero_);
X    r = comalloc();
X    if (cisreal(c)) {
X        r->real = qsin(c->real, epsilon);
X        return r;
X    }
X    if (qiszero(c->real)) {
X        r->imag = qsinh(c->imag, epsilon);
X        return r;
X    }
X    epsilon2 = qscale(epsilon, -2L);
X    coshval = qcosh(c->imag, epsilon2);
X    cosval = qcos(c->real, epsilon2);
X    tmp1 = qlegtoleg(cosval, epsilon2, _sinisneg_);
X    r->real = qmul(tmp1, coshval);
X    qfree(tmp1);
X    tmp1 = qsquare(coshval);
X    qfree(coshval);
X    tmp2 = qdec(tmp1);
X    qfree(tmp1);
X    tmp1 = qsqrt(tmp2, epsilon2);
X    qfree(tmp2);
X    r->imag = qmul(tmp1, cosval);
X    qfree(tmp1);
X    qfree(cosval);
X    if (qisneg(c->imag)) {
X        tmp1 = qneg(r->imag);
X        qfree(r->imag);
X        r->imag = tmp1;
X    }
X    return r;
X}
X
X
X/*
X * Convert a number from polar coordinates to normal complex number form
X * within the specified accuracy.  This produces the value:
X *    q1 * cos(q2) + q1 * sin(q2) * i.
X */
XCOMPLEX *
Xcpolar(q1, q2, epsilon)
X    NUMBER *q1, *q2, *epsilon;
X{
X    COMPLEX *r;
X    NUMBER *tmp, *epsilon2;
X    long scale;
X
X    r = comalloc();
X    if (qiszero(q1) || qiszero(q2)) {
X        r->real = qlink(q1);
X        return r;
X    }
X    epsilon2 = epsilon;
X    if (!qisunit(q1)) {
X        scale = zhighbit(q1->num) - zhighbit(q1->den) + 1;
X        if (scale > 0)
X            epsilon2 = qscale(epsilon, -scale);
X    }
X    r->real = qcos(q2, epsilon2);
X    r->imag = qlegtoleg(r->real, epsilon2, _sinisneg_);
X    if (epsilon2 != epsilon)
X        qfree(epsilon2);
X    if (qisone(q1))
X        return r;
X    tmp = qmul(r->real, q1);
X    qfree(r->real);
X    r->real = tmp;
X    tmp = qmul(r->imag, q1);
X    qfree(r->imag);
X    r->imag = tmp;
X    return r;
X}
X
X
X/*
X * Raise one complex number to the power of another one to within the
X * specified error.
X */
XCOMPLEX *
Xcpower(c1, c2, epsilon)
X    COMPLEX *c1, *c2;
X    NUMBER *epsilon;
X{
X    COMPLEX *tmp1, *tmp2;
X    NUMBER *epsilon2;
X
X    if (cisreal(c2) && qisint(c2->real))
X        return cpowi(c1, c2->real);
X    if (cisone(c1) || ciszero(c1))
X        return clink(c1);
X    epsilon2 = qscale(epsilon, -4L);
X    tmp1 = cln(c1, epsilon2);
X    tmp2 = cmul(tmp1, c2);
X    comfree(tmp1);
X    tmp1 = cexp(tmp2, epsilon);
X    comfree(tmp2);
X    qfree(epsilon2);
X    return tmp1;
X}
X
X
X/*
X * Return a trivial hash value for a complex number.
X */
XHASH
Xchash(c)
X    COMPLEX *c;
X{
X    HASH hash;
X
X    hash = qhash(c->real);
X    if (!cisreal(c))
X        hash += qhash(c->imag) * 2000029;
X    return hash;
X}
X
X
X/*
X * Print a complex number in the current output mode.
X */
Xvoid
Xcomprint(c)
X    COMPLEX *c;
X{
X    NUMBER qtmp;
X
X    if (_outmode_ == MODE_FRAC) {
X        cprintfr(c);
X        return;
X    }
X    if (!qiszero(c->real) || qiszero(c->imag))
X        qprintnum(c->real, MODE_DEFAULT);
X    qtmp = c->imag[0];
X    if (qiszero(&qtmp))
X        return;
X    if (!qiszero(c->real) && !qisneg(&qtmp))
X        math_chr('+');
X    if (qisneg(&qtmp)) {
X        math_chr('-');
X        qtmp.num.sign = 0;
X    }
X    qprintnum(&qtmp, MODE_DEFAULT);
X    math_chr('i');
X}
X
X
X/*
X * Print a complex number in rational representation.
X * Example:  2/3-4i/5
X */
Xvoid
Xcprintfr(c)
X    COMPLEX *c;
X{
X    NUMBER *r;
X    NUMBER *i;
X
X    r = c->real;
X    i = c->imag;
X    if (!qiszero(r) || qiszero(i))
X        qprintfr(r, 0L, FALSE);
X    if (qiszero(i))
X        return;
X    if (!qiszero(r) && !qisneg(i))
X        math_chr('+');
X    zprintval(i->num, 0L, 0L);
X    math_chr('i');
X    if (qisfrac(i)) {
X        math_chr('/');
X        zprintval(i->den, 0L, 0L);
X    }
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/comfunc.c || echo "restore of calc2.9.0/comfunc.c fails"
set `wc -c calc2.9.0/comfunc.c`;Sum=$1
if test "$Sum" != "11584"
then echo original size 11584, current size $Sum;fi
echo "x - extracting calc2.9.0/commath.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/commath.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 * Extended precision complex arithmetic primitive routines
X */
X
X#include "cmath.h"
X
X
XCOMPLEX _czero_ =        { &_qzero_, &_qzero_, 1 };
XCOMPLEX _cone_ =        { &_qone_, &_qzero_, 1 };
XCOMPLEX _conei_ =        { &_qzero_, &_qone_, 1 };
X
Xstatic COMPLEX _cnegone_ =    { &_qnegone_, &_qzero_, 1 };
X
X
X/*
X * Free list for complex numbers.
X */
Xstatic FREELIST freelist = {
X    sizeof(COMPLEX),    /* size of an item */
X    100            /* number of free items to keep */
X};
X
X
X/*
X * Add two complex numbers.
X */
XCOMPLEX *
Xcadd(c1, c2)
X    COMPLEX *c1, *c2;
X{
X    COMPLEX *r;
X
X    if (ciszero(c1))
X        return clink(c2);
X    if (ciszero(c2))
X        return clink(c1);
X    r = comalloc();
X    if (!qiszero(c1->real) || !qiszero(c2->real))
X        r->real = qadd(c1->real, c2->real);
X    if (!qiszero(c1->imag) || !qiszero(c2->imag))
X        r->imag = qadd(c1->imag, c2->imag);
X    return r;
X}
X
X
X/*
X * Subtract two complex numbers.
X */
XCOMPLEX *
Xcsub(c1, c2)
X    COMPLEX *c1, *c2;
X{
X    COMPLEX *r;
X
X    if ((c1->real == c2->real) && (c1->imag == c2->imag))
X        return clink(&_czero_);
X    if (ciszero(c2))
X        return clink(c1);
X    r = comalloc();
X    if (!qiszero(c1->real) || !qiszero(c2->real))
X        r->real = qsub(c1->real, c2->real);
X    if (!qiszero(c1->imag) || !qiszero(c2->imag))
X        r->imag = qsub(c1->imag, c2->imag);
X    return r;
X}
X
X
X/*
X * Multiply two complex numbers.
X * This saves one multiplication over the obvious algorithm by
X * trading it for several extra additions, as follows.  Let
X *    q1 = (a + b) * (c + d)
X *    q2 = a * c
X *    q3 = b * d
X * Then (a+bi) * (c+di) = (q2 - q3) + (q1 - q2 - q3)i.
X */
XCOMPLEX *
Xcmul(c1, c2)
X    COMPLEX *c1, *c2;
X{
X    COMPLEX *r;
X    NUMBER *q1, *q2, *q3, *q4;
X
X    if (ciszero(c1) || ciszero(c2))
X        return clink(&_czero_);
X    if (cisone(c1))
X        return clink(c2);
X    if (cisone(c2))
X        return clink(c1);
X    if (cisreal(c2))
X        return cmulq(c1, c2->real);
X    if (cisreal(c1))
X        return cmulq(c2, c1->real);
X    /*
X     * Need to do the full calculation.
X     */
X    r = comalloc();
X    q2 = qadd(c1->real, c1->imag);
X    q3 = qadd(c2->real, c2->imag);
X    q1 = qmul(q2, q3);
X    qfree(q2);
X    qfree(q3);
X    q2 = qmul(c1->real, c2->real);
X    q3 = qmul(c1->imag, c2->imag);
X    q4 = qadd(q2, q3);
X    r->real = qsub(q2, q3);
X    r->imag = qsub(q1, q4);
X    qfree(q1);
X    qfree(q2);
X    qfree(q3);
X    qfree(q4);
X    return r;
X}
X
X
X/*
X * Square a complex number.
X */
XCOMPLEX *
Xcsquare(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X    NUMBER *q1, *q2;
X
X    if (ciszero(c))
X        return clink(&_czero_);
X    if (cisrunit(c))
X        return clink(&_cone_);
X    if (cisiunit(c))
X        return clink(&_cnegone_);
X    r = comalloc();
X    if (cisreal(c)) {
X        r->real = qsquare(c->real);
X        return r;
X    }
X    if (cisimag(c)) {
X        q1 = qsquare(c->imag);
X        r->real = qneg(q1);
X        qfree(q1);
X        return r;
X    }
X    q1 = qsquare(c->real);
X    q2 = qsquare(c->imag);
X    r->real = qsub(q1, q2);
X    qfree(q1);
X    qfree(q2);
X    q1 = qmul(c->real, c->imag);
X    r->imag = qscale(q1, 1L);
X    qfree(q1);
X    return r;
X}
X
X
X/*
X * Divide two complex numbers.
X */
XCOMPLEX *
Xcdiv(c1, c2)
X    COMPLEX *c1, *c2;
X{
X    COMPLEX *r;
X    NUMBER *q1, *q2, *q3, *den;
X
X    if (ciszero(c2))
X        math_error("Division by zero");
X    if ((c1->real == c2->real) && (c1->imag == c2->imag))
X        return clink(&_cone_);
X    r = comalloc();
X    if (cisreal(c1) && cisreal(c2)) {
X        r->real = qdiv(c1->real, c2->real);
X        return r;
X    }
X    if (cisimag(c1) && cisimag(c2)) {
X        r->real = qdiv(c1->imag, c2->imag);
X        return r;
X    }
X    if (cisimag(c1) && cisreal(c2)) {
X        r->imag = qdiv(c1->imag, c2->real);
X        return r;
X    }
X    if (cisreal(c1) && cisimag(c2)) {
X        q1 = qdiv(c1->real, c2->imag);
X        r->imag = qneg(q1);
X        qfree(q1);
X        return r;
X    }
X    if (cisreal(c2)) {
X        r->real = qdiv(c1->real, c2->real);
X        r->imag = qdiv(c1->imag, c2->real);
X        return r;
X    }
X    q1 = qsquare(c2->real);
X    q2 = qsquare(c2->imag);
X    den = qadd(q1, q2);
X    qfree(q1);
X    qfree(q2);
X    q1 = qmul(c1->real, c2->real);
X    q2 = qmul(c1->imag, c2->imag);
X    q3 = qadd(q1, q2);
X    qfree(q1);
X    qfree(q2);
X    r->real = qdiv(q3, den);
X    qfree(q3);
X    q1 = qmul(c1->real, c2->imag);
X    q2 = qmul(c1->imag, c2->real);
X    q3 = qsub(q2, q1);
X    qfree(q1);
X    qfree(q2);
X    r->imag = qdiv(q3, den);
X    qfree(q3);
X    qfree(den);
X    return r;
X}
X
X
X/*
X * Invert a complex number.
X */
XCOMPLEX *
Xcinv(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X    NUMBER *q1, *q2, *den;
X
X    if (ciszero(c))
X        math_error("Inverting zero");
X    r = comalloc();
X    if (cisreal(c)) {
X        r->real = qinv(c->real);
X        return r;
X    }
X    if (cisimag(c)) {
X        q1 = qinv(c->imag);
X        r->imag = qneg(q1);
X        qfree(q1);
X        return r;
X    }
X    q1 = qsquare(c->real);
X    q2 = qsquare(c->imag);
X    den = qadd(q1, q2);
X    qfree(q1);
X    qfree(q2);
X    r->real = qdiv(c->real, den);
X    q1 = qdiv(c->imag, den);
X    r->imag = qneg(q1);
X    qfree(q1);
X    qfree(den);
X    return r;
X}
X
X
X/*
X * Negate a complex number.
X */
XCOMPLEX *
Xcneg(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (ciszero(c))
X        return clink(&_czero_);
X    r = comalloc();
X    if (!qiszero(c->real))
X        r->real = qneg(c->real);
X    if (!qiszero(c->imag))
X        r->imag = qneg(c->imag);
X    return r;
X}
X
X
X/*
X * Take the integer part of a complex number.
X * This means take the integer part of both components.
X */
XCOMPLEX *
Xcint(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (cisint(c))
X        return clink(c);
X    r = comalloc();
X    r->real = qint(c->real);
X    r->imag = qint(c->imag);
X    return r;
X}
X
X
X/*
X * Take the fractional part of a complex number.
X * This means take the fractional part of both components.
X */
XCOMPLEX *
Xcfrac(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (cisint(c))
X        return clink(&_czero_);
X    r = comalloc();
X    r->real = qfrac(c->real);
X    r->imag = qfrac(c->imag);
X    return r;
X}
X
X
X/*
X * Take the conjugate of a complex number.
X * This negates the complex part.
X */
XCOMPLEX *
Xcconj(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (cisreal(c))
X        return clink(c);
X    r = comalloc();
X    if (!qiszero(c->real))
X        r->real = qlink(c->real);
X    r->imag = qneg(c->imag);
X    return r;
X}
X
X
X/*
X * Return the real part of a complex number.
X */
XCOMPLEX *
Xcreal(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (cisreal(c))
X        return clink(c);
X    r = comalloc();
X    if (!qiszero(c->real))
X        r->real = qlink(c->real);
X    return r;
X}
X
X
X/*
X * Return the imaginary part of a complex number as a real.
X */
XCOMPLEX *
Xcimag(c)
X    COMPLEX *c;
X{
X    COMPLEX *r;
X
X    if (cisreal(c))
X        return clink(&_czero_);
X    r = comalloc();
X    r->real = qlink(c->imag);
X    return r;
X}
X
X
X/*
X * Add a real number to a complex number.
X */
XCOMPLEX *
Xcaddq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        return clink(c);
X    r = comalloc();
X    r->real = qadd(c->real, q);
X    r->imag = qlink(c->imag);
X    return r;
X}
X
X
X/*
X * Subtract a real number from a complex number.
X */
XCOMPLEX *
Xcsubq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        return clink(c);
X    r = comalloc();
X    r->real = qsub(c->real, q);
X    r->imag = qlink(c->imag);
X    return r;
X}
X
X
X/*
X * Shift the components of a complex number left by the specified
X * number of bits.  Negative values shift to the right.
X */
XCOMPLEX *
Xcshift(c, n)
X    COMPLEX *c;
X    long n;
X{
X    COMPLEX *r;
X
X    if (ciszero(c) || (n == 0))
X        return clink(c);
X    r = comalloc();
X    r->real = qshift(c->real, n);
X    r->imag = qshift(c->imag, n);
X    return r;
X}
X
X
X/*
X * Scale a complex number by a power of two.
X */
XCOMPLEX *
Xcscale(c, n)
X    COMPLEX *c;
X    long n;
X{
X    COMPLEX *r;
X
X    if (ciszero(c) || (n == 0))
X        return clink(c);
X    r = comalloc();
X    r->real = qscale(c->real, n);
X    r->imag = qscale(c->imag, n);
X    return r;
X}
X
X
X/*
X * Multiply a complex number by a real number.
X */
XCOMPLEX *
Xcmulq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        return clink(&_czero_);
X    if (qisone(q))
X        return clink(c);
X    if (qisnegone(q))
X        return cneg(c);
X    r = comalloc();
X    r->real = qmul(c->real, q);
X    r->imag = qmul(c->imag, q);
X    return r;
X}
X
X
X/*
X * Divide a complex number by a real number.
X */
XCOMPLEX *
Xcdivq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        math_error("Division by zero");
X    if (qisone(q))
X        return clink(c);
X    if (qisnegone(q))
X        return cneg(c);
X    r = comalloc();
X    r->real = qdiv(c->real, q);
X    r->imag = qdiv(c->imag, q);
X    return r;
X}
X
X
X/*
X * Take the integer quotient of a complex number by a real number.
X * This is defined to be the result of doing the quotient for each component.
X */
XCOMPLEX *
Xcquoq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        math_error("Division by zero");
X    r = comalloc();
X    r->real = qquo(c->real, q);
X    r->imag = qquo(c->imag, q);
X    return r;
X}
X
X
X/*
X * Take the modulus of a complex number by a real number.
X * This is defined to be the result of doing the modulo for each component.
X */
XCOMPLEX *
Xcmodq(c, q)
X    COMPLEX *c;
X    NUMBER *q;
X{
X    COMPLEX *r;
X
X    if (qiszero(q))
X        math_error("Division by zero");
X    r = comalloc();
X    r->real = qmod(c->real, q);
X    r->imag = qmod(c->imag, q);
X    return r;
X}
X
X
X/*
X * Construct a complex number given the real and imaginary components.
X */
XCOMPLEX *
Xqqtoc(q1, q2)
X    NUMBER *q1, *q2;
X{
X    COMPLEX *r;
X
X    if (qiszero(q1) && qiszero(q2))
X        return clink(&_czero_);
X    r = comalloc();
X    if (!qiszero(q1))
X        r->real = qlink(q1);
X    if (!qiszero(q2))
X        r->imag = qlink(q2);
X    return r;
X}
X
X
X/*
X * Compare two complex numbers for equality, returning FALSE if they are equal,
X * and TRUE if they differ.
X */
XBOOL
Xccmp(c1, c2)
X    COMPLEX *c1, *c2;
X{
X    BOOL i;
X
X    i = qcmp(c1->real, c2->real);
X    if (!i)
X        i = qcmp(c1->imag, c2->imag);
X    return i;
X}
X
X
X/*
X * Allocate a new complex number.
X */
XCOMPLEX *
Xcomalloc()
X{
X    COMPLEX *r;
X
X    r = (COMPLEX *) allocitem(&freelist);
X    if (r == NULL)
X        math_error("Cannot allocate complex number");
X    r->links = 1;
X    r->real = qlink(&_qzero_);
X    r->imag = qlink(&_qzero_);
X    return r;
X}
X
X
X/*
X * Free a complex number.
X */
Xvoid
Xcomfree(c)
X    COMPLEX *c;
X{
X    if (--(c->links) > 0)
X        return;
X    qfree(c->real);
X    qfree(c->imag);
X    freeitem(&freelist, (FREEITEM *) c);
X}
X
X/* END CODE */
SHAR_EOF
chmod 0644 calc2.9.0/commath.c || echo "restore of calc2.9.0/commath.c fails"
set `wc -c calc2.9.0/commath.c`;Sum=$1
if test "$Sum" != "9628"
then echo original size 9628, current size $Sum;fi
echo "x - extracting calc2.9.0/config.c (Text)"
sed 's/^X//' << 'SHAR_EOF' > calc2.9.0/config.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 * Configuration routines.
X */
X
X#include "calc.h"
X
X
X/*
X * Configuration parameter name and type.
X */
Xtypedef struct {
X    char *name;    /* name of configuration string */
X    int type;    /* type for configuration */
X} CONFIG;
X
X
X/*
X * Table of configuration types that can be set or read.
X */
Xstatic CONFIG configs[] = {
X    "trace",    CONFIG_TRACE,
X    "display",    CONFIG_DISPLAY,
X    "epsilon",    CONFIG_EPSILON,
X    "mode",        CONFIG_MODE,
X    "maxprint",    CONFIG_MAXPRINT,
X    "mul2",        CONFIG_MUL2,
X    "sq2",        CONFIG_SQ2,
X    "pow2",        CONFIG_POW2,
X    "redc2",    CONFIG_REDC2,
X    NULL,        0
X};
X
X
X/*
X * Possible output modes.
X */
Xstatic CONFIG modes[] = {
X    "frac",        MODE_FRAC,
X    "decimal",    MODE_FRAC,
X    "dec",        MODE_FRAC,
X    "int",        MODE_INT,
X    "real",        MODE_REAL,
X    "exp",        MODE_EXP,
X    "hexadecimal",    MODE_HEX,
X    "hex",        MODE_HEX,
X    "octal",    MODE_OCTAL,
X    "oct",        MODE_OCTAL,
X    "binary",    MODE_BINARY,
X    "bin",        MODE_BINARY,
X    NULL,        0
X};
X
X
X/*
X * Given a string value which represents a configuration name, return
X * the configuration type for that string.  Returns negative type if
X * the string is unknown.
X */
Xint
Xconfigtype(name)
X    char *name;        /* configuration name */
X{
X    CONFIG *cp;        /* current config pointer */
X
X    for (cp = configs; cp->name; cp++) {
X        if (strcmp(cp->name, name) == 0)
X            return cp->type;
X    }
X    return -1;
X}
X
X
X/*
X * Given the name of a mode, convert it to the internal format.
X * Returns -1 if the string is unknown.
X */
Xstatic int
Xmodetype(name)
X    char *name;        /* mode name */
X{
X    CONFIG *cp;        /* current config pointer */
X
X    for (cp = modes; cp->name; cp++) {
X        if (strcmp(cp->name, name) == 0)
X            return cp->type;
X    }
X    return -1;
X}
X
X
X/*
X * Given the mode type, convert it to a string representing that mode.
X * Where there are multiple strings representing the same mode, the first
X * one in the table is used.  Returns NULL if the node type is unknown.
X * The returned string cannot be modified.
X */
Xstatic char *
Xmodename(type)
X{
X    CONFIG *cp;        /* current config pointer */
X
X    for (cp = modes; cp->name; cp++) {
X        if (type == cp->type)
X            return cp->name;
X    }
X    return NULL;
X}
X
X
X/*
X * Set the specified configuration type to the specified value.
X * An error is generated if the type number or value is illegal.
X */
Xvoid
Xsetconfig(type, vp)
X    VALUE *vp;
X{
X    NUMBER *q;
X    long temp;
X
X    switch (type) {
X        case CONFIG_TRACE:
X            if (vp->v_type != V_NUM)
X                math_error("Non-numeric for trace");
X            q = vp->v_num;
X            temp = qtoi(q);
X            if (qisfrac(q) || !zistiny(q->num) ||
X                ((unsigned long) temp > TRACE_MAX))
X                    math_error("Bad trace value");
X            traceflags = (FLAG)temp;
X            break;
X
X        case CONFIG_DISPLAY:
X            if (vp->v_type != V_NUM)
X                math_error("Non-numeric for display");
X            q = vp->v_num;
X            temp = qtoi(q);
X            if (qisfrac(q) || qisneg(q) || !zistiny(q->num))
X                temp = -1;
X            math_setdigits(temp);
X            break;
X
X        case CONFIG_MODE:
X            if (vp->v_type != V_STR)
X                math_error("Non-string for mode");
X            temp = modetype(vp->v_str);
X            if (temp < 0)
X                math_error("Unknown mode \"%s\"", vp->v_str);
X            math_setmode((int) temp);
X            break;
X
X        case CONFIG_EPSILON:
X            if (vp->v_type != V_NUM)
X                math_error("Non-numeric for epsilon");
X            setepsilon(vp->v_num);
X            break;
X
X        case CONFIG_MAXPRINT:
X            if (vp->v_type != V_NUM)
X                math_error("Non-numeric for maxprint");
X            q = vp->v_num;
X            temp = qtoi(q);
X            if (qisfrac(q) || qisneg(q) || !zistiny(q->num))
X                temp = -1;
X            if (temp < 0)
X                math_error("Maxprint value is out of range");
SHAR_EOF
echo "End of part 3"
echo "File calc2.9.0/config.c is continued in part 4"
echo "4" > s2_seq_.tmp
exit 0