home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-12-07 | 59.5 KB | 2,856 lines |
- Newsgroups: comp.sources.unix
- From: dbell@canb.auug.org.au (David I. Bell)
- Subject: v27i130: calc-2.9.0 - arbitrary precision C-like programmable calculator, Part03/19
- References: <1.755316719.21314@gw.home.vix.com>
- Sender: unix-sources-moderator@gw.home.vix.com
- Approved: vixie@gw.home.vix.com
-
- Submitted-By: dbell@canb.auug.org.au (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
-