int _SLang_init_bstring (void)
{
SLang_Class_Type *cl;
if (NULL == (cl = SLclass_allocate_class ("BString_Type")))
return -1;
(void) SLclass_set_destroy_function (cl, bstring_destroy);
(void) SLclass_set_push_function (cl, bstring_push);
(void) SLclass_set_string_function (cl, bstring_string);
if (-1 == SLclass_register_class (cl, SLANG_BSTRING_TYPE, sizeof (char *),
SLANG_CLASS_TYPE_PTR))
return -1;
if ((-1 == SLclass_add_typecast (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_to_string, 1))
|| (-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_to_bstring, 1))
|| (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_BSTRING_TYPE, string_bstring_bin_op, bstring_bstring_bin_op_result))
|| (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_STRING_TYPE, bstring_string_bin_op, bstring_bstring_bin_op_result))
|| (-1 == SLclass_add_binary_op (SLANG_BSTRING_TYPE, SLANG_BSTRING_TYPE, bstring_bstring_bin_op, bstring_bstring_bin_op_result)))
return -1;
if (-1 == SLadd_intrin_fun_table (BString_Table, NULL))
return -1;
return 0;
}
int _pSLinit_slcomplex (void)
{
SLang_Class_Type *cl;
SLtype *types;
if (NULL == (cl = SLclass_allocate_class ("Complex_Type")))
return -1;
(void) SLclass_set_destroy_function (cl, complex_destroy);
(void) SLclass_set_push_function (cl, complex_push);
(void) SLclass_set_pop_function (cl, complex_pop);
if (-1 == SLclass_register_class (cl, SLANG_COMPLEX_TYPE, 2 * sizeof (double),
SLANG_CLASS_TYPE_VECTOR))
return -1;
types = _pSLarith_Arith_Types;
while (*types != SLANG_DOUBLE_TYPE)
{
SLtype t = *types++;
if ((-1 == SLclass_add_binary_op (t, SLANG_COMPLEX_TYPE, generic_complex_binary, complex_binary_result))
|| (-1 == SLclass_add_binary_op (SLANG_COMPLEX_TYPE, t, complex_generic_binary, complex_binary_result))
|| (-1 == (SLclass_add_typecast (t, SLANG_COMPLEX_TYPE, complex_typecast, 1))))
return -1;
}
if ((-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_COMPLEX_TYPE, complex_complex_binary, complex_binary_result)))
|| (-1 == (SLclass_add_binary_op (SLANG_COMPLEX_TYPE, SLANG_DOUBLE_TYPE, complex_double_binary, complex_binary_result)))
|| (-1 == (SLclass_add_binary_op (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, double_complex_binary, complex_binary_result)))
|| (-1 == (SLclass_add_unary_op (SLANG_COMPLEX_TYPE, complex_unary, complex_unary_result)))
|| (-1 == (SLclass_add_typecast (SLANG_DOUBLE_TYPE, SLANG_COMPLEX_TYPE, complex_typecast, 1))))
return -1;
return 0;
}
int SLang_init_posix_io (void)
{
SLang_Class_Type *cl;
if (NULL == (cl = SLclass_allocate_class ("FD_Type")))
return -1;
cl->cl_destroy = destroy_fd_type;
(void) SLclass_set_push_function (cl, fd_push);
cl->cl_datatype_deref = fdtype_datatype_deref;
if ((-1 == SLclass_register_class (cl, SLANG_FILE_FD_TYPE, sizeof (SLFile_FD_Type), SLANG_CLASS_TYPE_PTR))
|| (-1 == SLclass_add_binary_op (SLANG_FILE_FD_TYPE, SLANG_FILE_FD_TYPE, fd_fd_bin_op, fd_fd_bin_op_result)))
return -1;
if ((-1 == SLadd_intrin_fun_table(Fd_Name_Table, "__POSIXIO__"))
|| (-1 == SLadd_iconstant_table (PosixIO_Consts, NULL))
|| (-1 == _pSLerrno_init ()))
return -1;
return 0;
}
int _pSLarith_register_types (void)
{
SLang_Class_Type *cl;
SLtype a_type, b_type;
int i, j;
#if defined(HAVE_SETLOCALE) && defined(LC_NUMERIC)
/* make sure decimal point it used --- the parser requires it */
(void) setlocale (LC_NUMERIC, "C");
#endif
for (i = 0; i < NUM_INTEGER_TYPES; i++)
{
Integer_Info_Type *info;
info = Integer_Types + i;
_pSLang_set_arith_type (info->data_type, 1);
if (info->name == NULL)
{
/* This happens when the object is the same size as an integer
* For this case, we really want to copy the integer class.
* We will handle that when the synonym is created.
*/
continue;
}
if (NULL == (cl = SLclass_allocate_class (info->name)))
return -1;
(void) SLclass_set_string_function (cl, arith_string);
(void) SLclass_set_push_function (cl, integer_push);
(void) SLclass_set_pop_function (cl, integer_pop);
cl->cl_push_literal = info->push_literal;
cl->cl_to_bool = integer_to_bool;
cl->cl_byte_code_destroy = info->byte_code_destroy;
cl->cl_cmp = info->cmp_fun;
if (-1 == SLclass_register_class (cl, info->data_type, info->sizeof_type,
SLANG_CLASS_TYPE_SCALAR))
return -1;
if (-1 == SLclass_add_unary_op (info->data_type, info->unary_fun, arith_unary_op_result))
return -1;
#if 0
if (-1 == _pSLclass_add_arith_unary_op (info->data_type, info->arith_unary_fun, arith_unary_arith_op_result))
return -1;
#endif
}
#if SLANG_HAS_FLOAT
if (NULL == (cl = SLclass_allocate_class ("Double_Type")))
return -1;
(void) SLclass_set_push_function (cl, double_push);
(void) SLclass_set_pop_function (cl, double_pop);
(void) SLclass_set_string_function (cl, arith_string);
cl->cl_byte_code_destroy = double_byte_code_destroy;
cl->cl_push_literal = double_push_literal;
cl->cl_cmp = double_cmp_function;
if (-1 == SLclass_register_class (cl, SLANG_DOUBLE_TYPE, sizeof (double),
SLANG_CLASS_TYPE_SCALAR))
return -1;
if (-1 == SLclass_add_unary_op (SLANG_DOUBLE_TYPE, double_unary_op, arith_unary_op_result))
return -1;
#if 0
if (-1 == _pSLclass_add_arith_unary_op (SLANG_DOUBLE_TYPE, double_arith_unary_op, arith_unary_op_result))
return -1;
#endif
_pSLang_set_arith_type (SLANG_DOUBLE_TYPE, 2);
if (NULL == (cl = SLclass_allocate_class ("Float_Type")))
return -1;
(void) SLclass_set_string_function (cl, arith_string);
(void) SLclass_set_push_function (cl, float_push);
(void) SLclass_set_pop_function (cl, float_pop);
cl->cl_cmp = float_cmp_function;
if (-1 == SLclass_register_class (cl, SLANG_FLOAT_TYPE, sizeof (float),
SLANG_CLASS_TYPE_SCALAR))
return -1;
if (-1 == SLclass_add_unary_op (SLANG_FLOAT_TYPE, float_unary_op, arith_unary_op_result))
return -1;
#if 0
if (-1 == _pSLclass_add_arith_unary_op (SLANG_FLOAT_TYPE, float_arith_unary_op, arith_unary_op_result))
return -1;
#endif
_pSLang_set_arith_type (SLANG_FLOAT_TYPE, 2);
#endif
if (-1 == create_synonyms ())
return -1;
for (i = 0; i < MAX_ARITHMETIC_TYPES; i++)
{
a_type = _pSLarith_Arith_Types[i];
#if 0
if (Alias_Map[TYPE_TO_TABLE_INDEX(a_type)] != a_type)
continue;
#endif
if (a_type == 0)
continue;
for (j = 0; j < MAX_ARITHMETIC_TYPES; j++)
{
int implicit_ok;
b_type = _pSLarith_Arith_Types[j];
if (b_type == 0)
continue;
/* Allow implicit typecast, except from int to float */
implicit_ok = ((b_type >= SLANG_FLOAT_TYPE)
|| (a_type < SLANG_FLOAT_TYPE));
if (-1 == SLclass_add_binary_op (a_type, b_type, arith_bin_op, arith_bin_op_result))
return -1;
if (a_type != b_type)
if (-1 == SLclass_add_typecast (a_type, b_type, _pSLarith_typecast, implicit_ok))
return -1;
}
}
if (-1 == _pSLadd_arith_unary_table (Unary_Table, NULL))
return -1;
if (-1 == _pSLadd_arith_binary_table (Binary_Table, NULL))
return -1;
if ((-1 == SLadd_iconstant_table (IConst_Table, NULL))
#if SLANG_HAS_FLOAT
|| (-1 == SLadd_fconstant_table (FConst_Table, NULL))
|| (-1 == SLadd_dconstant_table (DConst_Table, NULL))
#endif
#if HAVE_LONG_LONG
|| (-1 == SLadd_llconstant_table (LLConst_Table, NULL))
#endif
)
return -1;
compute_inf_an_nan ();
return 0;
}
int SLclass_register_class (SLang_Class_Type *cl, SLtype type, unsigned int type_size, SLclass_Type class_type)
{
Class_Table_Type *t;
SLang_Class_Type **clp;
char *name;
int can_binop = 1; /* scalar_vector_bin_op should work
* for all data types.
*/
if (type == SLANG_VOID_TYPE)
clp = find_empty_class_slot (&type, &t);
else
clp = alloc_class_slot (type, &t);
if (clp == NULL)
{
_pSLang_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 (_pSL_Object_Union_Type)))
{
_pSLang_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;
if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy;
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;
if (cl->cl_acopy == NULL) cl->cl_acopy = scalar_acopy;
can_binop = 1;
break;
default:
_pSLang_verror (SL_INVALID_PARM, "%s: unknown class type (%d)", name, class_type);
return -1;
}
if (type_size == 0)
{
_pSLang_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 = _pSLarray_cl_foreach;
cl->cl_foreach_open = _pSLarray_cl_foreach_open;
cl->cl_foreach_close = _pSLarray_cl_foreach_close;
}
cl->cl_sizeof_type = type_size;
if (NULL == (cl->cl_transfer_buf = (VOID_STAR) SLmalloc (type_size)))
return -1;
add_class_to_slot (t, clp, 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 = _pSLanytype_typecast;
return 0;
}
int _pSLregister_types (void)
{
SLang_Class_Type *cl;
#if 1
/* A good compiler should optimize this code away. */
if ((sizeof(short) != SIZEOF_SHORT)
|| (sizeof(int) != SIZEOF_INT)
|| (sizeof(long) != SIZEOF_LONG)
|| (sizeof(float) != SIZEOF_FLOAT)
|| (sizeof(double) != SIZEOF_DOUBLE))
SLang_exit_error ("S-Lang Library not built properly. Fix SIZEOF_* in config.h and recompile");
#endif
if (-1 == _pSLclass_init ())
return -1;
/* Undefined Type */
if (NULL == (cl = SLclass_allocate_class ("Undefined_Type")))
return -1;
(void) SLclass_set_push_function (cl, undefined_method);
(void) SLclass_set_pop_function (cl, undefined_method);
(void) SLclass_set_destroy_function (cl, void_undefined_method);
if (-1 == SLclass_register_class (cl, SLANG_UNDEFINED_TYPE, sizeof (int),
SLANG_CLASS_TYPE_SCALAR))
return -1;
/* Make Void_Type a synonym for Undefined_Type. Note that this does
* not mean that Void_Type represents SLANG_VOID_TYPE. Void_Type is
* used by array_map to indicate no array is to be created.
*/
if (-1 == SLclass_create_synonym ("Void_Type", SLANG_UNDEFINED_TYPE))
return -1;
if (-1 == _pSLarith_register_types ())
return -1;
/* SLANG_INTP_TYPE -- not used within the interpreter */
if (NULL == (cl = SLclass_allocate_class ("_IntegerP_Type")))
return -1;
(void) SLclass_set_push_function (cl, intp_push);
(void) SLclass_set_pop_function (cl, intp_pop);
if (-1 == SLclass_register_class (cl, SLANG_INTP_TYPE, sizeof (int *),
SLANG_CLASS_TYPE_SCALAR))
return -1;
/* String Type */
if (NULL == (cl = SLclass_allocate_class ("String_Type")))
return -1;
(void) SLclass_set_destroy_function (cl, string_destroy);
(void) SLclass_set_push_function (cl, string_push);
(void) SLclass_set_acopy_function (cl, string_acopy);
cl->cl_foreach_open = _pSLbstring_foreach_open;
cl->cl_foreach_close = _pSLbstring_foreach_close;
cl->cl_foreach = _pSLbstring_foreach;
cl->cl_cmp = string_cmp;
if (-1 == SLclass_register_class (cl, SLANG_STRING_TYPE, sizeof (char *),
SLANG_CLASS_TYPE_PTR))
return -1;
/* ref Type */
if (NULL == (cl = SLclass_allocate_class ("Ref_Type")))
return -1;
cl->cl_dereference = ref_dereference;
cl->cl_push = ref_push;
cl->cl_destroy = ref_destroy;
cl->cl_string = ref_string;
cl->cl_cmp = ref_cmp;
if (-1 == SLclass_register_class (cl, SLANG_REF_TYPE,
sizeof (SLang_Ref_Type *),
SLANG_CLASS_TYPE_PTR))
return -1;
/* NULL Type */
if (NULL == (cl = SLclass_allocate_class ("Null_Type")))
return -1;
cl->cl_push = null_push;
cl->cl_pop = null_pop;
cl->cl_foreach_open = null_foreach_open;
cl->cl_foreach_close = null_foreach_close;
cl->cl_foreach = null_foreach;
cl->cl_to_bool = null_to_bool;
if (-1 == SLclass_register_class (cl, SLANG_NULL_TYPE, sizeof (char *),
SLANG_CLASS_TYPE_SCALAR))
return -1;
/* AnyType */
if (NULL == (cl = SLclass_allocate_class ("Any_Type")))
return -1;
(void) SLclass_set_push_function (cl, anytype_push);
(void) SLclass_set_destroy_function (cl, anytype_destroy);
#if 0
(void) SLclass_set_apush_function (cl, anytype_apush);
#endif
cl->cl_dereference = anytype_dereference;
if (-1 == SLclass_register_class (cl, SLANG_ANY_TYPE, sizeof (VOID_STAR),
SLANG_CLASS_TYPE_PTR))
return -1;
if (-1 == _pSLang_init_bstring ())
return -1;
if ((-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_INT_TYPE, string_to_int, 0))
|| (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_STRING_TYPE, string_string_bin_op, string_string_bin_op_result)))
return -1;
return 0;
}