summaryrefslogtreecommitdiffstats
path: root/mdk-stage1/slang/slassoc.c
diff options
context:
space:
mode:
Diffstat (limited to 'mdk-stage1/slang/slassoc.c')
-rw-r--r--mdk-stage1/slang/slassoc.c713
1 files changed, 713 insertions, 0 deletions
diff --git a/mdk-stage1/slang/slassoc.c b/mdk-stage1/slang/slassoc.c
new file mode 100644
index 000000000..5997458d2
--- /dev/null
+++ b/mdk-stage1/slang/slassoc.c
@@ -0,0 +1,713 @@
+/* Copyright (c) 1998, 1999, 2001 John E. Davis
+ * This file is part of the S-Lang library.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Perl Artistic License.
+ */
+#include "slinclud.h"
+
+#define SL_APP_WANTS_FOREACH
+#include "slang.h"
+#include "_slang.h"
+
+#define USE_NEW_ANYTYPE_CODE 1
+
+typedef struct _SLAssoc_Array_Element_Type
+{
+ char *key; /* slstring */
+ struct _SLAssoc_Array_Element_Type *next;
+ SLang_Object_Type value;
+}
+_SLAssoc_Array_Element_Type;
+
+typedef struct
+{
+ _SLAssoc_Array_Element_Type *elements[SLASSOC_HASH_TABLE_SIZE];
+ SLang_Object_Type default_value;
+ unsigned int num_elements;
+#define HAS_DEFAULT_VALUE 1
+ unsigned int flags;
+ unsigned char type;
+}
+SLang_Assoc_Array_Type;
+
+#define USE_CACHED_STRING 1
+
+#if USE_CACHED_STRING
+static char *Cached_String;
+static SLang_Object_Type *Cached_Obj;
+static SLang_Assoc_Array_Type *Cached_Array;
+#endif
+
+static SLang_Assoc_Array_Type *alloc_assoc_array (unsigned char 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 (has_default_value)
+ {
+ if (
+#if USE_NEW_ANYTYPE_CODE
+ ((type != SLANG_ANY_TYPE) && (-1 == SLclass_typecast (type, 1, 1)))
+#else
+ (-1 == SLclass_typecast (type, 1, 1))
+#endif
+ || (-1 == SLang_pop (&a->default_value)))
+ {
+ SLfree ((char *) a);
+ return NULL;
+ }
+
+ a->flags |= HAS_DEFAULT_VALUE;
+ }
+ return a;
+}
+
+static void free_element (_SLAssoc_Array_Element_Type *e)
+{
+ if (e == NULL)
+ return;
+
+ SLang_free_object (&e->value);
+ SLang_free_slstring (e->key);
+#if USE_CACHED_STRING
+ if (e->key == Cached_String)
+ Cached_String = NULL;
+#endif
+ SLfree ((char *)e);
+}
+
+static void delete_assoc_array (SLang_Assoc_Array_Type *a)
+{
+ unsigned int i;
+
+ if (a == NULL) return;
+
+ for (i = 0; i < SLASSOC_HASH_TABLE_SIZE; i++)
+ {
+ _SLAssoc_Array_Element_Type *e;
+
+ e = a->elements[i];
+ while (e != NULL)
+ {
+ _SLAssoc_Array_Element_Type *next_e;
+
+ next_e = e->next;
+ free_element (e);
+ e = next_e;
+ }
+ }
+ if (a->flags & HAS_DEFAULT_VALUE)
+ SLang_free_object (&a->default_value);
+
+ SLfree ((char *) a);
+}
+
+_INLINE_
+static SLang_Object_Type *
+find_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash)
+{
+ unsigned int h;
+ _SLAssoc_Array_Element_Type *e;
+
+ h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE);
+ e = a->elements[h];
+
+ while (e != NULL)
+ {
+ if (str == e->key) /* slstrings can be compared this way */
+ {
+#if USE_CACHED_STRING
+ Cached_String = str;
+ Cached_Obj = &e->value;
+ Cached_Array = a;
+#endif
+ return &e->value;
+ }
+
+ e = e->next;
+ }
+
+ return NULL;
+}
+
+static _SLAssoc_Array_Element_Type *
+create_element (SLang_Assoc_Array_Type *a, char *str, unsigned long hash)
+{
+ unsigned int h;
+ _SLAssoc_Array_Element_Type *e;
+
+ e = (_SLAssoc_Array_Element_Type *) SLmalloc (sizeof (_SLAssoc_Array_Element_Type));
+ if (e == NULL)
+ return NULL;
+
+ memset ((char *) e, 0, sizeof (_SLAssoc_Array_Element_Type));
+ h = (unsigned int) (hash % SLASSOC_HASH_TABLE_SIZE);
+
+ if (NULL == (str = _SLstring_dup_hashed_string (str, hash)))
+ {
+ SLfree ((char *) e);
+ return NULL;
+ }
+
+ e->key = str;
+ e->next = a->elements[h];
+ a->elements[h] = e;
+
+ a->num_elements += 1;
+#if USE_CACHED_STRING
+ Cached_String = str;
+ Cached_Obj = &e->value;
+ Cached_Array = a;
+#endif
+ return e;
+}
+
+static int store_object (SLang_Assoc_Array_Type *a, char *s, SLang_Object_Type *obj)
+{
+ unsigned long hash;
+ SLang_Object_Type *v;
+
+#if USE_CACHED_STRING
+ if ((s == Cached_String) && (a == Cached_Array))
+ {
+ v = Cached_Obj;
+ SLang_free_object (v);
+ }
+ else
+ {
+#endif
+ hash = _SLcompute_string_hash (s);
+ if (NULL != (v = find_element (a, s, hash)))
+ SLang_free_object (v);
+ else
+ {
+ _SLAssoc_Array_Element_Type *e;
+
+ e = create_element (a, s, hash);
+ if (e == NULL)
+ return -1;
+
+ v = &e->value;
+ }
+#if USE_CACHED_STRING
+ }
+#endif
+
+ *v = *obj;
+
+ return 0;
+}
+
+static void assoc_destroy (unsigned char type, VOID_STAR ptr)
+{
+ (void) type;
+ delete_assoc_array ((SLang_Assoc_Array_Type *) ptr);
+}
+
+static int pop_index (unsigned int num_indices,
+ SLang_MMT_Type **mmt,
+ SLang_Assoc_Array_Type **a,
+ char **str)
+{
+ if (NULL == (*mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE)))
+ {
+ *a = NULL;
+ *str = NULL;
+ return -1;
+ }
+
+ if ((num_indices != 1)
+ || (-1 == SLang_pop_slstring (str)))
+ {
+ SLang_verror (SL_NOT_IMPLEMENTED,
+ "Assoc_Type arrays require a single string index");
+ SLang_free_mmt (*mmt);
+ *mmt = NULL;
+ *a = NULL;
+ *str = NULL;
+ return -1;
+ }
+
+ *a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*mmt);
+ return 0;
+}
+
+static int assoc_aget (unsigned char type, unsigned int num_indices)
+{
+ SLang_MMT_Type *mmt;
+ char *str;
+ SLang_Assoc_Array_Type *a;
+ SLang_Object_Type *obj;
+ int ret;
+
+ (void) type;
+
+ if (-1 == pop_index (num_indices, &mmt, &a, &str))
+ return -1;
+
+#if USE_CACHED_STRING
+ if ((str == Cached_String) && (a == Cached_Array))
+ obj = Cached_Obj;
+ else
+#endif
+ obj = find_element (a, str, _SLcompute_string_hash (str));
+
+ if ((obj == NULL)
+ && (a->flags & HAS_DEFAULT_VALUE))
+ obj = &a->default_value;
+
+ if (obj == NULL)
+ {
+ SLang_verror (SL_INTRINSIC_ERROR,
+ "No such element in Assoc Array: %s", str);
+ ret = -1;
+ }
+ else
+ {
+#if _SLANG_OPTIMIZE_FOR_SPEED
+ if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[obj->data_type])
+ ret = SLang_push (obj);
+#endif
+ else
+ ret = _SLpush_slang_obj (obj);
+ }
+
+ SLang_free_slstring (str);
+ SLang_free_mmt (mmt);
+ return ret;
+}
+
+static int assoc_aput (unsigned char type, unsigned int num_indices)
+{
+ SLang_MMT_Type *mmt;
+ char *str;
+ SLang_Assoc_Array_Type *a;
+ SLang_Object_Type obj;
+ int ret;
+
+ (void) type;
+
+ if (-1 == pop_index (num_indices, &mmt, &a, &str))
+ return -1;
+
+ ret = -1;
+
+ if (0 == SLang_pop (&obj))
+ {
+ if ((obj.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, 1))
+ || (-1 == SLang_pop (&obj)))
+ goto the_return;
+ }
+
+ if (-1 == store_object (a, str, &obj))
+ SLang_free_object (&obj);
+ else
+ ret = 0;
+ }
+
+ the_return:
+ SLang_free_slstring (str);
+ SLang_free_mmt (mmt);
+ return ret;
+}
+
+static int assoc_anew (unsigned char type, unsigned int num_dims)
+{
+ SLang_MMT_Type *mmt;
+ SLang_Assoc_Array_Type *a;
+ int has_default_value;
+
+ has_default_value = 0;
+ switch (num_dims)
+ {
+ case 0:
+ type = SLANG_ANY_TYPE;
+ break;
+ case 2:
+ (void) SLreverse_stack (2);
+ has_default_value = 1;
+ /* drop */
+ case 1:
+ if (0 == _SLang_pop_datatype (&type))
+ break;
+ num_dims--;
+ /* drop */
+ default:
+ SLdo_pop_n (num_dims);
+ SLang_verror (SL_SYNTAX_ERROR, "Usage: Assoc_Type [DataType_Type]");
+ return -1;
+ }
+
+ a = alloc_assoc_array (type, has_default_value);
+ if (a == NULL)
+ return -1;
+
+ if (NULL == (mmt = SLang_create_mmt (SLANG_ASSOC_TYPE, (VOID_STAR) a)))
+ {
+ delete_assoc_array (a);
+ return -1;
+ }
+
+ if (-1 == SLang_push_mmt (mmt))
+ {
+ SLang_free_mmt (mmt);
+ return -1;
+ }
+
+ return 0;
+}
+
+static void assoc_get_keys (SLang_Assoc_Array_Type *a)
+{
+ SLang_Array_Type *at;
+ int num;
+ unsigned int i, j;
+ char **data;
+
+ /* Note: If support for threads is added, then we need to modify this
+ * algorithm to prevent another thread from modifying the array.
+ * However, that should be handled in inner_interp.
+ */
+ num = a->num_elements;
+
+ if (NULL == (at = SLang_create_array (SLANG_STRING_TYPE, 0, NULL, &num, 1)))
+ return;
+
+ data = (char **)at->data;
+
+ i = 0;
+ for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++)
+ {
+ _SLAssoc_Array_Element_Type *e;
+
+ e = a->elements[j];
+ while (e != NULL)
+ {
+ /* Next cannot fail because it is an slstring */
+ data [i] = SLang_create_slstring (e->key);
+ e = e->next;
+ i++;
+ }
+ }
+ (void) SLang_push_array (at, 1);
+}
+
+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 == _SLpush_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 = _SLclass_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 assoc_get_values (SLang_Assoc_Array_Type *a)
+{
+ SLang_Array_Type *at;
+ int num;
+ unsigned int i, j;
+ char *dest_data;
+ unsigned char type;
+ SLang_Class_Type *cl;
+ unsigned int sizeof_type;
+
+ /* Note: If support for threads is added, then we need to modify this
+ * algorithm to prevent another thread from modifying the array.
+ * However, that should be handled in inner_interp.
+ */
+ num = a->num_elements;
+ type = a->type;
+
+ cl = _SLclass_get_class (type);
+ sizeof_type = cl->cl_sizeof_type;
+
+ if (NULL == (at = SLang_create_array (type, 0, NULL, &num, 1)))
+ return;
+
+ dest_data = (char *)at->data;
+
+ i = 0;
+ for (j = 0; j < SLASSOC_HASH_TABLE_SIZE; j++)
+ {
+ _SLAssoc_Array_Element_Type *e;
+
+ e = a->elements[j];
+ while (e != NULL)
+ {
+ if (-1 == transfer_element (cl, (VOID_STAR) dest_data, &e->value))
+ {
+ SLang_free_array (at);
+ return;
+ }
+
+ dest_data += sizeof_type;
+ e = e->next;
+ i++;
+ }
+ }
+ (void) SLang_push_array (at, 1);
+}
+
+static int assoc_key_exists (SLang_Assoc_Array_Type *a, char *key)
+{
+ return (NULL != find_element (a, key, _SLcompute_string_hash (key)));
+}
+
+static void assoc_delete_key (SLang_Assoc_Array_Type *a, char *key)
+{
+ unsigned int h;
+ _SLAssoc_Array_Element_Type *v, *v0;
+
+ h = (unsigned int) (_SLcompute_string_hash (key) % SLASSOC_HASH_TABLE_SIZE);
+
+ v0 = NULL;
+ v = a->elements[h];
+ while (v != NULL)
+ {
+ if (v->key == key)
+ {
+ if (v0 != NULL)
+ v0->next = v->next;
+ else
+ a->elements[h] = v->next;
+
+ free_element (v);
+ a->num_elements -= 1;
+ return;
+ }
+ v0 = v;
+ v = v->next;
+ }
+
+ /* No such element. Let it pass with no error. */
+}
+
+#define A SLANG_ASSOC_TYPE
+#define S SLANG_STRING_TYPE
+static SLang_Intrin_Fun_Type Assoc_Table [] =
+{
+ MAKE_INTRINSIC_1("assoc_get_keys", assoc_get_keys, SLANG_VOID_TYPE, A),
+ MAKE_INTRINSIC_1("assoc_get_values", assoc_get_values, SLANG_VOID_TYPE, A),
+ MAKE_INTRINSIC_2("assoc_key_exists", assoc_key_exists, SLANG_INT_TYPE, A, S),
+ MAKE_INTRINSIC_2("assoc_delete_key", assoc_delete_key, SLANG_VOID_TYPE, A, S),
+
+ SLANG_END_INTRIN_FUN_TABLE
+};
+#undef A
+#undef S
+
+static int assoc_length (unsigned char type, VOID_STAR v, unsigned int *len)
+{
+ SLang_Assoc_Array_Type *a;
+
+ (void) type;
+ a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (*(SLang_MMT_Type **)v);
+ *len = a->num_elements;
+ return 0;
+}
+
+struct _SLang_Foreach_Context_Type
+{
+ SLang_MMT_Type *mmt;
+ SLang_Assoc_Array_Type *a;
+ unsigned int this_hash_index;
+ unsigned int next_same_hash_index;
+#define CTX_WRITE_KEYS 1
+#define CTX_WRITE_VALUES 2
+ unsigned char flags;
+};
+
+static SLang_Foreach_Context_Type *
+cl_foreach_open (unsigned char type, unsigned int num)
+{
+ SLang_Foreach_Context_Type *c;
+ unsigned char flags;
+ SLang_MMT_Type *mmt;
+
+ (void) type;
+
+ if (NULL == (mmt = SLang_pop_mmt (SLANG_ASSOC_TYPE)))
+ return NULL;
+
+ flags = 0;
+
+ while (num--)
+ {
+ char *s;
+
+ if (-1 == SLang_pop_slstring (&s))
+ {
+ SLang_free_mmt (mmt);
+ return NULL;
+ }
+
+ if (0 == strcmp (s, "keys"))
+ flags |= CTX_WRITE_KEYS;
+ else if (0 == strcmp (s, "values"))
+ flags |= CTX_WRITE_VALUES;
+ else
+ {
+ SLang_verror (SL_NOT_IMPLEMENTED,
+ "using '%s' not supported by SLassoc_Type",
+ s);
+ SLang_free_slstring (s);
+ SLang_free_mmt (mmt);
+ return NULL;
+ }
+
+ SLang_free_slstring (s);
+ }
+
+ if (NULL == (c = (SLang_Foreach_Context_Type *) SLmalloc (sizeof (SLang_Foreach_Context_Type))))
+ {
+ SLang_free_mmt (mmt);
+ return NULL;
+ }
+
+ memset ((char *) c, 0, sizeof (SLang_Foreach_Context_Type));
+
+ if (flags == 0) flags = CTX_WRITE_VALUES|CTX_WRITE_KEYS;
+
+ c->flags = flags;
+ c->mmt = mmt;
+ c->a = (SLang_Assoc_Array_Type *) SLang_object_from_mmt (mmt);
+
+ return c;
+}
+
+static void cl_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+ (void) type;
+ if (c == NULL) return;
+ SLang_free_mmt (c->mmt);
+ SLfree ((char *) c);
+}
+
+static int cl_foreach (unsigned char type, SLang_Foreach_Context_Type *c)
+{
+ SLang_Assoc_Array_Type *a;
+ _SLAssoc_Array_Element_Type *e;
+ unsigned int i, j;
+
+ (void) type;
+
+ if (c == NULL)
+ return -1;
+
+ a = c->a;
+
+ i = c->this_hash_index;
+ if (i >= SLASSOC_HASH_TABLE_SIZE)
+ return 0;
+
+ e = a->elements[i];
+
+ j = c->next_same_hash_index;
+ c->next_same_hash_index = j + 1;
+
+ while ((j > 0) && (e != NULL))
+ {
+ j--;
+ e = e->next;
+ }
+
+ if (e == NULL)
+ {
+ do
+ {
+ i++;
+ if (i >= SLASSOC_HASH_TABLE_SIZE)
+ return 0; /* no more */
+ }
+ while (a->elements [i] == NULL);
+
+ e = a->elements[i];
+ c->this_hash_index = i;
+ c->next_same_hash_index = 1;
+ }
+
+ if ((c->flags & CTX_WRITE_KEYS)
+ && (-1 == SLang_push_string (e->key)))
+ return -1;
+
+ if ((c->flags & CTX_WRITE_VALUES)
+ && (-1 == _SLpush_slang_obj (&e->value)))
+ return -1;
+
+ /* keep going */
+ return 1;
+}
+
+int SLang_init_slassoc (void)
+{
+ SLang_Class_Type *cl;
+
+ if (SLclass_is_class_defined (SLANG_ASSOC_TYPE))
+ return 0;
+
+ if (NULL == (cl = SLclass_allocate_class ("Assoc_Type")))
+ return -1;
+
+ (void) SLclass_set_destroy_function (cl, assoc_destroy);
+ (void) SLclass_set_aput_function (cl, assoc_aput);
+ (void) SLclass_set_aget_function (cl, assoc_aget);
+ (void) SLclass_set_anew_function (cl, assoc_anew);
+ cl->cl_length = assoc_length;
+ cl->cl_foreach_open = cl_foreach_open;
+ cl->cl_foreach_close = cl_foreach_close;
+ cl->cl_foreach = cl_foreach;
+
+ if (-1 == SLclass_register_class (cl, SLANG_ASSOC_TYPE, sizeof (SLang_Assoc_Array_Type), SLANG_CLASS_TYPE_MMT))
+ return -1;
+
+ if (-1 == SLadd_intrin_fun_table (Assoc_Table, "__SLASSOC__"))
+ return -1;
+
+ return 0;
+}
+