/* After this call, the stack will contain an Any_Type object */
static int anytype_push (SLtype type, VOID_STAR ptr)
{
SLang_Any_Type *obj;
/* Push the object onto the stack, then pop it back off into our anytype
* container. That way, any memory managing associated with the type
* will be performed automatically. Another way to think of it is that
* pushing an Any_Type onto the stack will create another copy of the
* object represented by it.
*/
if (-1 == _pSLpush_slang_obj (*(SLang_Object_Type **)ptr))
return -1;
if (-1 == SLang_pop_anytype (&obj))
return -1;
/* There is no need to reference count the anytype objects since every
* push results in a new anytype container.
*/
if (-1 == SLclass_push_ptr_obj (type, (VOID_STAR) obj))
{
SLang_free_anytype (obj);
return -1;
}
return 0;
}
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 int l2a_push_callback (VOID_STAR vlist, SLuindex_Type i)
{
SLang_Object_Type *obj;
if (NULL == (obj = find_nth_element ((SLang_List_Type *)vlist, i, NULL)))
return -1;
return _pSLpush_slang_obj (obj);
}
static void push_list_elements (SLang_List_Type *list)
{
SLindex_Type n = list->length;
SLindex_Type i;
for (i = 0; i < n; i++)
{
SLang_Object_Type *objp = find_nth_element (list, i, NULL);
if ((objp == NULL) || (-1 == _pSLpush_slang_obj (objp)))
return;
}
}
static int list_pop_nth (SLang_List_Type *list, SLindex_Type indx)
{
SLang_Object_Type *obj;
if (NULL == (obj = find_nth_element (list, indx, NULL)))
return -1;
if (-1 == _pSLpush_slang_obj (obj))
return -1;
list_delete_elem (list, &indx);
return 0;
}
static int cl_foreach (SLtype type, SLang_Foreach_Context_Type *c)
{
SLang_Assoc_Array_Type *a;
_pSLAssoc_Array_Element_Type *e, *emax;
(void) type;
if (c == NULL)
return -1;
a = c->a;
e = a->elements + c->next_hash_index;
emax = a->elements + a->table_len;
while (1)
{
if (e == emax)
return 0;
if ((e->key != NULL) && (e->key != Deleted_Key))
break;
e++;
}
c->next_hash_index = (e - a->elements) + 1;
if ((c->flags & CTX_WRITE_KEYS)
&& (-1 == SLang_push_string (e->key)))
return -1;
if (c->flags & CTX_WRITE_VALUES)
{
#if SLANG_OPTIMIZE_FOR_SPEED
if (c->is_scalar)
{
if (-1 == SLang_push (&e->value))
return -1;
}
else
#endif
if (-1 == _pSLpush_slang_obj (&e->value))
return -1;
}
/* keep going */
return 1;
}
int _pSLassoc_aget (SLtype type, unsigned int num_indices)
{
unsigned long hash;
SLang_MMT_Type *mmt;
SLstr_Type *str;
_pSLAssoc_Array_Element_Type *e;
SLang_Assoc_Array_Type *a;
SLang_Object_Type *obj;
int ret;
(void) type;
if (-1 == pop_index (num_indices, &mmt, &a, &str, &hash))
return -1;
e = find_element (a, str, hash);
if (e == NULL)
{
if (a->flags & HAS_DEFAULT_VALUE)
obj = &a->default_value;
else
{
ret = -1;
_pSLang_verror (SL_INTRINSIC_ERROR,
"No such element in Assoc Array: %s", str);
goto free_and_return;
}
}
else obj = &e->value;
#if SLANG_OPTIMIZE_FOR_SPEED
if (a->is_scalar_type)
ret = SLang_push (obj);
else
#endif
ret = _pSLpush_slang_obj (obj);
free_and_return:
_pSLang_free_slstring (str);
SLang_free_mmt (mmt);
return ret;
}
static int cl_foreach (SLtype type, SLang_Foreach_Context_Type *c)
{
SLang_Object_Type *obj;
(void) type;
if (c == NULL)
return -1;
if (c->list->length <= c->next_index)
return 0;
if ((NULL == (obj = find_nth_element (c->list, c->next_index, NULL)))
|| (-1 == _pSLpush_slang_obj (obj)))
return -1;
c->next_index++;
return 1;
}
static void qualifier_intrin (void)
{
int has_default;
char *name;
SLang_Struct_Type *q;
SLang_Object_Type *objp;
if (-1 == _pSLang_get_qualifiers (&q))
return;
has_default = (SLang_Num_Function_Args == 2);
if (has_default)
{
if (-1 == SLroll_stack (2))
return;
}
if (-1 == SLang_pop_slstring (&name))
return;
if (q != NULL)
objp = _pSLstruct_get_field_value (q, name);
else
objp = NULL;
SLang_free_slstring (name);
if (objp != NULL)
{
if (has_default)
SLdo_pop ();
_pSLpush_slang_obj (objp);
}
else if (has_default == 0)
(void) SLang_push_null ();
/* Note: objp and q should _not_ be freed since they were not allocated */
}
/* 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;
}
/* FIXME: Extend this to allow an index array */
static int _pSLlist_aget (SLtype type, unsigned int num_indices)
{
SLang_List_Type *list, *new_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;
ret = -1;
if (ind_at == NULL)
{
obj = find_nth_element (list, indx, NULL);
if (obj != NULL)
ret = _pSLpush_slang_obj (obj);
free_list (list);
return ret;
}
num = ind_at->num_elements;
if (NULL == (new_list = allocate_list (num)))
goto free_and_return;
idx_data = (SLindex_Type *)ind_at->data;
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 == insert_element (new_list, &objb, i))
{
SLang_free_object (&objb);
goto free_and_return;
}
}
ret = push_list (new_list, 1); /* frees upon error */
new_list = NULL;
free_and_return:
if (new_list != NULL)
free_list (new_list);
free_list (list);
SLang_free_array (ind_at);
return ret;
}
/* This function performs a deref since we may want the symmetry
* a = Any_Type[1]; a[x] = "foo"; bar = a[x]; ==> bar == "foo"
* That is, we do not want bar to be an Any_Type.
*
* Unfortunately, this does not work because of the use of the transfer
* buffer by both slarray.c and sltypecast.c. I can work around that
* but I am not sure that I like typeof(Any_Type[0]) != Any_Type.
*/
static int anytype_apush (SLtype type, VOID_STAR ptr)
{
(void) type;
return _pSLpush_slang_obj (*(SLang_Object_Type **)ptr);
}
static int anytype_dereference (SLtype unused, VOID_STAR ptr)
{
(void) unused;
return _pSLpush_slang_obj (*(SLang_Object_Type **) ptr);
}
/* This function will result in an object that is represented by the
* anytype object.
*/
int SLang_push_anytype (SLang_Any_Type *any)
{
return _pSLpush_slang_obj ((SLang_Object_Type *)any);
}
int _pSLassoc_inc_value (unsigned int num_indices, int inc)
{
unsigned long hash;
SLang_MMT_Type *mmt;
SLstr_Type *str;
_pSLAssoc_Array_Element_Type *e;
SLang_Assoc_Array_Type *a;
SLang_Object_Type *objp;
SLang_Object_Type inc_obj;
int ret;
if (-1 == pop_index (num_indices, &mmt, &a, &str, &hash))
return -1;
e = find_element (a, str, hash);
ret = -1;
if (e == NULL)
{
if (a->flags & HAS_DEFAULT_VALUE)
{
if (-1 == _pSLpush_slang_obj (&a->default_value))
goto free_and_return;
}
else
{
_pSLang_verror (SL_INTRINSIC_ERROR,
"No such element in Assoc Array: %s", str);
goto free_and_return;
}
if (NULL == (e = assoc_aput (a, e, str, hash)))
goto free_and_return;
}
objp = &e->value;
if (objp->o_data_type == SLANG_INT_TYPE)
{
ret = 0;
objp->v.int_val += inc;
goto free_and_return;
}
inc_obj.o_data_type = SLANG_INT_TYPE;
inc_obj.v.int_val = inc;
if ((-1 == _pSLang_do_binary_ab (SLANG_PLUS, objp, &inc_obj))
|| (NULL == assoc_aput (a, e, str, hash)))
goto free_and_return;
ret = 0;
/* drop */
free_and_return:
_pSLang_free_slstring (str);
SLang_free_mmt (mmt);
return ret;
}
