

/* Pocket Smalltalk
   Copyright (c) 1998,1999 by Andrew Brault
   http://www.pocketsmalltalk.com
   See LICENSE.TXT for license information */

/* Primitives belonging to classes in the Number hierarchy */


#include "main.h"

#define _DONT_USE_FP_TRAPS_ 1
#include <FloatMgr.h>


Err SysTrapFlpFToA(FlpDouble a, Char * s) SYS_TRAP(sysTrapFlpDispatch);
void SysTrapFlpLToF(FlpDouble*, Long) SYS_TRAP(sysTrapFlpEmDispatch);
Long SysTrapFlpFToL(FlpDouble) SYS_TRAP(sysTrapFlpEmDispatch);
void SysTrapBinOp(FlpDouble*, FlpDouble, FlpDouble) SYS_TRAP(sysTrapFlpEmDispatch);
SDWord SysTrapCompare(FlpDouble, FlpDouble) SYS_TRAP(sysTrapFlpEmDispatch);
FlpDouble SysTrapFlpNeg(FlpDouble f) SYS_TRAP(sysTrapFlpEmDispatch);



boolean is_integer(Object object)
{
  return IS_SMALLINT(object) ||
         (OBJECT_CLASS(object) == LongInteger);
}


Object as_smalltalk_integer(int32 value)
{
  Object longint;

  if(CAN_BE_SMALLINT(value))
    return TO_SMALLINT(value);
  else {
    longint = instantiate_byte_indexed(LongInteger, sizeof(int32));
    MEMCOPY(OBJECT_BYTES(longint), &value, sizeof(int32));
    return longint;
  }
}


/* object _must_ be either a SmallInteger or a LongInteger */
int32 as_c_integer(Object object)
{
  int32 value;

  if(IS_SMALLINT(object))
    return FROM_SMALLINT(object);
  else {
    MEMCOPY(&value, OBJECT_BYTES(object), sizeof(int32));
    return value;
  }
}


/* Compare integers.  Only the right argument is checked to
   make sure it is an integer.  If it is not, Failure_value
   is returned (and the primitive fail code is set to 1).
   op is one of these characters:
     '<' (less)
     '[' (less or equal)
     '>' (greater)
     ']' (greater or equal)
     '=' (equal)
     '!' (not-equal)
*/
Object integer_compare(Object left, Object right, char op)
{
  int32 lval, rval;
  boolean result;

  if(!is_integer(right))
    { FAIL(1); }
  lval = as_c_integer(left);
  rval = as_c_integer(right);

  switch(op) {
  case '<': result = lval < rval; break;
  case '[': result = lval <= rval; break;
  case '>': result = lval > rval; break;
  case ']': result = lval >= rval; break;
  case '=': result = lval == rval; break;
  case '!': result = lval != rval; break;
  }

  return AS_BOOLEAN(result); 
}


/* Operate on integers.  Only the right argument is checked to
   make sure it is an integer.  If it is not, Failure_value
   is returned (and the primitive fail code is set to 1).
   op is one of these characters:
     '+' (addition)
     '-' (subtraction)
     '*' (multiplication)
     '&' (bitwise AND)
     '|' (bitwise OR)
     '^' (bitwise XOR)
   (note that division and modulus have to be handled
    separately due to the possibility of division by 0)
*/
Object integer_op(Object left, Object right, char op)
{
  int32 lval, rval, result;

  if(!is_integer(right))
    { FAIL(1); }
  lval = as_c_integer(left);
  rval = as_c_integer(right);

  switch(op) {
  case '+': result = lval + rval; break;
  case '-': result = lval - rval; break;
  case '*': result = lval * rval; break;
  case '&': result = lval & rval; break;
  case '|': result = lval | rval; break;
  case '^': result = lval ^ rval; break;
  }

  return as_smalltalk_integer(result);
}




/* SmallInteger>>#+
   LongInteger>>>#+
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_add(Object arg)
{
  return integer_op(receiver, arg, '+');
}


/* SmallInteger>>#-
   LongInteger>>>#-
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_subtract(Object arg)
{
  return integer_op(receiver, arg, '-');
}


/* SmallInteger>>#*
   LongInteger>>>#*
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_multiply(Object arg)
{
  return integer_op(receiver, arg, '*');
}


/* SmallInteger>>#bitAnd:
   LongInteger>>>#bitAnd:
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_bitand(Object arg)
{
  return integer_op(receiver, arg, '&');
}


/* SmallInteger>>#bitOr:
   LongInteger>>>#bitOr:
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_bitor(Object arg)
{
  return integer_op(receiver, arg, '|');
}


/* SmallInteger>>#bitXor:
   LongInteger>>>#bitXor:
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_bitxor(Object arg)
{
  return integer_op(receiver, arg, '^');
}


/* SmallInteger>>#//
   LongInteger>>>#//
   Division with truncation toward -inf
   This is not the same as C / operator!
   Fails with:
     1 - argument is not an integer
     2 - division by 0
*/
Object p_integer_truncate_div(Object arg)
{
  int32 lval, rval, result;

  if(!is_integer(arg))
    { FAIL(1); }
  lval = as_c_integer(receiver);
  rval = as_c_integer(arg);
  if(rval == 0)
    { FAIL(2); }
  result = lval / rval;
  if(result < 0) {
    if(result * rval != lval)
      result--;
  }
  else if(result == 0) {
    if((lval < 0) != (rval < 0))
      result--;
  }
  return as_smalltalk_integer(result);
}


/* SmallInteger>>#quo:
   LongInteger>>>#quo:
   Division with truncation toward 0
   Same as C / operator.
   Fails with:
     1 - argument is not an integer
     2 - division by 0
*/
Object p_integer_quo_div(Object arg)
{
  int32 rval;

  if(!is_integer(arg))
    { FAIL(1); }
  rval = as_c_integer(arg);
  if(rval == 0)
    { FAIL(2); }
  return as_smalltalk_integer(as_c_integer(receiver) / rval);
}


/* SmallInteger>>#gcd:
   LongInteger>>>#gcd:
   GCD calculation.
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_gcd(Object arg)
{
  int32 gcd, x, temp;

  if(!is_integer(arg))
    { FAIL(1); }
  x = as_c_integer(arg);
  if(x < 0) x = -x;
  gcd = as_c_integer(receiver);
  if(gcd < 0) gcd = -gcd;
  while(x) {
    temp = gcd % x;
    gcd = x;
    x = temp;
  }
  return as_smalltalk_integer(gcd);
}


/* SmallInteger>>#<
   LongInteger>>>#<
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_less(Object arg)
{
  return integer_compare(receiver, arg, '<');
}


/* SmallInteger>>#<=
   LongInteger>>#<=
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_lesseq(Object arg)
{
  return integer_compare(receiver, arg, '[');
}


/* SmallInteger>>#>
   LongInteger>>#>
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_greater(Object arg)
{
  return integer_compare(receiver, arg, '>');
}


/* SmallInteger>>#>=
   LongInteger>>#>=
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_greatereq(Object arg)
{
  return integer_compare(receiver, arg, ']');
}


/* SmallInteger>>#=
   LongInteger>>#=
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_equal(Object arg)
{
  return integer_compare(receiver, arg, '=');
}


/* SmallInteger>>#~=
   LongInteger>>#~=
   Fails with:
     1 - argument is not an integer
*/
Object p_integer_notequal(Object arg)
{
  return integer_compare(receiver, arg, '~');
}


/* SmallInteger>>#rem:
   LongInteger>>#rem:
   Modulus with truncation toward 0.
   Same as C % operator.
   Fails with:
     1 - argument is not an integer
     2 - division by 0
*/
Object p_integer_rem(Object arg)
{
  int32 rval;

  if(!is_integer(arg))
    { FAIL(1); }
  rval = as_c_integer(arg);
  if(rval == 0)
    { FAIL(2); }
  return as_smalltalk_integer(as_c_integer(receiver) % rval);
}


/* SmallInteger>>#\\
   LongInteger>>#\\
   Modulus with truncation toward -inf.
   Not the same as C % operator!
   Fails with:
     1 - argument is not an integer
     2 - division by 0
*/
Object p_integer_mod(Object arg)
{
  int32 lval, rval, result;

  if(!is_integer(arg))
    { FAIL(1); }
  lval = as_c_integer(receiver);
  rval = as_c_integer(arg);
  if(rval == 0)
    { FAIL(2); }

  result = lval % rval;
  if (rval < 0) {
    if (result > 0)
      result += rval;
  }
  else {
    if (result < 0)
      result += rval;
  };
  return as_smalltalk_integer(result);
}


/* SmallInteger>>#bitShift:
   LongInteger>>#bitShift:
   Fails with:
     1 - argument is not a SmallInteger
*/
Object p_integer_bitshift(Object arg)
{
  int16 shift_amount;
  int32 n, result;

  if(!IS_SMALLINT(arg))
    { FAIL(1); }
  shift_amount = FROM_SMALLINT(arg);
  n = as_c_integer(receiver);
  if(shift_amount >= 0)
    result = n << shift_amount;
  else
    result = n >> -shift_amount;
  return as_smalltalk_integer(result);
}


/* Integer>>#printString
   Answer a String containing the printed representation
   of the receiver.
*/
Object p_integer_print_string(void)
{
  char buffer[30];
  Object string;
  int len;

  StrIToA(buffer, as_c_integer(receiver));
  len = STRLEN(buffer);
  string = instantiate_byte_indexed(String, len);
  MEMCOPY(OBJECT_BYTES(string), buffer, len);
  return string;
}


#ifdef USE_MATHLIB

/* Assumes its argument is an instance of Double */
double from_smalltalk_double(Object object)
{
  FlpCompDouble d;
  
  MEMCOPY(&d.d, OBJECT_BYTES(object), sizeof(d));
  return d.d;
}


Object as_smalltalk_double(double value)
{
  Object object;
  FlpCompDouble d;
  
  d.d = value;
  object = instantiate_byte_indexed(Double, sizeof(FlpCompDouble));
  MEMCOPY(OBJECT_BYTES(object), &value, sizeof(FlpCompDouble));
  return object;
}


Object double_binary_op(Object left, Object right, long op)
{
  FlpCompDouble lval, rval, result;

  if(!IS_SMALLTALK_DOUBLE(right))
    { FAIL(1); }
  lval.d = from_smalltalk_double(left);
  rval.d = from_smalltalk_double(right);
  asm("move.l %0,%%d2" : : "g" (op) : "d2");
  SysTrapBinOp(&result.fd, lval.fd, rval.fd);
  return as_smalltalk_double(result.d);
}


/* Double>>#printString */
Object p_double_print_string(void)
{
  char buffer[40];
  Object string;
  int len;
  FlpCompDouble value;
  
  value.d = from_smalltalk_double(receiver);
  asm("moveq.l %0,%%d2" : : "i" (sysFloatFToA) : "d2");
  SysTrapFlpFToA(value.fd, buffer);
  len = STRLEN(buffer);
  string = instantiate_byte_indexed(String, len);
  MEMCOPY(OBJECT_BYTES(string), buffer, len);
  return string;  
}


/* Double>>#asInteger */
Object p_double_as_integer(void)
{
  FlpCompDouble value;
  int32 intval;

  if(!IS_SMALLTALK_DOUBLE(receiver))
    { FAIL(1); }
  value.d = from_smalltalk_double(receiver);
  asm("moveq.l %0,%%d2" : : "i" (sysFloatEm_d_dtoi) : "d2");
  intval = SysTrapFlpFToL(value.fd);
  return as_smalltalk_integer(intval);
}


/* Integer>>#asDouble */
Object p_integer_as_double(void)
{
  int32 value;
  FlpCompDouble d;
  
  value = as_c_integer(receiver);
  asm("moveq.l %0,%%d2" : : "i" (sysFloatEm_d_itod) : "d2");
  SysTrapFlpLToF(&d.fd, value);
  return as_smalltalk_double(d.d);
}


/* Double>>#+ */
Object p_double_add(Object arg)
{
  return double_binary_op(receiver, arg, sysFloatEm_d_add);
}


/* Double>>#- */
Object p_double_subtract(Object arg)
{
  return double_binary_op(receiver, arg, sysFloatEm_d_sub);
}


/* Double>>#* */
Object p_double_multiply(Object arg)
{
  return double_binary_op(receiver, arg, sysFloatEm_d_mul);
}


/* Double>>#/ */
Object p_double_divide(Object arg)
{
  return double_binary_op(receiver, arg, sysFloatEm_d_div);
}


/* Double>>#< */
Object p_double_less(Object arg)
{
  FlpCompDouble lval, rval;
  boolean result;

  if(!IS_SMALLTALK_DOUBLE(arg))
    { FAIL(1); }
  lval.d = from_smalltalk_double(receiver);
  rval.d = from_smalltalk_double(arg);
  asm("moveq.l %0,%%d2" : : "i" (sysFloatEm_d_flt) : "d2");
  result = SysTrapCompare(lval.fd, rval.fd);
  return AS_BOOLEAN(result); 
}


/* Double>>#unary: */
Object p_double_unary_function(Object findex)
{
  int32 n;
  double result, value;
  
  if(!IS_SMALLINT(findex))
    { FAIL(1); }
  n = FROM_SMALLINT(findex);
  value = from_smalltalk_double(receiver);
  switch(n) {
  case 0: MathLibACos(MathLibRef, value, &result); break;
  case 1: MathLibASin(MathLibRef, value, &result); break;
  case 2: MathLibATan(MathLibRef, value, &result); break;
  case 3: MathLibCos(MathLibRef, value, &result); break;
  case 4: MathLibSin(MathLibRef, value, &result); break;
  case 5: MathLibTan(MathLibRef, value, &result); break;
  case 6: MathLibCosH(MathLibRef, value, &result); break;
  case 7: MathLibSinH(MathLibRef, value, &result); break;
  case 8: MathLibTanH(MathLibRef, value, &result); break;
  case 9: MathLibACosH(MathLibRef, value, &result); break;
  case 10: MathLibASinH(MathLibRef, value, &result); break;
  case 11: MathLibATanH(MathLibRef, value, &result); break;
  case 12: MathLibExp(MathLibRef, value, &result); break;
  case 13: MathLibLog(MathLibRef, value, &result); break;
  case 14: MathLibLog10(MathLibRef, value, &result); break;
  case 15: MathLibExpM1(MathLibRef, value, &result); break;
  case 16: MathLibLog1P(MathLibRef, value, &result); break;
  case 17: MathLibLogB(MathLibRef, value, &result); break;
  case 18: MathLibLog2(MathLibRef, value, &result); break;
  case 19: MathLibSqrt(MathLibRef, value, &result); break;
  case 20: MathLibCbrt(MathLibRef, value, &result); break;
  case 21: MathLibCeil(MathLibRef, value, &result); break;
  case 22: MathLibFAbs(MathLibRef, value, &result); break;
  case 23: MathLibFloor(MathLibRef, value, &result); break;
  case 24: MathLibSignificand(MathLibRef, value, &result); break;
  case 25: MathLibRInt(MathLibRef, value, &result); break;
  case 26: MathLibRound(MathLibRef, value, &result); break;
  case 27: MathLibTrunc(MathLibRef, value, &result); break;
  default: { FAIL(1); }
  }
  return as_smalltalk_double(result);
}


/* Double>>#rem: */
Object p_double_remainder(Object arg)
{
  double lval, rval, result;

  if(!IS_SMALLTALK_DOUBLE(arg))
    { FAIL(1); }
  lval = from_smalltalk_double(receiver);
  rval = from_smalltalk_double(arg);
  MathLibDRem(MathLibRef, lval, rval, &result);
  return as_smalltalk_double(result);
}


#endif /* USE_MATHLIB */

