summaryrefslogtreecommitdiff
path: root/libm/ldouble/lcalc.c
diff options
context:
space:
mode:
Diffstat (limited to 'libm/ldouble/lcalc.c')
-rw-r--r--libm/ldouble/lcalc.c1484
1 files changed, 1484 insertions, 0 deletions
diff --git a/libm/ldouble/lcalc.c b/libm/ldouble/lcalc.c
new file mode 100644
index 000000000..87250952f
--- /dev/null
+++ b/libm/ldouble/lcalc.c
@@ -0,0 +1,1484 @@
+/* calc.c */
+/* Keyboard command interpreter */
+/* by Stephen L. Moshier */
+
+/* Include functions for IEEE special values */
+#define NANS 1
+
+/* 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 "lcalc.h"
+#include "ehead.h"
+
+/* space for working precision numbers */
+static long 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 long double PIL;
+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, &PIL},
+{"\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
+
+/* the symbol table of functions: */
+#if SALONE
+long double hex(), cmdh(), cmdhlp();
+long double cmddm(), cmdtm(), cmdem();
+long double take(), mxit(), exit(), bits(), csys();
+long double cmddig(), prhlst(), abmac();
+long double ifrac(), xcmpl();
+long double floorl(), logl(), powl(), sqrtl(), tanhl(), expl();
+long double ellpel(), ellpkl(), incbetl(), incbil();
+long double stdtrl(), stdtril(), zstdtrl(), zstdtril();
+long double sinl(), cosl(), tanl(), asinl(), acosl(), atanl(), atan2l();
+long double tanhl(), atanhl();
+#ifdef NANS
+int isnanl(), isfinitel(), signbitl();
+long double zisnan(), zisfinite(), zsignbit();
+#endif
+
+struct funent funtbl[] = {
+{"h", OPR | FUNC, cmdh},
+{"help", OPR | FUNC, cmdhlp},
+{"hex", OPR | FUNC, hex},
+/*"view", OPR | FUNC, view,*/
+{"exp", OPR | FUNC, expl},
+{"floor", OPR | FUNC, floorl},
+{"log", OPR | FUNC, logl},
+{"pow", OPR | FUNC, powl},
+{"sqrt", OPR | FUNC, sqrtl},
+{"tanh", OPR | FUNC, tanhl},
+{"sin", OPR | FUNC, sinl},
+{"cos", OPR | FUNC, cosl},
+{"tan", OPR | FUNC, tanl},
+{"asin", OPR | FUNC, asinl},
+{"acos", OPR | FUNC, acosl},
+{"atan", OPR | FUNC, atanl},
+{"atantwo", OPR | FUNC, atan2l},
+{"tanh", OPR | FUNC, tanhl},
+{"atanh", OPR | FUNC, atanhl},
+{"ellpe", OPR | FUNC, ellpel},
+{"ellpk", OPR | FUNC, ellpkl},
+{"incbet", OPR | FUNC, incbetl},
+{"incbi", OPR | FUNC, incbil},
+{"stdtr", OPR | FUNC, zstdtrl},
+{"stdtri", OPR | FUNC, zstdtril},
+{"ifrac", OPR | FUNC, ifrac},
+{"cmp", OPR | FUNC, xcmpl},
+#ifdef NANS
+{"isnan", OPR | FUNC, zisnan},
+{"isfinite", OPR | FUNC, zisfinite},
+{"signbit", OPR | FUNC, zsignbit},
+#endif
+{"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(), init();
+
+/* 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 long 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 long 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
+
+long double acc; /* the accumulator, for arithmetic */
+int accflg; /* flags accumulator in use */
+long 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.0L; /* 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", (double )acc ); */
+#if NE == 6
+ e64toasc( &acc, str, 100 );
+#else
+ e113toasc( &acc, str, 100 );
+#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.0L;
+ 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.0L )
+ {
+/*
+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;
+long 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.0L;
+ 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 NE == 6
+ asctoe64( number, &qnc );
+#else
+ asctoe113( number, &qnc );
+#endif
+/* sscanf( number, "%le", &nc ); */
+ }
+/* 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 */
+
+long double cmdex()
+{
+
+if( menptr == 0 )
+ {
+ printf( "Main menu is active.\n" );
+ }
+else
+ --menptr;
+
+cmdh();
+return(0.0L);
+}
+
+
+/* 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 */
+long 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.0L);
+}
+
+
+long double cmdh()
+{
+
+prhlst( menstk[menptr] );
+printf( "\n" );
+return(0.0L);
+}
+
+/* print keyword spellings */
+
+long double prhlst(ps)
+register struct symbol *ps;
+{
+register int j, k;
+int m;
+
+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.0L);
+}
+
+
+#if SALONE
+void init(){}
+#endif
+
+
+/* macro commands */
+
+/* define macro */
+long double cmddm()
+{
+
+zgets( maclin, TRUE );
+return(0.0L);
+}
+
+/* type (i.e., display) macro */
+long double cmdtm()
+{
+
+printf( "%s\n", maclin );
+return(0.0L);
+}
+
+/* execute macro # times */
+long double cmdem( arg )
+long double arg;
+{
+long double f;
+long n;
+long double floorl();
+
+f = floorl(arg);
+n = f;
+if( n <= 0 )
+ n = 1;
+maccnt = n;
+return(0.0L);
+}
+
+
+/* open a take file */
+
+long 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.0L);
+ }
+takptr += 1;
+takstk[ takptr ] = f;
+printf( "Running %s\n", fname );
+return(0.0L);
+}
+
+
+/* abort macro execution */
+long double abmac()
+{
+
+maccnt = 0;
+interl = line;
+return(0.0L);
+}
+
+
+/* display integer part in hex, octal, and decimal
+ */
+long double hex(qx)
+long double qx;
+{
+long double f;
+long z;
+long double floorl();
+
+f = floorl(qx);
+z = f;
+printf( "0%lo 0x%lx %ld.\n", z, z, z );
+return(qx);
+}
+
+#define NASC 16
+
+long double bits( x )
+long double x;
+{
+int i, j;
+unsigned short dd[4], ee[10];
+char strx[40];
+unsigned short *p;
+
+p = (unsigned short *) &x;
+for( i=0; i<NE; i++ )
+ ee[i] = *p++;
+
+j = 0;
+for( i=0; i<NE; i++ )
+ {
+ printf( "0x%04x,", ee[i] & 0xffff );
+ if( ++j > 7 )
+ {
+ j = 0;
+ printf( "\n" );
+ }
+ }
+printf( "\n" );
+
+/* double conversions
+ */
+*((double *)dd) = x;
+printf( "double: " );
+for( i=0; i<4; i++ )
+ printf( "0x%04x,", dd[i] & 0xffff );
+printf( "\n" );
+
+#if 1
+printf( "double -> long double: " );
+*(long double *)ee = *(double *)dd;
+for( i=0; i<6; i++ )
+ printf( "0x%04x,", ee[i] & 0xffff );
+printf( "\n" );
+e53toasc( dd, strx, NASC );
+printf( "e53toasc: %s\n", strx );
+printf( "Native printf: %.17e\n", *(double *)dd );
+
+/* float conversions
+ */
+*((float *)dd) = x;
+printf( "float: " );
+for( i=0; i<2; i++ )
+ printf( "0x%04x,", dd[i] & 0xffff );
+printf( "\n" );
+e24toe( dd, ee );
+printf( "e24toe: " );
+for( i=0; i<NE; i++ )
+ printf( "0x%04x,", ee[i] & 0xffff );
+printf( "\n" );
+e24toasc( dd, strx, NASC );
+printf( "e24toasc: %s\n", strx );
+/* printf( "Native printf: %.16e\n", (double) *(float *)dd ); */
+
+#ifdef DEC
+printf( "etodec: " );
+etodec( x, dd );
+for( i=0; i<4; i++ )
+ printf( "0x%04x,", dd[i] & 0xffff );
+printf( "\n" );
+printf( "dectoe: " );
+dectoe( dd, ee );
+for( i=0; i<NE; i++ )
+ printf( "0x%04x,", ee[i] & 0xffff );
+printf( "\n" );
+printf( "DEC printf: %.16e\n", *(double *)dd );
+#endif
+#endif /* 0 */
+return(x);
+}
+
+
+/* Exit to monitor. */
+long double mxit()
+{
+
+exit(0);
+return(0.0L);
+}
+
+
+long double cmddig( x )
+long double x;
+{
+long double f;
+long lx;
+
+f = floorl(x);
+lx = f;
+ndigits = lx;
+if( ndigits <= 0 )
+ ndigits = DEFDIS;
+return(f);
+}
+
+
+long double csys(x)
+char *x;
+{
+void system();
+
+system( x+1 );
+cmdh();
+return(0.0L);
+}
+
+
+long double ifrac(x)
+long double x;
+{
+unsigned long lx;
+long double y, z;
+
+z = floorl(x);
+lx = z;
+y = x - z;
+printf( " int = %lx\n", lx );
+return(y);
+}
+
+long double xcmpl(x,y)
+long double x,y;
+{
+long double ans;
+char str[40];
+
+#if NE == 6
+ e64toasc( &x, str, 100 );
+ printf( "x = %s\n", str );
+ e64toasc( &y, str, 100 );
+ printf( "y = %s\n", str );
+#else
+ e113toasc( &x, str, 100 );
+ printf( "x = %s\n", str );
+ e113toasc( &y, str, 100 );
+ printf( "y = %s\n", str );
+#endif
+
+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 );
+}
+
+long double zstdtrl(k,t)
+long double k, t;
+{
+int ki;
+long double y;
+ki = k;
+y = stdtrl(ki,t);
+return(y);
+}
+
+long double zstdtril(k,t)
+long double k, t;
+{
+int ki;
+long double y;
+ki = k;
+y = stdtril(ki,t);
+return(y);
+}
+
+#ifdef NANS
+long double zisnan(x)
+long double x;
+{
+ long double y;
+ int k;
+ k = isnanl(x);
+ y = k;
+ return(y);
+}
+long double zisfinite(x)
+long double x;
+{
+ long double y;
+ int k;
+ k = isfinitel(x);
+ y = k;
+ return(y);
+}
+long double zsignbit(x)
+long double x;
+{
+ long double y;
+ int k;
+ k = signbitl(x);
+ y = k;
+ return(y);
+}
+#endif