static void delete_assoc_array (SLang_Assoc_Array_Type *a) { _pSLAssoc_Array_Element_Type *e, *emax; #if SLANG_OPTIMIZE_FOR_SPEED int is_scalar_type = a->is_scalar_type; #endif if (a == NULL) return; e = a->elements; if (e != NULL) { emax = e + a->table_len; while (e < emax) { if ((e->key != NULL) && (e->key != Deleted_Key)) { _pSLfree_hashed_string ((char *)e->key, strlen (e->key), e->hash); #if SLANG_OPTIMIZE_FOR_SPEED if ((is_scalar_type == 0) && (e->value.o_data_type != SLANG_INT_TYPE)) #endif SLang_free_object (&e->value); } e++; } SLfree ((char *) a->elements); } if (a->flags & HAS_DEFAULT_VALUE) SLang_free_object (&a->default_value); SLfree ((char *) a); }
_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; }
/* joins l2 onto l1 */ static int list_join_internal (SLang_List_Type *l1, SLang_List_Type *l2) { Chunk_Type *chunk; SLindex_Type num2; chunk = l2->first; num2 = l2->length; while (num2 > 0) { SLindex_Type i, imax; SLang_Object_Type *objs; objs = chunk->elements; i = 0; imax = chunk->num_elements; while ((num2 > 0) && (i < imax)) { SLang_Object_Type obj; if (-1 == _pSLslang_copy_obj (objs+i, &obj)) return -1; if (-1 == insert_element(l1, &obj, l1->length)) { SLang_free_object (&obj); return -1; } i++; num2--; } chunk = chunk->next; } return 0; }
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 _pSLAssoc_Array_Element_Type *store_object (SLang_Assoc_Array_Type *a, _pSLAssoc_Array_Element_Type *e, SLstr_Type *s, unsigned long hash, SLang_Object_Type *obj) { if ((e != NULL) || (NULL != (e = find_element (a, s, hash)))) { #if SLANG_OPTIMIZE_FOR_SPEED if ((a->is_scalar_type == 0) && (e->value.o_data_type != SLANG_INT_TYPE)) #endif SLang_free_object (&e->value); } else { if ((a->num_occupied == a->resize_num) && (-1 == resize_table (a))) return NULL; if (NULL == (e = find_empty_element (a->elements, a->table_len, s, hash))) return NULL; if (e->key == Deleted_Key) a->num_deleted--; else a->num_occupied++; if (NULL == (e->key = _pSLstring_dup_hashed_string (s, hash))) return NULL; e->hash = hash; } e->value = *obj; return e; }
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; }
static void free_thrown_object (void) { if (Object_Thrownp != NULL) { SLang_free_object (Object_Thrownp); Object_Thrownp = NULL; } }
static void anytype_destroy (SLtype type, VOID_STAR ptr) { SLang_Object_Type *obj; (void) type; obj = *(SLang_Object_Type **)ptr; SLang_free_object (obj); SLfree ((char *) obj); }
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; }
static int aput_object (SLang_List_Type *list, SLindex_Type indx, SLang_Object_Type *obj) { SLang_Object_Type *elem; if (NULL == (elem = find_nth_element (list, indx, NULL))) return -1; SLang_free_object (elem); *elem = *obj; return 0; }
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; }
static void assoc_delete_key (SLang_Assoc_Array_Type *a, char *key) { _pSLAssoc_Array_Element_Type *e; e = find_element (a, key, _pSLstring_get_hash (key)); if (e == NULL) return; _pSLang_free_slstring ((char *) e->key); SLang_free_object (&e->value); e->key = Deleted_Key; a->num_deleted++; }
/* this will be called with use_current_queue set to 0 if the catch block * was processed with no error. If an error occurs processing the catch * block, then that error will take precedence over the one triggering the * catch block. However, if the original error is rethrown, then this routine * will still be called with use_current_queue non-zero since all the caller * knows is that an error occured and cannot tell if it was a rethrow. */ int _pSLang_pop_error_context (int use_current_queue) { Error_Context_Type *e; e = Error_Context; if (e == NULL) return -1; Error_Context = e->next; if ((use_current_queue == 0) || (e->rethrow)) { (void) _pSLerr_set_error_queue (e->err_queue); _pSLerr_delete_error_queue (Error_Message_Queue); Error_Message_Queue = e->err_queue; free_thrown_object (); if (e->object_was_thrown) { Object_Thrownp = &Object_Thrown; Object_Thrown = e->object_thrown; } } else { _pSLerr_delete_error_queue (e->err_queue); if (e->object_was_thrown) SLang_free_object (&e->object_thrown); } if (_pSLang_Error == 0) { if (e->err_cleared == 0) { SLang_free_slstring ((char *)File_With_Error); SLang_free_slstring ((char *)Function_With_Error); File_With_Error = e->file; e->file = NULL; Function_With_Error = e->function; e->function = NULL; Linenum_With_Error = e->linenum; (void) SLang_set_error (e->err); } } if (_pSLang_Error == SL_UserBreak_Error) SLKeyBoard_Quit = 1; SLang_free_slstring ((char *) e->file); SLang_free_slstring ((char *) e->function); SLfree ((char *) e); return 0; }
static void delete_chunk (Chunk_Type *c) { unsigned int i, n; SLang_Object_Type *objs; if (c == NULL) return; n = c->num_elements; objs = c->elements; for (i = 0; i < n; i++) SLang_free_object (objs+i); SLfree ((char *) objs); SLfree ((char *) c); }
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; }
static void list_append_elem (void) { int indx; SLang_Object_Type obj; SLang_List_Type *list; indx = -1; if (-1 == pop_insert_append_args (&list, &obj, &indx)) return; if (indx < 0) indx += list->length; if (-1 == insert_element (list, &obj, indx+1)) SLang_free_object (&obj); free_list (list); }
static void list_delete_elem (SLang_List_Type *list, SLindex_Type *indxp) { SLang_Object_Type *elem; Chunk_Type *c; char *src, *dest, *src_max; SLindex_Type indx; indx = *indxp; if (NULL == (elem = find_nth_element (list, indx, &c))) return; if (indx < 0) indx += list->length; /* checked by find_nth_element */ SLang_free_object (elem); c->num_elements--; list->length--; if (c->num_elements == 0) { if (list->first == c) list->first = c->next; if (list->last == c) list->last = c->prev; if (c->next != NULL) c->next->prev = c->prev; if (c->prev != NULL) c->prev->next = c->next; delete_chunk (c); if (list->recent == c) list->recent = NULL; return; } src = (char *) (elem + 1); dest = (char *) elem; src_max = src + sizeof(SLang_Object_Type)*((c->elements+c->num_elements)-elem); while (src < src_max) *dest++ = *src++; if ((list->recent != NULL) && (list->recent_num > indx)) list->recent_num--; }
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; }
/* 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; }
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 function does not handle LONG_LONG */ int _pSLang_sscanf (void) { int num; unsigned int num_refs; char *format; char *input_string, *input_string_max; SLFUTURE_CONST char *f, *s; unsigned char map8[256], map10[256], map16[256]; if (SLang_Num_Function_Args < 2) { _pSLang_verror (SL_INVALID_PARM, "Int_Type sscanf (str, format, ...)"); return -1; } num_refs = (unsigned int) SLang_Num_Function_Args; if (-1 == SLreverse_stack (num_refs)) return -1; num_refs -= 2; if (-1 == SLang_pop_slstring (&input_string)) return -1; if (-1 == SLang_pop_slstring (&format)) { SLang_free_slstring (input_string); return -1; } f = format; s = input_string; input_string_max = input_string + strlen (input_string); init_map (map8, 8); init_map (map10, 10); init_map (map16, 16); num = 0; while (num_refs != 0) { SLang_Object_Type obj; SLang_Ref_Type *ref; SLFUTURE_CONST char *smax; unsigned char *map; int base; int no_assign; int is_short; int is_long; int status; char chf; unsigned int width; int has_width; chf = *f++; if (chf == 0) { /* Hmmm.... what is the most useful thing to do?? */ #if 1 break; #else _pSLang_verror (SL_INVALID_PARM, "sscanf: format not big enough for output list"); goto return_error; #endif } if (isspace (chf)) { char *s1 = _pSLskip_whitespace (s); if (s1 == s) break; s = s1; continue; } if ((chf != '%') || ((chf = *f++) == '%')) { if (*s != chf) break; s++; continue; } no_assign = 0; is_short = 0; is_long = 0; width = 0; smax = input_string_max; /* Look for the flag character */ if (chf == '*') { no_assign = 1; chf = *f++; } /* Width */ has_width = isdigit (chf); if (has_width) { f--; (void) parse_uint (&f, f + strlen(f), &width, 10, map10); chf = *f++; } /* Now the type modifier */ switch (chf) { case 'h': is_short = 1; chf = *f++; break; case 'L': /* not implemented */ case 'l': is_long = 1; chf = *f++; break; } status = -1; if ((chf != 'c') && (chf != '[')) { s = _pSLskip_whitespace (s); if (*s == 0) break; } if (has_width) { if (width > (unsigned int) (input_string_max - s)) width = (unsigned int) (input_string_max - s); smax = s + width; } /* Now the format descriptor */ map = map10; base = 10; try_again: /* used by i, x, and o, conversions */ switch (chf) { case 0: _pSLang_verror (SL_INVALID_PARM, "sscanf: Unexpected end of format"); goto return_error; case 'D': is_long = 1; case 'd': if (is_short) { obj.o_data_type = SLANG_SHORT_TYPE; status = parse_short (&s, smax, &obj.v.short_val, base, map); } else if (is_long) { obj.o_data_type = SLANG_LONG_TYPE; status = parse_long (&s, smax, &obj.v.long_val, base, map); } else { obj.o_data_type = SLANG_INT_TYPE; status = parse_int (&s, smax, &obj.v.int_val, base, map); } break; case 'U': is_long = 1; case 'u': if (is_short) { obj.o_data_type = SLANG_USHORT_TYPE; status = parse_ushort (&s, smax, &obj.v.ushort_val, base, map); } else if (is_long) { obj.o_data_type = SLANG_ULONG_TYPE; status = parse_ulong (&s, smax, &obj.v.ulong_val, base, map); } else { obj.o_data_type = SLANG_INT_TYPE; status = parse_uint (&s, smax, &obj.v.uint_val, base, map); } break; case 'I': is_long = 1; case 'i': if ((s + 1 >= smax) || (*s != 0)) chf = 'd'; else if (((s[1] == 'x') || (s[1] == 'X')) && (s + 2 < smax)) { s += 2; chf = 'x'; } else chf = 'o'; goto try_again; case 'O': is_long = 1; case 'o': map = map8; base = 8; chf = 'd'; goto try_again; case 'X': is_long = 1; case 'x': base = 16; map = map16; chf = 'd'; goto try_again; case 'E': case 'F': is_long = 1; case 'e': case 'f': case 'g': #if SLANG_HAS_FLOAT if (is_long) { obj.o_data_type = SLANG_DOUBLE_TYPE; status = parse_double (&s, smax, &obj.v.double_val); } else { obj.o_data_type = SLANG_FLOAT_TYPE; status = parse_float (&s, smax, &obj.v.float_val); } #else _pSLang_verror (SL_NOT_IMPLEMENTED, "This version of the S-Lang does not support floating point"); status = -1; #endif break; case 's': obj.o_data_type = SLANG_STRING_TYPE; status = parse_string (&s, smax, &obj.v.s_val); break; case 'c': if (has_width == 0) { obj.o_data_type = SLANG_UCHAR_TYPE; obj.v.uchar_val = *s++; status = 1; break; } obj.o_data_type = SLANG_STRING_TYPE; status = parse_bstring (&s, smax, &obj.v.s_val); break; case '[': obj.o_data_type = SLANG_STRING_TYPE; status = parse_range (&s, smax, &f, &obj.v.s_val); break; case 'n': obj.o_data_type = SLANG_UINT_TYPE; obj.v.uint_val = (unsigned int) (s - input_string); status = 1; break; default: status = -1; _pSLang_verror (SL_NOT_IMPLEMENTED, "format specifier '%c' is not supported", chf); break; } if (status == 0) break; if (status == -1) goto return_error; if (no_assign) { SLang_free_object (&obj); continue; } if (-1 == SLang_pop_ref (&ref)) { SLang_free_object (&obj); goto return_error; } if (-1 == SLang_push (&obj)) { SLang_free_object (&obj); SLang_free_ref (ref); goto return_error; } if (-1 == _pSLang_deref_assign (ref)) { SLang_free_ref (ref); goto return_error; } SLang_free_ref (ref); num++; num_refs--; } if (-1 == SLdo_pop_n (num_refs)) goto return_error; SLang_free_slstring (format); SLang_free_slstring (input_string); return num; return_error: /* NULLS ok */ SLang_free_slstring (format); SLang_free_slstring (input_string); return -1; }