diff options
Diffstat (limited to 'libm/double/dcalc.c')
| -rw-r--r-- | libm/double/dcalc.c | 1512 |
1 files changed, 1512 insertions, 0 deletions
diff --git a/libm/double/dcalc.c b/libm/double/dcalc.c new file mode 100644 index 000000000..b740edae2 --- /dev/null +++ b/libm/double/dcalc.c @@ -0,0 +1,1512 @@ +/* calc.c */ +/* Keyboard command interpreter */ +/* by Stephen L. Moshier */ + + +/* length of command line: */ +#define LINLEN 128 + +#define XON 0x11 +#define XOFF 0x13 + +#define SALONE 1 +#define DECPDP 0 +#define INTLOGIN 0 +#define INTHELP 1 +#ifndef TRUE +#define TRUE 1 +#endif + +/* Initialize squirrel printf: */ +#define INIPRINTF 0 + +#if DECPDP +#define TRUE 1 +#endif + +#include <stdio.h> +#include <string.h> + +static char idterp[] = { +"\n\nSteve Moshier's command interpreter V1.3\n"}; +#define ISLOWER(c) ((c >= 'a') && (c <= 'z')) +#define ISUPPER(c) ((c >= 'A') && (c <= 'Z')) +#define ISALPHA(c) (ISLOWER(c) || ISUPPER(c)) +#define ISDIGIT(c) ((c >= '0') && (c <= '9')) +#define ISATF(c) (((c >= 'a')&&(c <= 'f')) || ((c >= 'A')&&(c <= 'F'))) +#define ISXDIGIT(c) (ISDIGIT(c) || ISATF(c)) +#define ISOCTAL(c) ((c >= '0') && (c < '8')) +#define ISALNUM(c) (ISALPHA(c) || (ISDIGIT(c)) +FILE *fopen(); + +#include "dcalc.h" +/* #include "ehead.h" */ +#include <math.h> +/* int strlen(), strcmp(); */ +int system(); + +/* space for working precision numbers */ +static double vs[22]; + +/* the symbol table of temporary variables: */ + +#define NTEMP 4 +struct varent temp[NTEMP] = { +{"T", OPR | TEMP, &vs[14]}, +{"T", OPR | TEMP, &vs[15]}, +{"T", OPR | TEMP, &vs[16]}, +{"\0", OPR | TEMP, &vs[17]} +}; + +/* the symbol table of operators */ +/* EOL is interpreted on null, newline, or ; */ +struct symbol oprtbl[] = { +{"BOL", OPR | BOL, 0}, +{"EOL", OPR | EOL, 0}, +{"-", OPR | UMINUS, 8}, +/*"~", OPR | COMP, 8,*/ +{",", OPR | EOE, 1}, +{"=", OPR | EQU, 2}, +/*"|", OPR | LOR, 3,*/ +/*"^", OPR | LXOR, 4,*/ +/*"&", OPR | LAND, 5,*/ +{"+", OPR | PLUS, 6}, +{"-", OPR | MINUS, 6}, +{"*", OPR | MULT, 7}, +{"/", OPR | DIV, 7}, +/*"%", OPR | MOD, 7,*/ +{"(", OPR | LPAREN, 11}, +{")", OPR | RPAREN, 11}, +{"\0", ILLEG, 0} +}; + +#define NOPR 8 + +/* the symbol table of indirect variables: */ +extern double PI; +struct varent indtbl[] = { +{"t", VAR | IND, &vs[21]}, +{"u", VAR | IND, &vs[20]}, +{"v", VAR | IND, &vs[19]}, +{"w", VAR | IND, &vs[18]}, +{"x", VAR | IND, &vs[10]}, +{"y", VAR | IND, &vs[11]}, +{"z", VAR | IND, &vs[12]}, +{"pi", VAR | IND, &PI}, +{"\0", ILLEG, 0} +}; + +/* the symbol table of constants: */ + +#define NCONST 10 +struct varent contbl[NCONST] = { +{"C",CONST,&vs[0]}, +{"C",CONST,&vs[1]}, +{"C",CONST,&vs[2]}, +{"C",CONST,&vs[3]}, +{"C",CONST,&vs[4]}, +{"C",CONST,&vs[5]}, +{"C",CONST,&vs[6]}, +{"C",CONST,&vs[7]}, +{"C",CONST,&vs[8]}, +{"\0",CONST,&vs[9]} +}; + +/* the symbol table of string variables: */ + +static char strngs[160] = {0}; + +#define NSTRNG 5 +struct strent strtbl[NSTRNG] = { +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{0, VAR | STRING, 0}, +{"\0",ILLEG,0}, +}; + + +/* Help messages */ +#if INTHELP +static char *intmsg[] = { +"?", +"Unkown symbol", +"Expression ends in illegal operator", +"Precede ( by operator", +")( is illegal", +"Unmatched )", +"Missing )", +"Illegal left hand side", +"Missing symbol", +"Must assign to a variable", +"Divide by zero", +"Missing symbol", +"Missing operator", +"Precede quantity by operator", +"Quantity preceded by )", +"Function syntax", +"Too many function args", +"No more temps", +"Arg list" +}; +#endif + +#ifdef ANSIPROT +double floor ( double ); +int dprec ( void ); +#else +double floor(); +int dprec(); +#endif +/* the symbol table of functions: */ +#if SALONE +#ifdef ANSIPROT +extern double floor ( double ); +extern double log ( double ); +extern double pow ( double, double ); +extern double sqrt ( double ); +extern double tanh ( double ); +extern double exp ( double ); +extern double fabs ( double ); +extern double hypot ( double, double ); +extern double frexp ( double, int * ); +extern double ldexp ( double, int ); +extern double incbet ( double, double, double ); +extern double incbi ( double, double, double ); +extern double sin ( double ); +extern double cos ( double ); +extern double atan ( double ); +extern double atan2 ( double, double ); +extern double gamma ( double ); +extern double lgam ( double ); +double zfrexp ( double ); +double zldexp ( double, double ); +double makenan ( double ); +double makeinfinity ( double ); +double hex ( double ); +double hexinput ( double, double ); +double cmdh ( void ); +double cmdhlp ( void ); +double init ( void ); +double cmddm ( void ); +double cmdtm ( void ); +double cmdem ( double ); +double take ( char * ); +double mxit ( void ); +double bits ( double ); +double csys ( char * ); +double cmddig ( double ); +double prhlst ( void * ); +double abmac ( void ); +double ifrac ( double ); +double xcmpl ( double, double ); +void exit ( int ); +#else +void exit(); +double hex(), hexinput(), cmdh(), cmdhlp(), init(); +double cmddm(), cmdtm(), cmdem(); +double take(), mxit(), bits(), csys(); +double cmddig(), prhlst(), abmac(); +double ifrac(), xcmpl(); +double floor(), log(), pow(), sqrt(), tanh(), exp(), fabs(), hypot(); +double frexp(), zfrexp(), ldexp(), zldexp(), makenan(), makeinfinity(); +double incbet(), incbi(), sin(), cos(), atan(), atan2(), gamma(), lgam(); +#define GLIBC2 0 +#if GLIBC2 +double lgamma(); +#endif +#endif /* not ANSIPROT */ +struct funent funtbl[] = { +{"h", OPR | FUNC, cmdh}, +{"help", OPR | FUNC, cmdhlp}, +{"hex", OPR | FUNC, hex}, +{"hexinput", OPR | FUNC, hexinput}, +/*"view", OPR | FUNC, view,*/ +{"exp", OPR | FUNC, exp}, +{"floor", OPR | FUNC, floor}, +{"log", OPR | FUNC, log}, +{"pow", OPR | FUNC, pow}, +{"sqrt", OPR | FUNC, sqrt}, +{"tanh", OPR | FUNC, tanh}, +{"sin", OPR | FUNC, sin}, +{"cos", OPR | FUNC, cos}, +{"atan", OPR | FUNC, atan}, +{"atantwo", OPR | FUNC, atan2}, +{"tanh", OPR | FUNC, tanh}, +{"gamma", OPR | FUNC, gamma}, +#if GLIBC2 +{"lgamma", OPR | FUNC, lgamma}, +#else +{"lgam", OPR | FUNC, lgam}, +#endif +{"incbet", OPR | FUNC, incbet}, +{"incbi", OPR | FUNC, incbi}, +{"fabs", OPR | FUNC, fabs}, +{"hypot", OPR | FUNC, hypot}, +{"ldexp", OPR | FUNC, zldexp}, +{"frexp", OPR | FUNC, zfrexp}, +{"nan", OPR | FUNC, makenan}, +{"infinity", OPR | FUNC, makeinfinity}, +{"ifrac", OPR | FUNC, ifrac}, +{"cmp", OPR | FUNC, xcmpl}, +{"bits", OPR | FUNC, bits}, +{"digits", OPR | FUNC, cmddig}, +{"dm", OPR | FUNC, cmddm}, +{"tm", OPR | FUNC, cmdtm}, +{"em", OPR | FUNC, cmdem}, +{"take", OPR | FUNC | COMMAN, take}, +{"system", OPR | FUNC | COMMAN, csys}, +{"exit", OPR | FUNC, mxit}, +/* +"remain", OPR | FUNC, eremain, +*/ +{"\0", OPR | FUNC, 0} +}; + +/* the symbol table of key words */ +struct funent keytbl[] = { +{"\0", ILLEG, 0} +}; +#endif + +void zgets(); + +/* Number of decimals to display */ +#define DEFDIS 70 +static int ndigits = DEFDIS; + +/* Menu stack */ +struct funent *menstk[5] = {&funtbl[0], NULL, NULL, NULL, NULL}; +int menptr = 0; + +/* Take file stack */ +FILE *takstk[10] = {0}; +int takptr = -1; + +/* size of the expression scan list: */ +#define NSCAN 20 + +/* previous token, saved for syntax checking: */ +struct symbol *lastok = 0; + +/* variables used by parser: */ +static char str[128] = {0}; +int uposs = 0; /* possible unary operator */ +static double qnc; +char lc[40] = { '\n' }; /* ASCII string of token symbol */ +static char line[LINLEN] = { '\n','\0' }; /* input command line */ +static char maclin[LINLEN] = { '\n','\0' }; /* macro command */ +char *interl = line; /* pointer into line */ +extern char *interl; +static int maccnt = 0; /* number of times to execute macro command */ +static int comptr = 0; /* comma stack pointer */ +static double comstk[5]; /* comma argument stack */ +static int narptr = 0; /* pointer to number of args */ +static int narstk[5] = {0}; /* stack of number of function args */ + +/* main() */ + +/* Entire program starts here */ + +int main() +{ + +/* the scan table: */ + +/* array of pointers to symbols which have been parsed: */ +struct symbol *ascsym[NSCAN]; + +/* current place in ascsym: */ +register struct symbol **as; + +/* array of attributes of operators parsed: */ +int ascopr[NSCAN]; + +/* current place in ascopr: */ +register int *ao; + +#if LARGEMEM +/* array of precedence levels of operators: */ +long asclev[NSCAN]; +/* current place in asclev: */ +long *al; +long symval; /* value of symbol just parsed */ +#else +int asclev[NSCAN]; +int *al; +int symval; +#endif + +double acc; /* the accumulator, for arithmetic */ +int accflg; /* flags accumulator in use */ +double val; /* value to be combined into accumulator */ +register struct symbol *psym; /* pointer to symbol just parsed */ +struct varent *pvar; /* pointer to an indirect variable symbol */ +struct funent *pfun; /* pointer to a function symbol */ +struct strent *pstr; /* pointer to a string symbol */ +int att; /* attributes of symbol just parsed */ +int i; /* counter */ +int offset; /* parenthesis level */ +int lhsflg; /* kluge to detect illegal assignments */ +struct symbol *parser(); /* parser returns pointer to symbol */ +int errcod; /* for syntax error printout */ + + +/* Perform general initialization */ + +init(); + +menstk[0] = &funtbl[0]; +menptr = 0; +cmdhlp(); /* print out list of symbols */ + + +/* Return here to get next command line to execute */ +getcmd: + +/* initialize registers and mutable symbols */ + +accflg = 0; /* Accumulator not in use */ +acc = 0.0; /* Clear the accumulator */ +offset = 0; /* Parenthesis level zero */ +comptr = 0; /* Start of comma stack */ +narptr = -1; /* Start of function arg counter stack */ + +psym = (struct symbol *)&contbl[0]; +for( i=0; i<NCONST; i++ ) + { + psym->attrib = CONST; /* clearing the busy bit */ + ++psym; + } +psym = (struct symbol *)&temp[0]; +for( i=0; i<NTEMP; i++ ) + { + psym->attrib = VAR | TEMP; /* clearing the busy bit */ + ++psym; + } + +pstr = &strtbl[0]; +for( i=0; i<NSTRNG; i++ ) + { + pstr->spel = &strngs[ 40*i ]; + pstr->attrib = STRING | VAR; + pstr->string = &strngs[ 40*i ]; + ++pstr; + } + +/* List of scanned symbols is empty: */ +as = &ascsym[0]; +*as = 0; +--as; +/* First item in scan list is Beginning of Line operator */ +ao = &ascopr[0]; +*ao = oprtbl[0].attrib & 0xf; /* BOL */ +/* value of first item: */ +al = &asclev[0]; +*al = oprtbl[0].sym; + +lhsflg = 0; /* illegal left hand side flag */ +psym = &oprtbl[0]; /* pointer to current token */ + +/* get next token from input string */ + +gettok: +lastok = psym; /* last token = current token */ +psym = parser(); /* get a new current token */ +/*printf( "%s attrib %7o value %7o\n", psym->spel, psym->attrib & 0xffff, + psym->sym );*/ + +/* Examine attributes of the symbol returned by the parser */ +att = psym->attrib; +if( att == ILLEG ) + { + errcod = 1; + goto synerr; + } + +/* Push functions onto scan list without analyzing further */ +if( att & FUNC ) + { + /* A command is a function whose argument is + * a pointer to the rest of the input line. + * A second argument is also passed: the address + * of the last token parsed. + */ + if( att & COMMAN ) + { + pfun = (struct funent *)psym; + ( *(pfun->fun))( interl, lastok ); + abmac(); /* scrub the input line */ + goto getcmd; /* and ask for more input */ + } + ++narptr; /* offset to number of args */ + narstk[narptr] = 0; + i = lastok->attrib & 0xffff; /* attrib=short, i=int */ + if( ((i & OPR) == 0) + || (i == (OPR | RPAREN)) + || (i == (OPR | FUNC)) ) + { + errcod = 15; + goto synerr; + } + + ++lhsflg; + ++as; + *as = psym; + ++ao; + *ao = FUNC; + ++al; + *al = offset + UMINUS; + goto gettok; + } + +/* deal with operators */ +if( att & OPR ) + { + att &= 0xf; + /* expression cannot end with an operator other than + * (, ), BOL, or a function + */ + if( (att == RPAREN) || (att == EOL) || (att == EOE)) + { + i = lastok->attrib & 0xffff; /* attrib=short, i=int */ + if( (i & OPR) + && (i != (OPR | RPAREN)) + && (i != (OPR | LPAREN)) + && (i != (OPR | FUNC)) + && (i != (OPR | BOL)) ) + { + errcod = 2; + goto synerr; + } + } + ++lhsflg; /* any operator but ( and = is not a legal lhs */ + +/* operator processing, continued */ + + switch( att ) + { + case EOE: + lhsflg = 0; + break; + case LPAREN: + /* ( must be preceded by an operator of some sort. */ + if( ((lastok->attrib & OPR) == 0) ) + { + errcod = 3; + goto synerr; + } + /* also, a preceding ) is illegal */ + if( (unsigned short )lastok->attrib == (OPR|RPAREN)) + { + errcod = 4; + goto synerr; + } + /* Begin looking for illegal left hand sides: */ + lhsflg = 0; + offset += RPAREN; /* new parenthesis level */ + goto gettok; + case RPAREN: + offset -= RPAREN; /* parenthesis level */ + if( offset < 0 ) + { + errcod = 5; /* parenthesis error */ + goto synerr; + } + goto gettok; + case EOL: + if( offset != 0 ) + { + errcod = 6; /* parenthesis error */ + goto synerr; + } + break; + case EQU: + if( --lhsflg ) /* was incremented before switch{} */ + { + errcod = 7; + goto synerr; + } + case UMINUS: + case COMP: + goto pshopr; /* evaluate right to left */ + default: ; + } + + +/* evaluate expression whenever precedence is not increasing */ + +symval = psym->sym + offset; + +while( symval <= *al ) + { + /* if just starting, must fill accumulator with last + * thing on the line + */ + if( (accflg == 0) && (as >= ascsym) && (((*as)->attrib & FUNC) == 0 )) + { + pvar = (struct varent *)*as; +/* + if( pvar->attrib & STRING ) + strcpy( (char *)&acc, (char *)pvar->value ); + else +*/ + acc = *pvar->value; + --as; + accflg = 1; + } + +/* handle beginning of line type cases, where the symbol + * list ascsym[] may be empty. + */ + switch( *ao ) + { + case BOL: + printf( "%.16e\n", acc ); +#if 0 +#if NE == 6 + e64toasc( &acc, str, 100 ); +#else + e113toasc( &acc, str, 100 ); +#endif +#endif + printf( "%s\n", str ); + goto getcmd; /* all finished */ + case UMINUS: + acc = -acc; + goto nochg; +/* + case COMP: + acc = ~acc; + goto nochg; +*/ + default: ; + } +/* Now it is illegal for symbol list to be empty, + * because we are going to need a symbol below. + */ + if( as < &ascsym[0] ) + { + errcod = 8; + goto synerr; + } +/* get attributes and value of current symbol */ + att = (*as)->attrib; + pvar = (struct varent *)*as; + if( att & FUNC ) + val = 0.0; + else + { +/* + if( att & STRING ) + strcpy( (char *)&val, (char *)pvar->value ); + else +*/ + val = *pvar->value; + } + +/* Expression evaluation, continued. */ + + switch( *ao ) + { + case FUNC: + pfun = (struct funent *)*as; + /* Call the function with appropriate number of args */ + i = narstk[ narptr ]; + --narptr; + switch(i) + { + case 0: + acc = ( *(pfun->fun) )(acc); + break; + case 1: + acc = ( *(pfun->fun) )(acc, comstk[comptr-1]); + break; + case 2: + acc = ( *(pfun->fun) )(acc, comstk[comptr-2], + comstk[comptr-1]); + break; + case 3: + acc = ( *(pfun->fun) )(acc, comstk[comptr-3], + comstk[comptr-2], comstk[comptr-1]); + break; + default: + errcod = 16; + goto synerr; + } + comptr -= i; + accflg = 1; /* in case at end of line */ + break; + case EQU: + if( ( att & TEMP) || ((att & VAR) == 0) || (att & STRING) ) + { + errcod = 9; + goto synerr; /* can only assign to a variable */ + } + pvar = (struct varent *)*as; + *pvar->value = acc; + break; + case PLUS: + acc = acc + val; break; + case MINUS: + acc = val - acc; break; + case MULT: + acc = acc * val; break; + case DIV: + if( acc == 0.0 ) + { +/* +divzer: +*/ + errcod = 10; + goto synerr; + } + acc = val / acc; break; +/* + case MOD: + if( acc == 0 ) + goto divzer; + acc = val % acc; break; + case LOR: + acc |= val; break; + case LXOR: + acc ^= val; break; + case LAND: + acc &= val; break; +*/ + case EOE: + if( narptr < 0 ) + { + errcod = 18; + goto synerr; + } + narstk[narptr] += 1; + comstk[comptr++] = acc; +/* printf( "\ncomptr: %d narptr: %d %d\n", comptr, narptr, acc );*/ + acc = val; + break; + } + + +/* expression evaluation, continued */ + +/* Pop evaluated tokens from scan list: */ + /* make temporary variable not busy */ + if( att & TEMP ) + (*as)->attrib &= ~BUSY; + if( as < &ascsym[0] ) /* can this happen? */ + { + errcod = 11; + goto synerr; + } + --as; +nochg: + --ao; + --al; + if( ao < &ascopr[0] ) /* can this happen? */ + { + errcod = 12; + goto synerr; + } +/* If precedence level will now increase, then */ +/* save accumulator in a temporary location */ + if( symval > *al ) + { + /* find a free temp location */ + pvar = &temp[0]; + for( i=0; i<NTEMP; i++ ) + { + if( (pvar->attrib & BUSY) == 0) + goto temfnd; + ++pvar; + } + errcod = 17; + printf( "no more temps\n" ); + pvar = &temp[0]; + goto synerr; + + temfnd: + pvar->attrib |= BUSY; + *pvar->value = acc; + /*printf( "temp %d\n", acc );*/ + accflg = 0; + ++as; /* push the temp onto the scan list */ + *as = (struct symbol *)pvar; + } + } /* End of evaluation loop */ + + +/* Push operator onto scan list when precedence increases */ + +pshopr: + ++ao; + *ao = psym->attrib & 0xf; + ++al; + *al = psym->sym + offset; + goto gettok; + } /* end of OPR processing */ + + +/* Token was not an operator. Push symbol onto scan list. */ +if( (lastok->attrib & OPR) == 0 ) + { + errcod = 13; + goto synerr; /* quantities must be preceded by an operator */ + } +if( (unsigned short )lastok->attrib == (OPR | RPAREN) ) /* ...but not by ) */ + { + errcod = 14; + goto synerr; + } +++as; +*as = psym; +goto gettok; + +synerr: + +#if INTHELP +printf( "%s ", intmsg[errcod] ); +#endif +printf( " error %d\n", errcod ); +abmac(); /* flush the command line */ +goto getcmd; +} /* end of program */ + +/* parser() */ + +/* Get token from input string and identify it. */ + + +static char number[128]; + +struct symbol *parser( ) +{ +register struct symbol *psym; +register char *pline; +struct varent *pvar; +struct strent *pstr; +char *cp, *plc, *pn; +long lnc; +int i; +double tem; + +/* reference for old Whitesmiths compiler: */ +/* + *extern FILE *stdout; + */ + +pline = interl; /* get current location in command string */ + + +/* If at beginning of string, must ask for more input */ +if( pline == line ) + { + + if( maccnt > 0 ) + { + --maccnt; + cp = maclin; + plc = pline; + while( (*plc++ = *cp++) != 0 ) + ; + goto mstart; + } + if( takptr < 0 ) + { /* no take file active: prompt keyboard input */ + printf("* "); + } +/* Various ways of typing in a command line. */ + +/* + * Old Whitesmiths call to print "*" immediately + * use RT11 .GTLIN to get command string + * from command file or terminal + */ + +/* + * fflush(stdout); + * gtlin(line); + */ + + + zgets( line, TRUE ); /* keyboard input for other systems: */ + + +mstart: + uposs = 1; /* unary operators possible at start of line */ + } + +ignore: +/* Skip over spaces */ +while( *pline == ' ' ) + ++pline; + +/* unary minus after operator */ +if( uposs && (*pline == '-') ) + { + psym = &oprtbl[2]; /* UMINUS */ + ++pline; + goto pdon3; + } + /* COMP */ +/* +if( uposs && (*pline == '~') ) + { + psym = &oprtbl[3]; + ++pline; + goto pdon3; + } +*/ +if( uposs && (*pline == '+') ) /* ignore leading plus sign */ + { + ++pline; + goto ignore; + } + +/* end of null terminated input */ +if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) + { + pline = line; + goto endlin; + } +if( *pline == ';' ) + { + ++pline; +endlin: + psym = &oprtbl[1]; /* EOL */ + goto pdon2; + } + + +/* parser() */ + + +/* Test for numeric input */ +if( (ISDIGIT(*pline)) || (*pline == '.') ) + { + lnc = 0; /* initialize numeric input to zero */ + qnc = 0.0; + if( *pline == '0' ) + { /* leading "0" may mean octal or hex radix */ + ++pline; + if( *pline == '.' ) + goto decimal; /* 0.ddd */ + /* leading "0x" means hexadecimal radix */ + if( (*pline == 'x') || (*pline == 'X') ) + { + ++pline; + while( ISXDIGIT(*pline) ) + { + i = *pline++ & 0xff; + if( i >= 'a' ) + i -= 047; + if( i >= 'A' ) + i -= 07; + i -= 060; + lnc = (lnc << 4) + i; + qnc = lnc; + } + goto numdon; + } + else + { + while( ISOCTAL( *pline ) ) + { + i = ((*pline++) & 0xff) - 060; + lnc = (lnc << 3) + i; + qnc = lnc; + } + goto numdon; + } + } + else + { + /* no leading "0" means decimal radix */ +/******/ +decimal: + pn = number; + while( (ISDIGIT(*pline)) || (*pline == '.') ) + *pn++ = *pline++; +/* get possible exponent field */ + if( (*pline == 'e') || (*pline == 'E') ) + *pn++ = *pline++; + else + goto numcvt; + if( (*pline == '-') || (*pline == '+') ) + *pn++ = *pline++; + while( ISDIGIT(*pline) ) + *pn++ = *pline++; +numcvt: + *pn++ = ' '; + *pn++ = 0; +#if 0 +#if NE == 6 + asctoe64( number, &qnc ); +#else + asctoe113( number, &qnc ); +#endif +#endif + sscanf( number, "%le", &qnc ); + } +/* output the number */ +numdon: + /* search the symbol table of constants */ + pvar = &contbl[0]; + for( i=0; i<NCONST; i++ ) + { + if( (pvar->attrib & BUSY) == 0 ) + goto confnd; + tem = *pvar->value; + if( tem == qnc ) + { + psym = (struct symbol *)pvar; + goto pdon2; + } + ++pvar; + } + printf( "no room for constant\n" ); + psym = (struct symbol *)&contbl[0]; + goto pdon2; + +confnd: + pvar->spel= contbl[0].spel; + pvar->attrib = CONST | BUSY; + *pvar->value = qnc; + psym = (struct symbol *)pvar; + goto pdon2; + } + +/* check for operators */ +psym = &oprtbl[3]; +for( i=0; i<NOPR; i++ ) + { + if( *pline == *(psym->spel) ) + goto pdon1; + ++psym; + } + +/* if quoted, it is a string variable */ +if( *pline == '"' ) + { + /* find an empty slot for the string */ + pstr = strtbl; /* string table */ + for( i=0; i<NSTRNG-1; i++ ) + { + if( (pstr->attrib & BUSY) == 0 ) + goto fndstr; + ++pstr; + } + printf( "No room for string\n" ); + pstr->attrib |= ILLEG; + psym = (struct symbol *)pstr; + goto pdon0; + +fndstr: + pstr->attrib |= BUSY; + plc = pstr->string; + ++pline; + for( i=0; i<39; i++ ) + { + *plc++ = *pline; + if( (*pline == '\n') || (*pline == '\0') || (*pline == '\r') ) + { +illstr: + pstr = &strtbl[NSTRNG-1]; + pstr->attrib |= ILLEG; + printf( "Missing string terminator\n" ); + psym = (struct symbol *)pstr; + goto pdon0; + } + if( *pline++ == '"' ) + goto finstr; + } + + goto illstr; /* no terminator found */ + +finstr: + --plc; + *plc = '\0'; + psym = (struct symbol *)pstr; + goto pdon2; + } +/* If none of the above, search function and symbol tables: */ + +/* copy character string to array lc[] */ +plc = &lc[0]; +while( ISALPHA(*pline) ) + { + /* convert to lower case characters */ + if( ISUPPER( *pline ) ) + *pline += 040; + *plc++ = *pline++; + } +*plc = 0; /* Null terminate the output string */ + +/* parser() */ + +psym = (struct symbol *)menstk[menptr]; /* function table */ +plc = &lc[0]; +cp = psym->spel; +do + { + if( strcmp( plc, cp ) == 0 ) + goto pdon3; /* following unary minus is possible */ + ++psym; + cp = psym->spel; + } +while( *cp != '\0' ); + +psym = (struct symbol *)&indtbl[0]; /* indirect symbol table */ +plc = &lc[0]; +cp = psym->spel; +do + { + if( strcmp( plc, cp ) == 0 ) + goto pdon2; + ++psym; + cp = psym->spel; + } +while( *cp != '\0' ); + +pdon0: +pline = line; /* scrub line if illegal symbol */ +goto pdon2; + +pdon1: +++pline; +if( (psym->attrib & 0xf) == RPAREN ) +pdon2: uposs = 0; +else +pdon3: uposs = 1; + +interl = pline; +return( psym ); +} /* end of parser */ + +/* exit from current menu */ + +double cmdex() +{ + +if( menptr == 0 ) + { + printf( "Main menu is active.\n" ); + } +else + --menptr; + +cmdh(); +return(0.0); +} + + +/* gets() */ + +void zgets( gline, echo ) +char *gline; +int echo; +{ +register char *pline; +register int i; + + +scrub: +pline = gline; +getsl: + if( (pline - gline) >= LINLEN ) + { + printf( "\nLine too long\n *" ); + goto scrub; + } + if( takptr < 0 ) + { /* get character from keyboard */ +/* +if DECPDP + gtlin( gline ); + return(0); +else +*/ + *pline = getchar(); +/*endif*/ + } + else + { /* get a character from take file */ + i = fgetc( takstk[takptr] ); + if( i == -1 ) + { /* end of take file */ + if( takptr >= 0 ) + { /* close file and bump take stack */ + fclose( takstk[takptr] ); + takptr -= 1; + } + if( takptr < 0 ) /* no more take files: */ + printf( "*" ); /* prompt keyboard input */ + goto scrub; /* start a new input line */ + } + *pline = i; + } + + *pline &= 0x7f; + /* xon or xoff characters need filtering out. */ + if ( *pline == XON || *pline == XOFF ) + goto getsl; + + /* control U or control C */ + if( (*pline == 025) || (*pline == 03) ) + { + printf( "\n" ); + goto scrub; + } + + /* Backspace or rubout */ + if( (*pline == 010) || (*pline == 0177) ) + { + pline -= 1; + if( pline >= gline ) + { + if ( echo ) + printf( "\010\040\010" ); + goto getsl; + } + else + goto scrub; + } + if ( echo ) + printf( "%c", *pline ); + if( (*pline != '\n') && (*pline != '\r') ) + { + ++pline; + goto getsl; + } + *pline = 0; + if ( echo ) + printf( "%c", '\n' ); /* \r already echoed */ +} + + +/* help function */ +double cmdhlp() +{ + +printf( "%s", idterp ); +printf( "\nFunctions:\n" ); +prhlst( &funtbl[0] ); +printf( "\nVariables:\n" ); +prhlst( &indtbl[0] ); +printf( "\nOperators:\n" ); +prhlst( &oprtbl[2] ); +printf("\n"); +return(0.0); +} + + +double cmdh() +{ + +prhlst( menstk[menptr] ); +printf( "\n" ); +return(0.0); +} + +/* print keyword spellings */ + +double prhlst(vps) +void *vps; +{ +register int j, k; +int m; +register struct symbol *ps = vps; + +j = 0; +while( *(ps->spel) != '\0' ) + { + k = strlen( ps->spel ) - 1; +/* size of a tab field is 2**3 chars */ + m = ((k >> 3) + 1) << 3; + j += m; + if( j > 72 ) + { + printf( "\n" ); + j = m; + } + printf( "%s\t", ps->spel ); + ++ps; + } +return(0.0); +} + + +#if SALONE +double init() +{ +/* Set coprocessor to double precision. */ +dprec(); +return 0.0; +} +#endif + + +/* macro commands */ + +/* define macro */ +double cmddm() +{ + +zgets( maclin, TRUE ); +return(0.0); +} + +/* type (i.e., display) macro */ +double cmdtm() +{ + +printf( "%s\n", maclin ); +return 0.0; +} + +/* execute macro # times */ +double cmdem( arg ) +double arg; +{ +double f; +long n; + +f = floor(arg); +n = f; +if( n <= 0 ) + n = 1; +maccnt = n; +return(0.0); +} + + +/* open a take file */ + +double take( fname ) +char *fname; +{ +FILE *f; + +while( *fname == ' ' ) + fname += 1; +f = fopen( fname, "r" ); + +if( f == 0 ) + { + printf( "Can't open take file %s\n", fname ); + takptr = -1; /* terminate all take file input */ + return 0.0; + } +takptr += 1; +takstk[ takptr ] = f; +printf( "Running %s\n", fname ); +return(0.0); +} + + +/* abort macro execution */ +double abmac() +{ + +maccnt = 0; +interl = line; +return(0.0); +} + + +/* display integer part in hex, octal, and decimal + */ +double hex(qx) +double qx; +{ +double f; +long z; + +f = floor(qx); +z = f; +printf( "0%lo 0x%lx %ld.\n", z, z, z ); +return(qx); +} + +#define NASC 16 + +double bits( x ) +double x; +{ +union + { + double d; + short i[4]; + } du; +union + { + float f; + short i[2]; + } df; +int i; + +du.d = x; +printf( "double: " ); +for( i=0; i<4; i++ ) + printf( "0x%04x,", du.i[i] & 0xffff ); +printf( "\n" ); + +df.f = (float) x; +printf( "float: " ); +for( i=0; i<2; i++ ) + printf( "0x%04x,", df.i[i] & 0xffff ); +printf( "\n" ); +return(x); +} + + +/* Exit to monitor. */ +double mxit() +{ + +exit(0); +return(0.0); +} + + +double cmddig( x ) +double x; +{ +double f; +long lx; + +f = floor(x); +lx = f; +ndigits = lx; +if( ndigits <= 0 ) + ndigits = DEFDIS; +return(f); +} + + +double csys(x) +char *x; +{ + +system( x+1 ); +cmdh(); +return(0.0); +} + + +double ifrac(x) +double x; +{ +unsigned long lx; +long double y, z; + +z = floor(x); +lx = z; +y = x - z; +printf( " int = %lx\n", lx ); +return(y); +} + +double xcmpl(x,y) +double x,y; +{ +double ans; + +ans = -2.0; +if( x == y ) + { + printf( "x == y " ); + ans = 0.0; + } +if( x < y ) + { + printf( "x < y" ); + ans = -1.0; + } +if( x > y ) + { + printf( "x > y" ); + ans = 1.0; + } +return( ans ); +} + +extern double INFINITY, NAN; + +double makenan(x) +double x; +{ +return(NAN); +} + +double makeinfinity(x) +double x; +{ +return(INFINITY); +} + +double zfrexp(x) +double x; +{ +double y; +int e; +y = frexp(x, &e); +printf("exponent = %d, significand = ", e ); +return(y); +} + +double zldexp(x,e) +double x, e; +{ +double y; +int i; + +i = e; +y = ldexp(x,i); +return(y); +} + +double hexinput(a, b) +double a,b; +{ +union + { + double d; + unsigned short i[4]; + } u; +unsigned long l; + +#ifdef IBMPC +l = a; +u.i[3] = l >> 16; +u.i[2] = l; +l = b; +u.i[1] = l >> 16; +u.i[0] = l; +#endif +#ifdef DEC +l = a; +u.i[3] = l >> 16; +u.i[2] = l; +l = b; +u.i[1] = l >> 16; +u.i[0] = l; +#endif +#ifdef MIEEE +l = a; +u.i[0] = l >> 16; +u.i[1] = l; +l = b; +u.i[2] = l >> 16; +u.i[3] = l; +#endif +#ifdef UNK +l = a; +u.i[0] = l >> 16; +u.i[1] = l; +l = b; +u.i[2] = l >> 16; +u.i[3] = l; +#endif +return(u.d); +} |