_INLINE_
static _pSLAssoc_Array_Element_Type *
assoc_aput (SLang_Assoc_Array_Type *a, _pSLAssoc_Array_Element_Type *e,
SLstr_Type *str, unsigned long hash)
{
SLang_Object_Type obj;
if (-1 == SLang_pop (&obj))
return NULL;
if ((obj.o_data_type != a->type)
#if USE_NEW_ANYTYPE_CODE
&& (a->type != SLANG_ANY_TYPE)
#endif
)
{
(void) SLang_push (&obj);
if ((-1 == SLclass_typecast (a->type, 1, 0))
|| (-1 == SLang_pop (&obj)))
return NULL;
}
if (NULL == (e = store_object (a, e, str, hash, &obj)))
SLang_free_object (&obj);
return e;
}
static int pop_as_list_internal (unsigned int count)
{
SLang_List_Type *list;
if (NULL == (list = allocate_list (count)))
return -1;
while (count)
{
SLang_Object_Type obj;
if (-1 == SLang_pop (&obj))
goto return_error;
if (-1 == insert_element (list, &obj, 0))
{
SLang_free_object (&obj);
goto return_error;
}
count--;
}
return push_list (list, 1);
return_error:
free_list (list);
return -1;
}
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 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.o_data_type))
{
_pSLclass_type_mismatch_error (type, obj.o_data_type);
SLang_free_object (&obj);
return -1;
}
i = TYPE_TO_TABLE_INDEX(type);
j = TYPE_TO_TABLE_INDEX(obj.o_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;
}
int SLang_pop_double (double *x)
{
SLang_Object_Type obj;
if (0 != SLang_pop (&obj))
return -1;
switch (obj.o_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.o_data_type);
SLang_free_object (&obj);
return -1;
}
return 0;
}
static void intrin_type_info (void)
{
SLang_Object_Type obj;
if (-1 == SLang_pop (&obj))
return;
SLang_push_datatype (obj.o_data_type);
SLang_free_object (&obj);
}
void _pSLstring_intrinsic (void) /*{{{*/
{
SLang_Object_Type x;
char *s;
if (SLang_pop (&x)) return;
if (NULL != (s = _pSLstringize_object (&x)))
_pSLang_push_slstring (s);
SLang_free_object (&x);
}
static int do_obj_cmp_fun (int (*fun)(SLang_Object_Type *, SLang_Object_Type *))
{
int eqs;
SLang_Object_Type a, b;
if (-1 == SLang_pop (&b))
return -1;
if (-1 == SLang_pop (&a))
{
SLang_free_object (&b);
return -1;
}
eqs = (*fun) (&a, &b);
SLang_free_object (&a);
SLang_free_object (&b);
return eqs;
}
int SLdo_pop_n (unsigned int n)
{
SLang_Object_Type x;
while (n--)
{
if (SLang_pop(&x)) return -1;
SLang_free_object (&x);
}
return 0;
}
int _pSLerr_throw (void)
{
int e;
int nargs = SLang_Num_Function_Args;
char *msg = NULL;
free_thrown_object ();
switch (nargs)
{
case 3:
if (-1 == SLang_pop (&Object_Thrown))
return -1;
Object_Thrownp = &Object_Thrown;
/* drop */
case 2:
if (-1 == SLang_pop_slstring (&msg))
{
free_thrown_object ();
return -1;
}
case 1:
/* drop */
if (-1 == _pSLerr_pop_exception (&e))
{
SLang_free_slstring (msg);/* NULL ok */
free_thrown_object ();
return -1;
}
break;
case 0: /* rethrow */
return rethrow_error ();
default:
_pSLang_verror (SL_NumArgs_Error, "expecting: throw error [, optional-message [, optional-arg]]");
return -1;
}
if (msg != NULL)
{
_pSLang_verror (e, "%s", msg);
SLang_free_slstring (msg);
}
else
SLang_set_error (e);
return 0;
}
static void intrin_type_info1 (void)
{
SLang_Object_Type obj;
unsigned int type;
if (-1 == SLang_pop (&obj))
return;
type = obj.o_data_type;
if (type == SLANG_ARRAY_TYPE)
type = obj.v.array_val->data_type;
SLang_free_object (&obj);
SLang_push_datatype (type);
}
int SLang_list_insert (SLang_List_Type *list, int indx)
{
SLang_Object_Type obj;
if (-1 == SLang_pop (&obj))
return -1;
if (indx < 0)
indx += list->length;
if (-1 == insert_element (list, &obj, indx))
{
SLang_free_object (&obj);
return -1;
}
return 0;
}
static int pop_insert_append_args (SLang_List_Type **listp,
SLang_Object_Type *obj, int *indx)
{
if (SLang_Num_Function_Args == 3)
{
if (-1 == SLang_pop_integer (indx))
return -1;
}
if (-1 == SLang_pop (obj))
return -1;
if (-1 == pop_list (listp))
{
SLang_free_object (obj);
return -1;
}
return 0;
}
int SLang_pop_anytype (SLang_Any_Type **any)
{
SLang_Object_Type *obj;
if (NULL == (obj = (SLang_Object_Type *) SLmalloc (sizeof (SLang_Object_Type))))
{
*any = NULL;
return -1;
}
if (-1 == SLang_pop (obj))
{
*any = NULL;
SLfree ((char *) obj);
return -1;
}
*any = (SLang_Any_Type *)obj;
return 0;
}
int SLerr_throw (int err, SLFUTURE_CONST char *msg, SLtype obj_type, VOID_STAR objptr)
{
free_thrown_object ();
if ((obj_type != 0) || (objptr != NULL))
{
if (-1 == SLang_push_value (obj_type, objptr))
return -1;
if (-1 == SLang_pop (&Object_Thrown))
return -1;
Object_Thrownp = &Object_Thrown;
}
if (msg != NULL)
_pSLang_verror (err, "%s", msg);
else
SLang_set_error (err);
return 0;
}
static SLang_Assoc_Array_Type *alloc_assoc_array (SLtype type, int has_default_value)
{
SLang_Assoc_Array_Type *a;
a = (SLang_Assoc_Array_Type *)SLmalloc (sizeof (SLang_Assoc_Array_Type));
if (a == NULL)
{
if (has_default_value)
SLdo_pop_n (1);
return NULL;
}
memset ((char *) a, 0, sizeof (SLang_Assoc_Array_Type));
a->type = type;
#if SLANG_OPTIMIZE_FOR_SPEED
a->is_scalar_type = (SLANG_CLASS_TYPE_SCALAR == _pSLang_get_class_type (type));
#endif
if (has_default_value)
{
if (
#if USE_NEW_ANYTYPE_CODE
((type != SLANG_ANY_TYPE) && (-1 == SLclass_typecast (type, 1, 0)))
#else
(-1 == SLclass_typecast (type, 1, 0))
#endif
|| (-1 == SLang_pop (&a->default_value)))
{
SLfree ((char *) a);
return NULL;
}
a->flags |= HAS_DEFAULT_VALUE;
}
if (-1 == resize_table (a))
{
delete_assoc_array (a);
return NULL;
}
return a;
}
static int _pSLlist_aput (SLtype type, unsigned int num_indices)
{
SLang_List_Type *list;
SLang_Object_Type obj;
SLang_Array_Type *ind_at;
SLindex_Type indx, *idx_data;
SLuindex_Type i, num;
int ret;
(void) type;
if (-1 == pop_list_and_index (num_indices, &list, &ind_at, &indx))
return -1;
if (ind_at == NULL)
{
if (-1 == SLang_pop (&obj))
{
free_list (list);
return -1;
}
if (-1 == aput_object (list, indx, &obj))
{
SLang_free_object (&obj);
free_list (list);
return -1;
}
free_list (list);
return 0;
}
idx_data = (SLindex_Type *)ind_at->data;
num = ind_at->num_elements;
if (-1 == SLang_pop (&obj))
{
free_list (list);
SLang_free_array (ind_at);
return -1;
}
ret = -1;
if (obj.o_data_type == SLANG_ARRAY_TYPE)
{
SLang_Array_Type *at = obj.v.array_val;
if ((at->num_elements != num) || (at->num_dims != 1))
{
SLang_verror (SL_Index_Error, "Inappropriate array for list[indices]=array expression");
goto free_and_return;
}
for (i = 0; i < num; i++)
{
SLang_Object_Type objb;
indx = idx_data[i];
if ((-1 == _pSLarray1d_push_elem (at, i))
|| (-1 == SLang_pop (&objb)))
goto free_and_return;
if (-1 == aput_object (list, indx, &objb))
{
SLang_free_object (&objb);
goto free_and_return;
}
}
ret = 0;
goto free_and_return;
}
if (obj.o_data_type == SLANG_LIST_TYPE)
{
SLang_List_Type *list2;
if (NULL == (list2 = (SLang_List_Type *)obj.v.ptr_val))
goto free_and_return;
if (list2->length != (SLindex_Type)num)
{
SLang_verror (SL_Index_Error, "Inappropriate list2 size for list[indices]=list2 expression");
goto free_and_return;
}
for (i = 0; i < num; i++)
{
SLang_Object_Type *obja;
SLang_Object_Type objb;
indx = idx_data[i];
if (NULL == (obja = find_nth_element (list, idx_data[i], NULL)))
goto free_and_return;
if (-1 == _pSLslang_copy_obj (obja, &objb))
goto free_and_return;
if (-1 == aput_object (list, indx, &objb))
{
SLang_free_object (&objb);
goto free_and_return;
}
}
ret = 0;
goto free_and_return;
}
for (i = 0; i < num; i++)
{
SLang_Object_Type objb;
indx = idx_data[i];
if (-1 == _pSLslang_copy_obj (&obj, &objb))
goto free_and_return;
if (-1 == aput_object (list, indx, &objb))
{
SLang_free_object (&objb);
goto free_and_return;
}
}
ret = 0;
/* drop */
free_and_return:
SLang_free_object (&obj);
SLang_free_array (ind_at);
free_list (list);
return ret;
}
/* FIXME: This is currently used only by list_dereference and breaks on an
* empty list. For this reason, it would probably fail in other contexts.
*/
static SLang_List_Type *make_sublist (SLang_List_Type *list, SLindex_Type indx_a, SLindex_Type length)
{
SLang_List_Type *new_list;
Chunk_Type *c, *new_c;
SLindex_Type i;
SLang_Object_Type *obj, *obj_max, *new_obj, *new_obj_max;
if (length == 0)
return allocate_list (0);
if ((indx_a < 0) || (indx_a + (length - 1) >= list->length))
{
_pSLang_verror (SL_Index_Error, "Indices are out of range for list object");
return NULL;
}
if (NULL == (new_list = allocate_list (length)))
return NULL;
if (-1 == make_chunk_chain (length, &new_list->first, &new_list->last, list->default_chunk_size))
{
free_list (new_list);
return NULL;
}
obj = find_nth_element (list, indx_a, &c);
if (obj == NULL)
{
free_list (new_list);
return NULL;
}
obj_max = c->elements + c->num_elements;
new_list->length = length;
new_c = new_list->first;
new_obj = new_c->elements;
new_obj_max = new_obj + new_c->chunk_size;
for (i = 0; i < length; i++)
{
while (obj == obj_max)
{
c = c->next;
obj = c->elements;
obj_max = obj + c->num_elements;
}
if (new_obj == new_obj_max)
{
new_c = new_c->next;
new_obj = new_c->elements;
new_obj_max = new_obj + new_c->chunk_size;
}
if ((-1 == _pSLpush_slang_obj (obj))
|| (-1 == SLang_pop (new_obj)))
{
free_list (new_list);
return NULL;
}
new_c->num_elements++;
obj++;
new_obj++;
}
return new_list;
}
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;
}
