/*******************************************************************
** Do float stack depth.
** fdepth ( -- n )
*******************************************************************/
static void Fdepth(FICL_VM *pVM)
{
int i;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
#endif
i = stackDepth(pVM->fStack);
PUSHINT(i);
}
/*******************************************************************
** Do float to integer conversion.
** float>int ( r -- n )
*******************************************************************/
static void Ftoi(FICL_VM *pVM)
{
FICL_INT i;
#if FICL_ROBUST > 1
vmCheckStack(pVM, 0, 1);
vmCheckFStack(pVM, 1, 0);
#endif
i = (FICL_INT)POPFLOAT();
PUSHINT(i);
}
/*******************************************************************
** Do float > comparison r1 > r2.
** f> ( r1 r2 -- T/F )
*******************************************************************/
static void FisGreater(FICL_VM *pVM)
{
float x, y;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 2, 0);
vmCheckStack(pVM, 0, 1);
#endif
y = POPFLOAT();
x = POPFLOAT();
PUSHINT(FICL_BOOL(x > y));
}
/*******************************************************************
** Do float = comparison r1 = r2.
** f= ( r1 r2 -- T/F )
*******************************************************************/
static void FisEqual(FICL_VM *pVM)
{
float x, y;
#if FICL_ROBUST > 1
vmCheckFStack(pVM, 2, 0);
vmCheckStack(pVM, 0, 1);
#endif
x = POPFLOAT();
y = POPFLOAT();
PUSHINT(FICL_BOOL(x == y));
}
thStatus thExecuteCode(char *blockname,CODEPTR code, CODEPTR codelimit)
{
#ifdef PHILDEBUG
#ifdef NOTPOSIX
#warning Phil says NOTPOSIX!
#else
#warning Phil says not NOTPOSIX! i.e. POSIX!!
#endif
#ifdef POINTER64
#warning Phil says POINTER64!
#else
#warning Phil says not POINTER64!
#endif
#ifdef USEMEMCPY
#warning Phil says USEMEMCPY!
#else
#warning Phil says not USEMEMCPY!
#endif
#endif
register CODEPTR pc;
CODE rawopcode,opcode,ltype,rtype,lrtypes;
DAINT nargs,result;
register DAINT *sp;
DAINT i,il,ir,*pi;
DAFLOAT f,fl,fr,*pf;
DADOUBLE d,dl,dr,*pd;
DAINT index;
sp = stack;
pc = code;
while(pc < codelimit){
/* printf("PC=%x, Op code %x, Stack=%x, SP=%x\n",pc,*pc,stack,sp);*/
rawopcode = *pc++;
if(rawopcode >= OPLP){ /* New style */
ltype = (rawopcode & OPLEFTTYPEMASK) >> 8;
rtype = (rawopcode & OPRIGHTTYPEMASK) >> 4;
/* lrtypes = opcode & OPLRTYPEMASK;*/
opcode = rawopcode & OPCODEMASK;
switch(opcode & OPGROUPMASK)
{
case OPPUSHGROUP: /* Pushes */
switch(opcode)
{
#ifdef USEMEMCPY
void *tmpptr;
#endif
case OPPUSHINT: /* Float included in pushes */
if((rawopcode & OPRESTYPEMASK) == OPRDOUBLE){
/* printf("sp=%x, pc=%x\n",sp,pc);*/
#ifdef USEMEMCPY
memcpy((void *)&d,((DADOUBLE *)pc)++,sizeof(DADOUBLE));
PUSHDOUBLE(d);
#else
#ifdef __sgi
PUSHDOUBLE(*((DADOUBLE *)pc)); pc++; pc++;
#else
PUSHDOUBLE(*(DADOUBLE *)pc);/*phil*/
pc = (CODEPTR) (DADOUBLE *) ((DADOUBLE *)pc + 1);
#endif
#endif
/* printf("sp=%x, pc=%x\n",sp,pc);*/
} else {
PUSHINT(*pc++);
}
break;
case OPPUSHPINT: /*Push a pointer*/
#ifdef USEMEMCPY
PUSHPOINTER((memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *))
,tmpptr));
#else
PUSHPOINTER(*(DAINT **)pc); /*phil*/
pc = (CODEPTR)(DAINT **) ((DAINT **)pc + 1);
#endif
break;
case OPPUSHINTP: /*Push what a pointer points to */
if((rawopcode & OPRESTYPEMASK) == OPRDOUBLE){
#ifdef USEMEMCPY
memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *));
d = *(DADOUBLE *) tmpptr;
#else
d = **(DADOUBLE **)pc;/*phil*/
pc = (CODEPTR) (DADOUBLE **) ((DADOUBLE **)pc + 1);
#endif
PUSHDOUBLE(d);/*phil*/
} else {
#ifdef USEMEMCPY
memcpy(&tmpptr,(((DAINT **)pc)++),sizeof(void *));
PUSHINT(*(DAINT *) tmpptr);
#else
PUSHINT(**(DAINT **)pc);/*phil*/
pc = (CODEPTR) (DAINT **) ((DAINT **)pc + 1);
#endif
}
break;
case OPPUSHFUNCTION: /*Push a intrinsic function code */
PUSHINT(*pc++);
break;
}
break;
case OPEOLGROUP:
sp--; /* Should empty the stack */
if(rtype == OPRDOUBLE) sp--; /* Double is two entries on stack */
break;
case OPLINDEXGROUP:
if(opcode==OPLFARG) {
if(rtype==OPRINT) {POPINT(i);}
else if(rtype==OPRFLOAT) {POPFLOAT(f);}/*phil*/
else {POPDOUBLE(d);}/*phil*/
POPINT(index); /* Pop the function code */
switch(index)
{
case 0: /* abs */
if(rtype==OPRINT) {
if(i<0) i = -i;
PUSHINT(i);
} else if(rtype==OPRFLOAT) {
if(f<0.0) f = -f;
PUSHFLOAT(f);/*phil*/
} else {
if(d<0.0) d = -d;
PUSHDOUBLE(d);/*phil*/
}
break;
case 1: /* sqrt */
if(rtype==OPRINT) d = i;
else if(rtype==OPRFLOAT) d = f;
if(d>=0) d = sqrt(d);
else {
fprintf(STDERR,"Test block %s: sqrt(%f)\n",blockname,d);
d = 0;
}
PUSHDOUBLE(d);/*phil*/
break;
case 2: /* exp */
if(rtype==OPRINT) d = i;
else if(rtype==OPRFLOAT) d = f;
d = exp(d);
PUSHDOUBLE(d);/*phil*/
break;
case 3: /* sin */
if(rtype==OPRINT) d = i;
else if(rtype==OPRFLOAT) d = f;
d = sin(d);
PUSHDOUBLE(d);/*phil*/
break;
case 4: /* cos */
if(rtype==OPRINT) d = i;
else if(rtype==OPRFLOAT) d = f;
d = cos(d);
PUSHDOUBLE(d);/*phil*/
break;
case 5: /* tan */
if(rtype==OPRINT) d = i;
else if(rtype==OPRFLOAT) d = f;
d = tan(d);
PUSHDOUBLE(d);/*phil*/
break;
}
break;
}
if(rtype==OPRFLOAT) { /* Floating point index */
POPFLOAT(f);/*phil*/
index = floatToLong(f);
} else if(rtype==OPRDOUBLE) { /* Double */
POPDOUBLE(d);/*phil*/
index = floatToLong(d);
} else {
POPINT(index);
}
index -= ((opcode & 0xF000) == 0x1000 ? 0 : 1);
/* ltype should always be == restype */
if(opcode == OPLINDEX || opcode == OPLINDEXB){
if(ltype == OPRDOUBLE) {
FETCHDARRAY(d);/*phil*/
PUSHDOUBLE(d);/*phil*/
} else if (ltype == OPRFLOAT) {
FETCHFARRAY(f);/*phil*/
PUSHFLOAT(f);/*phil*/
} else {
FETCHIARRAY(i);/*phil*/
PUSHINT(i);
}
} else { /*pointer on stack*/
sp--;
#ifdef POINTER64
sp--;
#endif
if(ltype == OPRDOUBLE) {
/* *((DADOUBLE **)sp)++ = (*((DADOUBLE **)sp)+index);*/
/* The following works better on the alpha */
pd = *((DADOUBLE **)sp);
pd += index;
PUSHPOINTER(pd);/*phil*/
} else { /* Assume INT and FLOAT the same size */
/**((DAINT **)sp)++ = (*((DAINT **)sp)+index);*/
/* The following works better on the alpha */
pi = *((DAINT **)sp);
pi += index;
PUSHPOINTER(pi);/*phil*/
}
}
break;
case OPEQUAL: /* Big ugly matrix of type conversions */
if(rtype==OPRINT) {
POPINT(i);
if(ltype==OPRINT) {
SAVEINT(i); /* Save result in result variable *//*phil*/
PUSHINT(i); /* Put result back on stack */
} else if(ltype==OPRFLOAT) {
f = i; /* Convert to floating */
SAVEFLOAT(f); /* Save variable *//*phil*/
PUSHFLOAT(f); /* Put back on stack *//*phil*/
} else { /* if(ltype==OPRDOUBLE) */
d = i;
SAVEDOUBLE(d);/*phil*/
PUSHDOUBLE(d);/*phil*/
}
} else if(rtype==OPRFLOAT) {
POPFLOAT(f);/*phil*/
if(ltype==OPRINT) {
i = floatToLong(f);
SAVEINT(i); /* Save result in result variable *//*phil*/
*sp++ = i;
} else if(ltype==OPRFLOAT) {
SAVEFLOAT(f); /* Save variable *//*phil*/
*sp++ = *(DAINT *)&f;
} else { /* if(ltype==OPRDOUBLE) */
d = f;
SAVEDOUBLE(d);/*phil*/
PUSHDOUBLE(d);/*phil*/
}
} else { /* if(rtype==OPRDOUBLE) */
POPDOUBLE(d);/*phil*/
if(ltype==OPRINT) {
i = floatToLong(d);
SAVEINT(i); /* Save result in result variable *//*phil*/
*sp++ = i;
} else if(ltype==OPRFLOAT) {
f = d;
SAVEFLOAT(f); /* Save variable *//*phil*/
*sp++ = *(DAINT *)&f;
} else { /* if(ltype==OPRDOUBLE) */
SAVEDOUBLE(d);/*phil*/
PUSHDOUBLE(d);/*phil*/
}
}
break;
case OPLOGGROUP: /* Logic and Bit operations */
case OPSHIFTGROUP: /* Logic and Bit operations */
if(rtype==OPRINT) {
POPINT(ir);
} else if(rtype==OPRFLOAT) {
POPFLOAT(f);/*phil*/
ir = floatToLong(f);
} else {
POPDOUBLE(d);/*phil*/
ir = floatToLong(d);
}
if(ltype==OPRINT) {
POPINT(il);
} else if(ltype==OPRFLOAT) {
POPFLOAT(f);/*phil*/
il = floatToLong(f);
} else {
POPDOUBLE(d);/*phil*/
il = floatToLong(d);
}
switch(opcode)
{
case OPLOGOR:
*sp++ = il || ir;
break;
case OPLOGXOR:
*sp++ = (il != 0) ^ (ir != 0);
break;
case OPLOGAND:
*sp++ = il && ir;
break;
case OPBITOR:
*sp++ = il | ir;
break;
case OPBITXOR:
*sp++ = il ^ ir;
break;
case OPBITAND:
*sp++ = il & ir;
break;
case OPSHL:
*sp++ = il << ir;
break;
case OPSHR:
*sp++ = il >> ir;
break;
}
break;
case OPCOMPGROUP: /* Logic comparisons */
/* Result of Add amd MUL groups should now always be double */
case OPADDGROUP: /* Add and Subtract */
case OPMULGROUP: /* * / and % */
if(rtype==OPRINT) {
POPINT(ir);
dr = ir;
} else if (rtype==OPRFLOAT) {
POPFLOAT(fr);/*phil*/
dr = fr;
} else {
POPDOUBLE(dr);/*phil*/
}
if(ltype==OPRINT) {
POPINT(il);
dl = il;
} else if (ltype==OPRFLOAT) {
POPFLOAT(fl);/*phil*/
dl = fl;
} else {
POPDOUBLE(dl);/*phil*/
}
if(rtype!=OPRINT || ltype!=OPRINT){
switch(opcode)
{
case OPISEQUAL:
*sp++ = dl == dr;
break;
case OPISNOTEQUAL:
*sp++ = dl != dr;
break;
case OPISLT:
*sp++ = dl < dr;
break;
case OPISGT:
*sp++ = dl > dr;
break;
case OPISLE:
*sp++ = dl <= dr;
break;
case OPISGE:
*sp++ = dl >= dr;
break;
case OPADD:
d = dl + dr;
PUSHDOUBLE(d);/*phil*/
break;
case OPSUB:
d = dl - dr;
PUSHDOUBLE(d);/*phil*/
break;
case OPTIMES:
d = dl * dr; /* Need to deal with overflow */
PUSHDOUBLE(d);/*phil*/
break;
case OPIDIV:
/* printf("OP=%x\n",rawopcode);*/
if(dr == 0.0) {
fprintf(STDERR,"Test block %s: %f/0.0\n",blockname,dl);
d = 0.0;
} else {
d = dl / dr; /* Need to deal with overflow and div 0 */
}
*sp++ = floatToLong(d);
break;
case OPDIV:
if(dr == 0.0) {
fprintf(STDERR,"Test block %s: %f/0.0\n",blockname,dl);
d = 0.0;
} else {
d = dl / dr; /* Need to deal with overflow and div 0 */
}
PUSHDOUBLE(d);/*phil*/
break;
case OPMOD:
d = fmod(dl,dr);
PUSHDOUBLE(d);/*phil*/
break;
}
} else { /* Both left and right are int */
switch(opcode)
{
case OPISEQUAL:
*sp++ = il == ir;
break;
case OPISNOTEQUAL:
*sp++ = il != ir;
break;
case OPISLT:
*sp++ = il < ir;
break;
case OPISGT:
*sp++ = il > ir;
break;
case OPISLE:
*sp++ = il <= ir;
break;
case OPISGE:
*sp++ = il >= ir;
break;
case OPADD:
*sp++ = il + ir;
break;
case OPSUB:
*sp++ = il - ir;
break;
case OPTIMES:
*sp++ = il * ir; /* Need to deal with overflow */
break;
case OPIDIV:
/* printf("At OPIDIV all int branch\n");*/
if(ir == 0) {
fprintf(STDERR,"Test block %s: %d/0.0\n",blockname,il);
*sp++ = 0;
} else {
*sp++ = il / ir;
}
break;
case OPDIV:
if(ir == 0) {
fprintf(STDERR,"Test block %s: %d/0.0\n",blockname,il);
d = 0.0;
} else
d = dl / dr; /* Need to deal with overflow and div 0 */
PUSHDOUBLE(d);/*phil*/
break;
case OPMOD:
*sp++ = il % ir; /* Need to deal with overflow and div 0 */
break;
}
}
break;
case OPUNARY: /* Unary Operators */
switch(opcode)
{
case OPNEG:
if(rtype==OPRINT) {
i = -(*--sp);
*sp++ = i;
} else if (rtype==OPRFLOAT) {
f = *(DAFLOAT *)(--sp);
f = -f;
*sp++ = *(DAINT *)&f;
} else {
POPDOUBLE(d);/*phil*/
d = -d;
PUSHDOUBLE(d);/*phil*/
}
break;
case OPNOT:
case OPCOMP:
if(rtype==OPRINT) {
POPINT(i);
} else if(rtype==OPRFLOAT) {
POPFLOAT(f);/*phil*/
i = floatToLong(f);
} else {
POPDOUBLE(d);/*phil*/
i = floatToLong(d);
}
i = (opcode == OPNOT ? !i : ~i);
*sp++ = i;
break;
}
break;
default:
fprintf(STDERR,"Test block %s: Operator %x not yet implimented\n",
blockname,opcode);
break;
} /* Terminates switch */
} else { /* terminates if(rawopcode >=OPLP) *//* Old Style, May not work anymore */
switch(*pc++)