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