/*
* BASIC by Phil Cockcroft
*/
#include "bas.h"
/*
* This file contains the numeric evaluation routines and some
* of the numeric functions.
*/
/*
* evalint() is called by a routine that requires an integer value
* e.g. string functions. It will always return an integer. If
* the result will not overflow an integer -1 is returned.
* N.B. most ( all ) routines assume that a negative return is an
* error.
*/
union ffn_vars {
struct {
value _ovr;
value _nvr;
} _ivs;
struct {
STR _ostr;
STR _nstr;
} _svs;
};
#define ovr _ivs._ovr
#define nvr _ivs._nvr
#define ostr _svs._ostr
#define nstr _svs._nstr
#ifdef __STDC__
static void recov_parms(struct entry **, int, union ffn_vars *, int);
static void setdrg(int);
static void hyper_sc(int);
#else
static void recov_parms();
static void setdrg();
static void hyper_sc();
#endif
#ifndef SOFTFP
#ifdef __STDC__
extern double sin(double);
extern double cos(double);
extern double asin(double);
extern double acos(double);
extern double atan(double);
extern double exp(double);
extern double log(double);
extern double sqrt(double);
#else
extern double sin();
extern double cos();
extern double asin();
extern double acos();
extern double atan();
extern double exp();
extern double log();
extern double sqrt();
#endif
static const double logmaxval = LOGMAXVAL;
static const double TWO = 2.0;
static const double INSIG = MAX_INSIG;
static const double logof2 = 0.69314718055994530942;
#endif
itype
evalint()
{
eval();
if(vartype != RVAL)
return(res.i);
if(conv(&res)){
error(INTOVER);
#if 0
if(res.f < ZERO)
res.i = -MAX_INT-1;
else
res.i = MAX_INT;
#endif
}
return(res.i);
}
/*
* evalreal is called in a similar manner to evalint but it always returns
* a real value (in res).
*/
void
evalreal()
{
eval();
if(vartype != RVAL){
cvt(&res);
vartype= RVAL;
}
}
/*
* This structure is only ever used by eval() and so is not declared
* in 'bas.h' with the others.
*/
struct m {
value r1;
int lastop;
int mvalue;
char vty;
};
/*
* eval() will evaluate any numeric expression and return the result
* in the UNION 'res'.
* A valid expression can be any numeric expression or a string
* comparison expression e.g. "as" <> "gh" . String expressions can
* themselves be used in relational tests and also be used with the
* logical operators. e.g. "a" <> "b" and "1" <> a$ is a valid
* expression.
*/
#define SETNOT 1
#define SETMINUS 2
void
eval()
{
register int c;
register struct m *j;
register int i;
value *pp;
int firsttime;
int unaries[2];
struct m restab[6];
j=restab;
j->mvalue=0;
unaries[0] = unaries[1] = 0;
firsttime = 1;
for(;;){
c=getch();
if(c=='-' && firsttime){
if((unaries[0] == SETMINUS) || unaries[1])
error(SYNTAX);
unaries[1] = unaries[0];
unaries[0] = SETMINUS;
continue;
}
else if(c==NOTT){
if(unaries[0] == SETNOT){
unaries[0] = unaries[1];
unaries[1] = 0;
firsttime++;
continue;
}
if(unaries[1])
error(SYNTAX);
unaries[1] = unaries[0];
unaries[0] = SETNOT;
firsttime++;
continue;
}
else if(c & SPECIAL){
if(c == IFUNCN) /* functions that don't have brackets */
(*functs[*point++ & 0177])();
else if(c == IFUNCA){ /* functions that do have brackets */
c = (int)*point++ & 0177;
if(*point++ !='(')
error(SYNTAX); /* functions that do */
(*functb[c])();
if(getch()!=')')
error(SYNTAX);
}
else if(c == OFUNC)
error(SYNTAX);
else if(c == FN)
ffn((struct entry *)0, (STR)0);
else
goto err1;
#ifdef NaN
if(vartype == RVAL && NaN(res.f))
(*fpfunc)();
#endif
}
else if(isletter(c)){
CHAR *sp = --point;
pp= (value *)getname(0); /* we have a variable */
#if 0
if(pp == 0){
point = sp;
ffn((struct entry *)0, (STR)0);
#ifdef NaN
/*LINTED*/
if(vartype == RVAL && NaN(res.f))
(*fpfunc)();
#endif
goto ex;
}
#endif
if(vartype== SVAL){ /* a string !!!!!! */
if(firsttime){ /* no need for checktype() since */
point = sp; /* we know it's a string */
stringcompare();
goto ex;
}
else error(2); /* variable required */
}
if(vartype == IVAL)
res.i = pp->i;
else
res = *pp;
}
else if(isnumber(c) || c=='.' || c == '&'){
if(!getnumb(--point, &point)) /* we have a number */
error(36); /* bad number */
}
else if(c=='('){ /* bracketed expression */
eval(); /* recursive call of eval() */
if(getch()!=')')
error(SYNTAX);
}
else {
err1: /* get here if the function we tried to access was not */
/* a legal maths func. or a string variable */
/* stringcompare() will give a syntax error if not a valid */
/* string. therefore this works ok */
point--;
if(!firsttime)
error(SYNTAX);
stringcompare();
}
ex:
/*
* now perform unary operations.
* only do this if we have some
*/
if(unaries[0]){
if(unaries[0] == SETMINUS)
negate(); /* unary minus */
else
notit(); /* unary not */
if(unaries[1] == SETMINUS)
negate();
else if(unaries[1] == SETNOT)
notit();
unaries[0] = unaries[1] = 0;
}
firsttime = 1;
switch(c = getch()){ /* get the precedence of the */
case '^': /* operator */
i = 5;
break;
case '*':
case '/':
case '\\':
case MODD:
firsttime = 0;
i = 4;
break;
case '+':
case '-':
firsttime = 0;
i = 3;
break;
case APRX:
case EQL: /* comparison operators */
case LTEQ:
case NEQE:
case LTTH:
case GTEQ:
case GRTH:
i = 2;
break;
case ANDD: /* logical operators */
case ORR:
case XORR:
case IMPP:
case EQVV:
i = 1;
break;
default:
i=0;
break;
}
#if 1
while(j->mvalue >= i){
if(! j->mvalue ){ /* end of expression */
point--;
return;
}
if(j->vty!=vartype){ /* make both parameters */
if(vartype != RVAL) /* the same type */
cvt(&res);
else
cvt(&j->r1); /* if changed then they must be */
vartype= RVAL; /* changed to reals */
}
(*mbin[(j->mvalue<<1)+vartype])(&j->r1,&res,j->lastop);
#ifdef NaN
if(vartype == RVAL && NaN(res.f))
(*fpfunc)();
#endif
j--; /* execute it then pop the stack and */
} /* deal with the next operator */
(++j)->lastop=c; /* precedence */
j->r1 = res;
j->mvalue= i;
j->vty=vartype;
#else
ame: if(j->mvalue < i){ /* current operator has higher */
(++j)->lastop=c; /* precedence */
j->r1 = res;
j->mvalue= i;
j->vty=vartype;
continue;
}
if(! j->mvalue ){ /* end of expression */
point--;
return;
}
if(j->vty!=vartype){ /* make both parameters */
if(vartype != RVAL) /* the same type */
cvt(&res);
else
cvt(&j->r1); /* if changed then they must be */
vartype= RVAL; /* changed to reals */
}
(*mbin[(j->mvalue<<1)+vartype])(&j->r1,&res,j->lastop);
#ifdef NaN
if(vartype == RVAL && NaN(res.f))
(*fpfunc)();
#endif
j--; /* execute it then pop the stack and */
goto ame; /* deal with the next operator */
#endif
}
}
/*
* The rest of the routines in this file evaluate functions and are
* relatively straight forward.
*/
void
tim()
{
#ifndef __STDC__
long t;
#else
time_t t;
#endif
VOID time(&t);
#ifndef SOFTFP
#ifdef BIG_INTS
res.i = t;
vartype = IVAL;
#else
res.f = t;
vartype = RVAL;
#endif
#else
overfl = t;
over(0,&res); /* convert from long to real */
#endif
}
#ifdef RAND48
extern double drand48(void);
extern long lrand48(void);
extern void srand48(long);
void
rnd()
{
itype rnumb;
if(*point != '('){
res.i = (itype)lrand48();
vartype = IVAL;
return;
}
point++;
rnumb = evalint();
if(getch()!=')')
error(SYNTAX);
if(rnumb == 0){
res.f = drand48();
vartype = RVAL;
}
else {
res.i = lrand48() % rnumb + 1;
vartype = IVAL;
}
}
/*
* This routine is the command 'random' and is placed here for some
* unknown reason it just sets the seed to rnd to the value from
* the time system call ( is a random number ).
*/
int
brandom()
{
long m;
VOID time(&m);
srand48((long)m);
normret;
}
#else
void
rnd()
{
static const double recip32 = 32767.0;
#ifdef SOFTFP
value temp;
#endif
register int rn;
rn = rand() & 077777;
if(*point!='('){
res.i= (short)rn;
vartype= IVAL;
return;
}
point++;
eval();
if(getch()!=')')
error(SYNTAX);
if(!IS_ZERO(res)){
if(vartype == RVAL && conv(&res))
error(FUNCT);
res.i= rn % res.i + 1;
vartype= IVAL;
return;
}
#ifndef SOFTFP
res.f = (double)rn / recip32;
#else
temp.i=rn;
cvt(&temp);
res = *( (value *)( &recip32 ) );
fdiv(&temp,&res); /* horrible */
#endif
vartype = RVAL;
}
/*
* This routine is the command 'random' and is placed here for some
* unknown reason it just sets the seed to rnd to the value from
* the time system call ( is a random number ).
*/
int
brandom()
{
long m;
VOID time(&m);
srand((int)m);
normret;
}
#endif
void
erlin()
{
res.i = (itype)elinnumb;
vartype= IVAL;
#ifndef BIG_INTS
if(res.i < 0 ){ /* make large linenumbers */
#ifndef SOFTFP
res.f = (unsigned)elinnumb;
vartype = RVAL;
#else
overfl=(unsigned)elinnumb; /* into reals as they */
over(0,&res); /* overflow integers */
#endif
}
#endif
}
void
erval()
{
res.i = (itype)ecode;
vartype= IVAL;
}
void
sgn()
{
eval();
#ifndef UNPORTABLE
if(vartype == RVAL){
if(res.f < ZERO)
res.i = -1;
else if(res.f > ZERO)
res.i = 1;
else res.i = 0;
vartype = IVAL;
return;
}
#endif
if(res.i<0) /* bit twiddling */
res.i = -1; /* real numbers have the top bit set if */
else if(res.i>0) /* negative and the top word is non-zero */
res.i= 1; /* for all non-zero numbers */
vartype=IVAL;
}
void
babs()
{
eval();
#ifndef UNPORTABLE
if(vartype == RVAL){
if(res.f < ZERO)
#ifndef SOFTFP
res.f = -res.f;
#else
negate();
#endif
return;
}
#endif
if(res.i<0)
negate();
}
void
len()
{
register STR st;
st = stringeval();
res.i = (itype)st->strlen;
vartype= IVAL;
FREE_STR(st);
}
void
ascval()
{
register STR st;
st = stringeval();
if(!st->strlen)
error(FUNCT);
res.i = (itype)UC(*st->strval);
vartype= IVAL;
FREE_STR(st);
}
void
bsqrtf()
{
evalreal();
if(res.f < ZERO){
c_error(37); /* negative square root */
return;
}
#ifndef SOFTFP
res.f = sqrt(res.f);
#else
sqrt(&res);
#endif
}
void
blogf()
{
evalreal();
if(res.f <= ZERO){
c_error(38); /* bad log value */
return;
}
#ifndef SOFTFP
res.f = log(res.f);
#else
log(&res);
#endif
}
void
blog10f()
{
static const double log10val = 2.30258509299404568402;
evalreal();
if(res.f <= ZERO){
c_error(38); /* bad log value */
return;
}
#ifndef SOFTFP
res.f = log(res.f) / log10val;
#else
log(&res);
fdiv(&log10val, &res);
#endif
}
void
bexpf()
{
evalreal();
#ifndef SOFTFP
if(res.f > logmaxval){
c_error(39);
res.f = logmaxval;
}
res.f = exp(res.f);
#else
if(!exp(&res))
error(39); /* overflow in exp */
#endif
}
void
pii()
{
#ifndef SOFTFP
res.f = pivalue;
#else
movein(&pivalue,&res);
#endif
vartype= RVAL;
}
/*
* This routine will deal with the eval() function. It has to do
* a lot of moving of data. to enable it to 'compile' an expression
* so that it can be evaluated.
*/
void
evalu()
{
register CHAR *tmp;
register STR st;
int c;
if(evallock>10)
error(43); /* mutually recursive eval */
evallock++;
st = stringeval();
if(st->strlen > MAXLIN-1)
error(10);
else if(!st->strlen)
error(SYNTAX);
*strmov(line, st->strval, st->strlen) = 0;
#if 0
/*
* when compiling, the resultant string will be less than or equal
* to the length of the original string
*/
st->strlen = 0; /* defeat default copy action */
RESERVE_SPACE(st, MAXLIN);
#endif
VOID compile(0, st->strval, 1);
tmp=point;
point = st->strval;
eval();
c = getch();
point=tmp;
evallock--;
FREE_STR(st);
if(c)
error(SYNTAX);
}
void
ffn(pep, strp)
struct entry *pep;
STR strp;
{
register struct deffn *p;
register struct entry *ep;
register int i;
union ffn_vars *cur_arg;
struct entry **rp, *rep;
CHAR *spoint;
struct forst *fp;
char vty;
char ctype;
STR st;
STR retst = 0;
union ffn_vars args[FN_MAX_ARGS];
if( (ep = pep) == 0){
if(!ispletter(point))
error(SYNTAX);
ep = getnm(ISFUNC, 0);
if(!ep)
error(UNDEFFN);
ctype = IS_MFN;
vty = vartype;
if( (strp && vty != SVAL) || (!strp && vty == SVAL))
error(UNDEFFN);
retst = strp;
}
else
ctype = IS_MPR;
p = ep->_deffn;
if(p->narg){
if(*point++!='(')
error(SYNTAX);
rp = p->vargs;
for(cur_arg = args, i=0 ;; cur_arg++, rp++){
rep = *rp;
if(rep->vtype == SVAL){
if(rep->flags & IS_FSTRING)
error(3);
st = ALLOC_STR( (ival)0);
st->strval = rep->_dst.str;
st->strlen = rep->_dst.len;
RESERVE_SPACE(st, (ival)rep->_dst.len);
cur_arg->ostr = st;
cur_arg->nstr = stringeval();
}
else {
cur_arg->ovr = rep->_dval; /* save values */
eval();
putin(&cur_arg->nvr,
(int) (rep->vtype & NVALMASK));
}
if(++i >= p->narg)
break;
if( getch() != ',' )
error(SYNTAX);
}
if( getch() != ')' )
error(SYNTAX);
/* got arguments in nvrs[] */
/* put in new values */
rp = p->vargs;
for(cur_arg = args, i=0; i < p->narg; i++, cur_arg++, rp++){
rep = *rp;
if(rep->vtype == SVAL)
stringassign(&rep->_dst, rep, cur_arg->nstr, 1);
else
rep->_dval = cur_arg->nvr;
}
}
if(p->mline != IS_FN){
if(p->mline != ctype)
error(56);
if(ctype == IS_MPR)
check();
if(p->ncall >= MAX_FCALLS)
error(44);
fp = (forstp)mmalloc((ival)(sizeof(struct forst) +
sizeof(struct JMPBUF)));
fp->fnJMP = (struct JMPBUF *)(fp + 1);
if((fp->prev = estack) != 0)
fp->prev->next = fp;
else
bstack = fp;
fp->next = 0;
estack = fp;
if(p->mline == IS_MFN){
if(vty == RVAL)
fp->fnval.f = ZERO;
else if(vty == SVAL){
fp->fnsval.str = 0;
fp->fnsval.len = 0;
}
else
fp->fnval.i = 0;
}
fp->fnvar = ep;
fp->fnLOCAL = 0; /* by default there is no hash table */
fp->stolin = stocurlin;
fp->pt = point;
fp->elses = elsecount;
fp->fortyp = FNTYP; /* get the right type */
fp->fnSBEG = str_used;
fp->fnSEND = str_uend;
str_used = str_uend = 0;
stocurlin = p->mpnt;
point = stocurlin->lin;
elsecount = 0;
p->ncall++;
if(setjmp(fp->fnenv) != NORM_RESET)
execute();
/*
* get the right values for local vars
* setjmp does not save register vars
*/
for(fp = estack ; fp ; fp = fp->prev)
if(fp->fortyp == FNTYP)
break;
if(!fp) /* fire door to stop improper stacking */
reset();
ep = fp->fnvar;
p = ep->_deffn;
/*
* recover all environment
*/
stocurlin = fp->stolin;
point = fp->pt;
elsecount = fp->elses;
if(p->mline == IS_MFN){
if(vty == SVAL){
retst->strval = fp->fnsval.str;
retst->strlen = fp->fnsval.len;
RESERVE_SPACE(retst, (ival)fp->fnsval.len);
}
else {
res = fp->fnval;
vartype = vty;
}
}
recov_parms(p->vargs, p->narg, args, 0);
if( (estack = fp->prev) == 0)
bstack = 0;
else
fp->prev->next = 0;
clr_stack(fp); /* WARNING - also recovers any local vars */
return;
}
if(++fnlock >= MAX_FCALLS)
error(44);
spoint=point;
point=p->exp;
if(vty == SVAL){
/*
* this is horrible. We must recover this string
*/
st = stringeval();
COPY_OVER_STR(retst, st);
FREE_STR(st);
}
else
eval();
if(fnlock > 0)
fnlock--;
recov_parms(p->vargs, p->narg, args, 1);
if(getch())
error(SYNTAX);
point= spoint;
if(vty != SVAL && vartype != vty){
if(vartype != RVAL)
cvt(&res);
else if(conv(&res))
error(INTOVER);
vartype = vty;
}
}
static void
recov_parms(arp, nargs, args, tofree)
struct entry **arp;
int nargs;
union ffn_vars *args;
int tofree;
{
register int i;
union ffn_vars *cur_arg;
struct entry **rp, *rep;
STR ost = 0;
for(rp = arp, cur_arg = args, i=0; i < nargs; i++, cur_arg++,rp++){
rep = *rp;
if(rep->vtype == SVAL){
stringassign(&rep->_dst, rep, cur_arg->ostr, 1);
if(ost == 0)
ost = cur_arg->ostr;
}
else
rep->_dval = cur_arg->ovr;
}
if(ost && tofree)
FREE_STR(ost);
}
void
drop_fns()
{
register forstp fp, nfp = 0;
register struct entry *ep;
for(fp = bstack ; fp ; fp = nfp){
nfp = fp->next;
if(fp->fortyp == FNTYP){
ep = fp->fnvar;
ep->_deffn->ncall--;
if(ep->vtype == SVAL && ep->_deffn->mline == IS_MFN){
if(fp->fnsval.str != 0){
mfree( (MEMP)fp->fnsval.str);
fp->fnsval.str = 0;
}
}
if(fp->next)
fp->next->prev = fp->prev;
else
estack = fp->prev;
if(fp->prev)
fp->prev->next = fp->next;
else
bstack = fp->next;
if(fp->fnLOCAL)
recover_vars(fp, 0);
if(str_used)
FREE_STR(str_used);
str_used = fp->fnSBEG;
str_uend = fp->fnSEND;
mfree( (MEMP)fp);
}
}
}
int
fnend()
{
register forstp fp;
check();
for(fp = estack ; fp ; fp = fp->prev)
if(fp->fortyp == FNTYP)
break;
if(!fp)
error(51);
longjmp(fp->fnenv, NORM_RESET);
normret;
}
int
fncmd()
{
register struct entry *ep;
register forstp fp;
STR st;
if(!ispletter(point))
error(SYNTAX);
ep = getnm(ISFUNC, 0);
if(!ep)
error(UNDEFFN);
if(ep->_deffn->mline == IS_FN)
error(UNDEFFN);
if(ep->_deffn->mline == IS_MPR){
/*
check();
*/
ffn(ep, (STR)0);
normret;
}
if(getch() != '=')
error(SYNTAX);
for(fp = estack ; fp ; fp = fp->prev)
if(fp->fortyp == FNTYP)
break;
if(!fp || fp->fnvar != ep)
error(UNDEFFN);
if(vartype == SVAL){
st = stringeval();
check();
stringassign(&fp->fnsval, ep, st, 0);
}
else {
eval();
check();
putin(&fp->fnval, (int)(ep->vtype & NVALMASK));
}
normret;
}
void
recover_vars(sptr, doit)
forstp sptr;
int doit;
{
register loc_sav_t *ls;
register struct loc_sav_e *lse;
loc_sav_t *nls;
ls = sptr->fnLOCAL;
sptr->fnLOCAL = 0;
while(ls != 0){
nls = ls->next;
lse = ls->arg;
if(!doit){
for(; ls->narg ; ls->narg--, lse++)
if(lse->lentry)
free_entry(lse->lentry);
}
else {
for(; ls->narg ; ls->narg--, lse++){
drop_val(lse->hentry, 0);
if(lse->lentry)
add_entry(lse->lentry);
free_entry(lse->hentry);
}
}
mfree( (MEMP)ls);
ls = nls;
}
}
/* int() - return the greatest integer less than x */
void
intf()
{
#ifndef SOFTFP
extern double floor();
eval();
if(vartype != RVAL)
return;
res.f = floor(res.f);
if(!conv(&res))
vartype= IVAL;
#else
value temp;
static double ONE = 1.0;
eval();
if(vartype != RVAL) /* conv and integ truncate not round */
return;
#ifndef UNPORTABLE
if(res.f >= ZERO){
#else
if(res.i>=0){ /* positive easy */
#endif
if(!conv(&res))
vartype= IVAL;
else integ(&res);
return;
}
temp = res;
integ(&res);
if(cmp(&res,&temp)){ /* not got an integer subtract one */
res = *((value *)&ONE);
fsub(&temp,&res);
integ(&res);
}
if(!conv(&res))
vartype= IVAL;
#endif /* not floating point */
}
void
bfixf()
{
extern double floor();
eval();
if(vartype != RVAL)
return;
if(res.f < ZERO)
res.f = -floor(-res.f);
else
res.f = floor(res.f);
}
static char *
real_memory()
{
itype l;
char *p;
#ifdef pdp11
l = evalint();
p = (char *)l;
#else
#ifdef BIG_INTS
l = evalint();
p = (char *)l;
#else
#ifdef MSDOS
l = evalint();
p = (char *)l;
#else
register long ll; /* really only for a vax */
evalreal();
if(res.f > 0x7fff000 || res.f < 0) /* check this */
error(FUNCT);
ll = res.f;
p = (char *)ll;
#endif
#endif
#endif
return(p);
}
#if defined(SYS5_4) && __STDC__ == 0
static sigjmp_buf pksig_catch;
#else
static jmp_buf pksig_catch;
#endif
static SIGFUNC
pksig_catchf(sig)
int sig;
{
#if defined(SYS5_4) && __STDC__ == 0
siglongjmp(pksig_catch, sig);
#else
longjmp(pksig_catch, sig);
#endif
}
static int
pkpok(loc, val, mode)
char *loc;
itype val;
int mode;
{
int rval = -1;
#ifdef __STDC__
SIGFUNC (*old_bus)(int), (*old_seg)(int);
#else
SIGFUNC (*old_bus)(), (*old_seg)();
#endif
old_bus = signal(SIGBUS, pksig_catchf);
old_seg = signal(SIGSEGV, pksig_catchf);
#if defined(SYS5_4) && __STDC__ == 0
switch(sigsetjmp(pksig_catch, 0)){
#else
switch(setjmp(pksig_catch)){
#endif
case 0:
if(mode)
rval = (int)UC(*loc);
else
*loc = (char) val;
break;
case SIGBUS:
break;
case SIGSEGV:
break;
default:
break;
}
VOID signal(SIGBUS, old_bus);
VOID signal(SIGSEGV, old_seg);
return(rval);
}
void
peekf()
{
register char *p;
p = real_memory();
res.i = (itype)pkpok(p, (itype)0, 1);
vartype = IVAL;
}
int
poke() /* sp = approx position of stack */
{ /* can give bus errors */
register char *p;
register itype i;
p = real_memory();
if(getch() != ',')
error(SYNTAX);
i = evalint();
check();
if(i<0 || i > 255)
error(FUNCT);
VOID pkpok(p, i, 0);
normret;
}
static void
setdrg(tofrom)
int tofrom;
{
#ifndef SOFTFP
static const double grad_to_rad = PI_VALUE/200;
static const double deg_to_rad = PI_VALUE/180;
if(drg_opt == OPT_RAD)
return;
if(tofrom){
/* for sin and cos. and tan */
if(drg_opt == OPT_GRAD)
res.f *= grad_to_rad;
else
res.f *= deg_to_rad;
}
else { /* for atan */
if(drg_opt == OPT_GRAD)
res.f /= grad_to_rad;
else
res.f /= deg_to_rad;
}
#endif
}
void
bsinf()
{
evalreal();
setdrg(1);
#ifndef SOFTFP
res.f = sin(res.f);
#else
sin(&res);
#endif
}
void
bcosf()
{
evalreal();
setdrg(1);
#ifndef SOFTFP
res.f = cos(res.f);
#else
cos(&res);
#endif
}
void
btanf()
{
double x;
evalreal();
setdrg(1);
#ifndef SOFTFP
x = cos(res.f);
if(x == ZERO){
c_error(25);
res.f = BIG;
}
else
res.f = sin(res.f) / x;
#else
tan(&res);
#endif
}
void
batanf()
{
evalreal();
#ifndef SOFTFP
res.f = atan(res.f);
#else
atan(&res);
#endif
setdrg(0);
}
void
basinf()
{
evalreal();
#ifndef SOFTFP
res.f = asin(res.f);
#endif
setdrg(0);
}
void
bacosf()
{
evalreal();
#ifndef SOFTFP
res.f = acos(res.f);
#endif
setdrg(0);
}
/*
* hyperbolic functions
*/
#ifndef SOFTFP
static int
hyp_sign(xp)
double *xp;
{
register int res;
if(*xp < ZERO){
res = -1;
*xp = - *xp;
}
else
res = 1;
return(res);
}
#endif
static void
hyper_sc(sin_cos_tan)
int sin_cos_tan;
{
double x, y;
int sign;
evalreal();
#ifndef SOFTFP
sign = hyp_sign(&res.f);
if(res.f >= 20.0){
switch(sin_cos_tan){
case 2: /*TANH*/
res.f = (sign > 0) ? ONE : -ONE;
break;
case 1: /*COSH*/
case 0: /*SINH*/
/* there is a discontinuity here from a
* number <= logmaxval to > logmaxval.
* can solve this problem if we do
* exp(res.f - ln2) between logmaxval and
* logmaxval + ln2
*/
if(res.f > logmaxval){
if(res.f > logmaxval + logof2){
c_error(34);
res.f = BIG;
}
else
res.f = exp(res.f - logof2);
}
else
res.f = exp(res.f) / TWO;
if(sin_cos_tan == 0 && sign < 0)
res.f = -res.f;
break;
}
return;
}
x = exp(res.f);
y = ONE / x;
switch(sin_cos_tan){
case 2: /*TANH*/
res.f = (x - y) / (x + y);
break;
case 1: /*COSH*/
res.f = (x + y) / TWO;
break;
case 0: /*SINH*/
res.f = (x - y) / TWO;
break;
}
if(sin_cos_tan != 1 && sign < 0)
res.f = -res.f;
#endif
}
static void
ahyper_sc(sin_cos_tan)
int sin_cos_tan;
{
double x;
int neg;
evalreal();
#ifndef SOFTFP
x = res.f;
neg = hyp_sign(&x);
switch(sin_cos_tan){
case 2: /* TANH */
if(x >= ONE)
goto setnan;
res.f = log(ONE + (res.f + res.f) / ( ONE - res.f)) / TWO;
break;
case 1: /* COSH */
if(res.f < ONE)
goto setnan;
if(x < INSIG)
res.f = log(x + sqrt(x * x - ONE));
else
res.f = log(x) + logof2;
break;
case 0: /* SINH */
if(x < INSIG)
res.f = log(x + sqrt(x * x + ONE));
else
res.f = log(x) + logof2;
if(neg < 0)
res.f = -res.f;
break;
}
return;
setnan:
c_error(34);
res.f = (neg > 0) ? BIG : BIGminus;
#endif
}
void
bsinh()
{
hyper_sc(0);
}
void
bcosh()
{
hyper_sc(1);
}
void
btanh()
{
hyper_sc(2);
}
void
basinh()
{
ahyper_sc(0);
}
void
bacosh()
{
ahyper_sc(1);
}
void
batanh()
{
ahyper_sc(2);
}
/*
* the option command.
*/
#ifdef OWN_ALLOC
extern int max_mem_size;
#endif
int
bopts()
{
register int c;
itype memsiz;
if( (c = getch()) == OPT_BASE){
VOID base();
normret;
}
if(c != OFUNC)
error(SYNTAX);
switch(c = UC(*point++)){
#ifndef SOFTFP
case OPT_GRAD:
case OPT_DEG:
#endif
case OPT_RAD:
drg_opt = c;
break;
case OPT_MEM:
memsiz = evalint();
if(memsiz <= 0)
memsiz = MAX_MEM_DEFAULT;
else if(memsiz > MAX_MEM_MAX)
memsiz = MAX_MEM_MAX;
#ifdef OWN_ALLOC
max_mem_size = memsiz;
#endif
break;
default:
error(SYNTAX);
break;
}
normret;
}
/*
* the "system" function, returns the status of the command it executes
*/
void
ssystem()
{
register STR st;
st = stringeval();
NULL_TERMINATE(st);
flushall();
res.i = (itype)do_system(st->strval);
vartype = IVAL;
FREE_STR(st);
}
/*
* perform a system call. parameters are taken as is
*/
#define MAX_SYS_ARGS 6
extern int errno;
#ifdef __STDC__
extern int syscall(int, ...);
#else
extern int syscall();
#endif
static int sys_error;
void
bsyscall()
{
register int nargs;
int args[MAX_SYS_ARGS];
itype scall;
itype rval;
sys_error = 0;
scall = evalint();
if(scall < 1 || scall > 10000)
error(FUNCT);
for(nargs = 0 ; nargs < MAX_SYS_ARGS ; nargs++)
args[nargs] = 0;
for(nargs = 0; getch() == ',' ; nargs++){
if(nargs >= MAX_SYS_ARGS)
error(FUNCT);
args[nargs] = (int)evalint();
}
point--;
errno = 0;
rval = syscall(scall, args[0],args[1],args[2],args[3],args[4],args[5]);
sys_error = errno;
vartype = IVAL;
res.i = rval;
}
void
bsyserr()
{
res.i = (ival)sys_error;
vartype = IVAL;
}
static void
bminmax(is_min)
int is_min;
{
value curval;
char vtyp;
int rc;
eval();
curval = res;
vtyp = vartype;
if(getch() != ',')
error(SYNTAX);
do {
eval();
if(vtyp != vartype){
if(vartype != RVAL)
cvt(&res);
else
cvt(&curval);
vartype = RVAL;
vtyp = RVAL;
}
rc = cmp(&res, &curval);
if( (rc < 0 && is_min) || (rc > 0 && !is_min)){
curval = res;
vtyp = vartype;
}
}while(getch() == ',');
res = curval;
vartype = vtyp;
point--;
}
void
bmax()
{
bminmax(0);
}
void
bmin()
{
bminmax(1);
}
void
bcreal()
{
evalreal();
}
void
bcint()
{
ival ret;
ret = evalint();
res.i = ret;
vartype = IVAL;
}
/*
* matrix commands.
*/
static void chk_dims(struct entry *, struct entry *);
static int mat_len(struct entry *);
static void matmuli(struct entry *, struct entry *, struct entry *,
ival, ival, ival);
static void matmulr(struct entry *, struct entry *, struct entry *,
ival, ival, ival);
int
bmat()
{
struct entry *lhep;
struct entry *arg1;
struct entry *arg2;
struct entry *newent;
int c;
int rcnt;
valp vp, xp, zp;
ival *vpp, *xpp, *zpp;
char vty;
ival da1, da2, db2, db1;
c = getch();
switch(c){
case INPUT:
return(matinput());
case READ:
do {
lhep = getmat(0);
matread((MEMP)lhep->_darr, (int)vartype, mat_len(lhep));
} while(getch() == ',');
point--;
normret;
case PRINT:
return(matprint());
default:
point--;
break;
}
lhep = getmat(1);
newent = newentry;
vty = vartype;
if(getch() != '=')
error(4);
c = getch();
switch(c){
default:
point--;
break;
}
arg1 = getmat(0);
c = getch();
if(istermin(c)){
point--;
if(lhep == 0){
lhep = newent;
vartype = vty;
def_darr(lhep, arg1->_dims[0],
(arg1->dimens > 1) ? arg1->_dims[1] : 0);
newentry = 0;
}
else
chk_dims(lhep, arg1);
VOID strmov(lhep->_darr, arg1->_darr,
(ival)(mat_len(lhep) * TYP_SIZ(lhep->vtype)));
normret;
}
switch(c){
case '.':
arg2 = getmat(0);
if(arg1->dimens > 1){
da1 = arg1->_dims[1];
da2 = arg1->_dims[0];
}
else {
da1 = arg1->_dims[0];
da2 = 1;
}
if(arg2->dimens > 1){
db1 = arg2->_dims[1];
db2 = arg2->_dims[0];
}
else {
db1 = arg2->_dims[0];
db2 = 1;
}
if(da2 != db1)
error(58);
if(lhep == 0){
lhep = newent;
vartype = vty;
def_darr(lhep, da1, (db2 > 1) ? db2 : 0);
newentry = 0;
}
else {
/*
* result cannot be one of the two parameters
*/
if(lhep == arg1 || lhep == arg2)
error(58);
if(lhep->vtype != arg1->vtype || lhep->_dims[0] != da1)
error(58);
if(db2 > 1){
if(lhep->dimens <= 1 || lhep->_dims[1] != db2)
error(58);
}
else {
if(lhep->dimens > 1 && lhep->_dims[1] != 1)
error(58);
}
}
/*
* now do matrix multiplication
*/
if(vartype == RVAL)
matmulr(lhep, arg1, arg2, da1, da2, db2);
else
matmuli(lhep, arg1, arg2, da1, da2, db2);
break;
case '+':
case '-':
arg2 = getmat(0);
chk_dims(arg1, arg2);
if(lhep == 0){
lhep = newent;
vartype = vty;
def_darr(lhep, arg1->_dims[0],
(arg1->dimens > 1) ? arg1->_dims[1] : 0);
newentry = 0;
}
else
chk_dims(lhep, arg1);
rcnt = mat_len(lhep);
xp = (valp)(MEMP)arg1->_darr;
zp = (valp)(MEMP)arg2->_darr;
vp = (valp)(MEMP)lhep->_darr;
if(vartype == RVAL){
if(c == '+'){
for(; rcnt ; rcnt--){
vp->f = xp->f + zp->f;
vp++;
xp++;
zp++;
}
}
else for(; rcnt ; rcnt--){
vp->f = xp->f - zp->f;
vp++;
xp++;
zp++;
}
}
else {
xpp = &xp->i;
vpp = &vp->i;
zpp = &zp->i;
if(c == '+'){
for(; rcnt ; rcnt--){
long l = *xpp + *zpp;
if(IS_OVER(*zpp, *xpp, l))
error(INTOVER);
*vpp = l;
vpp++;
xpp++;
zpp++;
}
}
else {
for(; rcnt ; rcnt--){
long l = *xpp - *zpp;
if(IS_OVER(*zpp, *xpp, l))
error(INTOVER);
*vpp = l;
vpp++;
xpp++;
zpp++;
}
}
}
break;
case '*':
if(lhep == 0){
lhep = newent;
vartype = vty;
def_darr(lhep, arg1->_dims[0],
(arg1->dimens > 1) ? arg1->_dims[1] : 0);
newentry = 0;
}
else
chk_dims(lhep, arg1);
eval();
if(vartype != lhep->vtype){
if(vartype != RVAL)
cvt(&res);
else if(conv(&res))
error(INTOVER);
vartype = lhep->vtype;
}
rcnt = mat_len(lhep);
xp = (valp)(MEMP)arg1->_darr;
vp = (valp)(MEMP)lhep->_darr;
if(vartype == RVAL){
for(; rcnt ; rcnt--){
vp->f = xp->f * res.f;
vp++;
xp++;
}
}
else {
xpp = &xp->i;
vpp = &vp->i;
for(; rcnt ; rcnt--){
#ifdef BIG_INTS
*vpp = mmult_ply(*xpp, res.i, INTOVER);
#else
long l = *xpp * res.i;
if(IS_OVER(res.i, *xxp, l))
error(INTOVER);
*vpp = l;
#endif
vpp++;
xpp++;
}
}
break;
default:
error(SYNTAX);
}
normret;
}
#if 0
#define MAT_LEN(lhep, cnt) \
do { \
(cnt) = (lhep)->_dims[0]; \
if((lhep)->dimens > 1) \
(cnt) *= (lhep)->_dims[1]; \
} while(0)
#define mat_len(lhep) \
(((lhep)->dimens > 1 ) ? ((lhep)->_dims[0] * (lhep)->_dims[1]) : \
(lhep)->_dims[0])
#else
static int
mat_len(lhep)
struct entry *lhep;
{
int rcnt;
rcnt = lhep->_dims[0];
if(lhep->dimens > 1)
rcnt *= lhep->_dims[1];
return(rcnt);
}
#endif
static void
chk_dims(lhep, arg1)
struct entry *lhep, *arg1;
{
if(lhep->vtype == arg1->vtype && lhep->dimens == arg1->dimens &&
lhep->_dims[0] == arg1->_dims[0] && (lhep->dimens == 1 ||
lhep->_dims[1] == arg1->_dims[1]))
return;
error(58);
}
/*
* matrix multiplication (finally!!)
*/
static void
matmulr(lhep, arg1, arg2, da1, da2, db2)
struct entry *lhep, *arg1, *arg2;
ival da1, da2, db2;
{
ival i,j,k;
valp vp, vpp, zp, zpp, xp, xpp;
double x;
vpp = (valp)(MEMP)arg1->_darr;
zpp = (valp)(MEMP)lhep->_darr;
for(i = 0 ; i < da1 ; i++){
/*
* VP = arg1, ZP = lhep
* vp = arg1->[i];
* zp = lhep->[i];
* xp = arg2->[?,j]
*/
zp = zpp;
xpp = (valp)(MEMP)arg2->_darr;
for(j = 0 ; j < db2 ; j++){
x = ZERO;
vp = vpp;
xp = xpp;
for(k = 0 ; k < da2 ; k++){
x = x + vp->f * xp->f;
xp += db2;
vp++;
}
zp->f = x;
zp++;
xpp++;
}
vpp += da2;
zpp += db2;
}
}
static void
matmuli(lhep, arg1, arg2, da1, da2, db2)
struct entry *lhep, *arg1, *arg2;
ival da1, da2, db2;
{
ival i,j,k;
ival *vp, *vpp, *zp, *zpp, *xp, *xpp;
long x, l, ll;
vpp = (ival *)(MEMP)arg1->_darr;
zpp = (ival *)(MEMP)lhep->_darr;
for(i = 0 ; i < da1 ; i++){
/*
* VP = arg1, ZP = lhep
* vp = arg1->[i];
* zp = lhep->[i];
* xp = arg2->[?,j]
*/
zp = zpp;
xpp = (ival *)(MEMP)arg2->_darr;
for(j = 0 ; j < db2 ; j++){
x = 0;
vp = vpp;
xp = xpp;
for(k = 0 ; k < da2 ; k++){
#ifdef BIG_INTS
l = mmult_ply(*xp, *vp, INTOVER);
#else
l = *vp * *xp;
if(IS_OVER(*vp, *xp, l))
error(INTOVER);
#endif
ll = x + l;
if(IS_OVER(x, l, ll))
error(INTOVER);
x = ll;
xp += db2;
vp++;
}
*zp = x;
zp++;
xpp++;
}
vpp += da2;
zpp += db2;
}
}
syntax highlighted by Code2HTML, v. 0.9.1