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; }