/*
* BASIC by Phil Cockcroft
*/
#include "bas.h"
/* this file contains all the routines that were originally done in assembler
* these routines only require a floating point emulator to work.
* To speed things up some routines could be put into assembler and some
* could be made into macros. the relevent routines are labeled as such
*/
#ifndef VAX_ASSEM /* if done in assembler don't bring it in */
#ifndef NS_ASSEM
/* AS */
/* get a single character from the line pointed to by getch() */
int
getch()
{
register char *p;
p = (char *)point;
#ifdef __STDC__
while(*p == ' ')
p++;
#ifdef mips
point = (CHAR *)(p+1);
return(*(unsigned char *)p);
#else
point = (CHAR *)++p;
return(*(unsigned char *)(p - 1));
#endif
#else
while(*p++ == ' ');
point = p;
return(UC(*--p));
#endif
}
/* AS #define ELSE 0351 */
void
check() /* check to see no garbage at end of command */
{
register char *p;
register char c;
p = (char *)point;
while(*p == ' ')
p++;
if((c = *p) == 0 || c == ':' || (c == (char)ELSE && elsecount)){
point = (CHAR *)p;
return;
}
error(SYNTAX); /* not a terminator - error */
}
#endif
#endif
#ifndef SOFTFP
/*ARGSUSED*/
void
#ifdef __STDC__
fpcrash(void)
#else
fpcrash()
#endif
{
c_error(34); /* arithmetic overflow */
if(res.f < ZERO)
res.f = BIGminus;
else
res.f = BIG;
}
#endif
void
startfp()
{
#ifndef SOFTFP
fpfunc = fpcrash; /* will call error(34) on overflow */
#else
fpfunc = 0;
#endif
}
int
_conv(p)
register value *p;
{
register ival i;
i = p->f;
if(i < 0){
if(i == -MAX_INT - 1){
p->i = i;
return(0);
}
i--;
}
else if(i == 0 && p->f < ZERO)
i--;
if( (p->f - i) >= 0.5)
i++;
p->i = i;
return(0);
}
/* AS */
/* compare two values. return 0 if equal -1 if first less than second
* or 1 for vice versa.
*/
int
cmp(p,q)
register value *p,*q;
{
if(vartype != RVAL){
if(p->i == q->i)
return(0);
else if(p->i < q->i)
return(-1);
return(1);
}
if(p->f == q->f)
return(0);
else if(p->f< q->f )
return(-1);
return(1);
}
/* the arithmetic operation jump table */
/* all the routines below should be put into AS */
#ifdef __STDC__
#if defined(mips) && !defined(lint) && !defined(CDS_COMPILER)
static void fandor(valp, valp, int), andor(valp, valp, int);
static void comop(valp, valp, int), fads(valp, valp, int);
static void ads(valp, valp, int), fmdm(valp, valp, int);
static void mdm(valp, valp, int), fexp(valp, valp, int), ex(valp, valp,int);
#else
static mbinf_t fandor, andor, comop, fads, ads, fmdm, mdm, fexp, ex;
#endif
#else
#ifdef mips
static void fandor(), andor(), comop(), fads(), ads(), fmdm();
static void mdm(), fexp(), ex();
#else
static mbinf_t fandor, andor, comop, fads, ads, fmdm, mdm, fexp, ex;
#endif
#endif
#ifdef __STDC__
const mathf_t mbin = {
#else
mathf_t mbin = {
#endif
0, 0,
fandor,
andor,
comop,
comop,
fads,
ads,
fmdm,
mdm,
fexp,
ex,
};
static void
ex(p,q,c) /* integer exponentiation */
valp p,q;
int c;
{
if(p->i < 0)
error(41);
if(q->i >= 0 && q->i < 31){
register itype ll = 1;
for(c = 0; c < q->i ; c++){
ll = mmult_ply(p->i, ll, 0);
if(vartype == RVAL)
goto exp_over;
}
q->i = ll;
return;
}
exp_over:;
cvt(p);
cvt(q);
vartype = RVAL;
fexp(p,q,c);
}
static void
fmdm(p,q,c) /* floating * / mod */
valp p,q;
int c;
{
#ifdef __STDC__
double fmod(double, double);
#else
double fmod();
#endif
/*
double floor();
double x;
*/
if(c == '*'){
fmul(p,q);
return;
}
if(q->f == ZERO)
error(25);
if(c != MODD)
fdiv(p,q);
else { /* floating mod - yeuch */
q->f = fmod(p->f, q->f);
/*
if( (x = p->f/q->f) < ZERO)
q->f = p->f + floor(-x) * q->f;
else
q->f = p->f - floor(x) * q->f;
*/
}
}
static void
mdm(p,q,c) /* integer * / mod */
valp p,q;
int c;
{
register itype ll;
if(c=='*'){
#ifdef BIG_INTS
ll = mmult_ply(p->i, q->i, 0);
if(vartype != RVAL)
q->i = ll;
else {
cvt(p);
cvt(q);
fmul(p, q);
}
#else
register long l = (long)p->i * q->i;
if(l > 32767 || l < -32768){ /* overflow */
q->f = l;
vartype = RVAL;
}
else q->i = (itype)l;
#endif
return;
}
if(!q->i) /* zero divisor error */
error(25);
ll = p->i % q->i;
if(c != MODD){
if(ll && c == '/'){
#ifdef SOFTFP
cvt(p);
cvt(q);
fdiv(p,q);
#else
q->f = (double)p->i / (double)q->i;
#endif
vartype = RVAL;
}
else
q->i = p->i / q->i;
}
else
q->i = ll;
}
static void
fads(p,q,c) /* floating + - */
valp p,q;
int c;
{
if(c=='+')
fadd(p,q);
else
fsub(p,q);
}
static void
ads(p,q,c) /* integer + - */
valp p,q;
int c;
{
register long l;
register itype ii;
l = p->i;
if(c == '+'){
l += q->i;
if(!IS_OVER(q->i, p->i, l)){ /* overflow */
q->i = (itype)l;
return;
}
}
else if( (ii = -q->i) != q->i){
l += ii;
if(!IS_OVER(ii, p->i, l)){ /* overflow */
q->i = (itype)l;
return;
}
}
cvt(p);
cvt(q);
vartype = RVAL;
if(c=='+')
fadd(p,q);
else
fsub(p,q);
}
#define APRXVAL (1e-9)
static int
aprx(p, q)
valp p, q;
{
double x;
if(vartype != RVAL)
return(p->i == q->i);
vartype = IVAL;
if(p->f == q->f)
return(1);
if(q->f == ZERO){
/*
* I know that p->f is not zero since p->f != q->f
*/
x = p->f;
}
else if(p->f == ZERO)
x = q->f;
else {
if( (x = (p->f / q->f)) < ZERO)
x += ONE;
else
x -= ONE;
}
if(x < ZERO)
return( x >= -APRXVAL);
return(x <= APRXVAL);
}
static void
comop(p,q,c) /* comparison operations */
valp p,q;
int c;
{
if(c == APRX)
q->i = aprx(p, q) ? -1 : 0;
else
compare(c,cmp(p,q));
}
static void
fandor(p,q,c) /* floating logical AND/OR/XOR */
valp p,q;
int c;
{
p->i = IS_ZERO(*p) ? 0 : -1;
q->i = IS_ZERO(*q) ? 0 : -1;
vartype = IVAL;
andor(p,q,c);
}
static void
andor(p,q,c) /* integer logical */
valp p,q;
int c;
{
register itype i,j;
i = p->i;
j = q->i;
switch(c){
case ANDD:
i &= j;
break;
case ORR:
i |= j;
break;
case XORR:
i ^= j;
break;
case IMPP:
i = (~i) | (i & j);
break;
case EQVV:
i = ~(i ^ j);
break;
}
q->i = i;
}
/* down to about here */
/* MACRO */
/* convert + put the value in res into p */
void
putin(p,var)
value *p;
int var;
{
if(vartype != (char)var){
if(var != RVAL){
if(conv(&res))
error(35);
}
else
cvt(&res);
}
if(var != RVAL)
p->i = res.i;
else
#ifdef mips
*p = res;
#else
p->f = res.f;
#endif
}
/* MACRO */
void
negate() /* negate the value in res */
{
register itype t;
if(vartype != RVAL){
t = res.i;
res.i = -t;
if(t != res.i) /* normal case */
return;
cvt(&res); /* negate -maxint */
vartype = RVAL;
}
res.f = -res.f;
}
/* MACRO */
void
notit() /* logical negation */
{
if(vartype != RVAL){
res.i = ~res.i;
return;
}
res.i = IS_ZERO(res) ? -1 : 0;
vartype = IVAL;
}
#ifdef __STDC__
double log(double), exp(double);
#else
double log(),exp();
#endif
/*ARGSUSED*/
static void
fexp(p,q,c) /* floating exponentiation */
valp p,q;
int c;
{
double x;
if(p->f < ZERO)
error(41);
else if(q->f == ZERO)
q->f = ONE;
else if(p->f == ZERO) /* could use pow - but not on v6 */
q->f = ZERO;
else {
if( (x = log(p->f) * q->f) > LOGMAXVAL){ /* should be bigger */
c_error(40);
x = LOGMAXVAL;
}
q->f = exp(x);
}
}
#ifdef BIG_INTS
itype
mmult_ply(p, q, err)
itype p, q;
int err;
{
register unsigned long aa, bb;
register unsigned long result;
int minus = 0;
if(p < 0){
minus = 1;
aa = -p;
}
else
aa = p;
if(q < 0){
minus ^= 1;
bb = -q;
}
else
bb = q;
/*
* we use the smallest value as the loop variable, to reduce time
* whether this improves performance depends on the relative sizes
* of bb and aa.
*/
if(bb > aa){
result = aa;
aa = bb;
bb = result;
}
result = 0;
while(bb){
if(aa & TOP_BIT)
goto over;
if(bb & 1){
result += aa;
if(result & TOP_BIT)
goto over;
}
aa <<= 1;
bb >>= 1;
}
return( (itype) (minus ? -result : result) );
over:
if(err)
error(err);
vartype = RVAL;
return( (itype)0);
}
#endif
syntax highlighted by Code2HTML, v. 0.9.1