diff options
Diffstat (limited to 'mdk-stage1/slang/slclass.c')
| -rw-r--r-- | mdk-stage1/slang/slclass.c | 1391 |
1 files changed, 0 insertions, 1391 deletions
diff --git a/mdk-stage1/slang/slclass.c b/mdk-stage1/slang/slclass.c deleted file mode 100644 index 733888cb8..000000000 --- a/mdk-stage1/slang/slclass.c +++ /dev/null @@ -1,1391 +0,0 @@ -/* User defined objects */ -/* Copyright (c) 1992, 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" - -#include "slang.h" -#include "_slang.h" - -#if _SLANG_OPTIMIZE_FOR_SPEED -unsigned char _SLclass_Class_Type [256]; -#endif - -static SLang_Class_Type *Registered_Types[256]; -SLang_Class_Type *_SLclass_get_class (unsigned char type) -{ - SLang_Class_Type *cl; - - cl = Registered_Types [type]; - if (cl == NULL) - SLang_exit_error ("Application error: Type %d not registered", (int) type); - - return cl; -} - -int SLclass_is_class_defined (unsigned char type) -{ - return (NULL != Registered_Types[type]); -} - -VOID_STAR _SLclass_get_ptr_to_value (SLang_Class_Type *cl, - SLang_Object_Type *obj) -{ - VOID_STAR p; - - switch (cl->cl_class_type) - { - case SLANG_CLASS_TYPE_MMT: - case SLANG_CLASS_TYPE_PTR: - case SLANG_CLASS_TYPE_SCALAR: - p = (VOID_STAR) &obj->v; - break; - - case SLANG_CLASS_TYPE_VECTOR: - p = obj->v.ptr_val; - break; - - default: - p = NULL; - } - return p; -} - -char *SLclass_get_datatype_name (unsigned char stype) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (stype); - return cl->cl_name; -} - -static int method_undefined_error (unsigned char type, char *method, char *name) -{ - if (name == NULL) name = SLclass_get_datatype_name (type); - - SLang_verror (SL_TYPE_MISMATCH, "%s method not defined for %s", - method, name); - return -1; -} - -static int -scalar_vector_bin_op_result (int op, unsigned char a, unsigned char b, - unsigned char *c) -{ - (void) a; (void) b; - switch (op) - { - case SLANG_NE: - case SLANG_EQ: - *c = SLANG_INT_TYPE; - return 1; - } - return 0; -} - -static int -scalar_vector_bin_op (int op, - unsigned char a_type, VOID_STAR ap, unsigned int na, - unsigned char b_type, VOID_STAR bp, unsigned int nb, - VOID_STAR cp) -{ - int *c; - char *a, *b; - unsigned int da, db; - unsigned int n, n_max; - unsigned int data_type_len; - SLang_Class_Type *cl; - - (void) b_type; - cl = _SLclass_get_class (a_type); - - data_type_len = cl->cl_sizeof_type; - - a = (char *) ap; - b = (char *) bp; - c = (int *) cp; - - if (na == 1) da = 0; else da = data_type_len; - if (nb == 1) db = 0; else db = data_type_len; - if (na > nb) n_max = na; else n_max = nb; - - switch (op) - { - default: - return 0; - - case SLANG_NE: - for (n = 0; n < n_max; n++) - { - c[n] = (0 != SLMEMCMP(a, b, data_type_len)); - a += da; b += db; - } - break; - - case SLANG_EQ: - for (n = 0; n < n_max; n++) - { - c[n] = (0 == SLMEMCMP(a, b, data_type_len)); - a += da; b += db; - } - break; - } - return 1; -} - -static int scalar_fread (unsigned char type, FILE *fp, VOID_STAR ptr, - unsigned int desired, unsigned int *actual) -{ - unsigned int n; - - n = fread ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, - desired, fp); - *actual = n; - return 0; -} - -static int scalar_fwrite (unsigned char type, FILE *fp, VOID_STAR ptr, - unsigned int desired, unsigned int *actual) -{ - unsigned int n; - - n = fwrite ((char *) ptr, _SLclass_get_class (type)->cl_sizeof_type, - desired, fp); - *actual = n; - return 0; -} - -static int vector_apush (unsigned char type, VOID_STAR ptr) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - return (*cl->cl_push)(type, (VOID_STAR) &ptr); -} - -static int vector_apop (unsigned char type, VOID_STAR ptr) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - return (*cl->cl_pop)(type, (VOID_STAR) &ptr); -} - -static int default_push_mmt (unsigned char type_unused, VOID_STAR ptr) -{ - SLang_MMT_Type *ref; - - (void) type_unused; - ref = *(SLang_MMT_Type **) ptr; - return SLang_push_mmt (ref); -} - -static void default_destroy_simple (unsigned char type_unused, VOID_STAR ptr_unused) -{ - (void) type_unused; - (void) ptr_unused; -} - -static void default_destroy_user (unsigned char type, VOID_STAR ptr) -{ - (void) type; - SLang_free_mmt (*(SLang_MMT_Type **) ptr); -} - -static int default_pop (unsigned char type, VOID_STAR ptr) -{ - return SLclass_pop_ptr_obj (type, (VOID_STAR *) ptr); -} - -static int default_datatype_deref (unsigned char type) -{ - return method_undefined_error (type, "datatype_deref", NULL); -} - -static int default_acopy (unsigned char type, VOID_STAR from, VOID_STAR to) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - if (-1 == (*cl->cl_apush) (type, from)) - return -1; - return (*cl->cl_apop) (type, to); -} - -static int default_dereference_object (unsigned char type, VOID_STAR ptr) -{ - (void) ptr; - return method_undefined_error (type, "dereference", NULL); -} - -static char *default_string (unsigned char stype, VOID_STAR v) -{ - char buf [256]; - char *s; -#if SLANG_HAS_COMPLEX - double *cplx; -#endif - s = buf; - - switch (stype) - { - case SLANG_STRING_TYPE: - s = *(char **) v; - break; - - case SLANG_NULL_TYPE: - s = "NULL"; - break; - - case SLANG_DATATYPE_TYPE: - s = SLclass_get_datatype_name ((unsigned char) *(int *)v); - break; - -#if SLANG_HAS_COMPLEX - case SLANG_COMPLEX_TYPE: - cplx = *(double **) v; - if (cplx[1] < 0) - sprintf (s, "(%g - %gi)", cplx [0], -cplx [1]); - else - sprintf (s, "(%g + %gi)", cplx [0], cplx [1]); - break; -#endif - default: - s = SLclass_get_datatype_name (stype); - } - - return SLmake_string (s); -} - -static int -use_cmp_bin_op_result (int op, unsigned char a, unsigned char b, - unsigned char *c) -{ - if (a != b) - return 0; - switch (op) - { - case SLANG_NE: - case SLANG_EQ: - case SLANG_LT: - case SLANG_LE: - case SLANG_GT: - case SLANG_GE: - *c = SLANG_INT_TYPE; - return 1; - } - return 0; -} - -static int -use_cmp_bin_op (int op, - unsigned char a_type, VOID_STAR ap, unsigned int na, - unsigned char b_type, VOID_STAR bp, unsigned int nb, - VOID_STAR cp) -{ - int *c; - char *a, *b; - unsigned int da, db; - unsigned int n, n_max; - unsigned int data_type_len; - SLang_Class_Type *cl; - int (*cmp)(unsigned char, VOID_STAR, VOID_STAR, int *); - - (void) b_type; - cl = _SLclass_get_class (a_type); - cmp = cl->cl_cmp; - data_type_len = cl->cl_sizeof_type; - - a = (char *) ap; - b = (char *) bp; - c = (int *) cp; - - if (na == 1) da = 0; else da = data_type_len; - if (nb == 1) db = 0; else db = data_type_len; - if (na > nb) n_max = na; else n_max = nb; - - switch (op) - { - int result; - - default: - return 0; - - case SLANG_NE: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result != 0); - a += da; b += db; - } - break; - - case SLANG_EQ: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result == 0); - a += da; b += db; - } - break; - - case SLANG_GT: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result > 0); - a += da; b += db; - } - break; - case SLANG_GE: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result >= 0); - a += da; b += db; - } - break; - case SLANG_LT: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result < 0); - a += da; b += db; - } - break; - case SLANG_LE: - for (n = 0; n < n_max; n++) - { - if (-1 == (*cmp) (a_type, (VOID_STAR)a, (VOID_STAR)b, &result)) - return -1; - c[n] = (result <= 0); - a += da; b += db; - } - break; - } - return 1; -} - - -int SLclass_get_class_id (SLang_Class_Type *cl) -{ - if (cl == NULL) - return -1; - return (int) cl->cl_data_type; -} - -SLang_Class_Type *SLclass_allocate_class (char *name) -{ - SLang_Class_Type *cl; - unsigned int i; - - for (i = 0; i < 256; i++) - { - cl = Registered_Types [i]; - if ((cl != NULL) - && (0 == strcmp (cl->cl_name, name))) - { - SLang_verror (SL_DUPLICATE_DEFINITION, "Type name %s already exists", name); - return NULL; - } - } - - cl = (SLang_Class_Type *) SLmalloc (sizeof (SLang_Class_Type)); - if (cl == NULL) return NULL; - - SLMEMSET ((char *) cl, 0, sizeof (SLang_Class_Type)); - - if (NULL == (cl->cl_name = SLang_create_slstring (name))) - { - SLfree ((char *) cl); - return NULL; - } - - return cl; -} - -static int DataType_Ids [256]; - -int _SLang_push_datatype (unsigned char data_type) -{ - /* This data type could be a copy of another type, e.g., short and - * int if they are the same size (Int16 == Short). So, make sure - * we push the original and not the copy. - */ - data_type = _SLclass_get_class (data_type)->cl_data_type; - return SLclass_push_int_obj (SLANG_DATATYPE_TYPE, (int) data_type); -} - -static int datatype_deref (unsigned char type, VOID_STAR ptr) -{ - SLang_Class_Type *cl; - int status; - - /* The parser generated code for this as if a function call were to be - * made. However, we are calling the deref object routine - * instead of the function call. So, I must simulate the function call. - */ - if (-1 == _SL_increment_frame_pointer ()) - return -1; - - type = (unsigned char) *(int *) ptr; - cl = _SLclass_get_class (type); - status = (*cl->cl_datatype_deref) (type); - - (void) _SL_decrement_frame_pointer (); - return status; -} - -static int datatype_push (unsigned char type_unused, VOID_STAR ptr) -{ - (void) type_unused; - return _SLang_push_datatype (*(int *) ptr); -} - -int _SLang_pop_datatype (unsigned char *type) -{ - int i; - - if (-1 == SLclass_pop_int_obj (SLANG_DATATYPE_TYPE, &i)) - return -1; - - *type = (unsigned char) i; - return 0; -} - -static int datatype_pop (unsigned char type, VOID_STAR ptr) -{ - if (-1 == _SLang_pop_datatype (&type)) - return -1; - - *(int *) ptr = type; - return 0; -} - -int _SLclass_init (void) -{ - SLang_Class_Type *cl; - - /* First initialize the container classes. This is so binary operations - * added later will work with them. - */ - if (-1 == _SLarray_init_slarray ()) - return -1; - - /* DataType_Type */ - if (NULL == (cl = SLclass_allocate_class ("DataType_Type"))) - return -1; - cl->cl_pop = datatype_pop; - cl->cl_push = datatype_push; - cl->cl_dereference = datatype_deref; - if (-1 == SLclass_register_class (cl, SLANG_DATATYPE_TYPE, sizeof(int), - SLANG_CLASS_TYPE_SCALAR)) - return -1; - - return 0; -} - -static int register_new_datatype (char *name, unsigned char type) -{ - DataType_Ids [type] = type; - return SLadd_intrinsic_variable (name, (VOID_STAR) (DataType_Ids + type), - SLANG_DATATYPE_TYPE, 1); -} - -int SLclass_create_synonym (char *name, unsigned char type) -{ - if (NULL == _SLclass_get_class (type)) - return -1; - - return register_new_datatype (name, type); -} - -int _SLclass_copy_class (unsigned char to, unsigned char from) -{ - SLang_Class_Type *cl = _SLclass_get_class (from); - - if (Registered_Types[to] != NULL) - SLang_exit_error ("Application error: Class already exists"); - - Registered_Types[to] = cl; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (to != SLANG_UNDEFINED_TYPE) - _SLclass_Class_Type [to] = cl->cl_class_type; -#endif - return 0; -} - -int SLclass_register_class (SLang_Class_Type *cl, unsigned char type, unsigned int type_size, unsigned char class_type) -{ - char *name; - unsigned int i; - int can_binop = 1; /* scalar_vector_bin_op should work - * for all data types. - */ - - if (type == SLANG_VOID_TYPE) for (i = 0; i < 256; i++) - { - if ((Registered_Types[i] == NULL) - && (i != SLANG_VOID_TYPE)) - { - type = (unsigned char) i; - break; - } - } - - if ((NULL != Registered_Types [type]) - || (type == SLANG_VOID_TYPE)) - { - SLang_verror (SL_APPLICATION_ERROR, "Class type %d already in use", (int) type); - return -1; - } - - cl->cl_data_type = type; - cl->cl_class_type = class_type; - name = cl->cl_name; - - switch (class_type) - { - case SLANG_CLASS_TYPE_MMT: - if (cl->cl_push == NULL) cl->cl_push = default_push_mmt; - if (cl->cl_destroy == NULL) - return method_undefined_error (type, "destroy", name); - cl->cl_user_destroy_fun = cl->cl_destroy; - cl->cl_destroy = default_destroy_user; - type_size = sizeof (VOID_STAR); - break; - - case SLANG_CLASS_TYPE_SCALAR: - if (cl->cl_destroy == NULL) cl->cl_destroy = default_destroy_simple; - if ((type_size == 0) - || (type_size > sizeof (_SL_Object_Union_Type))) - { - SLang_verror (SL_INVALID_PARM, - "Type size for %s not appropriate for SCALAR type", - name); - return -1; - } - if (cl->cl_pop == NULL) - return method_undefined_error (type, "pop", name); - if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; - if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; - - can_binop = 1; - break; - - case SLANG_CLASS_TYPE_PTR: - if (cl->cl_destroy == NULL) - return method_undefined_error (type, "destroy", name); - type_size = sizeof (VOID_STAR); - break; - - case SLANG_CLASS_TYPE_VECTOR: - if (cl->cl_destroy == NULL) - return method_undefined_error (type, "destroy", name); - if (cl->cl_pop == NULL) - return method_undefined_error (type, "pop", name); - cl->cl_apop = vector_apop; - cl->cl_apush = vector_apush; - cl->cl_adestroy = default_destroy_simple; - if (cl->cl_fread == NULL) cl->cl_fread = scalar_fread; - if (cl->cl_fwrite == NULL) cl->cl_fwrite = scalar_fwrite; - can_binop = 1; - break; - - default: - SLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type); - return -1; - } - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (type != SLANG_UNDEFINED_TYPE) - _SLclass_Class_Type [type] = class_type; -#endif - - if (type_size == 0) - { - SLang_verror (SL_INVALID_PARM, "type size must be non-zero for %s", name); - return -1; - } - - if (cl->cl_string == NULL) cl->cl_string = default_string; - if (cl->cl_acopy == NULL) cl->cl_acopy = default_acopy; - if (cl->cl_datatype_deref == NULL) cl->cl_datatype_deref = default_datatype_deref; - - if (cl->cl_pop == NULL) cl->cl_pop = default_pop; - - if (cl->cl_push == NULL) - return method_undefined_error (type, "push", name); - - if (cl->cl_byte_code_destroy == NULL) - cl->cl_byte_code_destroy = cl->cl_destroy; - if (cl->cl_push_literal == NULL) - cl->cl_push_literal = cl->cl_push; - - if (cl->cl_dereference == NULL) - cl->cl_dereference = default_dereference_object; - - if (cl->cl_apop == NULL) cl->cl_apop = cl->cl_pop; - if (cl->cl_apush == NULL) cl->cl_apush = cl->cl_push; - if (cl->cl_adestroy == NULL) cl->cl_adestroy = cl->cl_destroy; - if (cl->cl_push_intrinsic == NULL) cl->cl_push_intrinsic = cl->cl_push; - - if ((cl->cl_foreach == NULL) - || (cl->cl_foreach_open == NULL) - || (cl->cl_foreach_close == NULL)) - { - cl->cl_foreach = _SLarray_cl_foreach; - cl->cl_foreach_open = _SLarray_cl_foreach_open; - cl->cl_foreach_close = _SLarray_cl_foreach_close; - } - - cl->cl_sizeof_type = type_size; - - if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size))) - return -1; - - Registered_Types[type] = cl; - - if (-1 == register_new_datatype (name, type)) - return -1; - - if (cl->cl_cmp != NULL) - { - if (-1 == SLclass_add_binary_op (type, type, use_cmp_bin_op, use_cmp_bin_op_result)) - return -1; - } - else if (can_binop - && (-1 == SLclass_add_binary_op (type, type, scalar_vector_bin_op, scalar_vector_bin_op_result))) - return -1; - - cl->cl_anytype_typecast = _SLanytype_typecast; - - return 0; -} - -int SLclass_add_math_op (unsigned char type, - int (*handler)(int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR), - int (*result) (int, unsigned char, unsigned char *)) -{ - SLang_Class_Type *cl = _SLclass_get_class (type); - - cl->cl_math_op = handler; - cl->cl_math_op_result_type = result; - return 0; -} - -int SLclass_add_binary_op (unsigned char a, unsigned char b, - int (*f) (int, - unsigned char, VOID_STAR, unsigned int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR), - int (*r) (int, unsigned char, unsigned char, unsigned char *)) -{ - SLang_Class_Type *cl; - SL_OOBinary_Type *ab; - - if ((f == NULL) || (r == NULL)) - { - SLang_verror (SL_INVALID_PARM, "SLclass_add_binary_op"); - return -1; - } - - cl = _SLclass_get_class (a); - (void) _SLclass_get_class (b); - - if (NULL == (ab = (SL_OOBinary_Type *) SLmalloc (sizeof(SL_OOBinary_Type)))) - return -1; - - ab->data_type = b; - ab->binary_function = f; - ab->binary_result = r; - ab->next = cl->cl_binary_ops; - cl->cl_binary_ops = ab; - - if ((a != SLANG_ARRAY_TYPE) - && (b != SLANG_ARRAY_TYPE)) - { - if ((-1 == _SLarray_add_bin_op (a)) - || (-1 == _SLarray_add_bin_op (b))) - return -1; - } - - return 0; -} - -int SLclass_add_unary_op (unsigned char type, - int (*f)(int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR), - int (*r)(int, unsigned char, unsigned char *)) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - if ((f == NULL) || (r == NULL)) - { - SLang_verror (SL_INVALID_PARM, "SLclass_add_unary_op"); - return -1; - } - - cl->cl_unary_op = f; - cl->cl_unary_op_result_type = r; - - return 0; -} - -int SLclass_add_app_unary_op (unsigned char type, - int (*f)(int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR), - int (*r)(int, unsigned char, unsigned char *)) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - if ((f == NULL) || (r == NULL)) - { - SLang_verror (SL_INVALID_PARM, "SLclass_add_app_unary_op"); - return -1; - } - - cl->cl_app_unary_op = f; - cl->cl_app_unary_op_result_type = r; - - return 0; -} - -int SLclass_set_pop_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR)) -{ - if (cl == NULL) return -1; - cl->cl_pop = f; - - return 0; -} - -int SLclass_set_push_function (SLang_Class_Type *cl, int (*f)(unsigned char, VOID_STAR)) -{ - if (cl == NULL) return -1; - cl->cl_push = f; - - return 0; -} - -int SLclass_set_string_function (SLang_Class_Type *cl, char *(*f)(unsigned char, VOID_STAR)) -{ - if (cl == NULL) return -1; - - cl->cl_string = f; - return 0; -} - -int SLclass_set_destroy_function (SLang_Class_Type *cl, void (*f)(unsigned char, VOID_STAR)) -{ - if (cl == NULL) return -1; - - cl->cl_destroy = f; - return 0; -} - -int SLclass_set_sget_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) -{ - if (cl == NULL) return -1; - cl->cl_sget = f; - return 0; -} - -int SLclass_set_sput_function (SLang_Class_Type *cl, int (*f)(unsigned char, char *)) -{ - if (cl == NULL) return -1; - cl->cl_sput = f; - return 0; -} - -int SLclass_set_aget_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) -{ - if (cl == NULL) return -1; - cl->cl_aget = f; - return 0; -} - -int SLclass_set_aput_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) -{ - if (cl == NULL) return -1; - cl->cl_aput = f; - return 0; -} - -int SLclass_set_anew_function (SLang_Class_Type *cl, int (*f)(unsigned char, unsigned int)) -{ - if (cl == NULL) return -1; - cl->cl_anew = f; - return 0; -} - -/* Misc */ -void _SLclass_type_mismatch_error (unsigned char a, unsigned char b) -{ - SLang_verror (SL_TYPE_MISMATCH, "Expecting %s, found %s", - SLclass_get_datatype_name (a), - SLclass_get_datatype_name (b)); -} - -/* */ - -static int null_binary_fun (int op, - unsigned char a, VOID_STAR ap, unsigned int na, - unsigned char b, VOID_STAR bp, unsigned int nb, - VOID_STAR cp) -{ - int *ic; - unsigned int i; - int c; - - (void) ap; (void) bp; - - switch (op) - { - case SLANG_EQ: - c = (a == b); - break; - - case SLANG_NE: - c = (a != b); - break; - - default: - return 0; - } - - if (na > nb) nb = na; - ic = (int *) cp; - for (i = 0; i < nb; i++) - ic[i] = c; - - return 1; -} - -static char *get_binary_op_string (int op) -{ - static char *ops[SLANG_MOD] = - { - "+", "=", "*", "/", "==", "!=", ">", ">=", "<", "<=", "^", - "or", "and", "&", "|", "xor", "shl", "shr", "mod" - }; - - if ((op > SLANG_MOD) || (op <= 0)) - return "??"; - return ops[op - 1]; -} - -int (*_SLclass_get_binary_fun (int op, - SLang_Class_Type *a_cl, SLang_Class_Type *b_cl, - SLang_Class_Type **c_cl, int do_error)) -(int, - unsigned char, VOID_STAR, unsigned int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR) -{ - SL_OOBinary_Type *bt; - unsigned char a, b, c; - - a = a_cl->cl_data_type; - b = b_cl->cl_data_type; - - if ((a == SLANG_NULL_TYPE) || (b == SLANG_NULL_TYPE)) - { - *c_cl = _SLclass_get_class (SLANG_INT_TYPE); - return null_binary_fun; - } - - bt = a_cl->cl_binary_ops; - - while (bt != NULL) - { - if (bt->data_type == b) - { - if (1 != (*bt->binary_result)(op, a, b, &c)) - break; - - if (c == a) *c_cl = a_cl; - else if (c == b) *c_cl = b_cl; - else *c_cl = _SLclass_get_class (c); - - return bt->binary_function; - } - - bt = bt->next; - } - - if (do_error) - SLang_verror (SL_TYPE_MISMATCH, "%s %s %s is not possible", - a_cl->cl_name, get_binary_op_string (op), b_cl->cl_name); - - *c_cl = NULL; - return NULL; -} - -int (*_SLclass_get_unary_fun (int op, - SLang_Class_Type *a_cl, - SLang_Class_Type **b_cl, - int utype)) -(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR) -{ - int (*f)(int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); - int (*r)(int, unsigned char, unsigned char *); - unsigned char a; - unsigned char b; - - switch (utype) - { - case _SLANG_BC_UNARY: - f = a_cl->cl_unary_op; - r = a_cl->cl_unary_op_result_type; - break; - - case _SLANG_BC_MATH_UNARY: - f = a_cl->cl_math_op; - r = a_cl->cl_math_op_result_type; - break; - - case _SLANG_BC_APP_UNARY: - f = a_cl->cl_app_unary_op; - r = a_cl->cl_app_unary_op_result_type; - break; - - default: - f = NULL; - r = NULL; - } - - a = a_cl->cl_data_type; - if ((f != NULL) && (r != NULL) && (1 == (*r) (op, a, &b))) - { - if (a == b) - *b_cl = a_cl; - else - *b_cl = _SLclass_get_class (b); - return f; - } - - SLang_verror (SL_TYPE_MISMATCH, "undefined unary operation/function on %s", - a_cl->cl_name); - - *b_cl = NULL; - - return NULL; -} - -int -SLclass_typecast (unsigned char to_type, int is_implicit, int allow_array) -{ - unsigned char 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.data_type; - if (from_type == to_type) - { - SLang_push (&obj); - return 0; - } - - cl_from = _SLclass_get_class (from_type); - - /* Since the typecast functions are designed to work on arrays, - * get the pointer to the value instead of just &obj.v. - */ - ap = _SLclass_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 = _SLclass_get_class (SLANG_ARRAY_TYPE); - bp = cl_to->cl_transfer_buf; - status = _SLarray_typecast (from_type, ap, 1, to_type, bp, is_implicit); - } - else - { - int (*t) (unsigned char, VOID_STAR, unsigned int, unsigned char, VOID_STAR); - - if (NULL == (t = _SLclass_get_typecast (from_type, to_type, is_implicit))) - { - SLang_free_object (&obj); - return -1; - } - - cl_to = _SLclass_get_class (to_type); - bp = cl_to->cl_transfer_buf; - status = (*t) (from_type, ap, 1, to_type, bp); - } - - if (1 == status) - { - if (-1 == (*cl_to->cl_apush)(to_type, bp)) - { - (*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: - - SLang_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; -} - -int (*_SLclass_get_typecast (unsigned char from, unsigned char to, int is_implicit)) -(unsigned char, VOID_STAR, unsigned int, - unsigned char, VOID_STAR) -{ - SL_Typecast_Type *t; - SLang_Class_Type *cl_from; - - cl_from = _SLclass_get_class (from); - - t = cl_from->cl_typecast_funs; - while (t != NULL) - { - if (t->data_type != to) - { - t = t->next; - continue; - } - - if (is_implicit && (t->allow_implicit == 0)) - break; - - return t->typecast; - } - - if (to == SLANG_ANY_TYPE) - return _SLanytype_typecast; - - if ((is_implicit == 0) - && (cl_from->cl_void_typecast != NULL)) - return cl_from->cl_void_typecast; - - SLang_verror (SL_TYPE_MISMATCH, "Unable to typecast %s to %s", - cl_from->cl_name, - SLclass_get_datatype_name (to)); - - return NULL; -} - -int -SLclass_add_typecast (unsigned char from, unsigned char to, - int (*f)_PROTO((unsigned char, VOID_STAR, unsigned int, - unsigned char, VOID_STAR)), - int allow_implicit) -{ - SL_Typecast_Type *t; - SLang_Class_Type *cl; - - cl = _SLclass_get_class (from); - if (to == SLANG_VOID_TYPE) - { - cl->cl_void_typecast = f; - return 0; - } - - (void) _SLclass_get_class (to); - - if (NULL == (t = (SL_Typecast_Type *) SLmalloc (sizeof (SL_Typecast_Type)))) - return -1; - - SLMEMSET((char *) t, 0, sizeof(SL_Typecast_Type)); - t->data_type = to; - t->next = cl->cl_typecast_funs; - t->typecast = f; - t->allow_implicit = allow_implicit; - - cl->cl_typecast_funs = t; - - return 0; -} - -SLang_MMT_Type *SLang_pop_mmt (unsigned char type) /*{{{*/ -{ - SLang_MMT_Type *mmt; - - if (-1 == SLclass_pop_ptr_obj (type, (VOID_STAR *) &mmt)) - mmt = NULL; - return mmt; - -#if 0 - SLang_Object_Type obj; - SLang_Class_Type *cl; - - if (_SLang_pop_object_of_type (type, &obj)) - return NULL; - - cl = _SLclass_get_class (type); - if ((cl->cl_class_type == SLANG_CLASS_TYPE_MMT) - && (obj.data_type == type)) - { - return obj.v.ref; - } - - _SLclass_type_mismatch_error (type, obj.data_type); - SLang_free_object (&obj); - return NULL; -#endif -} - -/*}}}*/ - -int SLang_push_mmt (SLang_MMT_Type *ref) /*{{{*/ -{ - if (ref == NULL) - return SLang_push_null (); - - ref->count += 1; - - if (0 == SLclass_push_ptr_obj (ref->data_type, (VOID_STAR) ref)) - return 0; - - ref->count -= 1; - return -1; -} - -/*}}}*/ - -void SLang_inc_mmt (SLang_MMT_Type *ref) -{ - if (ref != NULL) - ref->count += 1; -} - -VOID_STAR SLang_object_from_mmt (SLang_MMT_Type *ref) -{ - if (ref == NULL) - return NULL; - - return ref->user_data; -} - -SLang_MMT_Type *SLang_create_mmt (unsigned char t, VOID_STAR p) -{ - SLang_MMT_Type *ref; - - (void) _SLclass_get_class (t); /* check to see if it is registered */ - - if (NULL == (ref = (SLang_MMT_Type *) SLmalloc (sizeof (SLang_MMT_Type)))) - return NULL; - - SLMEMSET ((char *) ref, 0, sizeof (SLang_MMT_Type)); - - ref->data_type = t; - ref->user_data = p; - /* FIXME!! To be consistent with other types, the reference count should - * be set to 1 here. However, doing so will require other code changes - * involving the use of MMTs. For instance, SLang_free_mmt would have - * to be called after every push of the MMT. - */ - return ref; -} - -void SLang_free_mmt (SLang_MMT_Type *ref) -{ - unsigned char type; - SLang_Class_Type *cl; - - if (ref == NULL) - return; - - /* This can be zero if SLang_create_mmt is called followed - * by this routine before anything gets a chance to attach itself - * to it. - */ - if (ref->count > 1) - { - ref->count -= 1; - return; - } - - type = ref->data_type; - cl = _SLclass_get_class (type); - (*cl->cl_user_destroy_fun) (type, ref->user_data); - SLfree ((char *)ref); -} - -int SLang_push_value (unsigned char type, VOID_STAR v) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - return (*cl->cl_apush)(type, v); -} - -int SLang_pop_value (unsigned char type, VOID_STAR v) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - return (*cl->cl_apop)(type, v); -} - -void SLang_free_value (unsigned char type, VOID_STAR v) -{ - SLang_Class_Type *cl; - - cl = _SLclass_get_class (type); - (*cl->cl_adestroy) (type, v); -} - -/* These routines are very low-level and are designed for application data - * types to access the stack from their push/pop methods. The int and - * pointer versions are in slang.c - */ -#if SLANG_HAS_FLOAT -int SLclass_push_double_obj (unsigned char type, double x) -{ - SLang_Object_Type obj; - obj.data_type = type; - obj.v.double_val = x; - return SLang_push (&obj); -} -int SLclass_push_float_obj (unsigned char type, float x) -{ - SLang_Object_Type obj; - obj.data_type = type; - obj.v.float_val = x; - return SLang_push (&obj); -} - -#endif - -int SLclass_push_long_obj (unsigned char type, long x) -{ - SLang_Object_Type obj; - obj.data_type = type; - obj.v.long_val = x; - return SLang_push (&obj); -} - -int SLclass_push_short_obj (unsigned char type, short x) -{ - SLang_Object_Type obj; - obj.data_type = type; - obj.v.short_val = x; - return SLang_push (&obj); -} - -int SLclass_push_char_obj (unsigned char type, char x) -{ - SLang_Object_Type obj; - obj.data_type = type; - obj.v.char_val = x; - return SLang_push (&obj); -} - -#if SLANG_HAS_FLOAT -int SLclass_pop_double_obj (unsigned char type, double *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.double_val; - return 0; -} - -int SLclass_pop_float_obj (unsigned char type, float *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.float_val; - return 0; -} -#endif - -int SLclass_pop_long_obj (unsigned char type, long *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.long_val; - return 0; -} - -int SLclass_pop_int_obj (unsigned char type, int *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.int_val; - return 0; -} - -int SLclass_pop_short_obj (unsigned char type, short *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.short_val; - return 0; -} - -int SLclass_pop_char_obj (unsigned char type, char *x) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - return -1; - - *x = obj.v.char_val; - return 0; -} - -int SLclass_pop_ptr_obj (unsigned char type, VOID_STAR *s) -{ - SLang_Object_Type obj; - - if (-1 == _SLang_pop_object_of_type (type, &obj, 0)) - { - *s = (VOID_STAR) NULL; - return -1; - } - *s = obj.v.ptr_val; - return 0; -} - |