/* User defined objects */
/* Copyright (c) 1992, 1995 John E. Davis
 * All rights reserved.
 *
 * You may distribute under the terms of either the GNU General Public
 * License or the Perl Artistic License.
 */
#include "config.h"
#include "sl-feat.h"

#include <stdio.h>

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

#if _SLANG_OPTIMIZE_FOR_SPEED
unsigned char _SLclass_is_scalar_type [256];
#endif

static SLang_Class_Type *Registered_Types[256];
SLang_Class_Type *_SLclass_get_class (unsigned char type)
{
   SLang_Class_Type *cl;

   cl = Registered_Types [type];
   if (cl == NULL)
     SLang_exit_error ("Application error: Type %d not registered", (int) type);

   return cl;
}

VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *cl,
				     SLang_Object_Type *obj)
{
   VOID_STAR p;

   switch (cl->cl_class_type)
     {
      case SLANG_CLASS_TYPE_MMT:
      case SLANG_CLASS_TYPE_PTR:
      case SLANG_CLASS_TYPE_SCALAR:
	p = (VOID_STAR) &obj->v;
	break;

      case SLANG_CLASS_TYPE_VECTOR:
	p = obj->v.p_val;
	break;

      default:
	p = NULL;
     }
   return p;
}

char *SLclass_get_datatype_name (unsigned char stype)
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (stype);
   return cl->cl_name;
}

static int method_undefined_error (unsigned char type, char *method, char *name)
{
   if (name == NULL) name = SLclass_get_datatype_name (type);

   SLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s",
		 method, name);
   return -1;
}

static int
scalar_vector_bin_op_result (int op, unsigned char a, unsigned char b,
			     unsigned char *c)
{
   (void) a; (void) b;
   switch (op)
     {
      case SLANG_NE:
      case SLANG_EQ:
	*c = SLANG_INT_TYPE;
	return 1;
     }
   return 0;
}

static int
scalar_vector_bin_op (int op,
		      unsigned char a_type, VOID_STAR ap, unsigned int na,
		      unsigned char b_type, VOID_STAR bp, unsigned int nb,
		      VOID_STAR cp)
{
   int *c;
   char *a, *b;
   unsigned int da, db;
   unsigned int n, n_max;
   unsigned int data_type_len;
   SLang_Class_Type *cl;

   (void) b_type;
   cl = _SLclass_get_class (a_type);

   data_type_len = cl->cl_sizeof_type;

   a = (char *) ap;
   b = (char *) bp;
   c = (int *) cp;

   if (na == 1) da = 0; else da = data_type_len;
   if (nb == 1) db = 0; else db = data_type_len;
   if (na > nb) n_max = na; else n_max = nb;

   switch (op)
     {
      default:
	return 0;

      case SLANG_NE:
	for (n = 0; n < n_max; n++)
	  {
	     c[n] = (0 != SLMEMCMP(a, b, data_type_len));
	     a += da; b += db;
	  }
	break;

      case SLANG_EQ:
	for (n = 0; n < n_max; n++)
	  {
	     c[n] = (0 == SLMEMCMP(a, b, data_type_len));
	     a += da; b += db;
	  }
	break;
     }
   return 1;
}

static int vector_apush (unsigned char type, VOID_STAR ptr)
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (type);
   return (*cl->cl_push)(type, (VOID_STAR) &ptr);
}

static int vector_apop (unsigned char type, VOID_STAR ptr)
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (type);
   return (*cl->cl_pop)(type, (VOID_STAR) &ptr);
}

static int default_push_mmt (unsigned char type_unused, VOID_STAR ptr)
{
   SLang_MMT_Type *ref;

   (void) type_unused;
   ref = *(SLang_MMT_Type **) ptr;
   return SLang_push_mmt (ref);
}

static void default_destroy_simple (unsigned char type_unused, VOID_STAR ptr_unused)
{
   (void) type_unused;
   (void) ptr_unused;
}

static void default_destroy_user (unsigned char type, VOID_STAR ptr)
{
   (void) type;
   SLang_free_mmt (*(SLang_MMT_Type **) ptr);
}

static int default_pop (unsigned char type, VOID_STAR ptr)
{
   SLang_Object_Type obj;

   if (-1 == _SLang_pop_object_of_type (type, &obj))
     return -1;

   *(VOID_STAR *)ptr = obj.v.p_val;
   return 0;
}

static int default_datatype_deref (unsigned char type)
{
   return method_undefined_error (type, "datatype_deref", NULL);
}

static int default_acopy (unsigned char type, VOID_STAR from, VOID_STAR to)
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (type);
   if (-1 == (*cl->cl_apush) (type, from))
     return -1;
   return (*cl->cl_apop) (type, to);
}

static int default_dereference_object (unsigned char type, VOID_STAR ptr)
{
   (void) ptr;
   return method_undefined_error (type, "dereference", NULL);
}

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

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

static char *default_string (unsigned char stype, VOID_STAR v)
{
#if SLANG_HAS_COMPLEX
   double *cplx;
#endif
   char buf [256];
   char *s;

   s = buf;

   switch (stype)
     {
      case SLANG_STRING_TYPE:
	s = *(char **) v;
	break;

      case SLANG_INT_TYPE:
	sprintf (s, "%d", *(int *) v);
	break;

#if SLANG_HAS_FLOAT
      case SLANG_DOUBLE_TYPE:
	sprintf (s, Double_Format, *(double *) v);
	break;
#endif
#if SLANG_HAS_COMPLEX
      case SLANG_COMPLEX_TYPE:
	cplx = *(double **) v;
	sprintf (s, "(%g + %gi)", cplx [0], cplx [1]);
	break;
#endif
      case SLANG_NULL_TYPE:
	s = "NULL";
	break;

      case SLANG_DATATYPE_TYPE:
	s = SLclass_get_datatype_name ((unsigned char) *(int *)v);
	break;

      default:
	s = SLclass_get_datatype_name (stype);
     }

   return SLmake_string (s);
}

SLang_Class_Type *SLclass_allocate_class (char *name)
{
   SLang_Class_Type *cl;
   unsigned int i;

   for (i = 0; i < 256; i++)
     {
	cl = Registered_Types [i];
	if ((cl != NULL)
	    && (0 == strcmp (cl->cl_name, name)))
	  {
	     SLang_verror (SL_DUPLICATE_DEFINITION, "Type name %s already exists", name);
	     return NULL;
	  }
     }

   cl = (SLang_Class_Type *) SLmalloc (sizeof (SLang_Class_Type));
   if (cl == NULL) return NULL;

   SLMEMSET ((char *) cl, 0, sizeof (SLang_Class_Type));

   if (NULL == (cl->cl_name = SLang_create_slstring (name)))
     {
	SLfree ((char *) cl);
	return NULL;
     }

   return cl;
}

static int DataType_Ids [256];

int _SLang_push_datatype (unsigned char data_type)
{
   SLang_Object_Type obj;

   obj.data_type = SLANG_DATATYPE_TYPE;
   obj.v.i_val = (int) data_type;
   return SLang_push (&obj);
}

static int datatype_deref (unsigned char type, VOID_STAR ptr)
{
   SLang_Class_Type *cl;

   type = (unsigned char) *(int *) ptr;
   cl = _SLclass_get_class (type);

   return (*cl->cl_datatype_deref) (type);
}

static int datatype_push (unsigned char type_unused, VOID_STAR ptr)
{
   (void) type_unused;
   return _SLang_push_datatype (*(int *) ptr);
}

int _SLang_pop_datatype (unsigned char *type)
{
   SLang_Object_Type obj;

   if (-1 == _SLang_pop_object_of_type (SLANG_DATATYPE_TYPE, &obj))
     return -1;

   *type = obj.v.i_val;
   return 0;
}

static int datatype_pop (unsigned char type, VOID_STAR ptr)
{
   if (-1 == _SLang_pop_datatype (&type))
     return -1;

   *(int *) ptr = type;
   return 0;
}

int _SLclass_init (void)
{
   SLang_Class_Type *cl;

   /* First initialize the container classes.  This is so binary operations
    * added later will work with them.
    */
   if (-1 == _SLarray_init_slarray ())
     return -1;

   /* DataType_Type */
   if (NULL == (cl = SLclass_allocate_class ("DataType_Type")))
     return -1;
   cl->cl_pop = datatype_pop;
   cl->cl_push = datatype_push;
   cl->cl_dereference = datatype_deref;
   if (-1 == SLclass_register_class (cl, SLANG_DATATYPE_TYPE, sizeof(int),
				     SLANG_CLASS_TYPE_SCALAR))
     return -1;

   return 0;
}

static int register_new_datatype (char *name, unsigned char type)
{
   DataType_Ids [type] = type;
   return SLadd_intrinsic_variable (name, (VOID_STAR) (DataType_Ids + type),
				    SLANG_DATATYPE_TYPE, 1);
}

int SLclass_register_class (SLang_Class_Type *cl, unsigned char type, unsigned int type_size, unsigned char class_type)
{
   char *name;
   unsigned int i;
   int can_binop = 1;		       /* scalar_vector_bin_op should work
					* for all data types.
					*/

   if (type == SLANG_VOID_TYPE) for (i = 0; i < 256; i++)
     {
	if ((Registered_Types[i] == NULL)
	    && (i != SLANG_VOID_TYPE))
	  {
	     type = (unsigned char) i;
	     break;
	  }
     }

   if ((NULL != Registered_Types [type])
       || (type == SLANG_VOID_TYPE))
     {
	SLang_verror (SL_APPLICATION_ERROR, "Class type %d already in use", (int) type);
	return -1;
     }

   cl->cl_data_type = type;
   cl->cl_class_type = class_type;
   name = cl->cl_name;

   switch (class_type)
     {
      case SLANG_CLASS_TYPE_MMT:
	if (cl->cl_push == NULL) cl->cl_push = default_push_mmt;
	if (cl->cl_destroy == NULL)
	  return method_undefined_error (type, "destroy", name);
	cl->cl_user_destroy_fun = cl->cl_destroy;
	cl->cl_destroy = default_destroy_user;
	type_size = sizeof (VOID_STAR);
	break;

      case SLANG_CLASS_TYPE_SCALAR:
	if (cl->cl_destroy == NULL) cl->cl_destroy = default_destroy_simple;
	if ((type_size == 0)
	    || (type_size > sizeof (_SL_Object_Union_Type)))
	  {
	     SLang_verror (SL_INVALID_PARM,
			   "Type size for %s not appropriate for SCALAR type",
			   name);
	     return -1;
	  }
	if (cl->cl_pop == NULL)
	  return method_undefined_error (type, "pop", name);
	can_binop = 1;
#if _SLANG_OPTIMIZE_FOR_SPEED
	if (type != SLANG_UNDEFINED_TYPE)
	  _SLclass_is_scalar_type [type] = 1;
#endif
	break;

      case SLANG_CLASS_TYPE_PTR:
	if (cl->cl_destroy == NULL)
	  return method_undefined_error (type, "destroy", name);
	type_size = sizeof (VOID_STAR);
	break;

      case SLANG_CLASS_TYPE_VECTOR:
	if (cl->cl_destroy == NULL)
	  return method_undefined_error (type, "destroy", name);
	if (cl->cl_pop == NULL)
	  return method_undefined_error (type, "pop", name);
	cl->cl_apop = vector_apop;
	cl->cl_apush = vector_apush;
	cl->cl_adestroy = default_destroy_simple;
	can_binop = 1;
	break;

      default:
	SLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type);
	return -1;
     }

   if (type_size == 0)
     {
	SLang_verror (SL_INVALID_PARM, "type size must be non-zero for %s", name);
	return -1;
     }

   if (cl->cl_string == NULL) cl->cl_string = default_string;
   if (cl->cl_acopy == NULL) cl->cl_acopy = default_acopy;
   if (cl->cl_datatype_deref == NULL) cl->cl_datatype_deref = default_datatype_deref;

   if (cl->cl_pop == NULL) cl->cl_pop = default_pop;

   if (cl->cl_push == NULL)
     return method_undefined_error (type, "push", name);

   if (cl->cl_byte_code_destroy == NULL)
     cl->cl_byte_code_destroy = cl->cl_destroy;
   if (cl->cl_push_literal == NULL)
     cl->cl_push_literal = cl->cl_push;

   if (cl->cl_dereference == NULL)
     cl->cl_dereference = default_dereference_object;

   if (cl->cl_apop == NULL) cl->cl_apop = cl->cl_pop;
   if (cl->cl_apush == NULL) cl->cl_apush = cl->cl_push;
   if (cl->cl_adestroy == NULL) cl->cl_adestroy = cl->cl_destroy;
   if (cl->cl_push_intrinsic == NULL) cl->cl_push_intrinsic = cl->cl_push;

   cl->cl_sizeof_type = type_size;

   if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size)))
     return -1;

   Registered_Types[type] = cl;

   if (-1 == register_new_datatype (name, type))
     return -1;

   if (can_binop
       && (-1 == SLclass_add_binary_op (type, type, scalar_vector_bin_op, scalar_vector_bin_op_result)))
     return -1;

   return 0;
}

int SLclass_add_math_op (unsigned char type,
			 int (*handler)(int,
					unsigned char, VOID_STAR, unsigned int,
					VOID_STAR),
			 int (*result) (int, unsigned char, unsigned char *))
{
   SLang_Class_Type *cl = _SLclass_get_class (type);

   cl->cl_math_op = handler;
   cl->cl_math_op_result_type = result;
   return 0;
}

int SLclass_add_binary_op (unsigned char a, unsigned char b,
			   int (*f) (int,
				     unsigned char, VOID_STAR, unsigned int,
				     unsigned char, VOID_STAR, unsigned int,
				     VOID_STAR),
			   int (*r) (int, unsigned char, unsigned char, unsigned char *))
{
   SLang_Class_Type *cl;
   SL_OOBinary_Type *ab;

   if ((f == NULL) || (r == NULL))
     {
	SLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op");
	return -1;
     }

   cl = _SLclass_get_class (a);
   (void) _SLclass_get_class (b);

   if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type))))
     return -1;

   ab->data_type = b;
   ab->binary_function = f;
   ab->binary_result = r;
   ab->next = cl->cl_binary_ops;
   cl->cl_binary_ops = ab;

   if ((a != SLANG_ARRAY_TYPE)
       && (b != SLANG_ARRAY_TYPE))
     {
	if ((-1 == _SLarray_add_bin_op (a))
	    || (-1 == _SLarray_add_bin_op (b)))
	  return -1;
     }

   return 0;
}

int SLclass_add_unary_op (unsigned char type,
			  int (*f)(int,
				   unsigned char, VOID_STAR, unsigned int,
				   VOID_STAR),
			  int (*r)(int, unsigned char, unsigned char *))
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (type);
   if ((f == NULL) || (r == NULL))
     {
	SLang_verror (SL_INVALID_PARM, "SLclass_add_unary_op");
	return -1;
     }

   cl->cl_unary_op = f;
   cl->cl_unary_op_result_type = r;

   return 0;
}

int SLclass_add_app_unary_op (unsigned char type,
			      int (*f)(int,
				       unsigned char, VOID_STAR, unsigned int,
				       VOID_STAR),
			      int (*r)(int, unsigned char, unsigned char *))
{
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (type);
   if ((f == NULL) || (r == NULL))
     {
	SLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op");
	return -1;
     }

   cl->cl_app_unary_op = f;
   cl->cl_app_unary_op_result_type = r;

   return 0;
}

int SLclass_set_pop_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR))
{
   if (cl == NULL) return -1;
   cl->cl_pop = f;

   return 0;
}

int SLclass_set_push_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR))
{
   if (cl == NULL) return -1;
   cl->cl_push = f;

   return 0;
}

int SLclass_set_string_function (SLang_Class_Type *cl, char *(*f)(unsigned char, VOID_STAR))
{
   if (cl == NULL) return -1;

   cl->cl_string = f;
   return 0;
}

int SLclass_set_destroy_function (SLang_Class_Type *cl, void (*f)(unsigned char, VOID_STAR))
{
   if (cl == NULL) return -1;

   cl->cl_destroy = f;
   return 0;
}

/* Misc */
void _SLclass_type_mismatch_error (unsigned char a, unsigned char b)
{
   SLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s",
		 SLclass_get_datatype_name (a),
		 SLclass_get_datatype_name (b));
}

/* */

static int null_binary_fun (int op,
			    unsigned char a, VOID_STAR ap, unsigned int na,
			    unsigned char b, VOID_STAR bp, unsigned int nb,
			    VOID_STAR cp)
{
   int *ic;
   unsigned int i;
   int c;

   (void) ap; (void) bp;

   switch (op)
     {
      case SLANG_EQ:
	c = (a == b);
	break;

      case SLANG_NE:
	c = (a != b);
	break;

      default:
	return 0;
     }

   if (na > nb) nb = na;
   ic = (int *) cp;
   for (i = 0; i < nb; i++)
     ic[i] = c;

   return 1;
}

static char *get_binary_op_string (int op)
{
   static char *ops[SLANG_MOD] =
     {
	"+", "=", "*", "/", "==", "!=", ">", ">=", "<", "<=", "^",
	"or", "and", "&", "|", "xor", "shl", "shr", "mod"
     };

   if ((op > SLANG_MOD) || (op <= 0))
     return "-??-";
   return ops[op - 1];
}

int (*_SLclass_get_binary_fun (int op, 
			       SLang_Class_Type *a_cl, SLang_Class_Type *b_cl,
			       SLang_Class_Type **c_cl))
(int,
 unsigned char, VOID_STAR, unsigned int,
 unsigned char, VOID_STAR, unsigned int,
 VOID_STAR)
{
   SL_OOBinary_Type *bt;
   unsigned char a, b, c;

   a = a_cl->cl_data_type;
   b = b_cl->cl_data_type;

   if ((a == SLANG_NULL_TYPE) || (b == SLANG_NULL_TYPE))
     {
	*c_cl = _SLclass_get_class (SLANG_INT_TYPE);
	return null_binary_fun;
     }

   bt = a_cl->cl_binary_ops;

   while (bt != NULL)
     {
	if (bt->data_type == b)
	  {
	     if (1 != (*bt->binary_result)(op, a, b, &c))
	       break;

	     *c_cl = _SLclass_get_class (c);
	     return bt->binary_function;
	  }

	bt = bt->next;
     }

   SLang_verror (SL_TYPE_MISMATCH, "%s %s %s is not possible",
		 a_cl->cl_name, get_binary_op_string (op), b_cl->cl_name);

   *c_cl = NULL;
   return NULL;
}

int (*_SLclass_get_unary_fun (int op, 
			      SLang_Class_Type *a_cl,
			      SLang_Class_Type **b_cl,
			      int utype))
(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR)
{
   int (*f)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR);
   int (*r)(int, unsigned char, unsigned char *);

   unsigned char b;

   switch (utype)
     {
      case _SLANG_BC_UNARY:
	f = a_cl->cl_unary_op;
	r = a_cl->cl_unary_op_result_type;
	break;

      case _SLANG_BC_MATH_UNARY:
	f = a_cl->cl_math_op;
	r = a_cl->cl_math_op_result_type;
	break;

      case _SLANG_BC_APP_UNARY:
	f = a_cl->cl_app_unary_op;
	r = a_cl->cl_app_unary_op_result_type;
	break;

      default:
	f = NULL;
	r = NULL;
     }

   if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a_cl->cl_data_type, &b)))
     {
	*b_cl = _SLclass_get_class (b);
	return f;
     }
   
   SLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s",
		 a_cl->cl_name);

   *b_cl = NULL;

   return NULL;
}

int
_SLclass_typecast (unsigned char to_type, int is_implicit, int allow_array)
{
   unsigned char from_type;
   SLang_Class_Type *cl_to, *cl_from;
   SLang_Object_Type obj;
   VOID_STAR ap;
   VOID_STAR bp;
   int status;

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

   from_type = obj.data_type;
   if (from_type == to_type)
     {
	SLang_push (&obj);
	return 0;
     }

   cl_from = _SLclass_get_class (from_type);
   ap = _SLclass_get_ptr_to_value (cl_from, &obj);

   if (from_type == SLANG_ARRAY_TYPE)
     {
	if (allow_array == 0) goto return_error;

	cl_to = _SLclass_get_class (SLANG_ARRAY_TYPE);
	bp = cl_to->cl_transfer_buf;
	status = _SLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit);
     }
   else
     {
	int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR);
	
	if (NULL == (t = _SLclass_get_typecast (from_type, to_type, is_implicit)))
	  {
	     SLang_free_object (&obj);
	     return -1;
	  }

	cl_to = _SLclass_get_class (to_type);
	bp = cl_to->cl_transfer_buf;
	status = (*t) (from_type, ap, 1, to_type, bp);
     }

   if (1 == status)
     {
	if (-1 == (*cl_to->cl_apush)(to_type, bp))
	  {
	     (*cl_to->cl_adestroy) (to_type, bp);
	     SLang_free_object (&obj);
	     return -1;
	  }

	/* cl_apush will push a copy, so destry this one */
	(*cl_to->cl_adestroy) (to_type, bp);
	SLang_free_object (&obj);
	return 0;
     }

   return_error:

   SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
		 cl_from->cl_name,
		 SLclass_get_datatype_name (to_type));
   SLang_free_object (&obj);
   return -1;
}

int (*_SLclass_get_typecast (unsigned char from, unsigned char to, int is_implicit))
(unsigned char, VOID_STAR, unsigned int,
 unsigned char, VOID_STAR)
{
   SL_Typecast_Type *t;
   SLang_Class_Type *cl_from;

   cl_from = _SLclass_get_class (from);

   t = cl_from->cl_typecast_funs;
   while (t != NULL)
     {
	if (t->data_type != to)
	  {
	     t = t->next;
	     continue;
	  }

	if (is_implicit && (t->allow_implicit == 0))
	  break;

	return t->typecast;
     }

   if ((is_implicit == 0)
       && (cl_from->cl_void_typecast != NULL))
     return cl_from->cl_void_typecast;

   SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s",
		 cl_from->cl_name,
		 SLclass_get_datatype_name (to));

   return NULL;
}

int
SLclass_add_typecast (unsigned char from, unsigned char to,
		      int (*f)_PROTO((unsigned char, VOID_STAR, unsigned int,
				      unsigned char, VOID_STAR)),
		      int allow_implicit)
{
   SL_Typecast_Type *t;
   SLang_Class_Type *cl;

   cl = _SLclass_get_class (from);
   if (to == SLANG_VOID_TYPE)
     {
	cl->cl_void_typecast = f;
	return 0;
     }

   (void) _SLclass_get_class (to);

   if (NULL == (t = (SL_Typecast_Type *) SLmalloc (sizeof (SL_Typecast_Type))))
     return -1;

   SLMEMSET((char *) t, 0, sizeof(SL_Typecast_Type));
   t->data_type = to;
   t->next = cl->cl_typecast_funs;
   t->typecast = f;
   t->allow_implicit = allow_implicit;

   cl->cl_typecast_funs = t;

   return 0;
}

SLang_MMT_Type *SLang_pop_mmt (unsigned char type) /*{{{*/
{
   SLang_Object_Type obj;
   SLang_Class_Type *cl;

   if (_SLang_pop_object_of_type (type, &obj))
     return NULL;

   cl = _SLclass_get_class (type);
   if ((cl->cl_class_type == SLANG_CLASS_TYPE_MMT)
       && (obj.data_type == type))
     {
	return obj.v.ref;
     }

   _SLclass_type_mismatch_error (type, obj.data_type);
   SLang_free_object (&obj);
   return NULL;
}

/*}}}*/

int SLang_push_mmt (SLang_MMT_Type *ref) /*{{{*/
{
   SLang_Object_Type obj;

   if (ref == NULL)
     return _SLang_push_null ();

   ref->count += 1;
   obj.data_type = ref->data_type;
   obj.v.ref = ref;
   if (0 == SLang_push (&obj))
     return 0;

   ref->count -= 1;
   return -1;
}

/*}}}*/

void SLang_inc_mmt (SLang_MMT_Type *ref)
{
   if (ref != NULL)
     ref->count += 1;
}

VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *ref)
{
   if (ref == NULL)
     return NULL;

   return ref->user_data;
}

SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR p)
{
   SLang_MMT_Type *ref;

   (void) _SLclass_get_class (t);      /* check to see if it is registered */

   if (NULL == (ref = (SLang_MMT_Type *) SLmalloc (sizeof (SLang_MMT_Type))))
     return NULL;

   SLMEMSET ((char *) ref, 0, sizeof (SLang_MMT_Type));

   ref->data_type = t;
   ref->user_data = p;
   return ref;
}

void SLang_free_mmt (SLang_MMT_Type *ref)
{
   unsigned char type;
   SLang_Class_Type *cl;

   if (ref == NULL)
     return;

   /* This can be zero if SLang_create_user_object is called followed
    * by this routine before anything gets a chance to attach itself
    * to it.
    */
   if (ref->count > 1)
     {
	ref->count -= 1;
	return;
     }

   type = ref->data_type;
   cl = _SLclass_get_class (type);
   (*cl->cl_user_destroy_fun) (type, ref->user_data);
   SLfree ((char *)ref);
}