slarith.c

Go to the documentation of this file.

/*
Copyright (C) 2004, 2005, 2006 John E. Davis

This file is part of the S-Lang Library.

The S-Lang Library is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.

The S-Lang Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.  
*/


#include "slinclud.h"

#include <math.h>
#include <limits.h>

#ifdef HAVE_LOCALE_H
# include <locale.h>
#endif

#if SLANG_HAS_FLOAT
# include <float.h>
# ifdef HAVE_FLOATINGPOINT_H
#  include <floatingpoint.h>
# endif

# ifdef HAVE_IEEEFP_H
#  include <ieeefp.h>
# endif

# ifdef HAVE_NAN_H
#  include <nan.h>
# endif

#endif

#include "slang.h"
#include "_slang.h"

/*
 * This file defines binary and unary operations on all integer types.
 * Supported types include:
 *
 *    SLANG_CHAR_TYPE     (char)
 *    SLANG_SHORT_TYPE    (short)
 *    SLANG_INT_TYPE      (int)
 *    SLANG_LONG_TYPE     (long)
 *    SLANG_FLOAT_TYPE    (float)
 *    SLANG_DOUBLE_TYPE   (double)
 *
 * as well as unsigned types.  The result-type of an arithmentic operation
 * will depend upon the data types involved.  I am going to distinguish
 * between the boolean operations such as `and' and `or' from the arithmetic
 * operations such as `plus'.  Since the result of a boolean operation is
 * either 1 or 0, a boolean result will be represented by SLANG_CHAR_TYPE.
 * Ordinarily I would use an integer but for arrays it makes more sense to
 * use a character data type.
 *
 * So, the following will be assumed (`+' is any arithmetic operator)
 *
 *    char + char = int
 *    char|short + short = int
 *    char|short|int + int = int
 *    char|short|int|long + long = long
 *    char|short|int|long|float + float = float
 *    char|short|int|long|float|double + double = double
 *
 * In the actual implementation, a brute force approach is avoided.  Such
 * an approach would mean defining different functions for all possible
 * combinations of types.  Including the unsigned types, and not including
 * the complex number type, there are 10 arithmetic types and 10*10=100
 * different combinations of types.  Clearly this would be too much.
 *
 * One approach would be to define binary functions only between operands of
 * the same type and then convert types as appropriate.  This would require
 * just 6 such functions (int, uint, long, ulong, float, double).
 * However, many conversion functions are going to be required, particularly
 * since we are going to allow typecasting from one arithmetic to another.
 * Since the bit pattern of signed and unsigned types are the same, and only
 * the interpretation differs, there will be no functions to convert between
 * signed and unsigned forms of a given type.
 */

#ifdef HAVE_LONG_LONG
# define MAX_SLARITH_INT_TYPE   SLANG_ULLONG_TYPE
#else
# define MAX_SLARITH_INT_TYPE   SLANG_ULONG_TYPE
#endif

#define MAX_SLARITH_TYPE        SLANG_LDOUBLE_TYPE

#define MAX_ARITHMETIC_TYPES    (MAX_SLARITH_TYPE-SLANG_CHAR_TYPE+1)
#define TYPE_TO_TABLE_INDEX(t)  ((t)-SLANG_CHAR_TYPE)
#define TABLE_INDEX_TO_TYPE(i)  ((i)+SLANG_CHAR_TYPE)

#define IS_INTEGER_TYPE(t) \
   (((t) >= SLANG_CHAR_TYPE) && ((t) <= MAX_SLARITH_INT_TYPE))

/* This table contains the types that have been implemented here */
SLtype _pSLarith_Arith_Types [MAX_ARITHMETIC_TYPES+1] =
{
   SLANG_CHAR_TYPE,
   SLANG_UCHAR_TYPE,
   SLANG_SHORT_TYPE,
   SLANG_USHORT_TYPE,
   SLANG_INT_TYPE,
   SLANG_UINT_TYPE,
   SLANG_LONG_TYPE,
   SLANG_ULONG_TYPE,
#ifdef HAVE_LONG_LONG
     SLANG_LLONG_TYPE, SLANG_ULLONG_TYPE,
#endif
#ifdef SLANG_HAS_FLOAT
   SLANG_FLOAT_TYPE,
   SLANG_DOUBLE_TYPE,
# ifdef HAVE_LONG_DOUBLE
     SLANG_LDOUBLE_TYPE,
# endif
#endif
   0
};

static SLtype Alias_Map [MAX_ARITHMETIC_TYPES];
   
/* Here are a bunch of functions to convert from one type to another.  To
 * facilitate the process, a macros will be used.
 */

#define DEFUN_1(f,from_type,to_type) \
static void f (to_type *y, from_type *x, unsigned int n) \
{ \
   unsigned int i; \
   for (i = 0; i < n; i++) y[i] = (to_type) x[i]; \
}

#define DEFUN_2(f,from_type,to_type,copy_fun) \
static VOID_STAR f (VOID_STAR xp, unsigned int n) \
{ \
   from_type *x; \
   to_type *y; \
   x = (from_type *) xp; \
   if (NULL == (y = (to_type *) SLmalloc (sizeof (to_type) * n))) return NULL; \
   copy_fun (y, x, n); \
   return (VOID_STAR) y; \
}
typedef VOID_STAR (*Convert_Fun_Type)(VOID_STAR, unsigned int);

#if SLANG_HAS_FLOAT
#define TO_DOUBLE_FUN(name,type) \
   static double name (VOID_STAR x) { return (double) *(type *) x; }

typedef SLCONST struct
{
   unsigned int sizeof_type;
   double (*to_double_fun)(VOID_STAR);
}
To_Double_Fun_Table_Type;

#endif

/* Each element of the matrix determines how the row maps onto the column.
 * That is, let the matrix be B_ij.  Where the i,j indices refer to
 * precedence of the type.  Then,
 * B_ij->copy_function copies type i to type j.  Similarly,
 * B_ij->convert_function mallocs a new array of type j and copies i to it.
 *
 * Since types are always converted to higher levels of precedence for binary
 * operations, many of the elements are NULL.
 *
 * Is the idea clear?
 */
typedef struct
{
   FVOID_STAR copy_function;
   Convert_Fun_Type convert_function;
}
Binary_Matrix_Type;

#include "slarith2.inc"

#if SLANG_HAS_FLOAT
SLang_To_Double_Fun_Type
SLarith_get_to_double_fun (SLtype type, unsigned int *sizeof_type)
{
   To_Double_Fun_Table_Type *t;

   if ((type < SLANG_CHAR_TYPE) || (type > MAX_SLARITH_TYPE))
     return NULL;
   
   t = To_Double_Fun_Table + (type - SLANG_CHAR_TYPE);
   if ((sizeof_type != NULL) 
       && (t->to_double_fun != NULL))
     *sizeof_type = t->sizeof_type;
   
   return t->to_double_fun;
}
#endif                                 /* SLANG_HAS_FLOAT */

#define GENERIC_BINARY_FUNCTION int_int_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE int
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define ABS_FUNCTION abs
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION int_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION int_arith_unary_op
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION int_int_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_INT_TYPE,(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION int_cmp_function
#include "slarith.inc"

#define GENERIC_BINARY_FUNCTION uint_uint_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE unsigned int
#define GENERIC_TYPE_IS_UNSIGNED
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION uint_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION uint_arith_unary_op
#define ABS_FUNCTION(a) (a)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION uint_uint_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_int_obj(SLANG_UINT_TYPE,(int)(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION uint_cmp_function
#include "slarith.inc"

#if LONG_IS_NOT_INT
#define GENERIC_BINARY_FUNCTION long_long_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE long
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION long_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION long_arith_unary_op
#define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a))
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION long_long_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_LONG_TYPE,(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION long_cmp_function
#include "slarith.inc"

#define GENERIC_BINARY_FUNCTION ulong_ulong_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE unsigned long
#define GENERIC_TYPE_IS_UNSIGNED
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION ulong_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION ulong_arith_unary_op
#define ABS_FUNCTION(a) (a)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION ulong_ulong_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_long_obj(SLANG_ULONG_TYPE,(long)(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION ulong_cmp_function
#include "slarith.inc"
#else
#define long_long_bin_op        int_int_bin_op
#define ulong_ulong_bin_op      uint_uint_bin_op
#define long_unary_op           int_unary_op
#define ulong_unary_op          uint_unary_op
#define long_cmp_function       int_cmp_function
#define ulong_cmp_function      uint_cmp_function
#endif                                 /* LONG_IS_NOT_INT */

#ifdef HAVE_LONG_LONG
#define GENERIC_BINARY_FUNCTION llong_llong_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE long long
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION llong_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION llong_arith_unary_op
#define ABS_FUNCTION(a) (((a) >= 0) ? (a) : -(a))
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION llong_llong_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_llong_obj(SLANG_LLONG_TYPE,(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION llong_cmp_function
#include "slarith.inc"

#define GENERIC_BINARY_FUNCTION ullong_ullong_bin_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE unsigned long long
#define GENERIC_TYPE_IS_UNSIGNED
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) ((a) % (b))
#define TRAP_DIV_ZERO   1
#define GENERIC_UNARY_FUNCTION ullong_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION ullong_arith_unary_op
#define ABS_FUNCTION(a) (a)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION ullong_ullong_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_llong_obj(SLANG_ULLONG_TYPE,(long long)(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION ullong_cmp_function
#include "slarith.inc"
#endif                                 /* HAVE_LONG_LONG */

#if SLANG_HAS_FLOAT
#define GENERIC_BINARY_FUNCTION float_float_bin_op
#define GENERIC_TYPE float
#define POW_FUNCTION(a,b) (float)pow((double)(a),(double)(b))
#define POW_RESULT_TYPE float
#define MOD_FUNCTION(a,b) (float)fmod((a),(b))
#define TRAP_DIV_ZERO   0
#define GENERIC_UNARY_FUNCTION float_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION float_arith_unary_op
#define ABS_FUNCTION(a) (float)fabs((double) a)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION float_float_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE,(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_float_obj(SLANG_FLOAT_TYPE, (x))
#define CMP_FUNCTION float_cmp_function
#include "slarith.inc"

#define GENERIC_BINARY_FUNCTION double_double_bin_op
#define GENERIC_TYPE double
#define POW_FUNCTION(a,b) pow((double)(a),(double)(b))
#define POW_RESULT_TYPE double
#define MOD_FUNCTION(a,b) (float)fmod((a),(b))
#define TRAP_DIV_ZERO   0
#define GENERIC_UNARY_FUNCTION double_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION double_arith_unary_op
#define ABS_FUNCTION(a) fabs(a)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#if SLANG_OPTIMIZE_FOR_SPEED
# define SCALAR_BINARY_FUNCTION double_double_scalar_bin_op
#endif
#define PUSH_SCALAR_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE,(x))
#define PUSH_POW_OBJ_FUN(x) SLclass_push_double_obj(SLANG_DOUBLE_TYPE, (x))
#define CMP_FUNCTION double_cmp_function
#include "slarith.inc"
#endif                                 /* SLANG_HAS_FLOAT */

#define GENERIC_UNARY_FUNCTION char_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION char_arith_unary_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE signed char
#define ABS_FUNCTION abs
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#define CMP_FUNCTION char_cmp_function
#include "slarith.inc"

#define GENERIC_UNARY_FUNCTION uchar_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION uchar_arith_unary_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE unsigned char
#define GENERIC_TYPE_IS_UNSIGNED
#define ABS_FUNCTION(x) (x)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
#define CMP_FUNCTION uchar_cmp_function
#include "slarith.inc"

#if SHORT_IS_NOT_INT
#define GENERIC_UNARY_FUNCTION short_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION short_arith_unary_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE short
#define ABS_FUNCTION abs
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : (((x) < 0) ? -1 : 0))
#define CMP_FUNCTION short_cmp_function
#include "slarith.inc"

#define GENERIC_UNARY_FUNCTION ushort_unary_op
#define GENERIC_ARITH_UNARY_FUNCTION ushort_arith_unary_op
#define GENERIC_BIT_OPERATIONS
#define GENERIC_TYPE unsigned short
#define GENERIC_TYPE_IS_UNSIGNED
#define ABS_FUNCTION(x) (x)
#define SIGN_FUNCTION(x) (((x) > 0) ? 1 : 0)
#define CMP_FUNCTION ushort_cmp_function
#include "slarith.inc"
#endif                                 /* SHORT_IS_NOT_INT */


int _pSLarith_get_precedence (SLtype type)
{
   if ((type < SLANG_CHAR_TYPE) || (type > MAX_SLARITH_TYPE))
     return -1;
 
   type = Alias_Map[TYPE_TO_TABLE_INDEX(type)];
   return type - SLANG_CHAR_TYPE;
}

SLtype _pSLarith_promote_type (SLtype t)
{
   t = Alias_Map[TYPE_TO_TABLE_INDEX(t)];

   switch (t)
     {
      case SLANG_INT_TYPE:
      case SLANG_UINT_TYPE:
      case SLANG_LONG_TYPE:
      case SLANG_ULONG_TYPE:
#ifdef HAVE_LONG_LONG
      case SLANG_LLONG_TYPE:
      case SLANG_ULLONG_TYPE:
#endif
      case SLANG_FLOAT_TYPE:
      case SLANG_DOUBLE_TYPE:
        break;

      case SLANG_USHORT_TYPE:
#if SHORT_IS_INT
        t = SLANG_UINT_TYPE;
        break;
#endif
        /* drop */
      case SLANG_CHAR_TYPE:
      case SLANG_UCHAR_TYPE:
      case SLANG_SHORT_TYPE:
      default:
        t = SLANG_INT_TYPE;
     }

   return t;
}

static SLtype promote_to_common_type (SLtype a, SLtype b)
{
   a = _pSLarith_promote_type (a);
   b = _pSLarith_promote_type (b);
   
   return (a > b) ? a : b;
}

static int arith_bin_op_result (int op, SLtype a_type, SLtype b_type,
                                SLtype *c_type)
{
   switch (op)
     {
      case SLANG_EQ:
      case SLANG_NE:
      case SLANG_GT:
      case SLANG_GE:
      case SLANG_LT:
      case SLANG_LE:
      case SLANG_OR:
      case SLANG_AND:
        *c_type = SLANG_CHAR_TYPE;
        return 1;
#if SLANG_HAS_FLOAT
      case SLANG_POW:
        if (SLANG_FLOAT_TYPE == promote_to_common_type (a_type, b_type))
          *c_type = SLANG_FLOAT_TYPE;
        else
          *c_type = SLANG_DOUBLE_TYPE;
        return 1;
#endif
      case SLANG_BAND:
      case SLANG_BXOR:
      case SLANG_BOR:
      case SLANG_SHL:
      case SLANG_SHR:
        /* The bit-level operations are defined just for integer types */
        if ((0 == IS_INTEGER_TYPE (a_type))
            || (0 == IS_INTEGER_TYPE(b_type)))
          return 0;
        break;

      default:
        break;
     }

   *c_type = promote_to_common_type (a_type, b_type);
   return 1;
}

typedef int (*Bin_Fun_Type) (int,
                             SLtype, VOID_STAR, unsigned int,
                             SLtype, VOID_STAR, unsigned int,
                             VOID_STAR);

/* This array of functions must be indexed by precedence after arithmetic
 * promotions.
 */
static Bin_Fun_Type Bin_Fun_Map [MAX_ARITHMETIC_TYPES] =
{
   NULL,                               /* char */
     NULL,                             /* uchar */
     NULL,                             /* short */
     NULL,                             /* ushort */
     int_int_bin_op,                   /* int */
     uint_uint_bin_op,                 /* uint */
     long_long_bin_op,                 /* long */
     ulong_ulong_bin_op,               /* ulong */
#ifdef HAVE_LONG_LONG
     llong_llong_bin_op,               /* llong */
     ullong_ullong_bin_op,             /* ullong */
#else
     NULL, NULL,
#endif
     float_float_bin_op,                       /* float */
     double_double_bin_op                      /* double */
};

static int arith_bin_op (int op,
                         SLtype a_type, VOID_STAR ap, unsigned int na,
                         SLtype b_type, VOID_STAR bp, unsigned int nb,
                         VOID_STAR cp)
{
   Convert_Fun_Type af, bf;
   Bin_Fun_Type binfun;
   int a_indx, b_indx, c_indx;
   SLtype c_type;
   int ret;

   c_type = promote_to_common_type (a_type, b_type);

   a_indx = TYPE_TO_TABLE_INDEX(a_type);
   b_indx = TYPE_TO_TABLE_INDEX(b_type);
   c_indx = TYPE_TO_TABLE_INDEX(c_type);

   af = Binary_Matrix[a_indx][c_indx].convert_function;
   bf = Binary_Matrix[b_indx][c_indx].convert_function;
   binfun = Bin_Fun_Map[c_indx];

   if ((af != NULL)
       && (NULL == (ap = (VOID_STAR) (*af) (ap, na))))
     return -1;

   if ((bf != NULL)
       && (NULL == (bp = (VOID_STAR) (*bf) (bp, nb))))
     {
        if (af != NULL) SLfree ((char *) ap);
        return -1;
     }

   ret = (*binfun) (op, a_type, ap, na, b_type, bp, nb, cp);
   if (af != NULL) SLfree ((char *) ap);
   if (bf != NULL) SLfree ((char *) bp);

   return ret;
}

static int arith_unary_op_result (int op, SLtype a, SLtype *b)
{
   (void) a;
   switch (op)
     {
      default:
        return 0;

      case SLANG_SQR:
      case SLANG_MUL2:
      case SLANG_PLUSPLUS:
      case SLANG_MINUSMINUS:
      case SLANG_CHS:
      case SLANG_ABS:
        *b = a;
        break;

      case SLANG_BNOT:
        if (0 == IS_INTEGER_TYPE(a))
          return 0;
        *b = a;
        break;

      case SLANG_SIGN:
        *b = SLANG_INT_TYPE;
        break;

      case SLANG_NOT:
      case SLANG_ISPOS:
      case SLANG_ISNEG:
      case SLANG_ISNONNEG:
        *b = SLANG_CHAR_TYPE;
        break;
     }
   return 1;
}


static int integer_pop (SLtype type, VOID_STAR ptr)
{
   SLang_Object_Type obj;
   int i, j;
   void (*f)(VOID_STAR, VOID_STAR, unsigned int);

   if (-1 == SLang_pop (&obj))
     return -1;

   if (0 == IS_INTEGER_TYPE(obj.data_type))
     {
        _pSLclass_type_mismatch_error (type, obj.data_type);
        SLang_free_object (&obj);
        return -1;
     }

   i = TYPE_TO_TABLE_INDEX(type);
   j = TYPE_TO_TABLE_INDEX(obj.data_type);
   f = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
     Binary_Matrix[j][i].copy_function;

   (*f) (ptr, (VOID_STAR)&obj.v, 1);

   return 0;
}

static int integer_push (SLtype type, VOID_STAR ptr)
{
   SLang_Object_Type obj;
   int i;
   void (*f)(VOID_STAR, VOID_STAR, unsigned int);

   i = TYPE_TO_TABLE_INDEX(type);
   f = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
     Binary_Matrix[i][i].copy_function;

   obj.data_type = type;

   (*f) ((VOID_STAR)&obj.v, ptr, 1);

   return SLang_push (&obj);
}

int SLang_pop_char (char *i)
{
   return integer_pop (SLANG_CHAR_TYPE, (VOID_STAR) i);
}

int SLang_pop_uchar (unsigned char *i)
{
   return integer_pop (SLANG_UCHAR_TYPE, (VOID_STAR) i);
}

int SLang_pop_short (short *i)
{
   return integer_pop (_pSLANG_SHORT_TYPE, (VOID_STAR) i);
}

int SLang_pop_ushort (unsigned short *i)
{
   return integer_pop (_pSLANG_USHORT_TYPE, (VOID_STAR) i);
}

int SLang_pop_long (long *i)
{
   return integer_pop (_pSLANG_LONG_TYPE, (VOID_STAR) i);
}

int SLang_pop_ulong (unsigned long *i)
{
   return integer_pop (_pSLANG_ULONG_TYPE, (VOID_STAR) i);
}

#ifdef HAVE_LONG_LONG

static void llong_byte_code_destroy (SLtype unused, VOID_STAR ptr)
{
   (void) unused;
   SLfree (*(char **) ptr);
}

int SLang_pop_long_long (long long *i)
{
   return integer_pop (_pSLANG_LLONG_TYPE, (VOID_STAR) i);
}

int SLang_pop_ulong_long (unsigned long long *i)
{
   return integer_pop (_pSLANG_ULLONG_TYPE, (VOID_STAR) i);
}
#endif

int SLang_pop_uint (unsigned int *i)
{
   return integer_pop (SLANG_UINT_TYPE, (VOID_STAR) i);
}

int SLang_push_int (int i)
{
   return SLclass_push_int_obj (SLANG_INT_TYPE, i);
}
int SLang_push_uint (unsigned int i)
{
   return SLclass_push_int_obj (SLANG_UINT_TYPE, (int) i);
}
int SLang_push_char (char i)
{
   return SLclass_push_char_obj (SLANG_CHAR_TYPE, i);
}

int SLang_push_uchar (unsigned char i)
{
   return SLclass_push_char_obj (SLANG_UCHAR_TYPE, (char) i);
}
int SLang_push_short (short i)
{
   return SLclass_push_short_obj (_pSLANG_SHORT_TYPE, i);
}
int SLang_push_ushort (unsigned short i)
{
   return SLclass_push_short_obj (_pSLANG_USHORT_TYPE, (unsigned short) i);
}
int SLang_push_long (long i)
{
   return SLclass_push_long_obj (_pSLANG_LONG_TYPE, i);
}
int SLang_push_ulong (unsigned long i)
{
   return SLclass_push_long_obj (_pSLANG_ULONG_TYPE, (long) i);
}

#if HAVE_LONG_LONG
int SLang_push_long_long (long long i)
{
   return SLclass_push_llong_obj (_pSLANG_LLONG_TYPE, i);
}
int SLang_push_ulong_long (unsigned long long i)
{
   return SLclass_push_llong_obj (_pSLANG_ULLONG_TYPE, (long long) i);
}
#endif

_INLINE_
int _pSLarith_typecast (SLtype a_type, VOID_STAR ap, unsigned int na,
                       SLtype b_type, VOID_STAR bp)
{
   int i, j;

   void (*copy)(VOID_STAR, VOID_STAR, unsigned int);

   i = TYPE_TO_TABLE_INDEX (a_type);
   j = TYPE_TO_TABLE_INDEX (b_type);

   copy = (void (*)(VOID_STAR, VOID_STAR, unsigned int))
     Binary_Matrix[i][j].copy_function;

   (*copy) (bp, ap, na);
   return 1;
}

#if SLANG_HAS_FLOAT

int SLang_pop_double (double *x)
{
   SLang_Object_Type obj;

   if (0 != SLang_pop (&obj))
     return -1;

   switch (obj.data_type)
     {
      case SLANG_FLOAT_TYPE:
        *x = (double) obj.v.float_val;
        break;

      case SLANG_DOUBLE_TYPE:
        *x = obj.v.double_val;
        break;

      case SLANG_INT_TYPE:
        *x = (double) obj.v.int_val;
        break;

      case SLANG_CHAR_TYPE: *x = (double) obj.v.char_val; break;
      case SLANG_UCHAR_TYPE: *x = (double) obj.v.uchar_val; break;
      case SLANG_SHORT_TYPE: *x = (double) obj.v.short_val; break;
      case SLANG_USHORT_TYPE: *x = (double) obj.v.ushort_val; break;
      case SLANG_UINT_TYPE: *x = (double) obj.v.uint_val; break;
      case SLANG_LONG_TYPE: *x = (double) obj.v.long_val; break;
      case SLANG_ULONG_TYPE: *x = (double) obj.v.ulong_val; break;
#ifdef HAVE_LONG_LONG   
      case SLANG_LLONG_TYPE: *x = (double) obj.v.llong_val; break;
      case SLANG_ULLONG_TYPE: *x = (double) obj.v.ullong_val; break;
#endif
      default:
        _pSLclass_type_mismatch_error (SLANG_DOUBLE_TYPE, obj.data_type);
        SLang_free_object (&obj);
        return -1;
     }
   return 0;
}

int SLang_push_double (double x)
{
   return SLclass_push_double_obj (SLANG_DOUBLE_TYPE, x);
}

int SLang_pop_float (float *x)
{
   double d;

   /* Pop it as a double and let the double function do all the typcasting */
   if (-1 == SLang_pop_double (&d))
     return -1;

   *x = (float) d;
   return 0;
}

int SLang_push_float (float f)
{
   return SLclass_push_float_obj (SLANG_FLOAT_TYPE, (double) f);
}

/* Double */
static int double_push (SLtype type, VOID_STAR ptr)
{
#if SLANG_OPTIMIZE_FOR_SPEED
   SLang_Object_Type obj;
   obj.data_type = type;
   obj.v.double_val = *(double *)ptr;
   return SLang_push (&obj);
#else
   return SLclass_push_double_obj (type, *(double *) ptr);
#endif
}

static int double_push_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_double_obj (type, **(double **)ptr);
}

static int double_pop (SLtype unused, VOID_STAR ptr)
{
   (void) unused;
   return SLang_pop_double ((double *) ptr);
}

static void double_byte_code_destroy (SLtype unused, VOID_STAR ptr)
{
   (void) unused;
   SLfree (*(char **) ptr);
}

static int float_push (SLtype unused, VOID_STAR ptr)
{
   (void) unused;
   SLang_push_float (*(float *) ptr);
   return 0;
}

static int float_pop (SLtype unused, VOID_STAR ptr)
{
   (void) unused;
   return SLang_pop_float ((float *) ptr);
}

#endif                                 /* SLANG_HAS_FLOAT */

#if SLANG_HAS_FLOAT
static char Double_Format[16] = "%g";

void _pSLset_double_format (char *s)
{
   strncpy (Double_Format, s, 15);
   Double_Format[15] = 0;
}
#endif

static char *arith_string (SLtype type, VOID_STAR v)
{
   char buf [1024];
   char *s;

   s = buf;

   switch (type)
     {
      default:
        s = SLclass_get_datatype_name (type);
        break;

      case SLANG_CHAR_TYPE:
        sprintf (s, "%d", *(char *) v);
        break;
      case SLANG_UCHAR_TYPE:
        sprintf (s, "%u", *(unsigned char *) v);
        break;
      case SLANG_SHORT_TYPE:
        sprintf (s, "%d", *(short *) v);
        break;
      case SLANG_USHORT_TYPE:
        sprintf (s, "%u", *(unsigned short *) v);
        break;
      case SLANG_INT_TYPE:
        sprintf (s, "%d", *(int *) v);
        break;
      case SLANG_UINT_TYPE:
        sprintf (s, "%u", *(unsigned int *) v);
        break;
      case SLANG_LONG_TYPE:
        sprintf (s, "%ld", *(long *) v);
        break;
      case SLANG_ULONG_TYPE:
        sprintf (s, "%lu", *(unsigned long *) v);
        break;
#ifdef HAVE_LONG_LONG
      case SLANG_LLONG_TYPE:
        sprintf (s, "%lld", *(long long *) v);
        break;
      case SLANG_ULLONG_TYPE:
        sprintf (s, "%llu", *(unsigned long long *) v);
        break;
#endif
#if SLANG_HAS_FLOAT
      case SLANG_FLOAT_TYPE:
        if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(float *) v))
          sprintf (s, "%e", *(float *) v);
        break;
      case SLANG_DOUBLE_TYPE:
        if (EOF == SLsnprintf (buf, sizeof (buf), Double_Format, *(double *) v))
          sprintf (s, "%e", *(double *) v);
        break;
#endif
     }

   return SLmake_string (s);
}

static int integer_to_bool (SLtype type, int *t)
{
   (void) type;
   return SLang_pop_integer (t);
}

/* Note that integer literals are all stored in the byte-code as longs.  This
 * is why it is necessary to use *(long*).
 */
static int push_int_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_int_obj (type, (int) *(long *) ptr);
}

static int push_char_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_char_obj (type, (char) *(long *) ptr);
}

#if SHORT_IS_NOT_INT
static int push_short_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_short_obj (type, (short) *(long *) ptr);
}
#endif

#if LONG_IS_NOT_INT
static int push_long_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_long_obj (type, *(long *) ptr);
}
#endif

#ifdef HAVE_LONG_LONG
static int push_llong_literal (SLtype type, VOID_STAR ptr)
{
   return SLclass_push_llong_obj (type, **(long long **)ptr);
}
#endif
typedef struct
{
   char *name;
   SLtype data_type;
   unsigned int sizeof_type;
   int (*unary_fun)(int, SLtype, VOID_STAR, unsigned int, VOID_STAR);
   int (*push_literal) (SLtype, VOID_STAR);
   void (*byte_code_destroy)(SLtype, VOID_STAR);
   int (*cmp_fun) (SLtype, VOID_STAR, VOID_STAR, int *);
}
Integer_Info_Type;

#ifdef HAVE_LONG_LONG
# define NUM_INTEGER_TYPES 10
#else
# define NUM_INTEGER_TYPES 8
#endif
static Integer_Info_Type Integer_Types [NUM_INTEGER_TYPES] =
{
     {"Char_Type", SLANG_CHAR_TYPE, sizeof (char), char_unary_op, push_char_literal, NULL, char_cmp_function},
     {"UChar_Type", SLANG_UCHAR_TYPE, sizeof (unsigned char), uchar_unary_op, push_char_literal, NULL, uchar_cmp_function},
#if SHORT_IS_NOT_INT
     {"Short_Type", SLANG_SHORT_TYPE, sizeof (short), short_unary_op, push_short_literal, NULL, short_cmp_function},
     {"UShort_Type", SLANG_USHORT_TYPE, sizeof (unsigned short), ushort_unary_op, push_short_literal, NULL, ushort_cmp_function},
#else
     {NULL, SLANG_SHORT_TYPE, 0, NULL, NULL, NULL, NULL},
     {NULL, SLANG_USHORT_TYPE, 0, NULL, NULL, NULL, NULL},
#endif

     {"Integer_Type", SLANG_INT_TYPE, sizeof (int), int_unary_op, push_int_literal, NULL, int_cmp_function},
     {"UInteger_Type", SLANG_UINT_TYPE, sizeof (unsigned int), uint_unary_op, push_int_literal, NULL, uint_cmp_function},

#if LONG_IS_NOT_INT
     {"Long_Type", SLANG_LONG_TYPE, sizeof (long), long_unary_op, push_long_literal, NULL, long_cmp_function},
     {"ULong_Type", SLANG_ULONG_TYPE, sizeof (unsigned long), ulong_unary_op, push_long_literal, NULL, ulong_cmp_function},
#else
     {NULL, SLANG_LONG_TYPE, 0, NULL, NULL, NULL, NULL},
     {NULL, SLANG_ULONG_TYPE, 0, NULL, NULL, NULL, NULL},
#endif
#ifdef HAVE_LONG_LONG
# if LLONG_IS_NOT_LONG
     {"LLong_Type", SLANG_LLONG_TYPE, sizeof (long long), llong_unary_op, push_llong_literal, llong_byte_code_destroy, llong_cmp_function},
     {"ULLong_Type", SLANG_ULLONG_TYPE, sizeof (unsigned long long), ullong_unary_op, push_llong_literal, llong_byte_code_destroy, ullong_cmp_function},
# else
     {NULL, SLANG_LLONG_TYPE, 0, NULL, NULL, NULL, NULL},
     {NULL, SLANG_ULLONG_TYPE, 0, NULL, NULL, NULL, NULL},
# endif
#endif
};

static int create_synonyms (void)
{
   static char *names[8] =
     {
        "Int16_Type", "UInt16_Type", "Int32_Type", "UInt32_Type",
        "Int64_Type", "UInt64_Type",
        "Float32_Type", "Float64_Type"
     };
   int types[8];
   unsigned int i;

   memset ((char *) types, 0, sizeof (types));
   /* The assumption is that sizeof(unsigned X) == sizeof (X) */
   types[0] = _pSLANG_INT16_TYPE;
   types[1] = _pSLANG_UINT16_TYPE;
   types[2] = _pSLANG_INT32_TYPE;
   types[3] = _pSLANG_UINT32_TYPE;
   types[4] = _pSLANG_INT64_TYPE;
   types[5] = _pSLANG_UINT64_TYPE;

#if SLANG_HAS_FLOAT

#if SIZEOF_FLOAT == 4
   types[6] = SLANG_FLOAT_TYPE;
#else
# if SIZEOF_DOUBLE == 4
   types[6] = SLANG_DOUBLE_TYPE;
# endif
#endif
#if SIZEOF_FLOAT == 8
   types[7] = SLANG_FLOAT_TYPE;
#else
# if SIZEOF_DOUBLE == 8
   types[7] = SLANG_DOUBLE_TYPE;
# endif
#endif

#endif

   if ((-1 == SLclass_create_synonym ("Int_Type", SLANG_INT_TYPE))
       || (-1 == SLclass_create_synonym ("UInt_Type", SLANG_UINT_TYPE)))
     return -1;

   for (i = 0; i < 8; i++)
     {
        if (types[i] == 0) continue;

        if (-1 == SLclass_create_synonym (names[i], types[i]))
          return -1;
     }

   for (i = 0; i < MAX_ARITHMETIC_TYPES; i++)
     {
        Alias_Map[i] = TABLE_INDEX_TO_TYPE(i);
     }
#if SHORT_IS_INT
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_SHORT_TYPE)] = SLANG_INT_TYPE;
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_USHORT_TYPE)] = SLANG_UINT_TYPE;
   if ((-1 == SLclass_create_synonym ("Short_Type", SLANG_INT_TYPE))
       || (-1 == SLclass_create_synonym ("UShort_Type", SLANG_UINT_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_SHORT_TYPE, SLANG_INT_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_USHORT_TYPE, SLANG_UINT_TYPE)))
     return -1;
#endif
#if LONG_IS_INT
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_LONG_TYPE)] = SLANG_INT_TYPE;
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_ULONG_TYPE)] = SLANG_UINT_TYPE;
   if ((-1 == SLclass_create_synonym ("Long_Type", SLANG_INT_TYPE))
       || (-1 == SLclass_create_synonym ("ULong_Type", SLANG_UINT_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_LONG_TYPE, SLANG_INT_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_ULONG_TYPE, SLANG_UINT_TYPE)))
     return -1;
#endif
#if LLONG_IS_LONG
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_LLONG_TYPE)] = _pSLANG_LONG_TYPE;
   Alias_Map [TYPE_TO_TABLE_INDEX(SLANG_ULLONG_TYPE)] = _pSLANG_ULONG_TYPE;
   if ((-1 == SLclass_create_synonym ("LLong_Type", _pSLANG_LONG_TYPE))
       || (-1 == SLclass_create_synonym ("ULLong_Type", _pSLANG_ULONG_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_LLONG_TYPE, _pSLANG_LONG_TYPE))
       || (-1 == _pSLclass_copy_class (SLANG_ULLONG_TYPE, _pSLANG_ULONG_TYPE)))
     return -1;
#endif
   
   return 0;
}

static