int _pSLclass_obj_eqs (SLang_Object_Type *a, SLang_Object_Type *b)
{
SLang_Class_Type *a_cl, *b_cl;
VOID_STAR pa, pb;
int (*eqs)(SLtype, VOID_STAR, SLtype, VOID_STAR);
int status;
a_cl = _pSLclass_get_class (a->o_data_type);
b_cl = _pSLclass_get_class (b->o_data_type);
pa = _pSLclass_get_ptr_to_value (a_cl, a);
pb = _pSLclass_get_ptr_to_value (b_cl, b);
if ((pa == NULL) || (pb == NULL))
return -1;
if ((NULL == (eqs = a_cl->cl_eqs))
&& (NULL == (eqs = b_cl->cl_eqs)))
return do_default_eqs (a_cl, pa, b_cl, pb);
status = push_eqs_comparison (a, b);
if (status != 0)
return status;
status = (*eqs) (a->o_data_type, pa, b->o_data_type, pb);
pop_eqs_comparison ();
return status;
}
static int length_cmd (void)
{
SLang_Class_Type *cl;
SLang_Object_Type obj;
VOID_STAR p;
unsigned int length;
int len;
if (-1 == SLang_pop (&obj))
return -1;
cl = _pSLclass_get_class (obj.o_data_type);
p = _pSLclass_get_ptr_to_value (cl, &obj);
len = 1;
if (cl->cl_length != NULL)
{
if (0 == (*cl->cl_length)(obj.o_data_type, p, &length))
len = (int) length;
else
len = -1;
}
SLang_free_object (&obj);
return len;
}
static int
transfer_element (SLang_Class_Type *cl, VOID_STAR dest_data,
SLang_Object_Type *obj)
{
unsigned int sizeof_type;
VOID_STAR src_data;
#if USE_NEW_ANYTYPE_CODE
if (cl->cl_data_type == SLANG_ANY_TYPE)
{
SLang_Any_Type *any;
if ((-1 == _pSLpush_slang_obj (obj))
|| (-1 == SLang_pop_anytype (&any)))
return -1;
*(SLang_Any_Type **)dest_data = any;
return 0;
}
#endif
/* Optimize for scalar */
if (cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR)
{
sizeof_type = cl->cl_sizeof_type;
memcpy ((char *) dest_data, (char *)&obj->v, sizeof_type);
return 0;
}
src_data = _pSLclass_get_ptr_to_value (cl, obj);
if (-1 == (*cl->cl_acopy) (cl->cl_data_type, src_data, dest_data))
return -1;
return 0;
}
static void get_exception_info_intrinsic (void)
{
#define NUM_EXCEPT_FIELDS 8
static SLFUTURE_CONST char *field_names[NUM_EXCEPT_FIELDS] =
{
"error", "descr", "file", "line", "function", "object", "message", "traceback"
};
SLtype field_types[NUM_EXCEPT_FIELDS];
VOID_STAR field_values[NUM_EXCEPT_FIELDS];
int err;
SLCONST char *desc;
SLCONST char *file;
SLCONST char *function;
SLCONST char *errmsg;
SLCONST char *tbmsg;
int linenum;
err = _pSLerr_get_last_error ();
if (err == 0)
{
(void) SLang_push_null ();
return;
}
desc = SLerr_strerror (err);
(void) _pSLerr_get_last_error_line_info (&file, &linenum, &function);
field_types[0] = SLANG_INT_TYPE;
field_values[0] = (VOID_STAR) &err;
field_types[1] = SLANG_STRING_TYPE;
field_values[1] = (VOID_STAR) &desc;
field_types[2] = SLANG_STRING_TYPE;
field_values[2] = (VOID_STAR) &file;
field_types[3] = SLANG_INT_TYPE;
field_values[3] = (VOID_STAR) &linenum;
field_types[4] = SLANG_STRING_TYPE;
field_values[4] = (VOID_STAR) &function;
if ((Error_Context == NULL)
|| (Error_Context->object_was_thrown == 0))
{
char *null = NULL;
field_types[5] = SLANG_NULL_TYPE;
field_values[5] = (VOID_STAR) &null;
}
else
{
SLtype data_type = Error_Context->object_thrown.o_data_type;
field_types[5] = data_type;
field_values[5] = _pSLclass_get_ptr_to_value (_pSLclass_get_class (data_type),
&Error_Context->object_thrown);
}
errmsg = get_error_msg_from_queue (_SLERR_MSG_ERROR);
if ((errmsg == NULL) || (*errmsg == 0))
errmsg = desc;
field_types[6] = SLANG_STRING_TYPE;
field_values[6] = (VOID_STAR) &errmsg;
tbmsg = get_error_msg_from_queue (_SLERR_MSG_TRACEBACK);
field_types[7] = (tbmsg == NULL) ? SLANG_NULL_TYPE : SLANG_STRING_TYPE;
field_values[7] = (VOID_STAR) &tbmsg;
(void) SLstruct_create_struct (NUM_EXCEPT_FIELDS, field_names, field_types, field_values);
if (errmsg != desc)
SLang_free_slstring ((char *) errmsg);
SLang_free_slstring ((char *)tbmsg);
}
int
SLclass_typecast (SLtype to_type, int is_implicit, int allow_array)
{
SLtype 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.o_data_type;
if (from_type == to_type)
return SLang_push (&obj);
cl_from = _pSLclass_get_class (from_type);
cl_to = _pSLclass_get_class (to_type);
/* Check for alias, e.g., int and long */
if (cl_from == cl_to)
{
obj.o_data_type = to_type;
return SLang_push (&obj);
}
/* Since the typecast functions are designed to work on arrays,
* get the pointer to the value instead of just &obj.v.
*/
ap = _pSLclass_get_ptr_to_value (cl_from, &obj);
if ((from_type == SLANG_ARRAY_TYPE)
&& (allow_array || (to_type != SLANG_ANY_TYPE)))
{
if (allow_array == 0)
goto return_error;
cl_to = _pSLclass_get_class (SLANG_ARRAY_TYPE);
bp = cl_to->cl_transfer_buf;
status = _pSLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit);
}
else
{
int (*t) (SLtype, VOID_STAR, unsigned int, SLtype, VOID_STAR);
if (NULL == (t = _pSLclass_get_typecast (from_type, to_type, is_implicit)))
{
SLang_free_object (&obj);
return -1;
}
bp = cl_to->cl_transfer_buf;
status = (*t) (from_type, ap, 1, to_type, bp);
}
if (1 == status)
{
/* AnyType apush will do a reference, which is undesirable here.
* So, to avoid that, perform push instead of apush. Yes, this is
* an ugly hack.
*/
if (to_type == SLANG_ANY_TYPE)
status = (*cl_to->cl_push)(to_type, bp);
else
status = (*cl_to->cl_apush)(to_type, bp);
if (status == -1)
{
(*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:
_pSLang_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;
}
