/* TIPC Scheme '84 Runtime Support - Arithmetic Support
   (C) Copyright 1984,1985 by Texas Instruments Incorporated.
   All rights reserved.

   Author:  John C. Jensen
   Installation:  Texas Instruments Incorporated, Dallas, Texas
   Division:  Central Research Laboratories
   Cost Center:  Computer Science Laboratory
   Project:  Computer Architecture Branch
   Date Written:  9 May 1984
   Last Modification:
	  11 February 1986 - Change error message text "MOD" to
			     "REMAINDER"
*/
#include "scheme.h"

#include "slist.h"

int CXFERR_status = 0;		/* floating point error status code */

static int *resreg = NULL;	   /* Result regsiter */

/****************************************************************/
/*     Support of unary arithmetic operations on values other	*/
/*     than fixnums.						*/
/****************************************************************/
arith1(op, reg)
int op;
int reg[2];
 {
  int disp,page;
  int siz1;
  char *big1;
  double flo;

  double get_flo();
  char *getmem();

  /* fetch operand page number and displacement */
  setabort();
  resreg = reg;
  disp = reg[0];
  page = CORRPAGE(reg[1]);
  switch (ptype[page]) /* dispatch on pointer type */
   {
    case (FLOTYPE*2):  flo = get_flo(page, disp);
		       switch (op)
			{
			 case MINUS_OP:  if (flo == 0.0) goto get_out;
					 else flo = - flo;
					 break;
			 case ZERO_OP:	return(flo == 0.0);
			 case NEG_OP:  return(flo < 0.0);
			 case POS_OP:  return(flo > 0.0);
			 case ABS_OP:  if (flo >= 0.0) goto get_out;
				       else flo = -flo;
				       break;
			} /* end:  switch (op) */
		       alloc_flonum(reg, flo);
		       break;

    case (BIGTYPE*2):  siz1 = get_word(page,disp+1)+2;
		       if (!(big1 = getmem(siz1)))
			 abort(HEAPERR);
		       copybig(page,disp,big1);
		       switch(op)
			{
			 case MINUS_OP: big1[2] ^= 1; break;
			 case ZERO_OP: page = FALSE;
				       goto ret_page;
			 case POS_OP: page = !(big1[2] & 1);
				      goto ret_page;
			 case NEG_OP: page = big1[2] & 1;
ret_page:
				     rlsmem(big1,siz1);
				     return(page);
			 case ABS_OP: big1[2] &= '\376'; break;
			}
		       alloc_int(reg,big1);
		       rlsmem(big1,siz1);
		       break;

    default:	       /* Invalid operand to arithmetic function */
		       not_numb(op, reg);
		       return(-1);
   } /* end:  switch (ptype[page]) */
get_out:
  return(0);
 } /* end of function:	arith1(op, reg) */


/****************************************************************/
/*     Support of binary arithmetic operations on values other	*/
/*     than fixnums (+, -, *, /, mod)				*/
/****************************************************************/
arith2(op, reg1, reg2)
int op;
int reg1[2], reg2[2];
 {
  int disp1,disp2;		/* displacements of input operands */
  int page1,page2;		/* page numbers of input operands */
  int type1,type2;		/* input operand types */
  int fix1, fix2;		/* values of fixnum operands */
  int mag;			/* magnitude test result for bignums */
  int new_type; 		/* type used with mixed mode operands */
  char *getmem();		/* memory-grabbing function */
  char *big1,*big2,*big3;	/* bignum buffers */
  int siz1,siz2,siz3;		/* sizes of bignum buffers */
  double flo1, flo2;		/* values of flonum operands */

  double get_flo();

  setabort();			big1 = big2 = 0;
overs:	/* "re-entry" point in case bignum divide produces factional result */
  resreg = reg1;
  /* localize operand information */
  disp1 = reg1[0];		disp2 = reg2[0];
  page1 = CORRPAGE(reg1[1]);	page2 = CORRPAGE(reg2[1]);
  type1 = ptype[page1]; 	type2 = ptype[page2];

  /* validate and fetch 1st operand */
  switch (type1)
   {
    case (FIXTYPE*2):  fix1 = get_fix(page1, disp1);  break;
    case (FLOTYPE*2):  flo1 = get_flo(page1, disp1);  break;
    case (BIGTYPE*2):  siz1 = get_word(page1, disp1+1) + 4;
		       if (!(big1 = getmem(siz1)))
			 abort(HEAPERR);
		       copybig(page1,disp1,big1);
		       break;
    default:	       goto non_numeric;
   } /* end:  switch (type1) */

  /* validate and fetch 2nd operand */
  switch (type2)
   {
    case (FIXTYPE*2):  fix2 = get_fix(page2, disp2);  break;
    case (FLOTYPE*2):  flo2 = get_flo(page2, disp2);  break;
    case (BIGTYPE*2):  siz2 = get_word(page2, disp2+1) + 2;
		       if (!(big2 = getmem(siz2)))
			{
			 if (big1)
			   rlsmem(big1,siz1);
			 abort(HEAPERR);
			}
		       copybig(page2,disp2,big2);
		       break;
    default:	       goto non_numeric;
   } /* end:  switch (type1) */

  /* if types don't match, convert one of the operands */
  new_type = type1;
  if (type1 != type2)
   {
    switch (type1)
     {
      case (FIXTYPE*2):  switch (type2)
			  {
			   case (FLOTYPE*2):  new_type = FLOTYPE*2;
					      flo1 = fix1;
					      break;
			   case (BIGTYPE*2):  new_type = BIGTYPE*2;
					      siz1 = 7;
					      if (!(big1 = getmem(7)))
					       {
						rlsmem(big2,siz2);
						abort(HEAPERR);
					       }
					      fix2big(fix1,big1);
					      /* convert fixnum to bignum */
					      break;
			  } /* end:  switch (type2) */
			 break;

      case (FLOTYPE*2):  switch(type2)
			  {
			   case (FIXTYPE*2):  flo2 = fix2;
					      break;
			   case (BIGTYPE*2):  if (big2flo(big2,&flo2))
					       {
						rlsmem(big2,siz2);
				     BIGnum:    
					  /* No return from dos_err           */
				          dos_err(1,FLONUM_OVERFLOW_ERROR,reg2);
					   /*	reg1[0] = OVR_DISP;           */
					   /*	reg1[1] = ADJPAGE(OVR_PAGE);  */
					   /*	abort(OVERERR);		      */
					       }
					      rlsmem(big2,siz2);
					      break;
			  } /* end:  switch(type2) */
			 break;

      case (BIGTYPE*2):  switch(type2)
			  {
			   case (FIXTYPE*2):  siz2 = 7;
					      if (!(big2 = getmem(7)))
					       {
						rlsmem(big1,siz1);
						abort(HEAPERR);
					       }
					      fix2big(fix2,big2);
					      break;
			   case (FLOTYPE*2):  new_type = FLOTYPE*2;
					      if (big2flo(big1,&flo1))
					       {
						rlsmem(big1,siz1);
					  /* No return from dos_err           */
				          dos_err(1,FLONUM_OVERFLOW_ERROR,reg1);
						/* goto BIGnum; */
					       }
					      rlsmem(big1,siz1);
					      break;
			  } /* end:  switch(type2) */
			 break;
     } /* end:	switch (type1) */
   } /* end:  if (type1 != type2) */

  /* Preform the operation */
  switch (new_type)
   {
    case (FLOTYPE*2):  CXFERR_status = 0;
		       switch (op)
			{
			  case ADD_OP:	flo1 += flo2;  break;
			  case SUB_OP:	flo1 -= flo2;  break;
			  case MUL_OP:	flo1 *= flo2;  break;
			  case DIV_OP:	flo1 /= flo2;  break;
			  case QUOT_OP:
					set_src_err("QUOTIENT", 2, reg1, reg2);
					goto error_return;
			  case MOD_OP:
					set_src_err("REMAINDER", 2, reg1, reg2);
					goto error_return;
			  case AND_OP:
bad_and:
					set_src_err("LOGAND",2,reg1,reg2);
					goto error_return;
			  case OR_OP:
bad_or:
					set_src_err("LOGIOR",2,reg1,reg2);
					goto error_return;
			  case XOR_OP:
bad_xor:
					set_src_err("LOGXOR",2,reg1,reg2);
					goto error_return;
			  case EQ_OP:	return(flo1 == flo2);
			  case NE_OP:	return(flo1 != flo2);
			  case LT_OP:	return(flo1 < flo2);
			  case GT_OP:	return(flo1 > flo2);
			  case LE_OP:	return(flo1 <= flo2);
			  case GE_OP:	return(flo1 >= flo2);
			} /* end:  switch (op) */
		       if (CXFERR_status)
			{
			 float_overflow(op, reg1, reg2);
			 goto error_return;
			}
		       else
			{
			 if (reg1[C_PAGE] != SPECSYM*2)
			   alloc_flonum(reg1, flo1);
			}
		       break;

    case (BIGTYPE*2):  mag = magcomp(big1,big2) & 0x00ff;
		       switch (op)
			{
			 case SUB_OP: big2[2] ^= 1; /* Negate & fall thru */
				      mag ^= 16;
			 case ADD_OP: if (mag & 16) /* Same signs */
					if (mag & 2) /* |BIG1| greater? */
					 {
					  bigadd(big2,big1);
					  goto alloc1;
					 }
					 else
					 {
					  bigadd(big1,big2);
					  goto alloc2;
					 }
				       else
				       {
					if (mag & 2) /* |BIG1| greater? */
					 {
					  bigsub(big2,big1);
			      alloc1:	  alloc_int(reg1,big1);
					 }
					 else
					 {
					  bigsub(big1,big2);
			      alloc2:	  alloc_int(reg1,big2);
					 }
				       }
				      break;
			 case MUL_OP: /* if reg1 is zero, we're done */
				      if (type1 == FIXTYPE*2 && !fix1) break;
				      /* if reg2 is zero, set result to zero */
				      if (type2 == FIXTYPE*2 && !fix2)
				       {
					alloc_fixnum(reg1,0);
					break;
				       }
				      /* must perform multiply */
				      siz3 = (siz1 + siz2) - 3;
				      if (!(big3=getmem(siz3)))
				       {
				rls12:	rlsmem(big1,siz1);
					rlsmem(big2,siz2);
					abort(HEAPERR);
				       }
				      bigmul(big1,big2,big3);
			     alloc3:  alloc_int(reg1,big3);
			     rls3:    rlsmem(big3,siz3);
				      break;
			 case DIV_OP: if (mag & 1)  goto float_it;
				      siz3 = siz1 - siz2 + 5;
				      if (!(big3 = getmem(siz3)))
					goto rls12;
				      thefix(big1);
				      if (bigdiv(big1,big2,big3))
				       {
			      rls123:	rlsmem(big1,siz1);
					rlsmem(big2,siz2);
					rlsmem(big3,siz3);
					CXFERR_status = -2;
					float_over(op, reg1, reg2);
					goto error_return;
				       }
				      /* test for fractional result */
				      if (big1[3] || big1[4] ||
					  big1[1] || big1[0] != 1)
				       {
					rlsmem(big3,siz3);
float_it:
					rlsmem(big1,siz1);
					rlsmem(big2,siz2);
					sfloat(reg1); /* make reg1 flonum */
					goto overs; /* re-try as flonum */
				       }
				      goto alloc3;
			 case MOD_OP: if (!(mag & 1))
				       {
					siz3 = siz1 - siz2 + 5;
					if (!(big3 = getmem(siz3)))
					  goto rls12;
					thefix(big1);
					if (bigdiv(big1,big2,big3))
					  goto rls123;
					alloc_int(reg1,big1);
					goto rls3;
				       }
				      break;
			 case QUOT_OP: if (mag & 1)
					alloc_fixnum(reg1,0);
				       else
				       {
					siz3 = siz1 - siz2 + 5;
					if (!(big3 = getmem(siz3)))
					  goto rls12;
					thefix(big1);
					if (bigdiv(big1,big2,big3))
					  goto rls123;
					goto alloc3;
				       }
				      break;
			 case AND_OP:  goto bad_and;
			 case OR_OP:   goto bad_or;
			 case XOR_OP:  goto bad_xor;
			 case EQ_OP:
			 case NE_OP:
			 case LT_OP:
			 case GT_OP:
			 case LE_OP:
			 case GE_OP:
			   rlsmem(big1,siz1);
			   rlsmem(big2,siz2);
			   switch (op)
			    {
			     case EQ_OP: return(!(mag & 0x000f));
			     case NE_OP: return(mag & 0x000f);
			     case LT_OP: return(mag & 4);
			     case GT_OP: return(mag & 8);
			     case LE_OP: return(!(mag & 8));
			     case GE_OP: return(!(mag & 4));
			    }
			} /* end:  switch (op) */
		       rlsmem(big1,siz1);
		       rlsmem(big2,siz2);
		       break;
   } /* end:  switch (new_type) */
  goto end_arith2;
non_numeric:
  not_numb(op, reg1, reg2);
error_return:
  return(-1);
end_arith2:
  return(0);
 } /* end of function:	arith2(op, reg1, reg2) */


/****************************************************************/
/* float to integer conversion-- truncate (adjust toward zero)	*/
/****************************************************************/
truncate(reg)
int reg[2];			/* register holding value/result */
 {
  int disp,page;		/* pointer displacement, page number */
/*%%  long fix; 		    /* temp to hold result */*/

  disp = reg[C_DISP];
  page = CORRPAGE(reg[C_PAGE]);

  switch (ptype[page])
   {
    case FLOTYPE*2:  fixflo(reg,get_flo(page, disp)); /* fetch and
					    re-allocate as an integer */
					  /* falls through  to "break" */
    case BIGTYPE*2:  /* bignums and fixnums mutually exclusive */
    case FIXTYPE*2:  /* already a fixnum, so no action required */
		     break;
    default:	     not_numb(TRUNC_OP, reg); /* invalid type */
		     return(-1);
   } /* end:  switch (type) */
  return(0);
 } /* end of function:	truncate(reg) */

/****************************************************************/
/* float to integer-- floor (adjust toward -infinity)		*/
/****************************************************************/
floor(reg)
int reg[2];			/* register holding value/result */
 {
  int disp,page;		/* pointer displacement, page number */
/*%%  long fix; 		    /* temp to hold converted result */*/
  double flo;			/* temp to hold value to be converted */

  disp = reg[C_DISP];
  page = CORRPAGE(reg[C_PAGE]);

  switch (ptype[page])
   {
    case FLOTYPE*2:  flo = get_flo(page, disp);
		     if (flo < 0.0) flo -= 0.9999999999;
		     fixflo(reg, flo); /* re-allocate as an integer */
					/* falls through to "break" */
    case BIGTYPE*2:  /* bignums and fixnums mutually exclusive */
    case FIXTYPE*2:  /* already a fixnum, so no action required */
		     break;
    default:	     not_numb(FLOOR_OP, reg); /* invalid type */
		     return(-1);
   } /* end:  switch (type) */
  return(0);
 } /* end of function:	floor(reg) */

/****************************************************************/
/* float to integer-- ceiling (adjust toward +infinity) 	*/
/****************************************************************/
ceiling(reg)
int reg[2];			/* register holding value/result */
 {
  int disp,page;		/* pointer displacement, page number */
/*%%  long fix; 		    /* temp to hold converted result */*/
  double flo;			/* temp to hold value to be converted */

  disp = reg[C_DISP];
  page = CORRPAGE(reg[C_PAGE]);

  switch (ptype[page])
   {
    case FLOTYPE*2:  flo = get_flo(page, disp);
		     if (flo > 0.0) flo += 0.9999999999;
		     fixflo(reg,flo); /* re-allocate as an integer */
					/* falls through to "break" */
    case BIGTYPE*2:  /* bignums and fixnums mutually exclusive */
    case FIXTYPE*2:  /* already a fixnum, so no action required */
		     break;

    default:	     not_numb(CEIL_OP, reg); /* invalid type */
		     return(-1);
   } /* end:  switch (type) */
  return(0);
 } /* end of function:	ceiling(reg) */

/****************************************************************/
/* float to integer-- round (adjust toward nearest integer)	*/
/****************************************************************/
round(reg)
int reg[2];			/* register holding value/result */
 {
  int disp,page;		/* pointer displacement, page number */
/*%%  long fix; 		    /* temp to hold converted result */*/
  double flo;			/* floating point value */

  disp = reg[C_DISP];
  page = CORRPAGE(reg[C_PAGE]);

  switch (ptype[page])
   {
    case FLOTYPE*2:  flo = get_flo(page, disp);
		     flo += (flo<0 ? -0.5 : 0.5);
		     fixflo(reg,flo); /* re-allocate as an integer */
					/* falls through to "break" */
    case BIGTYPE*2:  /* bignums and fixnums mutually exclusive */
    case FIXTYPE*2:  /* already a fixnum, so no action required */
		     break;
    default:	     not_numb(ROUND_OP, reg); /* invalid type */
		     return(-1);
   } /* end:  switch (type) */
  return(0);
 } /* end of function:	round(reg) */

/****************************************************************/
/* Convert flonum to integer, which is stored in a register	*/
/****************************************************************/
fixflo(reg,flo)
int reg[2];
double flo;
 {
  int siz;
  char *getmem();
  char *bigbuf;
  setabort();
  if (flo==0.0) goto alloc_zero;
   else
   {
    if (siz=flosiz(flo))
     {
      if (!(bigbuf=getmem(siz)))  abort(HEAPERR);
      flotobig(flo,bigbuf);
      alloc_int(reg,bigbuf);
      rlsmem(bigbuf,siz);
     }
     else
     {
alloc_zero:
      alloc_fixnum(reg,0);
     }
   }
 } /* end of function: fixflo(reg,flo) */

/****************************************************************/
/* Convert value to floating point 				*/
/****************************************************************/
sfloat(reg)
int reg[2];			/* register containing value/result */
 {
  int disp,page,type;		/* pointer displacement, page number, type */
  int siz1;			/* size of working bignum */
  char *big1;			/* working bignum */
  double flo;			/* temp for floating point result */
  char *getmem();		/* memory-grabbing function */

  setabort();
  disp = reg[0];
  page = CORRPAGE(reg[1]);
  type = ptype[page];

  switch (type)
   {
    case FIXTYPE*2:  flo = get_fix(page, disp); /* fetch and convert value */
		     alloc_flo(reg, flo); /* re-allocate as flonum */
		     break;
    case BIGTYPE*2:  siz1 = get_word(page,disp+1)+2;
		     if (!(big1 = getmem(siz1)))
		       abort(HEAPERR);
		     copybig(page,disp,big1);
		     if (big2flo(big1, &flo))
		      {
		       rlsmem(big1,siz1);
		       /* Control does not return from dos_err */	
		       dos_err(1,FLONUM_OVERFLOW_ERROR, reg);	
		       /* reg[0] = OVR_DISP;		*/
		       /* reg[1] = ADJPAGE(OVR_PAGE);	*/
                       /* abort(OVERERR);		*/
		      }
		     rlsmem(big1, siz1);
		     alloc_flo(reg,flo);
		     break;
    case FLOTYPE*2:  /* already a flonum, so no action required */
		     break;
    default:	     not_numb(FLOAT_OP, reg);
		     return(-1);
   } /* end:  switch (type) */
  return(0);
 } /* end of function:	sfloat(reg) */


/* What to do when a fixnum result is too large to be fixnum */
enlarge(reg,i)
int reg[2];
long i;
 {
  alloc_block(reg, BIGTYPE, ((abs(i)>65535) ? 5 : 3));
  putlong(reg,i);
 }


/*     Arithmetic support error routines     */
/* Arithmetic Operations */
static char *operation[24]={"+","-",    "*",    "/",    "REMAINDER",
			"LOGAND","LOGIOR","MINUS","=?", "<>?",
			"<?",   ">?",   "<=?",  ">=?",  "ABS",
			"QUOTIENT","TRUNCATE","FLOOR","CEILING","ROUND",
			"FLOAT","ZERO?","POSITIVE?","NEGATIVE?"};
/* Note:  TRUE -> binary operation;  FALSE -> unary operation */
static char binary[24]={TRUE,	TRUE,	TRUE,	TRUE,	TRUE,
			TRUE,	TRUE,	FALSE,	TRUE,	TRUE,
			TRUE,	TRUE,	TRUE,	TRUE,	FALSE,
			TRUE,	FALSE,	FALSE,	FALSE,	FALSE,
			FALSE,	FALSE,	FALSE,	FALSE};
not_numb(op, reg1, reg2)
int op, reg1[2], reg2[2];
 {
  mov_reg(tmp_reg, nil_reg);
  if (binary[op]) cons(tmp_reg, reg2, tmp_reg);
  cons(reg1, reg1, tmp_reg);
  intern(tmp_reg, operation[op], strlen(operation[op]));
  cons(reg1, tmp_reg, reg1);
  set_numeric_error(1, NUMERIC_OPERAND_ERROR, reg1);
  reg1[C_DISP] = NTN_DISP;
  reg1[C_PAGE] = NTN_PAGE*2;
 }

float_overflow(op, reg1, reg2)
int op, reg1[2], reg2[2];
 {
  cons(tmp_reg, reg2, nil_reg);
  cons(reg1, reg1, tmp_reg);
  intern(tmp_reg, operation[op], strlen(operation[op]));
  cons(reg1, tmp_reg, reg1);
  set_numeric_error(1,
   (CXFERR_status == -1 ? FLONUM_OVERFLOW_ERROR : ZERO_DIVIDE_ERROR), reg1);
  reg1[C_DISP] = NTN_DISP;
  reg1[C_PAGE] = NTN_PAGE*2;
 }

/* What to do in the event of a floating-point exception */
CXFERR(code)
int code;
 {
  switch (code)
   {
    case 2: /* Overflow */
      set_numeric_error(1, FLONUM_OVERFLOW_ERROR, nil_reg);
      CXFERR_status = -1;
      break;
    case 3: /* Divide by zero */
      set_numeric_error(1, ZERO_DIVIDE_ERROR, nil_reg);
      CXFERR_status = -2;
      break;
   }
 }

/* Put the next number in the present pseudo-random sequence into REG */
/* For details on the generator KRANDOM, see the file STIMER.ASM      */
srandom(reg)
int reg[2];
 {
  alloc_fixnum(reg,krandom());
 }
