Sindbad~EG File Manager
/* Mathpert parser */
/* M. Beeson */
/*____________________________________________________________________*/
/* Parse an input string. Return (indirectly) a term as defined in terms.h.
Zero return value indicates no error */
/* If input does not parse, return an error number, and indirectly return
a pointer to the unparsed portion of the input string. This pointer
can be used to position the cursor, and the error number can be used
to get an error message. Neither of these things is handled in
this file. */
/*____________________________________________________________*/
/*
Original date 5.14.90
10.24.99 modified
2.4.00 modified funcname and function_term to ignore initial backslash
2.4.00 modified relop to accept TeX for LE, GE, NE.
2.4.00 modified term1 to accept TeX "\over"
2.4.00 modified greek to accept TeX "\beta", etc.
*/
#include <math.h>
#include <stdio.h>
#include <ctype.h>
#include <string.h>
#include <assert.h>
#include <stdlib.h>
#define PARSER_DLL
#include "export.h"
#include "terms.h"
#include "probtype.h"
#include "parser.h"
#include "userfunc.h"
#include "constant.h"
static term make_atom_from_string2( char *a);
static int parser_initialized;
static void parser_copy(term t, term *ans); /* copy a term */
static char decimalchar = '.';
static ncommas(char *x);
/* the following two function pointers are set by setup_parser
to point to actions in the calling program which are taken
when a new functor or new atom is encountered. */
static functor_action newfunctor;
static atom_action newatom;
static short strip_functor(char *buffer, int *len);
#define SUBSCRIPTABLE(x) ((x) == BESSELJ || (x)==BESSELY || (x)==BESSELI || (x) == BESSELK)
static term make_fake_bignum(char *x);
/* Each nonterminal of the grammar corresponds to a function working as
above, except that negative return value only means failure to parse
this nonterminal (not an actual error). Positive value means actual
error causing termination of effort to parse. 0 means success. */
/* Space allocation considerations. Terms have a head and args. The
head of a term is all that is allocated by the declaration term t.
Nonterminal functions can create terms this way and pass them to other
nonterminals as input. Space for arguments is created by make_term,
which uses malloc. Effects of make_term are undone by RELEASE.
Thus t= make_term(f,arity) allocates space pointed to by t.args,
and RELEASE(t) frees it. A call to make_term followed later by
a call to RELEASE in the same function leaves space unchanged.
However, sometimes the RELEASE call has to come in another
function.
Specifically, when a term t is declared and passed into a function which
returns an error, then we should theoretically free all the args which
have (recursively) been allocated between the call and its return.
This job is done by destroy_term, which recursively frees all the
args of a term, but leaves the head of the term untouched.
Destroy_term should thus be called only in the body of the function
where its argument is declared.
ARGREP copies terms from local space into the
space created by make_term. Hence no errors arise from having
nonterminals use declarations term t; and then using t to make terms that
are passed out of the function where t is declared.
*/
/* Global variables controlling the parser: */
static char *pminus; /* used in parser.c to point to - in a+ (-b) if user enters it */
/* but is never used by Mathpert as of 5.4.94 */
static int bignumflag; /* set and examined by bparse() to see if real or
fake bignums should be made */
static char function_letters[8] = "fFgGhH";
/* so f(x+y) is a function term but c(x+y) is c*(x+y) */
/* Mathpert makes this "fg" when doing limits so h(x+y) is h*(x+y) */
/* Search for "ambiguity" below to read more about this. */
/*__________________________________________________________________*/
/* The parser is a 'recursive descent' parser. The grammar is thus
without left-recursion. Here's the grammar:
lexpr --> lterm, lexpr1.
lexpr1 --> OR, lterm, lexpr1 | [].
lterm --> lfactor,lterm1.
lterm1 --> AND, lfactor,lterm1 | [].
lfactor --> NOT, blank_list, lfactor | rexpr.
rexpr --> expr, relop, expr | expr
relop --> GE, LE, < , > , ARROW, NE, SEQ
expr --> blank_list, term0, blank_list, expr1.
expr1 --> ( for example a + (-b) ; not implemented yet )
'+', blank_list, '(', blank_list, '-', blank_list, term, blank_list, ')',
blank_list, expr1.
expr1 --> '+', blank_list, term, expr1.
expr1 --> '->', blank_list, expr, expr1.
ineq --> expr, relop, expr.
expr1 --> '-', blank_list, term, expr1.
expr1 --> blank_list.
term0 --> '-', blank_list, pterm. ( term or minus a term )
term0 --> pterm.
pterm --> pfactor, term1.
term1 --> '*', blank_list, pfactor, term1.
term1 --> 'if', blank_list, interval.
term1 --> '/', blank_list, pfactor, term1.
term1 --> ':', blank_list, ptype.
term1 --> pfactor,term1. ( accepting unwritten '*' )
term1 --> blank_list.
pfactor --> primary, factor1.
ptype --> atomic_type (that means 'R', 'C', 'Z', 'N').
later more complex type formation rules can be added.
aterm --> '*', blank_list,afactor, aterm.
aterm --> '/', blank_list,afactor,term1.
aterm --> afactor,aterm.
aterm --> blank_list.
afactor --> aprimary, factor1.
(like term1 but won't take a product including a function name)
Since primary and aprimary differ only in one line, they are
coded together and an extra (first) parameter is passed, 0 for
primary and 1 for aprimary.
factor1 --> '^', blank_list, primary, blank_list, factor1.
factor1 --> '^', blank_list, '-', primary, blank_list,factor1.
factor1 --> '�', blank_list.
factor1 --> '!', blank_list. ( future postfix functions go here )
factor1 --> {'}*,blank_list. (as in u'')
factor1 --> blank_list.
primary --> number, blank_list.
primary --> '(', blank_list, lexpr, ')', blank_list.
primary --> '[', blank_list, lexpr, ']', blank_list.
primary --> '{', blank_list, lexpr, '}', blank_list.
( for vectors and matrices;
braces around one item are accepted as a grouping symbol)
primary --> '|', blank_list, lexpr, '|', blank_list. (for ABS)
primary --> function_term.
primary --> ident.
function_term --> funcname, after_funcname.
function_term --> funcname, {'}*, primary_tail. [ f''(x,y) for example]
aprimary is like primary but without the 'funcname' rule.
after_funcname --> �, primary_tail
| �, primary_tail
| ^, pfactor, primary_tail
| primary_tail
primary_tail(x) -->
in case unifunc(x) pfactor, aterm.
else
primary_tail(x) --> list of correct number of args separated by commas
and surrounded by matching parens or brackets (not braces)
And it only accepts an integer as the first arg of
ROOT or Bessel functions.
/*_____________________________________________________________*/
static int lexpr(term *expr,char *in,char **out);
static void blank_list(char *in, char **out);
static int lexpr1(term x, term *expr,char *in,char **out);
static int lterm(term *t, char *in, char **out);
static int lterm1(term x, term *expr,char *in,char **out);
static int lfactor(term *f, char *in, char **out);
static int rexpr(term *t, char *in, char **out);
static int relop(unsigned short *functorp, char *in, char **out);
static int expr(term *e, char *in, char **out);
static int expr1(term x, term *e, char *in, char **out);
static int term0( term *ans, char *in, char **out); /* either a term or minus a term */
static int pterm(term *t, char *in, char **out); /* changed from 'term' because
the compiler won't allow a function and a type to have the same name */
static int term1(term x, term *t, char *in, char **out);
static int pfactor(term *f, char *in, char **out);
static int factor1(term x, term *ans, char *in, char **out);
static int primary(int flag, term *p, char *in, char **out);
static int function_term(term *p, char *in, char **out);
static int after_funcname(unsigned short x, unsigned short arity, term *p, char *in, char **out);
static int primary_tail(unsigned short x, unsigned short arity,term *ans, char *in, char **out);
static int limit_tail(term *ans, char *in, char ** out);
static int aterm(term x, term *t, char *in, char **out);
static int afactor(term *f, char *in, char **out);
static int ident(term *ans,char *in, char **out);
static int greek(term *ans, char *in, char **out);
static int number(term *p, char *in, char **out);
static int funcname(unsigned short *f, char *in, char **out);
static int intervalterm(term expr, term *ans, char *in, char **out);
static int ptype(term *t, char *in, char **out);
static int integer(term *t, char *in, char **out);
/*___________________________________________________________________*/
static int complex, separator, unwritten_mult,
long_identifiers, letflag;
/*___________________________________________________________________*/
/* A program wishing to use the parser should first call setup_parser,
passing the values of certain control variables that will be used by
the parser. The parser uses heap.dll to create its terms, so the
program calling the parser should have already initialized the heap,
using create_heap (if multiple heaps are in use) or init_heap (for a
single heap). The space used by the heap belongs to the calling
program.
*/
/*___________________________________________________________________*/
static void setup_parser( parser_control * flags)
/* the control variables are packed into a structure of type parser_control,
which is passed by reference. */
/* Set the static globals corresponding to the args */
{ complex = flags->complex;
separator= flags->separator;
decimalchar = flags->decimalchar;
unwritten_mult = flags->unwritten_mult;
long_identifiers = flags->long_identifiers;
strncpy(function_letters,flags->functions,8);
letflag = flags->letflag;
function_letters[7] = '\0'; /* just to be sure it's null-terminated */
newfunctor = flags->newfunctor;
newatom = flags->newatom;
parser_initialized = 1; /* if parser.dll is unloaded, when it is
reloaded this static variable will be
zero again. */
}
/*___________________________________________________________________*/
MEXPORT_PARSER int EXPORT parse(parser_control *flags, term *expr,char *in,char **out)
/* the return value is the error code; 0 is success */
/* Parses string "in" returning term expr. Note: bignums are
returned as character strings.
"out" returns indirectly the first character not processed. If
there is no error, that will be the null at the end of "in". */
{ int err;
pminus = NULL; /* set global variable */
if(flags == NULL)
{ parser_initialized = 0;
return 1;
/* Next time, setup_parser will be called */
}
if(!parser_initialized)
setup_parser(flags);
err = lexpr(expr,in,out);
letflag = flags->letflag; /* restore original value; parser can
change this variable and if you don't
reset it, next parse can be wrong */
if (err)
return err;
/* but even if err==0 it can still be an error, if there is unused input*/
if (*out[0] == '\0')
return 0;
if (*out[0] == ')' )
return 313; /* Parentheses unbalanced */
if (*out[0] == ']' )
return 314; /* Brackets unbalanced */
if (*out[0] == '}' )
return 315; /* Braces unbalanced */
else
return 316; /* Can't understand this */
}
/*___________________________________________________________________*/
/* lexpr --> lterm, lexpr1. */
static int lexpr(term *expr,char *in,char **out)
{ term t;
int err;
char *next;
err = lterm(&t,in,&next);
if (err < 0)
{ *out = in;
return 0; /* succeed eating nothing */
}
if (err > 0)
{ *out = next;
return err; /* failure to parse */
}
err = lexpr1(t,expr,next,out);
return err;
}
/*_________________________________________________________________*/
static void blank_list(char *in, char **out)
/* eat blanks */
{ *out = in;
while( (**out == 32) && (**out != '\0'))
++ *out;
}
/* _________________________________________________________________*/
/* lexpr1 --> OR, lterm, lexpr1 | []. */
static int lexpr1(term x, term *expr,char *in,char **out)
/* x is the lexpr already processed */
/* Several functions, like this one, pass a term x in and get a new
term out indirectly. Space allocation has to be handled carefully in
this situation: (1) if the term-out is made equal to the term-in,
then we have to be sure that it is given permanent space. If the term-in
is in local space and we simply set the term-out equal to it, it will not
be in safe space. (2) If, on the other hand, the term-in is allocated
by calloc, and the term-out is not made equal to it, then we'll be using
up space.
*/
{ term t;
int err;
term nextx;
unsigned short f = FUNCTOR(x);
char *next,*rest;
int i;
if ((in[0] == '|') && (in[1] == '|'))
blank_list(in+2,&next);
else if (in[0] == '|' )
blank_list(in+1,&next);
else if (in[0] == ';' )
{ /* reject ';' unless x is a CASES or IF term */
if(f != CASES && f != IF)
return 328;
/*Semicolon can only be used after 'if' in a definition by cases.
Separate elements of a list by comma. */
if(f == CASES && FUNCTOR(ARG(ARITY(x)-1,x)) != IF)
/* The LAST arg of a CASES term doesn't have to be an IF;
but now, the last arg of x isn't going to be the
last arg of the CASES term, so we must reject this parse
if that arg isn't an IF */
return 328;
blank_list(in+1,&next);
}
else
{ *out = in;
*expr = x;
return 0; /* lexr1 --> []. */
}
/* now have received an OR or CASES */
err = lterm(&t,next,&rest);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0) /* failure to get another lterm, which we had to do,
so this is an error */
{ *out = next;
err = 257; /* "Logical expression must follow logical OR" */
return err;
}
if(f == OR || f == CASES) /* then append the arguments */
{ nextx = make_term(f,(unsigned short) (ARITY(x) + 1));
for(i=0;i<ARITY(x);i++)
ARGREP(nextx,i,ARG(i,x));
RELEASE(x); /* since ARG(i,x) has been copied to new space
pointed to by nextx.args */
ARGREP(nextx,ARITY(x),t);
err = lexpr1(nextx,expr,rest,out); /* no error */
return err;
}
else /* x doesn't have functor OR or CASES */
{ nextx = make_term((unsigned short)(in[0] == ';' ? CASES : OR),2);
ARGREP(nextx,0,x);
ARGREP(nextx,1,t);
err = lexpr1(nextx,expr,rest,out); /* no error */
return err;
}
}
/*__________________________________________________________________*/
static int lterm(term *t, char *in, char **out)
{ term f;
char *next;
int err;
err = lfactor(&f,in, &next) ;
if(err > 0)
{ *out = next;
return err;
}
if(err < 0)
{ *out = in;
return 259; /* Term expected */
}
err = lterm1(f,t,next,out);
return err;
}
/*______________________________________________________________________*/
/* lterm1 --> AND, lfactor,lterm1 | []. */
/* starts with something like ",b,c)" for example where x is the
term representing "a" which has already been processed.*/
static int lterm1(term x, term *expr,char *in,char **out)
/* x is the lterm already processed */
{ term t;
term nextx;
char *next, *rest;
int i,err;
if ((in[0] == '&') && (in[1] == '&'))
blank_list(in+2,&next);
else if (in[0] == '&' )
blank_list(in+1,&next);
else if (in[0] == ',' )
blank_list(in+1,&next);
else /* lterm1 --> []. */
{ *out = in;
*expr = x;
return 0;
}
/* now have received an AND */
err = lfactor(&t,next,&rest);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0) /* failure to get another lfactor, which we had to do,
so this is an error */
{ *out = next;
err = 258; /* "Logical expression must follow logical AND" */
return err;
}
if( FUNCTOR(x) == AND && !ISINTERVAL(x) ) /* then append the arguments */
/* but if x is an interval don't append args */
{ nextx = make_term(AND,(unsigned short) (ARITY(x) + 1));
for(i=0;i<ARITY(x);i++)
ARGREP(nextx,i,ARG(i,x));
RELEASE(x);
ARGREP(nextx,ARITY(x),t);
err = lterm1(nextx,expr,rest,out); /* no error */
return err;
}
else /* neither x nor t has functor AND, or x is an interval */
{ nextx = make_term(AND,2);
ARGREP(nextx,0,x);
ARGREP(nextx,1,t);
err = lterm1(nextx,expr,rest,out); /* no error */
return err;
}
}
/*_________________________________________________________________*/
static int lfactor(term *f, char *in, char **out)
{ char *next;
char *nextafterblanks;
term arg;
int err;
if( in[0] == '~')
next = in + 1;
else
{ err = rexpr(f,in,out); /* in doesn't begin with NOT */
if(!err && **out == '<' && (FUNCTOR(*f) == '<' || FUNCTOR(*f) == LE))
/* check for an interval term a <= x <= b */
{ char *temp;
term ans;
err = intervalterm(*f,&ans,*out,&temp);
if(!err)
{ *out = temp;
*f = ans;
return 0;
}
}
return err;
}
/* Now in DOES begin with NOT */
*f = make_term(NOT,1);
blank_list(next,&nextafterblanks);
err = lfactor(&arg,nextafterblanks,out);
if (err > 0)
return err;
if (err < 0)
{ *out = nextafterblanks;
return 256; /* "Logical expression must follow NOT" */
}
ARGREP(*f,0,arg);
return 0;
}
/*___________________________________________________________________*/
static int rexpr(term *t, char *in, char **out)
/* relational expression, or just plain old expression */
{ term e,e1;
char *next;
char *rest;
int err,saveletflag;
unsigned short functor;
err = expr(&e,in,&next);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0)
{ *out = in;
return 261; /* Expression expected */
}
err = relop(&functor,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0) /* no relop follows the first expression */
{ *out = next;
*t=e;
return 0;
}
if (err == 0) /* we did find a relop */
{ saveletflag = letflag;
letflag = 0;
err = expr(&e1,rest,out); /* x(...) on the right of = is multiplication, e.g. in P(x) = x(x-1) */
letflag = saveletflag;
if( err > 0 )
return err;
if( err < 0 )
{ *out = rest;
return 261; /* expression expected */
}
*t = make_term(functor,2);
ARGREP(*t,0,e);
ARGREP(*t,1,e1);
return 0;
}
return 0; /* just to keep Turbo C from complaining */
}
/*_____________________________________________________________________*/
static int relop(unsigned short *functorp, char *in, char **out)
{ if(in[0] == '<' && in[1] == '=')
{ *functorp = LE;
*out = in + 2;
return 0;
}
if(in[0] == '=' && in[1] == '<')
{ *functorp = LE;
*out = in + 2;
return 0;
}
if(in[0] == '=' && in[1] == '>')
{ *functorp = SEQ;
*out = in + 2;
return 0;
}
if(in[0] == '=' )
{ *functorp = (char) '=';
*out = in + 1;
return 0;
}
if(in[0] == '�')
{ *functorp = LE;
*out = in + 1;
return 0;
}
if(in[0] == '\\' && in[1] == 'l' && in[2] == 'e') /* accept "\le" as in TeX */
{ *functorp = LE;
*out = in + 3;
return 0;
}
if(in[0] == '>' && in[1] == '=')
{ *functorp = GE;
*out = in + 2;
return 0;
}
if(in[0] == '\\' && in[1] == 'g' && in[2] == 'e') /* accept "\ge" as in TeX */
{ *functorp = GE;
*out = in + 3;
return 0;
}
if(in[0] == '�')
{ *functorp = GE;
*out = in + 1;
return 0;
}
if(in[0] == '>' )
{ *functorp = '>';
*out = in + 1;
return 0;
}
if(in[0] == '<' )
{ *functorp = '<' ;
*out = in + 1;
return 0;
}
if(in[0] == '-' && in[1] == '>' )
{ *functorp = ARROW; /* as in lim(x->0,f(x)) */
*out = in + 2;
return 0;
}
if( (in[0] == '/' || in[0] == '\\') && in[1] == '=')
{ *functorp = NE;
*out = in + 2;
return 0;
}
if(in[0] == '\\' && in[1] == 'n' && in[2] == 'e') /* accept "\ne" as in TeX */
{ *functorp = NE;
*out = in + 3;
return 0;
}
return -1; /* can't get a relop */
}
/*______________________________________________________________________*/
static int expr(term *e, char *in, char **out)
{ int err;
char *next, *rest, *last;
term t;
blank_list(in,&next);
err = term0(&t,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if (err < 0)
{ *out = in;
return 262; /* expression expected */
}
blank_list(rest,&last);
err = expr1(t,e,last,out);
if (err > 0)
return err;
if (err < 0)
{ *out = last;
return 263; /* expression expected */
}
return 0;
}
/*_________________________________________________________________*/
static int ineq(term *t, char *in, char **out)
/* ineq --> expr, relop, expr */
{ term e,e1;
char *next;
char *rest;
int err;
unsigned short functor;
err = expr(&e,in,&next);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0)
{ *out = in;
return 261; /* Expression expected */
}
err = relop(&functor,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0 || functor == ARROW || functor == SEQ)
{ *out = rest;
return 326; /* Inequality expected */
}
/* we did find a relop */
err = expr(&e1,rest,out);
if( err > 0 )
return err;
if( err < 0 )
{ *out = rest;
return 261; /* expression expected */
}
*t = make_term(functor,2);
ARGREP(*t,0,e);
ARGREP(*t,1,e1);
return 0;
}
/*_________________________________________________________________*/
static int expr1(term x, term *e, char *in, char **out)
/* x is the sum built up so far */
/* expr1 reads a sum, adding in new terms to x */
{ int err,i;
char *next, *rest, *last, *next3;
term t,minusterm;
term newt;
if( (in[0] == '-' ) && (in[1] == '>')) /* to parse x -> -3 for example */
{ blank_list(in+2,&next);
err = expr(&t,next,&last); /* make t the term following the arrow */
if(err > 0)
{ *out = last;
return err;
}
if(err < 0)
{ *out = next;
return 264; /* "expression expected" */
}
newt = make_term(ARROW,2);
ARGREP(newt,0,x);
ARGREP(newt,1,t);
*out = last;
*e = newt;
return 0;
}
if( in[0] == '-' )
{ blank_list(in+1,&next);
err = pterm(&t,next,&rest);
if (err > 0)
{ *out = rest;
return err;
}
if (err < 0)
{ *out = next;
return 265; /* expression expected */
}
minusterm = make_term('-',1);
ARGREP(minusterm,0,t);
if(TYPE(t) != NOTYPE)
SETTYPE(minusterm,TYPE(t));
if(FUNCTOR(x) == '+') /* then return x + (-t) but in flattened form */
{ newt = make_term('+',(unsigned short)( ARITY(x) + 1));
for(i=0;i<ARITY(x);i++)
ARGREP(newt,i,ARG(i,x));
RELEASE(x);
ARGREP(newt,ARITY(x),minusterm);
}
else
{ newt = make_term('+', 2);
ARGREP(newt,0,x);
ARGREP(newt,1,minusterm);
}
err = expr1(newt,e,rest,out);
return err;
}
if( in[0] == '+' )
{ blank_list(in+1,&next);
/* Now check for the case in which use has entered something like
a + (-b) which will print like a-b; we want to be able to
tell confirm_problem to print it as a+(-b) */
if ( (next[0] == '(') || (next[0] == '[') )
{ blank_list(next+1,&next3);
if(next3[0] == '-') /* then we are in that situation */
pminus = next3; /* point pminus to the minus sign; */
}
err = pterm(&t,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0)
{ *out = next;
return 266; /*expression expected */
}
if( FUNCTOR(x) == '+')
{ if(PROVISIONAL(x))
{ UNSETPROVISIONAL(x);
newt = make_term('+',2);
ARGREP(newt,0,x);
ARGREP(newt,1,t);
}
else
{ newt = make_term('+',(unsigned short)(ARITY(x)+1));
for(i=0;i<ARITY(x);i++)
ARGREP(newt,i,ARG(i,x));
RELEASE(x);
ARGREP(newt,ARITY(x),t);
}
}
else
{ newt = make_term('+',2);
ARGREP(newt,0,x);
ARGREP(newt,1,t);
}
err = expr1(newt,e,rest,out);
if(err > 0)
return err;
if(err < 0)
{ *out = rest;
return 267; /* expression expected */
}
return 0;
}
*out = in;
*e = x;
return 0; /* expr1 --> []. */
}
/*______________________________________________________________________*/
static int term0( term *ans, char *in, char **out) /* either a term or minus a term */
{ int err;
term t;
char *next;
if( in[0] == '-' )
{ blank_list(in+1,&next);
err = pterm(&t,next,out);
if (err > 0)
return err;
if (err < 0)
{ *out = next;
return 268; /* expression expected */
}
*ans = make_term('-',1);
ARGREP(*ans,0,t);
if(TYPE(t) != NOTYPE)
SETTYPE(*ans,TYPE(t));
return 0;
}
err = pterm(ans,in,out);
if(err > 0)
return err;
if(err < 0)
return -1;
return 0;
}
/*_____________________________________________________________________*/
static int pterm(term *t, char *in, char **out)
{ int err;
char *next;
term f;
err = pfactor(&f,in,&next);
if( err > 0)
{ *out = next;
return err;
}
if( err<0)
{ *out = in;
if((in[0] == '-') && (pminus != NULL && *pminus !=in[0])) /* e.g. if input is a + -b */
return 282; /* Use parentheses before minus here */
return 269; /* Expression expected (factor actually)*/
}
err = term1(f,t,next,out);
if(err > 0)
return err;
if(err < 0)
{ *out = next;
return 269; /* Expression expected (term actually) */
}
return 0;
}
/*____________________________________________________________________*/
/* the first argument of term1 is the product so far built up */
static int term1(term x, term *t, char *in, char **out)
{ int err,i;
char *next, *rest;
int skipstar = 0;
term f,newt,newx;
if( in[0] == '/' ) /* term1 --> '/', blank_list, pfactor, term1. */
{ blank_list(in+1,&next);
err = pfactor(&f,next,&rest);
if(err>0)
{ *out = rest;
return err;
}
if(err<0)
{ if(in[1]== '=') /* as in x /= y for example; this is just the
end of the term, and /= is a relop */
{ *out = in;
return 0; /* term1 --> blank_list */
}
*out = next;
return 270; /* expression expected*/
}
newt = make_term('/',2);
ARGREP(newt,0,x);
ARGREP(newt,1,f);
err = term1(newt,t,rest,out);
if(err > 0)
{ /* destroy_term(f); */
RELEASE(newt);
/* but not destroy_term(newt) which would call destroy_term(x) */
return err;
}
if(err<0)
{ *out = rest;
return 271; /* expression expected*/
}
return 0;
}
if( in[0] == '\\' && in[1] == 'o' && in[2] == 'v' && in[3] == 'e' && in[4] == 'r' )
/* accept plain TeX "\over" notation */
{ blank_list(in+5,&next);
err = pfactor(&f,next,&rest);
if(err>0)
{ *out = rest;
return err;
}
if(err<0)
{ *out = next;
return 270; /* expression expected*/
}
newt = make_term('/',2);
ARGREP(newt,0,x);
ARGREP(newt,1,f);
err = term1(newt,t,rest,out);
if(err > 0)
{ /* destroy_term(f); */
RELEASE(newt);
/* but not destroy_term(newt) which would call destroy_term(x) */
return err;
}
if(err<0)
{ *out = rest;
return 271; /* expression expected*/
}
return 0;
}
if( in[0] == '*' ) /* term1 --> '*', blank_list, pfactor, term1. */
{ skipstar = 1;
blank_list(in+1,&next);
}
else if( (in[0] == 'i' ) && (in[1] == 'f')) /* to parse '1 if x>0' for example */
/* the rule is, term1-> 'if', ineq */
{ blank_list(in+2,&next);
err = ineq(&f,next,out);
if(err > 0)
return err;
if(err < 0)
{ *out = next;
return 326; /* "Inequality expected" */
}
if((*out)[0] == '<' || (*out)[0] == '>' || (*out)[0] == '#')
{ next = *out;
err = intervalterm(f,&newt,next,out);
if(err)
{ *out = next;
return 327;
/* Expecting an inequality or interval after 'if'. */
}
/* got an interval */
f = newt;
}
newt = make_term(IF,2);
ARGREP(newt,1,x); /* switch the order of arguments, making if(ineq,term) */
ARGREP(newt,0,f);
*t = newt;
return 0;
}
else if(in[0] == ':') /* term1 --> ':', blank_list, type */
{ term tp;
blank_list(in+1,&next);
err = ptype(&tp,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0)
{ *out = next;
return 330; /* Type expected. The colon is used to specify the kind or 'type' of a variable. */
}
*t = make_term(':',2);
SETTYPE(x,(unsigned char) INTDATA(tp));
ARGREP(*t,0,x);
ARGREP(*t,1,tp);
*out = rest;
return 0;
}
else if( unwritten_mult /* a global variable */
|| !isascii(in[0])
)
blank_list(in,&next);
else
{ *out = in;
return 272; /* expression expected */
}
err = pfactor(&f,next,&rest);
if (err > 0)
{ *out = rest;
return err;
}
if (err < 0) /* term1 --> blank_list. */
{ if(skipstar)
*out = in;
else
blank_list(next,out);
*t = x;
return 0;
}
if (FUNCTOR(x) == '*' ) /* then append the arguments */
{ newx = make_term('*',(unsigned short) (ARITY(x)+1));
for(i=0;i<ARITY(x);i++)
ARGREP(newx,i,ARG(i,x));
ARGREP(newx,ARITY(x),f);
err = term1(newx,t,rest,out);
if(err > 0)
{ RELEASE(newx);
return err;
}
if(err < 0)
{ *out = rest;
RELEASE(newx);
return 273; /* expression expected */
}
return 0;
}
else /* FUNCTOR(x) != '*' */
{ newx = make_term('*',2);
ARGREP(newx,0,x);
ARGREP(newx,1,f);
err = term1(newx,t,rest,out);
if(err > 0)
return err;
if(err < 0)
{ *out = rest;
return 274; /* expression expected */
}
}
return 0;
}
/*________________________________________________________________________*/
/* pfactor --> primary, factor1. */
static int pfactor(term *f, char *in, char **out)
{ int err;
char *next;
term p;
err = primary(0,&p,in,&next);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0)
{ *out = in;
return -1;
}
if(err == 0 &&
(FUNCTOR(p) == '+' || FUNCTOR(p) == '*') &&
(in[0] = '(' || in[0] == '[')
)
SETPROVISIONAL(p); /* mark it so we don't flatten those parens */
err = factor1(p,f,next,out);
if (err > 0)
return err;
if (err < 0)
{ *out = in;
return -1;
}
return 0;
}
/*______________________________________________________________*/
/* factor1 --> '^', blank_list, primary, blank_list, factor1.
factor1 --> '^', blank_list, '-', primary, blank_list,factor1.
factor1 --> '�', blank_list.
factor1 --> '!', blank_list. (future postfix functions go here)
factor1 --> {'}*, blank_list.
factor1 --> blank_list */
/* factor 1 (x,&ans,"^ab"... should return ans = (x^a) * b */
static int factor1(term x, term *ans, char *in, char **out)
{ int err;
char *next, *next2, *rest, *last;
term p,exponent;
if(in[0] == '^')
{ blank_list(in+1,&next);
if(next[0] == '-')
{ blank_list(next+1,&next2);
err = primary(0,&p,next2,&rest);
exponent = make_term('-',1);
ARGREP(exponent,0,p);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0)
{ *out = next;
return 275; /* expression expected */
}
blank_list(rest,out);
}
else /* if next[0] != '-' */
{ err = primary(0,&p,next,&rest);
if(err > 0)
{ *out = rest;
return err;
}
if(err < 0)
{ *out = next;
return 275; /* expression expected */
}
blank_list(rest,&last);
err = factor1(p,&exponent,last,out);
if(err > 0)
return err;
if(err < 0)
{ *out = last;
return err;
}
}
*ans = make_term('^',2);
ARGREP(*ans,0,x);
ARGREP(*ans,1,exponent);
if(err > 0)
return err;
if(err < 0)
{ *out = last;
return 276; /* expression expected */
}
return 0;
}
if(( in[0] == (char) '!') || (in[0] == (char) '�' )) /* postfix functions */
{ if(in[0] == (char) '!')
*ans = make_term(FACTORIAL,1);
else if(in[0] == (char) '�')
*ans = make_term(DEG,1);
ARGREP(*ans,0,x);
blank_list(in+1,out);
return 0;
}
if( in[0] == 39 ) /* 39 is ascii of '; this is a term like u'' */
{ char *marker= in;
long nprimes = 0;
term arg;
while ((*marker == 39) || (*marker == 32)) /* count the primes */
{ if(*marker==39)
++nprimes;
++marker;
}
*ans = make_term(PR,2);
arg = make_int(nprimes);
ARGREP(*ans,1,arg);
ARGREP(*ans,0,x);
*out = marker; /* first nonblank char after all the primes */
return 0;
}
blank_list(in,out); /* factor1 --> blank_list */
*ans = x;
return 0;
}
/*_________________________________________________________________________*/
/* primary --> number, blank_list.
primary --> '(', blank_list, lexpr, paren(')'), blank_list. (etc.)
primary --> function_term.
primary --> ident.
Known and unknown funcnames are treated together in the C version of the
parser.
*/
static int primary( int flag, term *p, char *in, char **out)
{ int err;
char *next, *rest;
if( in[0] == '(' || in[0] == '[' || /* left brackets */
in[0] == '{' /* vector, matrix, or absolute value signs */
)
{ blank_list(in+1,&next);
err = lexpr(p,next,&rest); /* eats trailing blanks */
if(err)
{ *out = rest;
return err;
}
switch(in[0])
{ case '(' : if(rest[0] != ')' )
{ *out = rest;
return 278; /* right ')' missing */
}
else break;
case '[' : if(rest[0] != ']' )
{ *out = rest;
return 279; /* right ']' missing */
}
else break;
case '{' : if(rest[0] != '}' )
{ *out = rest;
return 280; /* right '}' missing */
}
else
break;
}
blank_list(rest+1,out); /* eat any blanks following the close paren */
if (in[0] == '{' && (FUNCTOR(*p)==AND))
/* then parse as VECTOR or MATRIX instead */
{ /* which is it, VECTOR or MATRIX? */
int i;
unsigned short newfunctor;
if(FUNCTOR(ARG(0,*p))==VECTOR) /* a vector of vectors is a matrix */
{ /* check: if one entry is a vector all should be */
for(i=0;i<ARITY(*p);i++)
{ if (FUNCTOR(ARG(i,*p)) != VECTOR)
{ *out = in+1;
return 317; /* nested braces that don't form a legal matrix */
}
} /* I observed with Codeview that the next line was
being executed IN THE FOR-LOOP without these brackets
which it shouldn't be. */
newfunctor = MATRIX;
}
else
newfunctor = VECTOR;
SETFUNCTOR(*p,newfunctor,ARITY(*p));
}
return 0;
}
if (isdigit(in[0]) || (in[0] == decimalchar && isdigit(in[1])) )
/* primary -> number,blank_list */
/* a decimal point standing alone is not a number; that's why the isdigit(in[1]) */
{ err = number(p,in,&next);
if(err > 0)
{ *out = next;
return err;
}
if(err < 0 && decimalchar != ',')
{ *out = in+1;
return 281; /* number expected */
}
if(err == 0)
{ blank_list(next,out);
return 0;
}
/* and if decimalchar == ',' and err < 0, just go on and try something else */
}
err = function_term(p,in,out);
if( err > 0)
return err; /* input error */
if( err == 0)
{ if (flag==0) /* this is the nonterminal 'primary' */
return 0; /* got a function term */
else /* this is 'aprimary' */
return -1; /* don't accept a function term */
}
if( err < 0)
{ err = ident(p,in,out); /* just get an identifier */
if(err)
{ *out = in;
return err;
}
else return 0;
}
return 0; /* just to keep Turbo C from complaining */
}
/*_______________________________________________________________________*/
/* function_term --> funcname, after_funcname. */
/* 'function term' does not include terms with functor +, *, AND, OR */
/* If a term f(x) is encountered, where f is not a built-in functor and
also not (yet) recognized as a user-defined functor, there is an ambiguity:
should this be f*x or f(x)? Mathpert's rule is this:
(1) if the argument x is an atom, then it's a function term f(x).
(2) if the argument is a compound term, as in f(x+y),
then it's a function term if the function symbol is f,g, or h,
(or F,G, or H), and otherwise it's a multiplication.
(3) EXCEPT: when the problemtype is LIMITS or DIFFERENTIATE_FROM_DEFN,
then h is probably a number, not a function, so only f and g are
treated as in (2).
A user-defined function will first be encountered in a definition f(x)=...,
so one might argue that only if followed by an = should we accept f(x) as
a function term. But what about this example: d/dx( f(x)g(x));
and there may be other situations in which the user enters what amounts to
a function variable. Consider d/dx(f(x+a)g(x)); this will come out
right, but if the user puts c instead of f, it will be treated as
d/dx( c*(x+a)*g(x)), which is quite probably what's meant.
Another ambiguity: Even when long_identifiers==0, the user should ideally
be able to define function names that are longer than one character, but
this turns out to be impossible:
What about cf(x): is it c*f(x), or is 'cf' a function name?
And what about when 'f' is a known function name? we don't want to
parse clog x as a new function name 'clog'. Therefore we do require
defined functors to be governed by the rules for identifiers: if
long_identifiers==0, then they must be only one character long.
*/
static function_term(term *ans, char *in, char **out)
{ int err,count,i;
char c;
long nprimes=0;
int newfunctionflag=0;
term arg,arg2;
char newfuncname[32];
unsigned short f;
char *marker, *next, *firstarg;
short arity; /* actual arity of term generated */
int prefix; /* set it nonzero when this function term uses prefix notation */
err = funcname(&f,in,&next);
/* BUILT IN funcname or known functor */
/* or, if (err == 2), new functor of one character */
if(err == 2)
{ newfunctionflag = 1;
err = -1;
}
if( err > 0)
{ *out = next;
return err;
}
if (! isalpha(in[0]) &&
! (in[0] == '\\' && isalpha(in[1])) /* accept "\sin" etc. */
)
return -1; /* definitely not a function term */
if( err < 0) /* new function name */
{ newfunctionflag=1;
if( long_identifiers != 0)
{ newfuncname[0] = in[0];
newfuncname[1] = '\0';
next = in+1;
}
else
{ i=0;
while(isalpha(in[i]) && (i<31))
{ newfuncname[i] = in[i];
++i;
}
newfuncname[i] = '\0';
if(isalpha(in[i]))
{ *out = in;
return 312; /* new function names limited to 31 characters */
}
next = in + i;
}
}
marker = next;
/* Catch Bessel functions: */
if(f == BESSELK || f == BESSELJ || f == BESSELY || f == BESSELI)
{ if(!isdigit(*marker) && *marker != 39 && *marker != '(' && *marker != '[')
return -1; /* Not a Bessel function after all, only an identifier */
while(isdigit(*marker))
++marker;
}
/* Now, does a parenthesis or bracket or prime (ascii 39)
follow this funcname? */
while (*marker == 32)
++ marker; /* advance to first non-blank character */
if(*marker == '\0')
{ if (newfunctionflag)
return -1; /* not a function term */
*out = marker; /* else it's an error */
return 310; /* argument expected */
}
if( *marker == 39 ) /* then this is a term like f''(x) */
{ while ((*marker == 39) || (*marker==32))
/* count primes, ignoring blanks */
{ if (*marker == 39)
++nprimes;
++ marker;
} /* now nprimes is how many primes there are */
next = marker; /* advance next to the position past the primes */
*ans = make_term(PR,2);
} /* now the marker is past all the primes and on the next character */
if( (*marker != '(') && (*marker != '['))
{ if (newfunctionflag)
return -1; /* this isn't a function term */
c = in[0];
if((c == 'Y' || c == 'J' || c == 'I' || c == 'K') && !isalnum(in[1]))
return -1; /* fail, it isn't really a Bessel function as
we were hoping up to here, just an identifier after all. */
if(!PREFIX(f))
{ *out = marker;
return 311; /* parentheses expected */
}
prefix = 1; /* set this so we know not to require a paren after the args */
}
else
{ ++marker; /* pass the open paren that precedes the args */
prefix = 0; /* close paren must follow the last argument */
}
while(*marker == 32)
++ marker; /* advance to first arg */
firstarg = marker; /* save position of first argument */
/* Next we will count the arguments by counting commas at the
right level of parentheses nesting. This isn't any easier
than parsing if the functor is prefix (and being used without parentheses)
so we only do it for non-prefix functors. */
if(prefix == 0)
{ count = 1; /* at this point *marker is past the opening paren */
arity = 0;
while( count > 0 && *marker != '\0')
{ switch (*marker)
{ case ')' : --count; break;
case ']' : --count; break;
case '}' : --count; break;
case '(' : ++count; break;
case '[' : ++count; break;
case '{' : ++count; break;
}
if( count == 1 && *marker == ',' &&
( decimalchar != ',' ||
!(isdigit(marker[-1]) && isdigit(marker[1])) ||
((f == SUM || f == PRODUCT) && arity == 2) ||
(f == ROOT && arity == 0) ||
/* log(0,2) will be log to base 10 of 0.2 in French,
but root(3,9) will parse as arity 2 */
(f == INTEGRAL && arity == 2 && ncommas(marker+1) == 0) ||
/* integral(x^2,x,2,3) should parse; the 2,3 is not a decimal */
(f == LIMIT && arity == 0 && ncommas(marker+1) == 0)
/* lim(x->0,2) should parse; the 0,2 is not a decimal */
)
)
++arity;
++marker;
}
++arity; /* last argument wasn't followed by a comma */
}
else
arity = 1;
/* now the arity is set to the ACTUAL arity except for prefix functors */
if((*marker == '\0') && (count > 0) && !prefix )
{ *out = next;
return 313; /* parentheses unbalanced */
}
if( (f== LOG)) /* log/2 and log/1 are entered the same by the user,
so we have to find out here which one it is */
{ if (arity == 2)
f = LOGB;
else if (arity != 1)
{ *out = next;
return 283; /* wrong number of args*/
}
}
if( (f==DIFF) && (arity != 2) && (arity != 3))
{ *out = next;
return 283; /* wrong number of arguments */
}
if( (f==INTEGRAL) && (arity != 2) && (arity != 4))
{ *out = next;
return 283; /* wrong number of arguments */
}
if( (f == SUM || f == PRODUCT) &&
arity != 4 && arity != 5
)
{ *out = next;
return 283; /* wrong number of arguments */
}
if( (f==LIMIT) && (arity != 2))
/* at this point even a one-sided limit has arity 2
because it's entered as lim(x->0+,f(x)) */
{ *out = next;
return 283; /* wrong number of arguments */
}
if( !newfunctionflag) /* check number of arguments */
{ if(f == BESSELJ || f == BESSELK || f == BESSELY || f == BESSELI)
{ if( (isdigit(*next) && arity != 1)
/* j43(x) entered, index arg not in parentheses */
|| (!isdigit(*next) && arity != 2)
/* j(n,x) entered with parentheses */
)
{ *out = next;
return 283; /* wrong number of arguments */
}
}
else if (f != LOG && f != LOGB && f != DIFF && f != INTEGRAL
&& f != CASES && f != LIMIT && f != SUM && f != PRODUCT &&
arity != correct_arity(f)
)
{ *out = next;
return 283; /* wrong number of arguments */
}
}
if( newfunctionflag ) /* is this a function term or a multiplication? */
{ if( letflag /* global variable signalling user's intention to define */
|| arity > 1 || strchr(function_letters, in[0])
|| nprimes > 0 /* read a'(x) as a function term */
)
/* then it's definitely a function term, so enter it */
{ assert(newfunctor != NULL);
f = newfunctor(newfuncname,arity);
if(f == ILLEGAL)
return 325; /* Too many long function names */
letflag = 1; /* signalling the presence of undefined function symbols */
err = 0;
}
else /* if arity == 1 and the function name doesn't begin with f,g,h */
{ err = ident(&arg,firstarg,out);
if(err)
return -1; /* not a function term unless the argument
is an identifier */
if((**out == ')') || (**out == ']'))
{ assert(newfunctor != NULL);
f = newfunctor(newfuncname,arity);
letflag = 1;
err = 0;
}
else
return -1; /* it was something like a(x+y) with a
letter not f,g,h and a non-atomic arg */
}
}
if(err == 0)
{ if(f== LIMIT)
return limit_tail(ans,next,out);
else if (nprimes > 0)
{ arg2 = make_int(nprimes);
ARGREP(*ans,1,arg2);
arg = ARG(1,*ans);
return primary_tail(f,arity,ARGPTR(*ans),next,out);
}
else
{ err = after_funcname(f,arity,ans,next,out);
if(prefix && (err == 284))
return 320; /* can't understand function argument, try using parentheses */
else if(
(f == SUM || f == PRODUCT) &&
!err &&
arity == 5
)
{ if(ISINTEGER(ARG(4,*ans)))
return 0;
if(NEGATIVE(ARG(4,*ans)) && ISINTEGER(ARG(0,ARG(4,*ans))))
return 0;
return 283; /* wrong number of arguments. An arity-5
sum is created by the program only; the last arg must
be a positive or negative integer. The user isn't
supposed to enter such a term, so this error is
appropriate if an error is going to the user. */
}
else
return err;
}
}
return 0; /* just to keep the C compiler from complaining */
}
/*_______________________________________________________________________*/
static int after_funcname(unsigned short x, unsigned short nargs, term *p, char *in, char **out)
/* x is passed as either one of the #-defined known functors, or as
an index into the array of user-defined functions */
/* nargs is passed as the count of number of arguments to follow x */
/* p is used for the indirect return of a term with functor x whose
args are in the string in */
{ int err,i;
char *next,*rest,*last;
term temp;
term exponent;
term a1;
blank_list(in,&next);
if( isdigit(in[0]) /* subscripted function, as in J43(x) */
&& SUBSCRIPTABLE(x)
)
{ number(&temp,next,&rest);
if(TYPE(temp) == BIGNUM)
return 321; /* subscript too large */
if(TYPE(temp) != INTEGER)
return 322; /* subscript must be an integer */
if(INTDATA(temp) > 1000)
return 321; /* subscript can't exceed 1000 */
*p = make_term(x,(unsigned short)(nargs+1)); /* nargs comes in not counting the index */
after_funcname(x,nargs,&a1,rest,out);
ARGREP(*p,0,temp);
for(i=1;i<nargs+1;i++)
{ ARGREP(*p,i,ARG(i-1,a1));
}
RELEASE(a1); /* created by the call to after_funcname */
return 0;
}
if(next[0] == (char) '�' )
{ blank_list(next+1,&rest);
err = primary_tail(x,nargs,&temp,rest,out);
if(err>0)
return err;
if(err<0)
{ *out = rest;
return 284; /* can't understand argument */
}
*p = make_term('^',2);
ARGREP(*p,0,temp);
a1 = make_atom_from_string2("n");
ARGREP(*p,1,a1);
return 0;
}
if(next[0] == (char) '�' )
{ blank_list(next+1,&rest);
err = primary_tail(x,nargs,&temp,rest,out);
if(err>0)
return err;
if(err<0)
{ *out = rest;
return 284; /* can't understand argument */
}
*p = make_term('^',2);
ARGREP(*p,0,temp);
a1 = make_int(2L);
ARGREP(*p,0,a1);
return 0;
}
if(next[0] == (char) '^' )
{ blank_list(next+1,&rest);
err = pfactor(&exponent,rest,&last);
if (err>0)
{ *out = rest;
return err;
}
if(err<0)
{ *out = next+1;
return 285; /* can't understand exponent */
}
err = primary_tail(x,nargs,&temp,last,out);
if (err>0)
{ *out = last;
return err;
}
if(err<0)
{ *out = last;
return 284; /* can't understand argument */
}
*p = make_term('^',2);
ARGREP(*p,0,temp);
ARGREP(*p,1,exponent);
return 0;
}
/* now there are no superscripts between functor x and its args */
if(x == LIMIT)
err = limit_tail(p,next,out);
else
err = primary_tail(x,nargs,p,next,out);
if(err > 0)
return err;
if (err < 0)
{ *out = next;
return 284; /* Can't understand function argument */
}
return 0;
}
/*__________________________________________________________________________*/
static int primary_tail(unsigned short x, unsigned short nargs, term *ans, char *in, char **out)
/* x is a functor passed in to this function;
ans is returned as a term with functor x and nargs arguments. */
/* The primary_tail may or may not include parentheses or brackets */
{ int err;
char *next;
char *marker1, *marker2;
term f,t,temp;
int i;
if(PREFIX(x) && in[0] != '(' && in[0] != '[')
/* x is declared prefix, like sin, log, and so on */
/* ABS isn't prefix on output, but can be used prefix on input */
/* and is being used here without parentheses */
{ err = pfactor(&f,in,&next);
if(err > 0)
{ *out = next;
return err;
}
if(err < 0)
{ *out = in;
return 284; /* can't understand function argument */
}
err = aterm(f,&t,next,out);
if (err > 0)
{ *out = next;
return err;
}
if (err < 0)
{ *out = in;
return 284; /* can't understand function argument */
}
*ans = make_term(x,1);
ARGREP(*ans,0,t);
return 0;
}
/* So now x is not a prefix functor, or at least if it is,
it is being used with parentheses */
if( (in[0] != '(') && (in[0] != '[') )
{ *out = in;
return 294; /* open parentheses expected */
}
*ans = make_term(x,nargs);
marker1 = in+1; /* beginning of zero-th argument */
for(i=0; i< nargs; i++) /* marker1 is at beginning of i-th arg */
{ if( decimalchar == ',' &&
(
(i==0 && (x==ROOT || x == BESSELJ || x == BESSELY || x == BESSELI || x == BESSELK))
||
(i==2 && (x == SUM || x == PRODUCT))
||
/* example, integral(x^2,x,2,3), we know 2,3 is not a decimal */
(nargs > 1 && i==nargs-2 && ncommas(marker1) == 1)
)
)
{ /* then the i-th arg cannot be a decimal number, so root(3,9) should
be interpreted as having two arguments, even if decimalchar == ','.
*/
marker2 = marker1;
while(*marker2 == 32)
++marker2;
if(x != ROOT && *marker2 == '-')
++marker2;
while(isdigit(*marker2))
++marker2;
if( *marker2 == ',')
{ if(*marker1 == '-')
{ err = integer(&temp,marker1+1,&marker2);
if(err)
assert(0);
ARGREP(*ans,i,tnegate(temp));
}
else
{ err = integer(ARGPTR(*ans)+i,marker1,&marker2);
if(err)
assert(0);
}
}
else
err = expr(ARGPTR(*ans)+i, marker1,&marker2);
}
else
err = expr(ARGPTR(*ans) + i, marker1,&marker2);
/* eat one expression and put it in the i-th arg of *ans */
if(err > 0)
{ *out = marker2;
return err;
}
if(err < 0)
{ *out = marker1;
return 295; /* expected more arguments */
}
if(i==1 && (x==SUM || x == PRODUCT))
{ if(!(ISATOM(ARG(1,*ans))))
{ *out = marker1;
return 319; /* second argument of sum must be a variable */
}
if(FUNCTOR(ARG(1,*ans)) == 'i')
SETTYPE(ARG(1,*ans),INTEGER);
/* it was set to COMPLEX by make_atom_from_string2 */
}
marker1 = marker2; /* advance the marker */
while(*marker1 == 32 )
++marker1; /* eat blanks */
if( (*marker1 != ',' ) && i < nargs-1)
{ *out = marker1;
return 296; /* comma expected */
}
if( *marker1 == ',')
++marker1; /* pass the comma */
while(*marker1 == 32 )
++ marker1; /* eat blanks */
}
if ((in[0] == '(') && (*marker1 != ')') )
{ *out = marker1;
return 278; /* close parentheses expected */
}
if ((in[0] == '[') && (*marker1 != ']') )
{ *out = marker1;
return 279; /* close bracket expected */
}
*out = marker1+1;
return 0; /* everything ok */
}
/*________________________________________________________________________*/
static int limit_tail(term *ans, char *in, char ** out)
/* eats the (x->0,f(x)) part of lim(x->0,f(x))
Must take (x->0+,f(x)) etc. for one-sided limits.
Must take the args in either order, i.e. both
lim(x->0,f(x)) and lim(f(x),x->0) are acceptable and equivalent. */
{ char *arg2,*rest,*next,*firstarg;
char sign = 0;
char *buffer;
int err,i,j,count;
if(in[0] != '(' )
{ *out = in;
return 294; /* Open parentheses or brackets expected */
}
blank_list(in+1,&firstarg); /* leave firstarg pointing to first arg */
/* Now locate the comma and determine if this is a one-sided or
two-sided limit */
count = 0;
i=1;
while((count>0) ||
(in[i] != ',') ||
(decimalchar == ',' && isdigit(in[i-1]) && isdigit(in[i+1]) && ncommas(in +i+1))
/* example, lim(x->3,4, f(x)), don't stop at the first comma,
but in lim(x->3,4), DO stop. That's why we need ncommas here. */
)
{ if((in[i] == '(') || (in[i]== '[') || (in[i] == '{'))
++count;
else if ((in[i] == ')') || (in[i]== ']') || (in[i] == '}'))
--count;
++i;
}
/* Now in[i] is the comma; back up to last preceding non-blank symbol;
but first, mark the beginning of the second argument for reference */
blank_list(in+i+1,&arg2);
--i;
while(in[i] == 32)
--i;
/* Now in[i] is the last non-blank symbol in the first arg */
buffer = callocate(i+2,sizeof(char));
strncpy(buffer,in,i+1);
buffer[i+1] = 0;
if((in[i] == '+') || (in[i]== '-')) /* it's a one-sided limit */
{ sign = in[i];
buffer[i] = 32; /* replace the sign by a blank in buffer */
}
if(sign)
*ans = make_term(LIMIT,3);
else
*ans = make_term(LIMIT,2);
err = expr(ARGPTR(*ans),buffer + (int)(firstarg-in),&next); /* parse first argument */
free2(buffer);
if(err > 0)
{ *out = next;
return err;
}
if(err < 0)
{ *out = in;
return 277; /* expression expected */
}
if (sign == '+')
ARGREP(*ans,1,MAKE_ATOM(RIGHT));
else if (sign == '-')
ARGREP(*ans,1,MAKE_ATOM(LEFT));
j = sign ? 2 : 1; /* where to put next arg */
err = expr(((term *)ARGPTR(*ans)) + j, arg2,&rest);
if(err >0)
{ *out = rest;
return err;
}
if(err <0)
{ *out = arg2;
return 260; /* expression expected */
}
if((in[0] == '(') && (*rest != ')'))
{ *out = rest;
return 278; /* closing parenthesis expected */
}
if ((in[0] == '[') && (*rest != ']'))
{ *out = rest;
return 279; /* closing bracket expected */
}
*out = rest + 1;
return 0;
}
/*____________________________________________________________________*/
#define MAXIDENTIFIER 64 /* maximum length of an identifier */
static int ident(term *ans,char *in, char **out)
/* read an identifier (and any following blanks) */
{ char *marker = in;
char space[MAXIDENTIFIER + 1];
int count,i,err;
if(in[0] == '?') /* needed to display some reason strings */
{ *out = in+1;
*ans = make_term('?',0);
ans->args = NULL;
return 0;
}
if(in[0] < 0)
return 331; /* To enter a Greek symbol or ... */
if (! isalpha(in[0]))
return -1; /* not a variable name */
err = greek(ans,in,out); /* take 'alpha', etc., even if long_identifiers == 0 */
if(!err)
return 0;
switch(long_identifiers)
{ case 0: /* single-letter identifiers only */
*out = in + 1;
marker = space; /* use stack space */
marker[0] = in[0];
marker[1] = '\0';
*ans = make_atom_from_string2(marker);
i=1;
while(in[i]==32)
++i; /* eat any subsequent blanks */
*out = in+i;
return 0;
case 2: /* one letter and possibly numbers after that */
++marker;
count = 1;
while( isdigit(*marker) )
{ ++ marker;
++ count;
}
if(count >= MAXIDENTIFIER)
return 329; /* variable name too long */
marker = space;
for(i=0; i< count; i++)
marker[i] = in[i];
marker[count] = '\0';
*ans = make_atom_from_string2( marker);
if(FUNCTOR(*ans) == ILLEGAL)
return 323; /* Too many subscripted variables. */
/* Out of string space in newatom */
while(in[count] == 32)
++count; /* eat any subsequent blanks */
*out = in + count;
return 0;
case 3: /* begin with letter, then any alphanumerics */
++marker;
count = 1;
while( isalnum(*marker) )
{ ++ marker;
++ count;
}
if(count >= MAXIDENTIFIER)
return 329; /* variable name too long */
marker = space;
for(i=0; i< count; i++)
marker[i] = in[i];
marker[count] = '\0';
*ans = make_atom_from_string2( marker);
if(FUNCTOR(*ans) == ILLEGAL)
return 324; /* Too many long variable names. */
while(in[count] == 32) ++count; /* eat any subsequent blanks */
*out = in + count;
return 0;
}
return 0; /* just to keep Turbo C from complaining */
}
/*_______________________________________________________________*/
/* recognize strings like 'alpha'; return terms with specified greek functors */
/* These terms should be made with make_atom_from_string2 so that
an entry in the value list gets created, because they might be used
as parameters or otherwise evaluated. */
#define DIM 16
static int greek( term *ans, char *in, char **out)
{ int i=0;
char z[DIM];
#if 0 /* obsolete */
n= asciigreek(in[0]);
if(n) /* then it's an extended ascii code */
{ z[0] = in[0];
z[1] = '\0'; /* make a string out of it */
*ans = make_atom_from_string2(z);
return 0;
}
#endif
if(in[0] == '\\')
++in; /* accept TeX notation such as \beta */
while( isalpha(in[i]) )
{ z[i] = in[i];
i++; /* make a string out of it */
if(i==DIM)
return -1; /* don't overflow the buffer; all Greek letter names
are shorter than this. */
}
z[i] = '\0';
switch(z[0])
{ case 'a': if (!strcmp(z,"alpha"))
break;
return -1;
case 'f': if (!strcmp(z,"false"))
break;
return -1;
case 't' : if (!strcmp(z,"true"))
break;
if (!strcmp(z,"theta"))
break;
return -1;
case 'b' : if (!strcmp(z,"beta"))
break;
if (!strcmp(z,"bigphi"))
break;
return -1;
case 'i' : if (!strcmp(z,"infinity"))
break;
if (!strcmp(z,"infty"))
break; /* accept TeX notation for infinity */
return -1;
case 'g' : if (!strcmp(z,"gamma"))
break;
return -1;
case 'd' : if (!strcmp(z,"delta"))
break;
return -1;
case 'e' : if (!strcmp(z,"epsilon"))
break;
return -1;
case 'l' : if (!strcmp(z,"lambda"))
break;
return -1;
case 'm' : if (!strcmp(z,"mu"))
break;
return -1;
case 'p' : if (!strcmp(z,"phi"))
break;
if (!strcmp(z,"pi"))
break;
return -1;
case 's' : if (!strcmp(z,"sigma"))
break;
return -1;
default : return -1;
}
*ans = make_atom_from_string2(z);
*out = in+i;
return 0;
}
#undef DIM
/*_______________________________________________________________*/
/* number must recognize integers, even ones which must be bignums.
But it must not call bignums.c, so that bignums.c can be overlaid
in the same space as the parser. Hence the parser does not actually
create bignums. Instead, when it processes a bignum it creates an
object with functor INTEGER, but the argument, instead of a bignum, is
just a string for display by confirm_problem.
Number must also recognize floats.
But it does NOT recognize negative numbers, which are parsed as
terms with functor -. Negative numbers don't enter MATHPERT at all.
*/
int number( term *p, char *in, char **out)
{ int i;
int initialzerocount = 0;
unsigned long m;
char *marker = in;
char *marker2;
double ans;
int count = 0;
if (! isdigit(*in) && *in != decimalchar )
return -1;
/* Ignore initial zeroes: */
while(*marker == '0')
{ ++marker;
++initialzerocount;
}
if( initialzerocount && !isdigit(*marker) && *marker != decimalchar)
{ *p = make_int(0);
*out = marker;
return 0;
}
if(initialzerocount && *marker == ',' && decimalchar == ',' && !isdigit(marker[1]))
{ *p = make_int(0);
*out = marker;
return 0;
}
if(initialzerocount)
in += initialzerocount;
/* decide if this is a floating-point or integer number */
while( isdigit(*marker) )
{ ++marker;
++ count;
}
if( decimalchar == ',' && count == 0 && *marker == decimalchar && initialzerocount == 0)
return -1; /* in French, ,3 must be written 0,3 */
if( *marker == decimalchar && isdigit(marker[1]))
/* it's a decimal number */
{ if(count >= 308)
{ *out = in;
return 301; /* too large a decimal number */
/* a VERY unlikely error--user enters 308 digits ! */
}
++marker;
++count; /* pass the decimal point */
while(isdigit(*marker) )
{ ++ marker;
++ count; /* fractional part */
}
if(marker[0] == 'e' && (marker[1] == '+' || marker[1] == '-') &&
isdigit(marker[2]) && isdigit(marker[3]) && isdigit(marker[4])
)
/* an e-notation number like 4.56e+002 */
count += 5;
marker = callocate(count + 1, sizeof(char));
if(marker == NULL)
nospace();
for(i=0; i< count; i++)
{ if(in[i] == decimalchar)
marker[i] = '.' ;
else
marker[i] = in[i];
}
marker[count] = '\0';
if(count == 1 && marker[0] == '.')
return -1; /* e.g. in French, "," is not a number. But atof will succeed
on it and make it zero. */
/* because atof is locale-sensitive, this probably doesn't work right
in French Win32. I don't know what atof does in French Win16 or when
compiled as a 16-bit program and run on French Win32.
*/
ans = atof(marker);
free2(marker);
*p = make_double(ans);
*out = in + count;
return 0;
}
/* Now it's not a float, so it must be an integer */
marker = callocate(count+1,sizeof(char));
if(marker ==NULL)
nospace();
for(i=0; i<count; i++)
marker[i] = in[i];
marker[count] = '\0';
m = atol(marker);
/* Now, was there overflow, or not? */
marker2 = callocate(count+1,sizeof(char));
if(marker2 == NULL)
nospace();
ltoa(m,marker2,10); /* convert m back to a string */
if( strcmp(marker,marker2)) /* overflow, use bignums */
/* Note bignums are used if a LONG overflows, not
only if an UNSIGNED LONG overflows, because Mathpert
uses signed longs for integers */
{ free2(marker2);
*p = make_fake_bignum(marker);
free2(marker); /* make_fake_bignum allocates a new copy */
bignumflag = 1; /* this global variable is set and examined by bparse */
*out = in + count;
return 0;
}
else /* no overflow */
{ *p = make_int(m);
*out = in+count;
free2(marker);
free2(marker2);
return 0;
}
}
/*_____________________________________________________________________*/
/* aterm --> '*', blank_list,afactor, aterm.
aterm --> '/', blank_list,afactor,term1.
aterm --> afactor,aterm.
aterm --> blank_list.
Thus identical to 'term1' but won't take a factor which is a function_term.
It's called after a prefix function like log or sqrt to get
sqrt x sqrt y parsed as (sqrt x) * (sqrt y)
*/
static int aterm(term x, term *t, char *in, char **out)
{ int err,i;
char *next, *rest;
term f,newt,newx;
if( in[0] == '/' ) /* aterm --> '/', blank_list, pfactor, term1. */
{ blank_list(in+1,&next);
err = afactor(&f,next,&rest);
if(err>0)
{ *out = rest;
return err;
}
if(err<0)
{ *out = next;
return 270; /* expression expected */
}
newt = make_term('/',2);
ARGREP(newt,0,x);
ARGREP(newt,1,f);
err = term1(newt,t,rest,out);
if(err>0)
return err;
if(err<0)
{ *out = rest;
return 271; /* expression expected*/
}
return 0;
}
if (in[0] == '*' ) /* aterm --> '*', blank_list, afactor, aterm. */
blank_list(in+1,&next);
else if( unwritten_mult ) /* a global variable */
blank_list(in,&next);
else
{ *out = in;
return 272; /* expression expected */
}
err = afactor(&f,next,&rest);
if (err > 0)
{ *out = rest;
return err;
}
if (err < 0) /* aterm --> blank_list. */
{ blank_list(next,out);
*t = x;
return 0;
}
if (FUNCTOR(x) == '*' ) /* then append the arguments */
{ newx = make_term('*',(unsigned short)(ARITY(x)+1));
for(i=0;i<ARITY(x);i++)
ARGREP(newx,i,ARG(i,x));
RELEASE(x);
ARGREP(newx,ARITY(x),f);
err = aterm(newx,t,rest,out);
if(err>0)
return err;
if(err<0)
{ *out = rest;
return 274; /* expression expected */
}
}
else /* FUNCTOR(x) != '*' */
{ newx = make_term('*',2);
ARGREP(newx,0,x);
ARGREP(newx,1,f);
err = aterm(newx,t,rest,out);
if(err>0)
return err;
if(err<0)
{ *out = rest;
return 275; /* expression expected */
}
}
return 0;
}
/*_____________________________________________________________________*/
/* afactor --> aprimary, factor1. */
static int afactor(term *f, char *in, char **out)
{ int err;
char *next;
term p;
err = primary(1,&p,in,&next); /* the 1 says this is 'aprimary' */
if(err > 0)
{ *out = next;
return err;
}
if (err < 0)
{ *out = in;
return -1;
}
err = factor1(p,f,next,out);
if (err > 0)
return err;
if (err < 0)
{ *out = in;
return -1;
}
return 0;
}
/*______________________________________________________________________*/
static int funcname( unsigned short *f, char *in, char **out)
/* returns indirectly a value *f for use as a functor by make_term;
Return value -1 when the input is not a function name
2 when the function symbol is new (so may not turn out to
be a function name)
0 for success
some other error returns are possible, see comments in the code.
*/
/* It must not be case-sensitive with regard to known functors; thus
'sin' and 'Sin' and 'SIN' are all the same; but it must be case-sensitive
with regard to unknown functors. The main exception is one-character
built-in functors: these must be typed in upper-case. This applies
also to Bessel functions (which parse to binary functions with one-character
functors, even though typed as J0(x) or Y0(x)). Another exception is
Re[x] and Im[x], which have to be typed with capital R and I.
*/
{ char buffer[32]; /* maximum length of functor names is 31 */
char *marker;
int i=0;
int j=0;
int len;
long g;
int TeXflag = 0;
if(in[0] == '\\')
{ TeXflag = 1;
++in; /* ignore initial backslash, as in "\sin x" */
}
if (! isalpha(in[0]))
return -1; /* this is no function name */
if(isalpha(in[1])) /* convert names longer than one character to uppercase */
{ while( (i<31) && isalpha(in[i]))
{ buffer[i] = (char) toupper(in[i]);
i++;
}
}
else
{ i=1;
buffer[0] = in[0];
}
if (isalpha(in[i]))
{ *out = TeXflag ? in-1 : in;
return 312; /* names cannot exceed 31 characters */
}
buffer[i] = '\0'; /* now buffer contains an upper-case copy of the name,
unless the name was only one character, in which
case it contains it lower-case or upper-case, as
it originally occurred. */
g = strip_functor(buffer,&len); /* so now check if it begins with a built-in functor */
*f = (unsigned short) g;
if( (*f==REALPART || *f==IMAGPART || *f==BETAFUNCTION || *f==GAMMA) && in[0] > 96)
return -1;
/* accept only upper-case first letter for Re, Im, Gamma, and Beta */
if (g > 0) /* a built-in functor */
{ i = len;
while(in[i] == 32)
++i;
*out = in+i;
if(
(g == BESSELI || g == BESSELY || g == BESSELK || g == BESSELJ) &&
(**out == '(' || **out == '[')
)
{ /* we want to accept Y(x) as a new (non-Bessel) function */
marker = *out + 1;
while(*marker == 32 || isalnum(*marker))
++marker;
if(*marker == ')' || *marker == ']')
{ *f = in[0]; /* e.g. 'K', not BESSELK */
return 2;
}
}
return 0;
}
/* now, is buffer equal to any entry in the 'functors' array? */
/* There will typically be zero or only one or two entries in this
array, so it's not worthwhile to keep hash tables */
while( (j<31) && isalnum(in[j]))
{ buffer[j] = in[j]; /* copy the putative function name into
buffer retaining case sensitivity */
j++;
}
buffer[j] = '\0';
if(i==1) /* a one-character functor */
{ if(isalpha(in[0])) /* accept it just like that */
{ *f = in[0];
while(in[i] == 32) ++i;
*out = in+i;
return 2; /* signifying a new 1-character function */
}
else
return -1; /* not an acceptable function name */
}
return -1; /* not a built-in or pre-defined funcname */
}
/*______________________________________________________________________*/
static short strip_functor(char *buffer, int *len)
/* if buffer contains a string that begins with a built-in functor
name of length 3 or more, return the corresponding #defined index, e.g. SQRT, and the
length of the name, e.g. 4 for "sqrt". If buffer is exactly equal to
a functor of length 1 or 2, return the functor index and length in that
case also. The buffer may contain
more characters, e.g. "sqrtx". For example if the buffer contains
"coshx", then COSH will be returned with 4 in *len. The hyperbolic
functions are the only cases in which one function name has another
for an initial segment. Return -1 in case there is no built-in
functor name as an initial segment of buffer. Buffer is presumed to
contain only upper-case characters.
This way, "sqrtx" will parse as sqrt(x).
*/
{ switch(buffer[0])
{ case 'A':
switch (buffer[1])
{ case 'B' :
if(buffer[2] == 'S')
{ *len = 3;
return ABS;
}
break;
case 'C' :
if(buffer[2] == '0' && buffer[3] == 'S' && buffer[4] == 'H')
{ *len = 5;
return ACOSH;
}
if (buffer[2] == '0' && buffer[3] == 'T' && buffer[4] == 'H')
{ *len = 5;
return ACOTH;
}
if (buffer[2] == 'S' && buffer[3] == 'C' && buffer[4] == 'H')
{ *len = 5;
return ACSCH;
}
if (buffer[2] == '0' && buffer[3] == 'S' )
{ *len = 5;
return ACOS;
}
if (buffer[2] == '0' && buffer[3] == 'T')
{ *len = 5;
return ACOT;
}
if (buffer[2] == 'S' && buffer[3] == 'C')
{ *len = 5;
return ACSC;
}
break;
case 'L' :
if (buffer[2] == 'L')
{ *len = 3;
return FORALL;
}
break;
case 'N' :
if(buffer[2] == 'D')
{ *len = 3;
return AND;
}
break;
case 'R' :
if(buffer[2] == 'C')
switch(buffer[3])
{ case 'S':
if(buffer[4] == 'I' && buffer[5] == 'N' && buffer[6] == 'H')
{ *len = 7;
return ASINH;
}
if(buffer[4] == 'I' && buffer[5] == 'N')
{ *len = 6;
return ASIN;
}
if(buffer[4] == 'E' && buffer[5] == 'C' && buffer[6] == 'H')
{ *len = 7;
return ASECH;
}
if(buffer[4] == 'E' && buffer[5] == 'C')
{ *len = 6;
return ASEC;
}
break;
case 'C':
if(buffer[4] == 'O' && buffer[5] == 'S' && buffer[6] == 'H')
{ *len = 7;
return ACOSH;
}
if(buffer[4] == 'O' && buffer[5] == 'S')
{ *len = 6;
return ACOS;
}
if(buffer[4] == 'O' && buffer[5] == 'T' && buffer[6] == 'H')
{ *len = 7;
return ACOTH;
}
if(buffer[4] == 'O' && buffer[5] == 'T')
{ *len = 6;
return ACOT;
}
if(buffer[4] == 'S' && buffer[5] == 'C' && buffer[6] == 'H')
{ *len = 7;
return ACSCH;
}
if(buffer[4] == 'S' && buffer[5] == 'C')
{ *len = 6;
return ACSC;
}
break;
case 'T':
if(buffer[4] == 'A' && buffer[5] == 'N' && buffer[6] == 'H')
{ *len = 7;
return ATANH;
}
if(buffer[4] == 'A' && buffer[5] == 'N')
{ *len = 6;
return ATAN;
}
break;
}
break;
case 'S' :
if(buffer[2] == 'E' && buffer[3] == 'C' && buffer[4] == 'H')
{ *len = 5;
return ACSCH;
}
if(buffer[2] == 'E' && buffer[3] == 'C')
{ *len = 4;
return ASEC;
}
if(buffer[2] == 'I' && buffer[3] == 'N' && buffer[4] == 'H')
{ *len = 5;
return ASINH;
}
if(buffer[2] == 'I' && buffer[3] == 'N')
{ *len = 3;
return ASIN;
}
break;
case 'T':
if(buffer[2] == 'A' && buffer[3] == 'N' && buffer[4] == 'H')
{ *len = 5;
return ATANH;
}
if(buffer[2] == 'A' && buffer[3] == 'N')
{ *len = 4;
return ATAN;
}
break;
}
break;
case 'B':
if(!strncmp(buffer,"BINOMIAL",8))
{ *len = 8;
return BINOMIAL;
}
if(!strncmp(buffer,"BETA",4))
{ *len = 4;
return BETAFUNCTION;
}
break;
case 'C':
switch(buffer[1])
{ case 'O':
if(buffer[2] == 'S' && buffer[3] == 'H')
{ *len = 4;
return COSH;
}
if(buffer[2] == 'S' && !strncmp(buffer,"COSINTEGRAL",11))
{ *len = 11;
return COSINTEGRAL;
}
if(buffer[2] == 'S')
{ *len = 3;
return COS;
}
if(buffer[2] == 'T' && buffer[3] == 'H')
{ *len = 4;
return COTH;
}
if(buffer[2] == 'T')
{ *len = 3;
return COT;
}
break;
case 'S':
if(buffer[2] == 'C' && buffer[3] == 'H')
{ *len = 4;
return CSCH;
}
if(buffer[2] == 'C')
{ *len = 3;
return CSC;
}
break;
case 'A':
if(!strncmp(buffer,"CASES",5))
{ *len = 5;
return CASES;
}
break;
}
break;
case 'D':
if(!strncmp(buffer,"DEG",3))
{ *len = 3;
return DEG;
}
if(!strncmp(buffer,"DET",3))
{ *len = 3;
return DET;
}
if(!strncmp(buffer,"DIFF",4))
{ *len = 4;
return DIFF;
}
if(!strncmp(buffer,"DIGAMMA",7))
{ *len = 7;
return DIGAMMA;
}
break;
case 'E':
if(!strncmp(buffer,"ERFC",4))
{ *len = 4;
return ERFC;
}
if(!strncmp(buffer,"ERF",3))
{ *len = 3;
return ERF;
}
if (!strncmp(buffer,"EVAL",4))
{ *len = 4;
return EVAL;
}
if(!strncmp(buffer,"EXPINTEGRALE",12))
{ *len = 12;
return EXPINTEGRALE;
}
if (!strncmp(buffer,"EXPINTEGRALI",12))
{ *len = 12;
return EXPINTEGRALE;
}
if (!strncmp(buffer,"EXISTS",6))
{ *len = 6;
return EXISTS;
}
break;
case 'F':
if (!strncmp(buffer,"FLOOR",5))
{ *len = 5;
return FLOOR;
}
if(!strncmp(buffer,"FACTORIAL",9))
{ *len = 9;
return FACTORIAL;
}
break;
case 'G':
if(!strncmp(buffer,"GCD",3))
{ *len = 3;
return GCD;
}
if (!strncmp(buffer,"GAMMA",5))
{ *len = 5;
return GAMMA;
}
break;
case 'I' :
if(!strncmp(buffer,"INTEGRAL",8))
{ *len = 8;
return INTEGRAL;
}
if(!strncmp(buffer,"IF",2))
{ *len = 2;
return IF;
}
if(!strncmp(buffer,"INCOMPLETEBETA",14))
{ *len = 14;
return INCOMPLETEBETA;
}
if(!strncmp(buffer,"INCOMPLETEGAMMAP",16))
{ *len = 16;
return INCOMPLETEGAMMAP;
}
if(!strncmp(buffer,"INCOMPLETEGAMMA",15))
{ *len = 15;
return INCOMPLETEGAMMA;
}
if(buffer[1] == 'M')
{ *len = 2;
return IMAGPART;
}
if(!strncmp(buffer,"INVERSE",7))
{ *len = 7;
return MATRIXINVERSE;
}
if(!strcmp(buffer,"I"))
/* Not strncmp; Ix will be parsed as I times x */
{ *len = 1;
return BESSELI;
}
break;
case 'J':
if (!strcmp(buffer,"J"))
{ *len = 1;
return BESSELJ;
}
break;
case 'K':
if (!strcmp(buffer,"K"))
{ *len = 1;
return BESSELK;
}
break;
case 'L':
if (!strncmp(buffer,"LOG",3))
{ *len = 3;
return LOG;
}
if (buffer[1] == 'N')
{ *len = 2;
return LN;
}
if(!strncmp(buffer,"LIMIT",5))
{ *len = 5;
return LIMIT;
}
if (!strncmp(buffer,"LIM",3))
{ *len = 3;
return LIMIT;
}
if(!strncmp(buffer,"LOGINTEGRAL",11))
{ *len = 11;
return LOGINTEGRAL;
}
if (!strncmp(buffer,"LAM",3))
{ *len = 3;
return LAM;
}
break;
case 'M':
if(!strncmp(buffer,"MATRIX",5))
{ *len = 5;
return MATRIX;
}
if (!strncmp(buffer,"MOD",3))
{ *len = 3;
return MOD;
}
if(!strncmp(buffer,"MIN",3))
{ *len = 3;
return MINFUNCTOR;
}
if(!strncmp(buffer,"MAX",3))
{ *len = 3;
return MAXFUNCTOR;
}
break;
case 'N':
if (!strncmp(buffer,"NOT",3))
{ *len = 3;
return NOT;
}
break;
case 'P':
if (!strcmp(buffer,"PE"))
/* strcmp, not strncmp; pex parses as p times e time x */
{ *len = 2;
return WEIERSTRASSP;
}
if (!strncmp(buffer,"PRODUCT",7))
{ *len = 7;
return PRODUCT;
}
if (!strncmp(buffer,"POLYGAMMA",9))
{ *len = 9;
return POLYGAMMA;
}
break;
case 'R':
if (!strncmp(buffer,"ROOT",4))
{ *len = 4;
return ROOT;
}
if (!strcmp(buffer,"RE")) /* not strncmp; rex parses as r time e time x */
{ *len = 2;
return REALPART;
}
break;
case 'S':
if (!strncmp(buffer,"SINH",4))
{ *len = 4;
return SINH;
}
if (!strncmp(buffer,"SININTEGRAL",11))
{ *len = 11;
return SININTEGRAL;
}
if (!strncmp(buffer,"SIN",3))
{ *len = 3;
return SIN;
}
if (!strncmp(buffer,"SECH",4))
{ *len = 4;
return SECH;
}
if (!strncmp(buffer,"SEC",3))
{ *len = 3;
return SEC;
}
if (!strncmp(buffer,"SQRT",4))
{ *len = 4;
return SQRT;
}
if (!strncmp(buffer,"SUM",3))
{ *len = 3;
return SUM;
}
if (!strcmp(buffer,"SG")) /* not strncmp; sgx parses as s times g times x */
{ *len = 2;
return SG;
}
break;
case 'T':
if (!strncmp(buffer,"TANH",4))
{ *len = 4;
return TANH;
}
if (!strncmp(buffer,"TAN",3))
{ *len = 3;
return TAN;
}
break;
case 'V':
if (!strncmp(buffer,"VECTOR",6))
{ *len = 6;
return VECTOR;
}
break;
case 'W':
if (!strncmp(buffer,"WEIERSTRASSP",12))
{ *len = 12;
return WEIERSTRASSP;
}
break;
case 'Y':
if (!strcmp(buffer,"Y")) /* not strncmp */
{ *len = 1;
return BESSELY;
}
break;
case 'Z':
if (!strncmp(buffer,"ZETA",4))
{ *len = 4;
return RIEMANNZETA;
}
break;
}
return -1; /* not a known functor */
}
/*________________________________________________________________________*/
MEXPORT_PARSER short EXPORT string_functor(char *buffer)
/* buffer contains an all-upper-case string. If it is a built-in functor,
return the corresponding #-defined value; else return -1 */
/* Elliptic integrals, hypergeometric functions, Legendre polynomials
can't be parsed--they only arise as answers, at least for now. Since this
is also called by readdoc, documents involving such answers can't be
opened yet either. */
{
switch(buffer[0])
{ case 'A':
switch (buffer[1])
{ case 'B' : if (!strcmp(buffer,"ABS")) return ABS;
break;
case 'C' : if (!strcmp(buffer,"ACOS")) return ACOS;
if (!strcmp(buffer,"ACOT")) return ACOT;
if (!strcmp(buffer,"ACSC")) return ACSC;
if (!strcmp(buffer,"ACOSH")) return ACOSH;
if (!strcmp(buffer,"ACOTH")) return ACOTH;
if (!strcmp(buffer,"ACSCH")) return ACSCH;
break;
case 'L' : if (!strcmp(buffer,"ALL")) return FORALL;
break;
case 'N' : if (!strcmp(buffer,"AND")) return AND;
break;
case 'R' : if (!strcmp(buffer,"ARCSIN")) return ASIN;
if (!strcmp(buffer,"ARCCOS")) return ACOS;
if (!strcmp(buffer,"ARCTAN")) return ATAN;
if (!strcmp(buffer,"ARCSEC")) return ASEC;
if (!strcmp(buffer,"ARCCSC")) return ACSC;
if (!strcmp(buffer,"ARCCOT")) return ACOT;
if (!strcmp(buffer,"ARCSINH")) return ASINH;
if (!strcmp(buffer,"ARCCOSH")) return ACOSH;
if (!strcmp(buffer,"ARCTANH")) return ATANH;
if (!strcmp(buffer,"ARCSECH")) return ASECH;
if (!strcmp(buffer,"ARCCSCH")) return ACSCH;
if (!strcmp(buffer,"ARCCOTH")) return ACOTH;
break;
case 'S' : if (!strcmp(buffer, "ASEC")) return ASEC;
if (!strcmp(buffer, "ASECH")) return ASECH;
if (!strcmp(buffer,"ASIN")) return ASIN;
if (!strcmp(buffer,"ASINH")) return ASINH;
break;
case 'T' : if (!strcmp(buffer, "ATAN")) return ATAN;
if (!strcmp(buffer, "ATANH")) return ATANH;
break;
}
break;
case 'B': if (!strcmp(buffer,"BINOMIAL")) return BINOMIAL;
if (!strcmp(buffer,"BETA")) return BETAFUNCTION;
break;
case 'C': if (!strcmp(buffer,"COS")) return COS;
if (!strcmp(buffer,"COSH")) return COSH;
if (!strcmp(buffer,"COT")) return COT;
if (!strcmp(buffer,"COTH")) return COTH;
if (!strcmp(buffer,"CSC")) return CSC;
if (!strcmp(buffer,"CSCH")) return CSCH;
if (!strcmp(buffer,"CASES")) return CASES;
if (!strcmp(buffer,"COSINTEGRAL")) return COSINTEGRAL;
break;
case 'D': if (!strcmp(buffer,"DEG")) return DEG;
if (!strcmp(buffer,"DET")) return DET;
if (!strcmp(buffer,"DIFF")) return DIFF;
if (!strcmp(buffer,"DIGAMMA")) return DIGAMMA;
break;
case 'E': if (!strcmp(buffer,"ERF")) return ERF;
if (!strcmp(buffer,"ERFC")) return ERFC;
if (!strcmp(buffer,"EVAL")) return EVAL;
if (!strcmp(buffer,"EXPINTEGRALE")) return EXPINTEGRALE;
if (!strcmp(buffer,"EXPINTEGRALI")) return EXPINTEGRALE;
if (!strcmp(buffer,"EXISTS")) return EXISTS;
break;
case 'F': if (!strcmp(buffer,"FLOOR")) return FLOOR;
if( !strcmp(buffer,"FACTORIAL")) return FACTORIAL;
break;
case 'G': if (!strcmp(buffer,"GCD")) return GCD;
if (!strcmp(buffer,"GAMMA")) return GAMMA;
break;
case 'I' : if (!strcmp(buffer,"INTEGRAL")) return INTEGRAL;
if (!strcmp(buffer,"IF")) return IF;
if (!strcmp(buffer,"I")) return BESSELI;
if (!strcmp(buffer,"INCOMPLETEBETA")) return INCOMPLETEBETA;
if (!strcmp(buffer,"INCOMPLETEGAMMA")) return INCOMPLETEGAMMA;
if (!strcmp(buffer,"INCOMPLETEGAMMAP")) return INCOMPLETEGAMMAP;
if (!strcmp(buffer,"IM")) return IMAGPART;
if (!strcmp(buffer,"INVERSE")) return MATRIXINVERSE;
break;
case 'J': if (!strcmp(buffer,"J")) return BESSELJ;
break;
case 'K': if (!strcmp(buffer,"K")) return BESSELK;
break;
case 'L': if (!strcmp(buffer,"LOG")) return LOG;
if (!strcmp(buffer,"LN")) return LN;
if (!strcmp(buffer,"LIM")) return LIMIT;
if (!strcmp(buffer,"LIMIT")) return LIMIT;
if (!strcmp(buffer,"LOGINTEGRAL")) return LOGINTEGRAL;
if (!strcmp(buffer,"lam")) return LAM;
break;
case 'M': if (!strcmp(buffer,"MATRIX")) return MATRIX;
if (!strcmp(buffer,"MOD")) return MOD;
if(!strcmp(buffer,"MIN")) return MINFUNCTOR;
if(!strcmp(buffer,"MAX")) return MAXFUNCTOR;
break;
case 'N': if (!strcmp(buffer,"NOT")) return NOT;
break;
case 'P': if (!strcmp(buffer,"PE")) return WEIERSTRASSP;
if (!strcmp(buffer,"PRODUCT")) return PRODUCT;
if (!strcmp(buffer,"POLYGAMMA")) return POLYGAMMA;
break;
case 'R': if (!strcmp(buffer,"ROOT")) return ROOT;
if (!strcmp(buffer,"RE")) return REALPART;
break;
case 'S': if (!strcmp(buffer,"SIN")) return SIN;
if (!strcmp(buffer,"SINH")) return SINH;
if (!strcmp(buffer,"SEC")) return SEC;
if (!strcmp(buffer,"SECH")) return SECH;
if (!strcmp(buffer,"SQRT")) return SQRT;
if (!strcmp(buffer,"SUM")) return SUM;
if (!strcmp(buffer,"SININTEGRAL")) return SININTEGRAL;
if (!strcmp(buffer,"SG")) return SG;
break;
case 'T': if (!strcmp(buffer,"TAN")) return TAN;
if (!strcmp(buffer,"TANH")) return TANH;
break;
case 'V': if (!strcmp(buffer,"VECTOR")) return VECTOR;
break;
case 'W': if (!strcmp(buffer,"WEIERSTRASSP")) return WEIERSTRASSP;
break;
case 'Y': if (!strcmp(buffer,"Y")) return BESSELY;
break;
case 'Z': if (!strcmp(buffer,"ZETA")) return RIEMANNZETA;
break;
}
return -1; /* not a known functor */
}
/*______________________________________________________________________*/
MEXPORT_PARSER short EXPORT correct_arity(short x)
/* return the correct arity of a built-in functor */
/* or -1 if it isn't determined */
/* is not used for log, logb, diff, or integral, or for +, *, and, or; */
/* returns 1 for Bessel functions even though the index gets parsed as an
argument; so after_funcname gets 1 for nargs and adds an extra arg
for the subscript. */
{ int index;
if (UNARY(x))
return 1;
if ((x) < BINARYBOUND)
return 2;
if ((x == SUM) || (x == PRODUCT))
return 4; /* but 5 is also acceptable; the last arg gives display info */
index = is_defined(x);
if(index != -1)
{ /* look up arity of user-defined functor */
term lhs, rhs;
get_definition(index,&lhs,&rhs);
return ARITY(lhs);
}
/* now for 'special functions' >= GAMMA: */
switch(x)
{ case GAMMA : /* fall-through */
case DIGAMMA:
case COSINTEGRAL:
case SININTEGRAL:
case LOGINTEGRAL:
case ERF:
case ERFC:
case EXPINTEGRALI:
case COMPLETE_ELLIPTIC1:
case COMPLETE_ELLIPTIC2: return 1;
case COMPLETE_ELLIPTIC3: return 2;
case ELLIPTICF: return 2;
case ELLIPTICE: return 2;
case ELLIPTICPI: return 3;
case EXPINTEGRALE: return 2;
case BETAFUNCTION: return 2;
case INCOMPLETEBETA: return 3;
case INCOMPLETEGAMMA: return 2;
case INCOMPLETEGAMMAP: return 2;
case EXISTS: return 2;
case FORALL: return 2;
case EVAL: return 4;
}
return -1;
}
/*_________________________________________________________________*/
static int intervalterm(term expr, term *ans, char *in, char **out)
/* parse a<b<c ; a <= b < c etc. */
/* in has the form <= c where e.g. a<b has already been parsed;
expr holds the term (a<b) and we want to return
and(expr,b<=c) in *ans */
{ term c,right;
int err;
unsigned short g;
if(in[1] == '=')
{ g = LE;
err = lfactor(&c,in+2,out);
}
else
{ g = '<';
err = lfactor(&c,in+1,out);
}
if(err)
{ *out = in;
return err;
}
right = make_term(g,2);
ARGREP(right,1,c);
parser_copy(ARG(1,expr),ARGPTR(right));
/* Not ARGREP(right,0,ARG(1,expr)) because
then there are two pointers to this same term in the
result *ans of this parse; when we call destroy_term on it,
the second time we come to the subterm it will crash.
In short: destroy_term can only be used on TREE terms,
not DAGs, so the parser must make only TREES */
*ans = make_term(AND,2);
ARGREP(*ans,0,expr);
ARGREP(*ans,1,right);
SETINTERVAL(*ans); /* mark a bit to indicate this is an interval */
return 0;
}
/*_____________________________________________________________________*/
static term make_fake_bignum(char *x)
/* make a term that looks like a bignum but only points to a display
string of digits and commas. This is the kind of term returned
by the parser so that it doesn't have to call bignum.c */
/* display of bignums is controlled by global variable 'separator'.
separator == 0 means print using space, (blocks of 6 characters)
== 1 means no separation of digits
== 2 means blocks of 3 digits separated by commas
> 2 means blocks of 3 digist separated by ascii code specified
by separator.
*/
{ term ans;
int length = strlen(x);
char sepchar;
SETFUNCTOR(ans,0,1);
ans.info = 0; /* initialize the info field to zero */
SETTYPE(ans,BIGNUM); /* but don't SETAE; thus a fake bignum has no value */
switch (separator)
{ case 1: /* no separation of digits */
if( (ans.args = (void *) callocate(length+1,sizeof(char))) == NULL)
{ SETFUNCTOR(ans,ILLEGAL,0); nospace();}
else strcpy((char *)ARGPTR(ans),x);
return ans;
case 0: /* print using blocks of 6 chars separated by space */
if( ( ans.args = (void *) callocate( 6*(length+2)/6,sizeof(char)))==NULL)
{ SETFUNCTOR(ans,ILLEGAL,0); nospace();}
else
{ int i=0,j=0;
int comma = (length % 6);
if( comma == 0) comma = 6;
while(i < length)
{ ((char *) ans.args)[j] = x[i];
i++;
j++;
switch (comma)
{ case 0 : comma = 6; break;
default : --comma; break;
}
if(comma==0) { ((char *) ans.args)[j] = 32; ++j; comma=6;}
}
((char *) ans.args)[j-1] = '\0'; /* overwrite last space */
}
return ans;
case 2: /* print using comma */
default:
sepchar = separator == 2 ? ',' : separator;
if( ( ans.args = (void *) callocate( 4*(length+2)/3,sizeof(char)))==NULL)
{ SETFUNCTOR(ans,ILLEGAL,0);
nospace();
return ans;
}
else
{ int i=0,j=0;
int comma = (length % 3);
if( comma == 0)
comma = 3;
while(i < length)
{ ((char *) ans.args )[j] = x[i];
i++;
j++;
switch (comma)
{ case 0 : comma = 3; break;
default : --comma; break;
}
if(comma==0)
{ ((char *) ans.args)[j] = sepchar;
++j;
comma=3;
}
}
((char *) ans.args)[j-1] = '\0'; /* overwrite last comma */
}
return ans;
}
}
/* _________________________________________________________________*/
static unsigned short string_to_atom(char *x)
{ if(x[1] == '\0') /* a one-symbol atom */
{
#if 0
unsigned short k = asciigreek(x[0]); /* is it extended ASCII? */
if(k)
return k;
#endif
return x[0]; /* else return the ASCII code of that symbol */
}
switch( x[0])
{ case 'a':
if( !strcmp(x,"alpha")) return ALPHA;
break;
case 'b':
if( !strcmp(x,"beta")) return BETA;
break;
case 'd':
if( !strcmp(x,"delta")) return DELTA;
break;
case 'e':
if( !strcmp(x,"epsilon")) return EPSILON;
break;
case 'f':
if( !strcmp(x,"false")) return FALSEFUNCTOR;
break;
case 'g':
if( !strcmp(x,"gamma")) return LITTLEGAMMA;
break;
case 'i':
if( !strcmp(x,"infinity")) return INFINITY;
break;
case 'l':
if( !strcmp(x,"lambda")) return LAMBDA;
break;
case 'm':
if( !strcmp(x,"mu")) return MU;
break;
case 'p':
if( !strcmp(x,"phi")) return PHI;
if( !strcmp(x,"pi")) return PI_ATOM;
break;
case 's':
if( !strcmp(x,"sigma")) return SIGMA;
break;
case 't':
if( !strcmp(x,"theta")) return THETA;
if( !strcmp(x,"true")) return TRUEFUNCTOR;
break;
case 'z':
if( !strcmp(x,"zeta")) return RIEMANNZETA;
break;
}
assert(newatom != NULL);
return newatom(x);
}
/*______________________________________________________________________*/
/* make_atom_from_string2 is the way in which atoms are originally to be
created, even if the string has length 1. This function calls permalloc
for string space. (Since 'newatom' is passed to parser.dll as a function,
the calling program's newatom function will get used.)
*/
static term make_atom_from_string2( char *a)
/* DON'T CHANGE THIS. Change the non-static version and copy it */
{ short atom;
term ans;
atom = string_to_atom(a);
ans = MAKE_ATOM(atom);
/* Now set the type of the variable */
ZEROINFO(ans); /* make sure the .info field is zero */
if(atom == 'i')
{ if(complex)
SETCOMPLEX(ans);
else
SETTYPE(ans,INTEGER);
}
else if( *a == 'n' || *a == 'm' || *a == 'k' || *a == 'j')
SETTYPE(ans,INTEGER);
else if (complex)
{ if(*a == 'x' || *a == 'y' || *a == 'u' || *a == 'v' ||
*a == 'X' || *a == 'Y' || *a == 'U' || *a == 'V'
)
SETTYPE(ans,R);
else
SETTYPE(ans,DCOMPLEX);
}
else
SETTYPE(ans,R);
return ans;
}
/*_______________________________________________________________*/
#if 0 /* obsolete */
/* return the #-defined values ALPHA, BETA, and so on when
given the extended ascii code, or zero if not an extended ascii
code of a Greek character. */
#ifdef _Windows
static int charset = 1;
#else
static int charset = 0;
#endif
short EXPORT asciigreek(char n)
{ if(charset == 1) /* Under Windows, you can't enter symbols directly */
return 0;
else /* charset = 0, under DOS or using OEM character set */
{ switch(n)
{ case '�' : return ALPHA; /* 224 */
case '�' : return BETA;
case '�' : return GAMMA; /* 226 */
case '�' : return PI_ATOM; /* 227 */
case '�' : return SIGMA; /* 229 */
case '�' : return MU;
case '�' : return LITTLEGAMMA;
case '�' : return THETA; /* 233 */
case '�' : return DELTA; /* 235 */
case '�' : return PHI; /* 237 */
case '�' : return EPSILON; /* 238 */
case '�' : return INFINITY; /* 236 */
default : return 0;
}
}
}
#endif
/*________________________________________________________________________*/
static int fix_bignums(term *t)
/* replace 'fake' bignums with the real McCoy */
/* must take term * so it can affect the term in the calling environment */
/* calls free2 on the display strings in *t, which are allocated by
parse in the first place. */
{ char *x, *y, *marker, *savex;
unsigned short n;
bignum b;
int i,err;
if(OBJECT(*t) && TYPE(*t)==BIGNUM && !AE(*t) ) /* a fake bignum */
{ x= (char *) ARGPTR(*t); /* pointer to display string */
savex = x;
n = (unsigned short) strlen(x);
if (n== 0xffff)
return 1; /* very unlikely but theoretically possible */
y = callocate(n+1,sizeof(char));
if(y==NULL)
return 1;
/* now copy x to y but delete all spaces and commas */
marker = y;
while(*x)
{ if(*x != 32 && *x != ',')
{ *marker = *x;
++marker;
}
++x;
}
*marker = '\0'; /* terminate string y */
err= string_bignum(y,strlen(y),(bignum *) &b);
free2(y);
free2(savex); /* allocated by parse */
t->args = callocate(1,sizeof(bignum));
if(t->args == NULL)
{ nospace();
return 1;
}
*((bignum *)(t->args)) = b;
SETAE(*t); /* make it a real, not a fake, bignum */
if(err)
return err;
return 0;
}
/* so if we get here t was not a fake bignum */
if(ATOMIC(*t))
return 0; /* do nothing */
for(i=0; i< ARITY(*t);i++)
{ err = fix_bignums((term *) ARGPTR(*t) + i);
if (err)
return err;
}
return 0;
}
/*___________________________________________________________________________*/
MEXPORT_PARSER int EXPORT bparse(parser_control *flags, term *expr, char *in, char **out)
/* parse 'in' producing term expr, if successful,
or pointing out to the unprocessed string if not successful.
Zero return for success */
{ int err;
bignumflag = 0; /* this global variable is set to 1 when bignums parsed */
err = parse(flags, expr,in,out); /* this leaves bignums as 'fakes' */
if (err)
return err;
if(bignumflag==0)
return 0; /* so don't have to waste time with fix_bignums */
err = fix_bignums(expr);
if (err)
return err;
return 0;
}
/*__________________________________________________________________*/
static void parser_copy(term t, term *ans) /* copy a term */
/* This is similar to copy, but uses make_fake_bignum. */
{ int i;
if(OBJECT(t))
{ switch(TYPE(t))
{ case INTEGER:
*ans = make_int(INTDATA(t));
break;
case DOUBLE:
*ans = make_double(DOUBLEDATA(t));
break;
case BIGNUM:
*ans = make_fake_bignum((char *) t.args);
break;
}
ans->info = t.info;
return;
}
if(ISATOM(t))
{ *ans = MAKE_ATOM(FUNCTOR(t));
ans->args = t.args;
ans->info = t.info;
return;
}
*ans = make_term(FUNCTOR(t),ARITY(t));
for(i=0;i<ARITY(t);i++)
parser_copy(ARG(i,t),ARGPTR(*ans) + i);
ans->info = t.info;
}
/*____________________________________________________________________*/
static int ptype(term *t, char *in, char **out)
/* accept a legal type expression. In Mathpert these are only atomic types.
In Weierstrass we will eventually want compound types too.
*/
{ char a = in[0];
unsigned short p;
switch(a)
{ case 'C': p = DCOMPLEX; break;
case 'R': p = R; break;
case 'N': p = NATNUM; break;
case 'Z': p = INTEGER; break;
case 'Q': p = RATIONAL; break;
default:
return -1;
}
*t = make_int(p);
*out = in+1;
return 0;
}
/*____________________________________________________________________*/
static int integer(term *t, char *in, char **out)
/* read an integer if possible */
{ char *marker = in;
int count = 0;
int err;
char *buffer;
while (*marker == 32)
++marker; /* skip initial blanks */
while(isdigit(marker[count]))
++count;
if(count == 0)
return -1;
buffer = (char *) callocate(count+1,sizeof(char));
strncpy(buffer,marker,count);
buffer[count] = 0;
*out = in + count;
err = number(t,buffer,&marker);
return err ? -1 : 0;
}
/* ___________________________________________________________________*/
static ncommas(char *x)
/* return the number of commas at top parentheses-level in x before
the paren count goes negative or a null character is encountered.
Thus it returns 1 on "2,3)" and also 1 on "2,3),," and
also 1 on "2,log(3,4))"
*/
{ char *marker = x;
int count = 0;
int parencount = 0;
while(*marker != 0 && parencount >= 0)
{ if(*marker == '(' || *marker == '{' || *marker == '[')
++parencount;
if(*marker == ',')
++count;
if(*marker == ')' || *marker == '}' || *marker == ']')
--parencount;
++marker;
}
return count;
}
Sindbad File Manager Version 1.0, Coded By Sindbad EG ~ The Terrorists