diff options
Diffstat (limited to 'mdk-stage1/slang/slang.c')
| -rw-r--r-- | mdk-stage1/slang/slang.c | 5547 |
1 files changed, 0 insertions, 5547 deletions
diff --git a/mdk-stage1/slang/slang.c b/mdk-stage1/slang/slang.c deleted file mode 100644 index 6edc7df37..000000000 --- a/mdk-stage1/slang/slang.c +++ /dev/null @@ -1,5547 +0,0 @@ -/* -*- mode: C; mode: fold; -*- */ -/* slang.c --- guts of S-Lang interpreter */ -/* 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" - -#if SLANG_HAS_FLOAT -# include <math.h> -#endif - -#include "slang.h" -#include "_slang.h" - -#define USE_COMBINED_BYTECODES 0 - -struct _SLBlock_Type; - -typedef struct -{ - struct _SLBlock_Type *body; - unsigned int num_refs; -} -_SLBlock_Header_Type; - -typedef struct -{ - char *name; - SLang_Name_Type *next; - char name_type; - - union - { - _SLBlock_Header_Type *header; /* body of function */ - char *autoload_filename; - } - v; -#if _SLANG_HAS_DEBUG_CODE - char *file; -#endif -#define SLANG_MAX_LOCAL_VARIABLES 254 -#define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1) - unsigned char nlocals; /* number of local variables */ - unsigned char nargs; /* number of arguments */ -} -_SLang_Function_Type; - -typedef struct -{ - char *name; - SLang_Name_Type *next; - char name_type; - - SLang_Object_Type obj; -} -SLang_Global_Var_Type; - -typedef struct -{ - char *name; - SLang_Name_Type *next; - char name_type; - - int local_var_number; -} -SLang_Local_Var_Type; - -typedef struct _SLBlock_Type -{ - unsigned char bc_main_type; - unsigned char bc_sub_type; - union - { - struct _SLBlock_Type *blk; - int i_blk; - - SLang_Name_Type *nt_blk; - SLang_App_Unary_Type *nt_unary_blk; - SLang_Intrin_Var_Type *nt_ivar_blk; - SLang_Intrin_Fun_Type *nt_ifun_blk; - SLang_Global_Var_Type *nt_gvar_blk; - SLang_IConstant_Type *iconst_blk; - SLang_DConstant_Type *dconst_blk; - _SLang_Function_Type *nt_fun_blk; - - VOID_STAR ptr_blk; - char *s_blk; - SLang_BString_Type *bs_blk; - -#if SLANG_HAS_FLOAT - double *double_blk; /*literal double is a pointer */ -#endif - float float_blk; - long l_blk; - struct _SLang_Struct_Type *struct_blk; - int (*call_function)(void); - } - b; -} -SLBlock_Type; - -/* Debugging and tracing variables */ - -void (*SLang_Enter_Function)(char *) = NULL; -void (*SLang_Exit_Function)(char *) = NULL; -/* If non null, these call C functions before and after a slang function. */ - -int _SLang_Trace = 0; -/* If _SLang_Trace = -1, do not trace intrinsics */ -static int Trace_Mode = 0; - -static char *Trace_Function; /* function to be traced */ -int SLang_Traceback = 0; -/* non zero means do traceback. If less than 0, do not show local variables */ - -/* These variables handle _NARGS processing by the parser */ -int SLang_Num_Function_Args; -static int *Num_Args_Stack; -static unsigned int Recursion_Depth; -static SLang_Object_Type *Frame_Pointer; -static int Next_Function_Num_Args; -static unsigned int Frame_Pointer_Depth; -static unsigned int *Frame_Pointer_Stack; - -static int Lang_Break_Condition = 0; -/* true if any one below is true. This keeps us from testing 3 variables. - * I know this can be perfomed with a bitmapped variable, but... - */ -static int Lang_Break = 0; -static int Lang_Return = 0; -/* static int Lang_Continue = 0; */ - -SLang_Object_Type *_SLRun_Stack; -SLang_Object_Type *_SLStack_Pointer; -static SLang_Object_Type *_SLStack_Pointer_Max; - -/* Might want to increase this. */ -static SLang_Object_Type Local_Variable_Stack[SLANG_MAX_LOCAL_STACK]; -static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack; - -static void free_function_header (_SLBlock_Header_Type *); - -void (*SLang_Dump_Routine)(char *); - -static void call_dump_routine (char *fmt, ...) -{ - char buf[1024]; - va_list ap; - - va_start (ap, fmt); - if (SLang_Dump_Routine != NULL) - { - (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap); - (*SLang_Dump_Routine) (buf); - } - else - { - vfprintf (stderr, fmt, ap); - fflush (stderr); - } - va_end (ap); -} - -static void do_traceback (char *, unsigned int, char *); -static int init_interpreter (void); - -/*{{{ push/pop/etc stack manipulation functions */ - -/* This routine is assumed to work even in the presence of a SLang_Error. */ -_INLINE_ -int SLang_pop (SLang_Object_Type *x) -{ - register SLang_Object_Type *y; - - y = _SLStack_Pointer; - if (y == _SLRun_Stack) - { - if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; - x->data_type = 0; - return -1; - } - y--; - *x = *y; - - _SLStack_Pointer = y; - return 0; -} - -static int pop_ctrl_integer (int *i) -{ - int type; - SLang_Class_Type *cl; -#if _SLANG_OPTIMIZE_FOR_SPEED - register SLang_Object_Type *y; - - /* Most of the time, either an integer or a char will be on the stack. - * Optimize these cases. - */ - y = _SLStack_Pointer; - if (y == _SLRun_Stack) - { - if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; - return -1; - } - y--; - - type = y->data_type; - if (type == SLANG_INT_TYPE) - { - _SLStack_Pointer = y; - *i = y->v.int_val; - return 0; - } - if (type == SLANG_CHAR_TYPE) - { - _SLStack_Pointer = y; - *i = y->v.char_val; - return 0; - } -#else - if (-1 == (type = SLang_peek_at_stack ())) - return -1; -#endif - - cl = _SLclass_get_class ((unsigned char) type); - if (cl->cl_to_bool == NULL) - { - SLang_verror (SL_TYPE_MISMATCH, - "%s cannot be used in a boolean context", - cl->cl_name); - return -1; - } - return cl->cl_to_bool ((unsigned char) type, i); -} - -_INLINE_ -int SLang_peek_at_stack (void) -{ - if (_SLStack_Pointer == _SLRun_Stack) - { - if (SLang_Error == 0) - SLang_Error = SL_STACK_UNDERFLOW; - return -1; - } - - return (_SLStack_Pointer - 1)->data_type; -} - -int SLang_peek_at_stack1 (void) -{ - int type; - - type = SLang_peek_at_stack (); - if (type == SLANG_ARRAY_TYPE) - type = (_SLStack_Pointer - 1)->v.array_val->data_type; - - return type; -} - -_INLINE_ -void SLang_free_object (SLang_Object_Type *obj) -{ - unsigned char data_type; - SLang_Class_Type *cl; - - if (obj == NULL) return; - data_type = obj->data_type; -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [data_type]) - return; - if (data_type == SLANG_STRING_TYPE) - { - SLang_free_slstring (obj->v.s_val); - return; - } -#endif - cl = _SLclass_get_class (data_type); -#if !_SLANG_OPTIMIZE_FOR_SPEED - if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) -#endif - (*cl->cl_destroy) (data_type, (VOID_STAR) &obj->v); -} - -_INLINE_ -int SLang_push (SLang_Object_Type *x) -{ - register SLang_Object_Type *y; - y = _SLStack_Pointer; - - /* if there is a SLang_Error, probably not much harm will be done - if it is ignored here */ - /* if (SLang_Error) return; */ - - /* flag it now */ - if (y >= _SLStack_Pointer_Max) - { - if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; - return -1; - } - - *y = *x; - _SLStack_Pointer = y + 1; - return 0; -} - -/* _INLINE_ */ -int SLclass_push_ptr_obj (unsigned char type, VOID_STAR pval) -{ - register SLang_Object_Type *y; - y = _SLStack_Pointer; - - if (y >= _SLStack_Pointer_Max) - { - if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; - return -1; - } - - y->data_type = type; - y->v.ptr_val = pval; - - _SLStack_Pointer = y + 1; - return 0; -} - -_INLINE_ -int SLclass_push_int_obj (unsigned char type, int x) -{ - register SLang_Object_Type *y; - y = _SLStack_Pointer; - - if (y >= _SLStack_Pointer_Max) - { - if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW; - return -1; - } - - y->data_type = type; - y->v.int_val = x; - - _SLStack_Pointer = y + 1; - return 0; -} - -_INLINE_ -int _SLang_pop_object_of_type (unsigned char type, SLang_Object_Type *obj, - int allow_arrays) -{ - register SLang_Object_Type *y; - - y = _SLStack_Pointer; - if (y == _SLRun_Stack) - return SLang_pop (obj); - y--; - if (y->data_type != type) - { -#if _SLANG_OPTIMIZE_FOR_SPEED - /* This is an implicit typecast. We do not want to typecast - * floats to ints implicitly. - */ - if (_SLarith_Is_Arith_Type [type] - && _SLarith_Is_Arith_Type [y->data_type] - && (_SLarith_Is_Arith_Type [type] >= _SLarith_Is_Arith_Type[y->data_type])) - { - /* This should not fail */ - (void) _SLarith_typecast (y->data_type, (VOID_STAR)&y->v, 1, - type, (VOID_STAR)&obj->v); - obj->data_type = type; - _SLStack_Pointer = y; - return 0; - } -#endif - - if ((allow_arrays == 0) - || (y->data_type != SLANG_ARRAY_TYPE) - || (y->v.array_val->data_type != type)) - if (-1 == SLclass_typecast (type, 1, 0)) - return -1; - } - *obj = *y; - _SLStack_Pointer = y; - return 0; -} - -/* This function reverses the top n items on the stack and returns a - * an offset from the start of the stack to the last item. - */ -int SLreverse_stack (int n) -{ - SLang_Object_Type *otop, *obot, tmp; - - otop = _SLStack_Pointer; - if ((n > otop - _SLRun_Stack) || (n < 0)) - { - SLang_Error = SL_STACK_UNDERFLOW; - return -1; - } - obot = otop - n; - otop--; - while (otop > obot) - { - tmp = *obot; - *obot = *otop; - *otop = tmp; - otop--; - obot++; - } - return (int) ((_SLStack_Pointer - n) - _SLRun_Stack); -} - -_INLINE_ -int SLroll_stack (int np) -{ - int n, i; - SLang_Object_Type *otop, *obot, tmp; - - if ((n = abs(np)) <= 1) return 0; /* identity */ - - obot = otop = _SLStack_Pointer; - i = n; - while (i != 0) - { - if (obot <= _SLRun_Stack) - { - SLang_Error = SL_STACK_UNDERFLOW; - return -1; - } - obot--; - i--; - } - otop--; - - if (np > 0) - { - /* Put top on bottom and roll rest up. */ - tmp = *otop; - while (otop > obot) - { - *otop = *(otop - 1); - otop--; - } - *otop = tmp; - } - else - { - /* Put bottom on top and roll rest down. */ - tmp = *obot; - while (obot < otop) - { - *obot = *(obot + 1); - obot++; - } - *obot = tmp; - } - return 0; -} - -int _SLstack_depth (void) -{ - return (int) (_SLStack_Pointer - _SLRun_Stack); -} - -int SLdup_n (int n) -{ - SLang_Object_Type *bot, *top; - - if (n <= 0) - return 0; - - top = _SLStack_Pointer; - if (top < _SLRun_Stack + n) - { - if (SLang_Error == 0) - SLang_Error = SL_STACK_UNDERFLOW; - return -1; - } - if (top + n > _SLStack_Pointer_Max) - { - if (SLang_Error == 0) - SLang_Error = SL_STACK_OVERFLOW; - return -1; - } - bot = top - n; - - while (bot < top) - { - SLang_Class_Type *cl; - unsigned char data_type = bot->data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [data_type]) - { - *_SLStack_Pointer++ = *bot++; - continue; - } -#endif - cl = _SLclass_get_class (data_type); - if (-1 == (*cl->cl_push) (data_type, (VOID_STAR) &bot->v)) - return -1; - bot++; - } - return 0; -} - -/*}}}*/ - -/*{{{ inner interpreter and support functions */ - -_INLINE_ -int _SL_increment_frame_pointer (void) -{ - if (Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH) - { - SLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow"); - return -1; - } - Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args; - - SLang_Num_Function_Args = Next_Function_Num_Args; - Next_Function_Num_Args = 0; - Recursion_Depth++; - return 0; -} - -_INLINE_ -int _SL_decrement_frame_pointer (void) -{ - if (Recursion_Depth == 0) - { - SLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow"); - return -1; - } - - Recursion_Depth--; - if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH) - SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth]; - - return 0; -} - -_INLINE_ -int SLang_start_arg_list (void) -{ - if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) - { - Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - _SLRun_Stack); - Frame_Pointer = _SLStack_Pointer; - Frame_Pointer_Depth++; - Next_Function_Num_Args = 0; - return 0; - } - - SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow"); - return -1; -} - -_INLINE_ -int SLang_end_arg_list (void) -{ - if (Frame_Pointer_Depth == 0) - { - SLang_verror (SL_STACK_UNDERFLOW, "Frame Stack Underflow"); - return -1; - } - Frame_Pointer_Depth--; - if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH) - { - Next_Function_Num_Args = (int) (_SLStack_Pointer - Frame_Pointer); - Frame_Pointer = _SLRun_Stack + Frame_Pointer_Stack [Frame_Pointer_Depth]; - } - return 0; -} - -_INLINE_ -static int do_bc_call_direct_frame (int (*f)(void)) -{ - if ((0 == SLang_end_arg_list ()) - && (0 == _SL_increment_frame_pointer ())) - { - (void) (*f) (); - _SL_decrement_frame_pointer (); - } - if (SLang_Error) - return -1; - return 0; -} - -static int do_name_type_error (SLang_Name_Type *nt) -{ - char buf[256]; - if (nt != NULL) - { - (void) _SLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name); - do_traceback (buf, 0, NULL); - } - return -1; -} - -/* local and global variable assignments */ - -static int do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb) -{ - SLang_Class_Type *a_cl, *b_cl, *c_cl; - unsigned char b_data_type, a_data_type, c_data_type; - int (*binary_fun) (int, - unsigned char, VOID_STAR, unsigned int, - unsigned char, VOID_STAR, unsigned int, - VOID_STAR); - VOID_STAR pa; - VOID_STAR pb; - VOID_STAR pc; - int ret; - - b_data_type = objb->data_type; - a_data_type = obja->data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (_SLarith_Is_Arith_Type[a_data_type] - && _SLarith_Is_Arith_Type[b_data_type]) - { - int status; - status = _SLarith_bin_op (obja, objb, op); - if (status != 1) - return status; - /* drop and try it the hard way */ - } -#endif - - a_cl = _SLclass_get_class (a_data_type); - if (a_data_type == b_data_type) - b_cl = a_cl; - else - b_cl = _SLclass_get_class (b_data_type); - - if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1))) - return -1; - - c_data_type = c_cl->cl_data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_data_type]) - pa = (VOID_STAR) &obja->v; - else -#endif - pa = _SLclass_get_ptr_to_value (a_cl, obja); - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [b_data_type]) - pb = (VOID_STAR) &objb->v; - else -#endif - pb = _SLclass_get_ptr_to_value (b_cl, objb); - - pc = c_cl->cl_transfer_buf; - - if (1 != (*binary_fun) (op, - a_data_type, pa, 1, - b_data_type, pb, 1, - pc)) - { - SLang_verror (SL_NOT_IMPLEMENTED, - "Binary operation between %s and %s failed", - a_cl->cl_name, b_cl->cl_name); - - return -1; - } - - /* apush will create a copy, so make sure we free after the push */ - ret = (*c_cl->cl_apush)(c_data_type, pc); -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [c_data_type]) -#endif - (*c_cl->cl_adestroy)(c_data_type, pc); - - return ret; -} - -_INLINE_ -static void do_binary (int op) -{ - SLang_Object_Type obja, objb; - - if (SLang_pop (&objb)) return; - if (0 == SLang_pop (&obja)) - { - (void) do_binary_ab (op, &obja, &objb); -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja.data_type]) -#endif - SLang_free_object (&obja); - } -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type]) -#endif - SLang_free_object (&objb); -} - -static int do_unary_op (int op, SLang_Object_Type *obj, int unary_type) -{ - int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR); - VOID_STAR pa; - VOID_STAR pb; - SLang_Class_Type *a_cl, *b_cl; - unsigned char a_type, b_type; - int ret; - - a_type = obj->data_type; - a_cl = _SLclass_get_class (a_type); - - if (NULL == (f = _SLclass_get_unary_fun (op, a_cl, &b_cl, unary_type))) - return -1; - - b_type = b_cl->cl_data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_type]) - pa = (VOID_STAR) &obj->v; - else -#endif - pa = _SLclass_get_ptr_to_value (a_cl, obj); - - pb = b_cl->cl_transfer_buf; - - if (1 != (*f) (op, a_type, pa, 1, pb)) - { - SLang_verror (SL_NOT_IMPLEMENTED, - "Unary operation for %s failed", a_cl->cl_name); - return -1; - } - - ret = (*b_cl->cl_apush)(b_type, pb); - /* cl_apush creates a copy, so make sure we call cl_adestroy */ -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [b_type]) -#endif - (*b_cl->cl_adestroy)(b_type, pb); - - return ret; -} - -_INLINE_ -static int do_unary (int op, int unary_type) -{ - SLang_Object_Type obj; - int ret; - - if (-1 == SLang_pop (&obj)) return -1; - ret = do_unary_op (op, &obj, unary_type); -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obj.data_type]) -#endif - SLang_free_object (&obj); - return ret; -} - -static int do_assignment_binary (int op, SLang_Object_Type *obja_ptr) -{ - SLang_Object_Type objb; - int ret; - - if (SLang_pop (&objb)) - return -1; - - ret = do_binary_ab (op, obja_ptr, &objb); -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type]) -#endif - SLang_free_object (&objb); - return ret; -} - -/* The order of these is assumed to match the binary operators - * defined in slang.h - */ -static int -map_assignment_op_to_binary (unsigned char op_type, int *op, int *is_unary) -{ - *is_unary = 0; - switch (op_type) - { - case _SLANG_BCST_PLUSEQS: - case _SLANG_BCST_MINUSEQS: - case _SLANG_BCST_TIMESEQS: - case _SLANG_BCST_DIVEQS: - *op = SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS); - break; - - case _SLANG_BCST_BOREQS: - *op = SLANG_BOR; - break; - - case _SLANG_BCST_BANDEQS: - *op = SLANG_BAND; - break; - - case _SLANG_BCST_POST_MINUSMINUS: - case _SLANG_BCST_MINUSMINUS: - *op = SLANG_MINUS; - *is_unary = 1; - break; - - case _SLANG_BCST_PLUSPLUS: - case _SLANG_BCST_POST_PLUSPLUS: - *op = SLANG_PLUS; - *is_unary = 1; - break; - - default: - SLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented"); - return -1; - } - return 0; -} - -static int -perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr) -{ - switch (op_type) - { - case _SLANG_BCST_ASSIGN: - break; - - /* The order of these is assumed to match the binary operators - * defined in slang.h - */ - case _SLANG_BCST_PLUSEQS: - case _SLANG_BCST_MINUSEQS: - case _SLANG_BCST_TIMESEQS: - case _SLANG_BCST_DIVEQS: - if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS), obja_ptr)) - return -1; - break; - - case _SLANG_BCST_BOREQS: - if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr)) - return -1; - break; - - case _SLANG_BCST_BANDEQS: - if (-1 == do_assignment_binary (SLANG_BAND, obja_ptr)) - return -1; - break; - - case _SLANG_BCST_PLUSPLUS: - case _SLANG_BCST_POST_PLUSPLUS: -#if _SLANG_OPTIMIZE_FOR_SPEED - if (obja_ptr->data_type == SLANG_INT_TYPE) - return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val + 1); -#endif - if (-1 == do_unary_op (SLANG_PLUSPLUS, obja_ptr, _SLANG_BC_UNARY)) - return -1; - break; - - case _SLANG_BCST_MINUSMINUS: - case _SLANG_BCST_POST_MINUSMINUS: -#if _SLANG_OPTIMIZE_FOR_SPEED - if (obja_ptr->data_type == SLANG_INT_TYPE) - return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val - 1); -#endif - if (-1 == do_unary_op (SLANG_MINUSMINUS, obja_ptr, _SLANG_BC_UNARY)) - return -1; - break; - - default: - SLang_Error = SL_INTERNAL_ERROR; - return -1; - } - return 0; -} - -_INLINE_ -static int -set_lvalue_obj (unsigned char op_type, SLang_Object_Type *obja_ptr) -{ - if (op_type != _SLANG_BCST_ASSIGN) - { - if (-1 == perform_lvalue_operation (op_type, obja_ptr)) - return -1; - } -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja_ptr->data_type]) -#endif - SLang_free_object (obja_ptr); - - return SLang_pop(obja_ptr); -} - -static int -set_struct_lvalue (SLBlock_Type *bc_blk) -{ - int type; - SLang_Class_Type *cl; - char *name; - int op; - - if (-1 == (type = SLang_peek_at_stack ())) - return -1; - - cl = _SLclass_get_class (type); - if ((cl->cl_sput == NULL) - || (cl->cl_sget == NULL)) - { - SLang_verror (SL_NOT_IMPLEMENTED, - "%s does not support structure access", - cl->cl_name); - SLdo_pop_n (2); /* object plus what was to be assigned */ - return -1; - } - name = bc_blk->b.s_blk; - op = bc_blk->bc_sub_type; - - if (op != _SLANG_BCST_ASSIGN) - { - /* We have something like (A.x += b) or (A.x++). In either case, - * we need A.x. - */ - SLang_Object_Type obj_A; - SLang_Object_Type obj; - - if (-1 == SLang_pop (&obj_A)) - return -1; - - if ((-1 == _SLpush_slang_obj (&obj_A)) - || (-1 == cl->cl_sget ((unsigned char) type, name)) - || (-1 == SLang_pop (&obj))) - { - SLang_free_object (&obj_A); - return -1; - } - /* Now the value of A.x is in obj. */ - if (-1 == perform_lvalue_operation (op, &obj)) - { - SLang_free_object (&obj); - SLang_free_object (&obj_A); - return -1; - } - SLang_free_object (&obj); - /* The result of the operation is now on the stack. - * Perform assignment */ - if (-1 == SLang_push (&obj_A)) - { - SLang_free_object (&obj_A); - return -1; - } - } - - return (*cl->cl_sput) ((unsigned char) type, name); -} - -static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u) -{ - unsigned char type; - - type = a->data_type; - if (type == SLANG_ARRAY_TYPE) - type = a->v.array_val->data_type; - - u->data_type = type; - switch (type) - { - case SLANG_UCHAR_TYPE: - case SLANG_CHAR_TYPE: - u->v.char_val = 1; - break; - - case SLANG_SHORT_TYPE: - case SLANG_USHORT_TYPE: - u->v.short_val = 1; - break; - - case SLANG_LONG_TYPE: - case SLANG_ULONG_TYPE: - u->v.long_val = 1; - break; - -#if SLANG_HAS_FLOAT - case SLANG_FLOAT_TYPE: - u->v.float_val = 1; - break; - - case SLANG_COMPLEX_TYPE: - u->data_type = SLANG_DOUBLE_TYPE; - case SLANG_DOUBLE_TYPE: - u->v.double_val = 1; - break; -#endif - default: - u->data_type = SLANG_INT_TYPE; - u->v.int_val = 1; - } - return 0; -} - - -/* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'. The code that - * has been generated is: X __args i A __aput-op - * where __aput-op represents this function. We need to generate: - * __args i A __eargs __aget X op __args i A __eargs __aput - * Here, __eargs implies a call to do_bc_call_direct_frame with either - * the aput or aget function. In addition, __args represents a call to - * SLang_start_arg_list. Of course, i represents a set of indices. - * - * Note: If op is an unary operation (e.g., ++ or --), then X will not - * b present an will have to be taken to be 1. - * - * Implementation note: For efficiency, calls to setup the frame, start - * arg list will be omitted and SLang_Num_Function_Args will be set. - * This is ugly but the alternative is much less efficient rendering these - * assignment operators useless. So, the plan is to roll the stack to get X, - * then duplicate the next N values, call __aget followed by op X, finally - * calling __aput. Hence, the sequence is: - * - * start: X i .. j A - * dupN: X i .. j A i .. j A - * __aget: X i .. j A Y - * roll: i .. j A Y X - * op: i .. j A Z - * roll: Z i .. j A - * __aput: - */ -static int -set_array_lvalue (int op) -{ - SLang_Object_Type x, y; - int num_args, is_unary; - - if (-1 == map_assignment_op_to_binary (op, &op, &is_unary)) - return -1; - - /* Grab the indices and the array. Do not start a new frame. */ - if (-1 == SLang_end_arg_list ()) - return -1; - num_args = Next_Function_Num_Args; - Next_Function_Num_Args = 0; - - if (-1 == SLdup_n (num_args)) - return -1; - - SLang_Num_Function_Args = num_args; - if (-1 == _SLarray_aget ()) - return -1; - - if (-1 == SLang_pop (&y)) - return -1; - - if (is_unary == 0) - { - if ((-1 == SLroll_stack (-(num_args + 1))) - || (-1 == SLang_pop (&x))) - { - SLang_free_object (&y); - return -1; - } - } - else if (-1 == make_unit_object (&y, &x)) - { - SLang_free_object (&y); - return -1; - } - - if (-1 == do_binary_ab (op, &y, &x)) - { - SLang_free_object (&y); - SLang_free_object (&x); - return -1; - } -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [y.data_type]) -#endif - SLang_free_object (&y); - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [x.data_type]) -#endif - SLang_free_object (&x); - - if (-1 == SLroll_stack (num_args + 1)) - return -1; - - SLang_Num_Function_Args = num_args; - return _SLarray_aput (); -} - - -static int -set_intrin_lvalue (SLBlock_Type *bc_blk) -{ - unsigned char op_type; - SLang_Object_Type obja; - SLang_Class_Type *cl; - SLang_Intrin_Var_Type *ivar; - VOID_STAR intrinsic_addr; - unsigned char intrinsic_type; - - ivar = bc_blk->b.nt_ivar_blk; - - intrinsic_type = ivar->type; - intrinsic_addr = ivar->addr; - - op_type = bc_blk->bc_sub_type; - - cl = _SLclass_get_class (intrinsic_type); - - if (op_type != _SLANG_BCST_ASSIGN) - { - /* We want to get the current value into obja. This is the - * easiest way. - */ - if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr)) - || (-1 == SLang_pop (&obja))) - return -1; - - (void) perform_lvalue_operation (op_type, &obja); - SLang_free_object (&obja); - - if (SLang_Error) - return -1; - } - - return (*cl->cl_pop) (intrinsic_type, intrinsic_addr); -} - -int _SLang_deref_assign (SLang_Ref_Type *ref) -{ - SLang_Object_Type *objp; - SLang_Name_Type *nt; - SLBlock_Type blk; - - if (ref->is_global == 0) - { - objp = ref->v.local_obj; - if (objp > Local_Variable_Frame) - { - SLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope"); - return -1; - } - return set_lvalue_obj (_SLANG_BCST_ASSIGN, objp); - } - - nt = ref->v.nt; - switch (nt->name_type) - { - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - if (-1 == set_lvalue_obj (_SLANG_BCST_ASSIGN, - &((SLang_Global_Var_Type *)nt)->obj)) - { - do_name_type_error (nt); - return -1; - } - break; - - case SLANG_IVARIABLE: - blk.b.nt_blk = nt; - blk.bc_sub_type = _SLANG_BCST_ASSIGN; - if (-1 == set_intrin_lvalue (&blk)) - { - do_name_type_error (nt); - return -1; - } - break; - - case SLANG_LVARIABLE: - SLang_Error = SL_INTERNAL_ERROR; - /* set_intrin_lvalue (&blk); */ - return -1; - - case SLANG_RVARIABLE: - default: - SLang_verror (SL_READONLY_ERROR, "deref assignment to %s not allowed", nt->name); - return -1; - } - - return 0; -} - -static void set_deref_lvalue (SLBlock_Type *bc_blk) -{ - SLang_Object_Type *objp; - SLang_Ref_Type *ref; - - switch (bc_blk->bc_sub_type) - { - case SLANG_LVARIABLE: - objp = (Local_Variable_Frame - bc_blk->b.i_blk); - break; - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - objp = &bc_blk->b.nt_gvar_blk->obj; - break; - default: - SLang_Error = SL_INTERNAL_ERROR; - return; - } - - if (-1 == _SLpush_slang_obj (objp)) - return; - - if (-1 == SLang_pop_ref (&ref)) - return; - (void) _SLang_deref_assign (ref); - SLang_free_ref (ref); -} - -static int push_struct_field (char *name) -{ - int type; - SLang_Class_Type *cl; - - if (-1 == (type = SLang_peek_at_stack ())) - return -1; - - cl = _SLclass_get_class ((unsigned char) type); - if (cl->cl_sget == NULL) - { - SLang_verror (SL_NOT_IMPLEMENTED, - "%s does not permit structure access", - cl->cl_name); - SLdo_pop_n (2); - return -1; - } - - return (*cl->cl_sget) ((unsigned char) type, name); -} - -static void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir) -{ - unsigned int len; - char prefix [52]; - - len = Trace_Mode - 1; - if (len + 2 >= sizeof (prefix)) - len = sizeof (prefix) - 2; - - SLMEMSET (prefix, ' ', len); - prefix[len] = 0; - - call_dump_routine (prefix); - call_dump_routine (format, name, n); - - if (n > 0) - { - prefix[len] = ' '; - len++; - prefix[len] = 0; - - _SLdump_objects (prefix, objs, n, dir); - } -} - -/* Pop a data item from the stack and return a pointer to it. - * Strings are not freed from stack so use another routine to do it. - */ -static VOID_STAR pop_pointer (SLang_Object_Type *obj, unsigned char type) -{ -#ifndef _SLANG_OPTIMIZE_FOR_SPEED - SLang_Class_Type *cl; -#endif - - SLang_Array_Type *at; - - /* Arrays are special. Allow scalars to automatically convert to arrays. - */ - if (type == SLANG_ARRAY_TYPE) - { - if (-1 == SLang_pop_array (&at, 1)) - return NULL; - obj->data_type = SLANG_ARRAY_TYPE; - return obj->v.ptr_val = (VOID_STAR) at; - } - - if (type == 0) - { - /* This happens when an intrinsic is declared without any information - * regarding parameter types. - */ - if (-1 == SLang_pop (obj)) - return NULL; - type = obj->data_type; - } - else if (-1 == _SLang_pop_object_of_type (type, obj, 0)) - return NULL; - -#if _SLANG_OPTIMIZE_FOR_SPEED - type = _SLclass_Class_Type [type]; -#else - type = _SLclass_get_class (type)->cl_class_type; -#endif - - if (type == SLANG_CLASS_TYPE_SCALAR) - return (VOID_STAR) &obj->v; - else if (type == SLANG_CLASS_TYPE_MMT) - return SLang_object_from_mmt (obj->v.ref); - else - return obj->v.ptr_val; -} - -/* This is ugly. Does anyone have a advice for a cleaner way of doing - * this?? - */ -typedef void (*VF0_Type)(void); -typedef void (*VF1_Type)(VOID_STAR); -typedef void (*VF2_Type)(VOID_STAR, VOID_STAR); -typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); -typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef long (*LF0_Type)(void); -typedef long (*LF1_Type)(VOID_STAR); -typedef long (*LF2_Type)(VOID_STAR, VOID_STAR); -typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); -typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -#if SLANG_HAS_FLOAT -typedef double (*FF0_Type)(void); -typedef double (*FF1_Type)(VOID_STAR); -typedef double (*FF2_Type)(VOID_STAR, VOID_STAR); -typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR); -typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR); -#endif - -static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf) -{ -#if SLANG_HAS_FLOAT - double xf; -#endif - VOID_STAR p[SLANG_MAX_INTRIN_ARGS]; - SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS]; - long ret; - unsigned char type; - unsigned int argc; - unsigned int i; - FVOID_STAR fptr; - unsigned char *arg_types; - int stk_depth; - - fptr = objf->i_fun; - argc = objf->num_args; - type = objf->return_type; - arg_types = objf->arg_types; - - if (argc > SLANG_MAX_INTRIN_ARGS) - { - SLang_verror(SL_APPLICATION_ERROR, - "Intrinsic function %s requires too many parameters", objf->name); - return -1; - } - - if (-1 == _SL_increment_frame_pointer ()) - return -1; - - stk_depth = -1; - if (Trace_Mode && (_SLang_Trace > 0)) - { - int nargs; - - stk_depth = _SLstack_depth (); - - nargs = SLang_Num_Function_Args; - if (nargs == 0) - nargs = (int)argc; - - stk_depth -= nargs; - - if (stk_depth >= 0) - trace_dump (">>%s (%d args)\n", - objf->name, - _SLStack_Pointer - nargs, - nargs, - 1); - } - - i = argc; - while (i != 0) - { - i--; - if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i]))) - { - i++; - goto free_and_return; - } - } - - ret = 0; -#if SLANG_HAS_FLOAT - xf = 0.0; -#endif - - switch (argc) - { - case 0: - if (type == SLANG_VOID_TYPE) ((VF0_Type) fptr) (); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)(); -#endif - else ret = ((LF0_Type) fptr)(); - break; - - case 1: - if (type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF1_Type) fptr)(p[0]); -#endif - else ret = ((LF1_Type) fptr)(p[0]); - break; - - case 2: - if (type == SLANG_VOID_TYPE) ((VF2_Type) fptr)(p[0], p[1]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]); -#endif - else ret = ((LF2_Type) fptr)(p[0], p[1]); - break; - - case 3: - if (type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]); -#endif - else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]); - break; - - case 4: - if (type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]); -#endif - else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]); - break; - - case 5: - if (type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); -#endif - else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]); - break; - - case 6: - if (type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); -#endif - else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]); - break; - - case 7: - if (type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); -#if SLANG_HAS_FLOAT - else if (type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); -#endif - else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]); - break; - } - - switch (type) - { - case SLANG_VOID_TYPE: - break; - -#if SLANG_HAS_FLOAT - case SLANG_DOUBLE_TYPE: - (void) SLang_push_double (xf); - break; -#endif - case SLANG_UINT_TYPE: - case SLANG_INT_TYPE: (void) SLclass_push_int_obj (type, (int) ret); - break; - - case SLANG_CHAR_TYPE: - case SLANG_UCHAR_TYPE: (void) SLclass_push_char_obj (type, (char) ret); - break; - - case SLANG_SHORT_TYPE: - case SLANG_USHORT_TYPE: (void) SLclass_push_short_obj (type, (short) ret); - break; - - case SLANG_LONG_TYPE: - case SLANG_ULONG_TYPE: (void) SLclass_push_long_obj (type, ret); - break; - - case SLANG_STRING_TYPE: - if (NULL == (char *)ret) - { - if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR; - } - else (void) SLang_push_string ((char *)ret); - break; - - default: - SLang_verror (SL_NOT_IMPLEMENTED, - "Support for intrinsic functions returning %s is not provided", - SLclass_get_datatype_name (type)); - } - - if (stk_depth >= 0) - { - stk_depth = _SLstack_depth () - stk_depth; - - trace_dump ("<<%s (returning %d values)\n", - objf->name, - _SLStack_Pointer - stk_depth, - stk_depth, - 1); - } - - free_and_return: - while (i < argc) - { - SLang_free_object (objs + i); - i++; - } - - return _SL_decrement_frame_pointer (); -} - -static int inner_interp(register SLBlock_Type *); - -/* Switch_Obj_Ptr points to the NEXT available free switch object */ -static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH]; -static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects; -static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH; - -static void -lang_do_loops (unsigned char stype, SLBlock_Type *block, unsigned int num_blocks) -{ - int i, ctrl; - int first, last; - SLBlock_Type *blks[4]; - char *loop_name; - SLang_Foreach_Context_Type *foreach_context; - SLang_Class_Type *cl; - int type; - unsigned int j; - - j = 0; - for (i = 0; i < (int) num_blocks; i++) - { - if (block[i].bc_main_type != _SLANG_BC_BLOCK) - { - if (block[i].bc_main_type == _SLANG_BC_LINE_NUM) - continue; - - SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block"); - return; - } - blks[j] = block[i].b.blk; - j++; - } - - num_blocks = j; - block = blks[0]; - - switch (stype) - { - case _SLANG_BCST_FOREACH: - loop_name = "foreach"; - if (num_blocks != 1) - goto wrong_num_blocks_error; - - /* We should find Next_Function_Num_Args + 1 items on the stack. - * The first Next_Function_Num_Args items represent the arguments to - * to USING. The last item (deepest in stack) is the object to loop - * over. So, roll the stack up and grab it. - */ - if ((-1 == SLroll_stack (-(Next_Function_Num_Args + 1))) - || (-1 == (type = SLang_peek_at_stack ()))) - goto return_error; - - cl = _SLclass_get_class ((unsigned char) type); - if ((cl->cl_foreach == NULL) - || (cl->cl_foreach_open == NULL) - || (cl->cl_foreach_close == NULL)) - { - SLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name); - SLdo_pop_n (Next_Function_Num_Args + 1); - goto return_error; - } - - if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, Next_Function_Num_Args))) - goto return_error; - - while (1) - { - int status; - - if (SLang_Error) - { - (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); - goto return_error; - } - - status = (*cl->cl_foreach) ((unsigned char) type, foreach_context); - if (status <= 0) - { - if (status == 0) - break; - - (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); - goto return_error; - } - - inner_interp (block); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - } - (*cl->cl_foreach_close) ((unsigned char) type, foreach_context); - break; - - case _SLANG_BCST_WHILE: - loop_name = "while"; - - if (num_blocks != 2) - goto wrong_num_blocks_error; - - type = blks[1]->bc_main_type; - while (1) - { - if (SLang_Error) - goto return_error; - - inner_interp (block); - if (Lang_Break) break; - - if (-1 == pop_ctrl_integer (&ctrl)) - goto return_error; - - if (ctrl == 0) break; - - if (type) - { - inner_interp (blks[1]); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - } - } - break; - - case _SLANG_BCST_DOWHILE: - loop_name = "do...while"; - - if (num_blocks != 2) - goto wrong_num_blocks_error; - - while (1) - { - if (SLang_Error) - goto return_error; - - Lang_Break_Condition = /* Lang_Continue = */ 0; - inner_interp (block); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - inner_interp (blks[1]); - if (-1 == pop_ctrl_integer (&ctrl)) - goto return_error; - - if (ctrl == 0) break; - } - break; - - case _SLANG_BCST_CFOR: - loop_name = "for"; - - /* we need 4 blocks: first 3 control, the last is code */ - if (num_blocks != 4) goto wrong_num_blocks_error; - - inner_interp (block); - while (1) - { - if (SLang_Error) - goto return_error; - - inner_interp(blks[1]); /* test */ - if (-1 == pop_ctrl_integer (&ctrl)) - goto return_error; - - if (ctrl == 0) break; - inner_interp(blks[3]); /* code */ - if (Lang_Break) break; - inner_interp(blks[2]); /* bump */ - Lang_Break_Condition = /* Lang_Continue = */ 0; - } - break; - - case _SLANG_BCST_FOR: - loop_name = "_for"; - - if (num_blocks != 1) - goto wrong_num_blocks_error; - - /* 3 elements: first, last, step */ - if ((-1 == SLang_pop_integer (&ctrl)) - || (-1 == SLang_pop_integer (&last)) - || (-1 == SLang_pop_integer (&first))) - goto return_error; - - i = first; - while (1) - { - /* It is ugly to have this test here but I do not know of a - * simple way to do this without using two while loops. - */ - if (ctrl >= 0) - { - if (i > last) break; - } - else if (i < last) break; - - if (SLang_Error) goto return_error; - - SLclass_push_int_obj (SLANG_INT_TYPE, i); - inner_interp (block); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - - i += ctrl; - } - break; - - case _SLANG_BCST_LOOP: - loop_name = "loop"; - if (num_blocks != 1) - goto wrong_num_blocks_error; - - if (-1 == SLang_pop_integer (&ctrl)) - goto return_error; - while (ctrl > 0) - { - ctrl--; - - if (SLang_Error) - goto return_error; - - inner_interp (block); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - } - break; - - case _SLANG_BCST_FOREVER: - loop_name = "forever"; - - if (num_blocks != 1) - goto wrong_num_blocks_error; - - while (1) - { - if (SLang_Error) - goto return_error; - - inner_interp (block); - if (Lang_Break) break; - Lang_Break_Condition = /* Lang_Continue = */ 0; - } - break; - - default: SLang_verror(SL_INTERNAL_ERROR, "Unknown loop type"); - return; - } - Lang_Break = /* Lang_Continue = */ 0; - Lang_Break_Condition = Lang_Return; - return; - - wrong_num_blocks_error: - SLang_verror (SL_SYNTAX_ERROR, "Wrong number of blocks for '%s' construct", loop_name); - - /* drop */ - return_error: - do_traceback (loop_name, 0, NULL); -} - -static void lang_do_and_orelse (unsigned char stype, SLBlock_Type *addr, SLBlock_Type *addr_max) -{ - int test = 0; - int is_or; - - is_or = (stype == _SLANG_BCST_ORELSE); - - while (addr <= addr_max) - { - if (addr->bc_main_type == _SLANG_BC_LINE_NUM) - { - addr++; - continue; - } - - inner_interp (addr->b.blk); - if (SLang_Error - || Lang_Break_Condition - || (-1 == pop_ctrl_integer (&test))) - return; - - if (is_or == (test != 0)) - break; - - /* if (((stype == _SLANG_BCST_ANDELSE) && (test == 0)) - * || ((stype == _SLANG_BCST_ORELSE) && test)) - * break; - */ - - addr++; - } - SLclass_push_int_obj (SLANG_INT_TYPE, test); -} - -static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block) -{ - int test; - - if (-1 == pop_ctrl_integer (&test)) - return; - - if (test == 0) - non_zero_block = zero_block; - - if (non_zero_block != NULL) - inner_interp (non_zero_block->b.blk); -} - -int _SLang_trace_fun (char *f) -{ - if (NULL == (f = SLang_create_slstring (f))) - return -1; - - SLang_free_slstring (Trace_Function); - Trace_Function = f; - _SLang_Trace = 1; - return 0; -} - -int _SLdump_objects (char *prefix, SLang_Object_Type *x, unsigned int n, int dir) -{ - char *s; - SLang_Class_Type *cl; - - while (n) - { - cl = _SLclass_get_class (x->data_type); - - if (NULL == (s = _SLstringize_object (x))) - s = "??"; - - call_dump_routine ("%s[%s]:%s\n", prefix, cl->cl_name, s); - - SLang_free_slstring (s); - - x += dir; - n--; - } - return 0; -} - -static SLBlock_Type *Exit_Block_Ptr; -static SLBlock_Type *Global_User_Block[5]; -static SLBlock_Type **User_Block_Ptr = Global_User_Block; -char *_SLang_Current_Function_Name = NULL; - -static int execute_slang_fun (_SLang_Function_Type *fun) -{ - register unsigned int i; - register SLang_Object_Type *frame, *lvf; - register unsigned int n_locals; - _SLBlock_Header_Type *header; - /* SLBlock_Type *val; */ - SLBlock_Type *exit_block_save; - SLBlock_Type **user_block_save; - SLBlock_Type *user_blocks[5]; - char *save_fname; - - exit_block_save = Exit_Block_Ptr; - user_block_save = User_Block_Ptr; - User_Block_Ptr = user_blocks; - *(user_blocks) = NULL; - *(user_blocks + 1) = NULL; - *(user_blocks + 2) = NULL; - *(user_blocks + 3) = NULL; - *(user_blocks + 4) = NULL; - - Exit_Block_Ptr = NULL; - - save_fname = _SLang_Current_Function_Name; - _SLang_Current_Function_Name = fun->name; - - _SL_increment_frame_pointer (); - - /* need loaded? */ - if (fun->nlocals == AUTOLOAD_NUM_LOCALS) - { - header = NULL; - if (-1 == SLang_load_file(fun->v.autoload_filename)) - goto the_return; - - if (fun->nlocals == AUTOLOAD_NUM_LOCALS) - { - SLang_verror (SL_UNDEFINED_NAME, "%s: Function did not autoload", - _SLang_Current_Function_Name); - goto the_return; - } - } - - n_locals = fun->nlocals; - - /* let the error propagate through since it will do no harm - and allow us to restore stack. */ - - /* set new stack frame */ - lvf = frame = Local_Variable_Frame; - i = n_locals; - if ((lvf + i) > Local_Variable_Stack + SLANG_MAX_LOCAL_STACK) - { - SLang_verror(SL_STACK_OVERFLOW, "%s: Local Variable Stack Overflow", - _SLang_Current_Function_Name); - goto the_return; - } - - /* Make sure we do not allow this header to get destroyed by something - * like: define crash () { eval ("define crash ();") } - */ - header = fun->v.header; - header->num_refs++; - - while (i--) - { - lvf++; - lvf->data_type = SLANG_UNDEFINED_TYPE; - } - Local_Variable_Frame = lvf; - - /* read values of function arguments */ - i = fun->nargs; - while (i > 0) - { - i--; - (void) SLang_pop (Local_Variable_Frame - i); - } - - if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(_SLang_Current_Function_Name); - - if (_SLang_Trace) - { - int stack_depth; - - stack_depth = _SLstack_depth (); - - if ((Trace_Function != NULL) - && (0 == strcmp (Trace_Function, _SLang_Current_Function_Name)) - && (Trace_Mode == 0)) - Trace_Mode = 1; - - if (Trace_Mode) - { - /* The local variable frame grows backwards */ - trace_dump (">>%s (%d args)\n", - _SLang_Current_Function_Name, - Local_Variable_Frame, - (int) fun->nargs, - -1); - Trace_Mode++; - } - - inner_interp (header->body); - Lang_Break_Condition = Lang_Return = Lang_Break = 0; - if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); - - if (Trace_Mode) - { - Trace_Mode--; - stack_depth = _SLstack_depth () - stack_depth; - - trace_dump ("<<%s (returning %d values)\n", - _SLang_Current_Function_Name, - _SLStack_Pointer - stack_depth, - stack_depth, - 1); - - if (Trace_Mode == 1) - Trace_Mode = 0; - } - } - else - { - inner_interp (header->body); - Lang_Break_Condition = Lang_Return = Lang_Break = 0; - if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); - } - - if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(_SLang_Current_Function_Name); - - if (SLang_Error) - do_traceback(fun->name, n_locals, -#if _SLANG_HAS_DEBUG_CODE - fun->file -#else - NULL -#endif - ); - - /* free local variables.... */ - lvf = Local_Variable_Frame; - while (lvf > frame) - { -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [lvf->data_type]) -#endif - SLang_free_object (lvf); - lvf--; - } - Local_Variable_Frame = lvf; - - if (header->num_refs == 1) - free_function_header (header); - else - header->num_refs--; - - the_return: - - Lang_Break_Condition = Lang_Return = Lang_Break = 0; - Exit_Block_Ptr = exit_block_save; - User_Block_Ptr = user_block_save; - _SLang_Current_Function_Name = save_fname; - _SL_decrement_frame_pointer (); - - if (SLang_Error) - return -1; - - return 0; -} - -static void do_traceback (char *name, unsigned int locals, char *file) -{ - char *s; - unsigned int i; - SLang_Object_Type *objp; - unsigned short stype; - - /* FIXME: Priority=low - * I need to make this configurable!!! That is, let the - * application decide whether or not a usage error should result in a - * traceback. - */ - if (SLang_Error == SL_USAGE_ERROR) - return; - - if (SLang_Traceback == 0) - return; - - call_dump_routine ("S-Lang Traceback: %s\n", name); - if (SLang_Traceback < 0) - return; - - if (file != NULL) - call_dump_routine ("File: %s\n", file); - - if (locals == 0) - return; - - call_dump_routine (" Local Variables:\n"); - - for (i = 0; i < locals; i++) - { - SLang_Class_Type *cl; - char *class_name; - - objp = Local_Variable_Frame - i; - stype = objp->data_type; - - s = _SLstringize_object (objp); - cl = _SLclass_get_class (stype); - class_name = cl->cl_name; - - call_dump_routine ("\t$%d: Type: %s,\tValue:\t", i, class_name); - - if (s == NULL) call_dump_routine("??\n"); - else - { - char *q = ""; -#ifndef HAVE_VSNPRINTF - char buf[256]; - if (strlen (s) >= sizeof (buf)) - { - strncpy (buf, s, sizeof(buf)); - s = buf; - s[sizeof(buf) - 1] = 0; - } -#endif - if (SLANG_STRING_TYPE == stype) q = "\""; - call_dump_routine ("%s%s%s\n", q, s, q); - } - } -} - -static void do_app_unary (SLang_App_Unary_Type *nt) -{ - if (-1 == do_unary (nt->unary_op, nt->name_type)) - do_traceback (nt->name, 0, NULL); -} - -static int inner_interp_nametype (SLang_Name_Type *nt) -{ - SLBlock_Type bc_blks[2]; - - bc_blks[0].b.nt_blk = nt; - bc_blks[0].bc_main_type = nt->name_type; - bc_blks[1].bc_main_type = 0; - return inner_interp(bc_blks); -} - -int _SLang_dereference_ref (SLang_Ref_Type *ref) -{ - if (ref == NULL) - { - SLang_Error = SL_INTERNAL_ERROR; - return -1; - } - - if (ref->is_global == 0) - { - SLang_Object_Type *obj = ref->v.local_obj; - if (obj > Local_Variable_Frame) - { - SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); - return -1; - } - return _SLpush_slang_obj (ref->v.local_obj); - } - - (void) inner_interp_nametype (ref->v.nt); - return 0; -} - -int _SLang_is_ref_initialized (SLang_Ref_Type *ref) -{ - unsigned char type; - - if (ref == NULL) - { - SLang_Error = SL_INTERNAL_ERROR; - return -1; - } - - if (ref->is_global == 0) - { - SLang_Object_Type *obj = ref->v.local_obj; - if (obj > Local_Variable_Frame) - { - SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); - return -1; - } - type = ref->v.local_obj->data_type; - } - else - { - SLang_Name_Type *nt = ref->v.nt; - if ((nt->name_type != SLANG_GVARIABLE) - && (nt->name_type != SLANG_PVARIABLE)) - return 1; - type = ((SLang_Global_Var_Type *)nt)->obj.data_type; - } - return type != SLANG_UNDEFINED_TYPE; -} - -int _SLang_uninitialize_ref (SLang_Ref_Type *ref) -{ - SLang_Object_Type *obj; - - if (ref == NULL) - { - SLang_Error = SL_INTERNAL_ERROR; - return -1; - } - - if (ref->is_global == 0) - { - obj = ref->v.local_obj; - if (obj > Local_Variable_Frame) - { - SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope"); - return -1; - } - obj = ref->v.local_obj; - } - else - { - SLang_Name_Type *nt = ref->v.nt; - if ((nt->name_type != SLANG_GVARIABLE) - && (nt->name_type != SLANG_PVARIABLE)) - return -1; - obj = &((SLang_Global_Var_Type *)nt)->obj; - } - SLang_free_object (obj); - obj->data_type = SLANG_UNDEFINED_TYPE; - obj->v.ptr_val = NULL; - return 0; -} - -void (*SLang_Interrupt)(void); -static int Last_Error; -void (*SLang_User_Clear_Error)(void); -void _SLang_clear_error (void) -{ - if (Last_Error <= 0) - { - Last_Error = 0; - return; - } - Last_Error--; - if (SLang_User_Clear_Error != NULL) (*SLang_User_Clear_Error)(); -} - -int _SLpush_slang_obj (SLang_Object_Type *obj) -{ - unsigned char subtype; - SLang_Class_Type *cl; - - if (obj == NULL) return SLang_push_null (); - - subtype = obj->data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype]) - return SLang_push (obj); -#endif - - cl = _SLclass_get_class (subtype); - return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); -} - -_INLINE_ -static int push_local_variable (int i) -{ - SLang_Class_Type *cl; - SLang_Object_Type *obj; - unsigned char subtype; - - obj = Local_Variable_Frame - i; - subtype = obj->data_type; - -#if _SLANG_OPTIMIZE_FOR_SPEED - if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype]) - return SLang_push (obj); - if (subtype == SLANG_STRING_TYPE) - return _SLang_dup_and_push_slstring (obj->v.s_val); -#endif - - cl = _SLclass_get_class (subtype); - return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v); -} - -static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar) -{ - SLang_Class_Type *cl; - unsigned char stype; - - stype = ivar->type; - cl = _SLclass_get_class (stype); - - if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr)) - { - do_name_type_error ((SLang_Name_Type *) ivar); - return -1; - } - return 0; -} - -static int dereference_object (void) -{ - SLang_Object_Type obj; - SLang_Class_Type *cl; - unsigned char type; - int ret; - - if (-1 == SLang_pop (&obj)) - return -1; - - type = obj.data_type; - - cl = _SLclass_get_class (type); - ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v); - - SLang_free_object (&obj); - return ret; -} - -static int case_function (void) -{ - unsigned char type; - SLang_Object_Type obj; - SLang_Object_Type *swobjptr; - - swobjptr = Switch_Obj_Ptr - 1; - - if ((swobjptr < Switch_Objects) - || (0 == (type = swobjptr->data_type))) - { - SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword"); - return -1; - } - - if (-1 == SLang_pop (&obj)) - return -1; - - if (obj.data_type != type) - { - SLang_Class_Type *a_cl, *b_cl; - - a_cl = _SLclass_get_class (obj.data_type); - b_cl = _SLclass_get_class (type); - - if (NULL == _SLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &a_cl, 0)) - { - (void) SLclass_push_int_obj (SLANG_INT_TYPE, 0); - SLang_free_object (&obj); - return 0; - } - } - - (void) do_binary_ab (SLANG_EQ, swobjptr, &obj); - SLang_free_object (&obj); - return 0; -} - -static void tmp_variable_function (SLBlock_Type *addr) -{ - SLang_Object_Type *obj; - - switch (addr->bc_sub_type) - { - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - obj = &addr->b.nt_gvar_blk->obj; - break; - - case SLANG_LVARIABLE: - obj = Local_Variable_Frame - addr->b.i_blk; - break; - - default: - SLang_Error = SL_INTERNAL_ERROR; - return; - } - - /* There is no need to go through higher level routines since we are - * not creating or destroying extra copies. - */ - if (-1 == SLang_push (obj)) - return; - - obj->data_type = SLANG_UNDEFINED_TYPE; - obj->v.ptr_val = NULL; -} - - -static int -do_inner_interp_error (SLBlock_Type *err_block, - SLBlock_Type *addr_start, - SLBlock_Type *addr) -{ - int save_err, slerr; - - /* Someday I can use the these variable to provide extra information - * about what went wrong. - */ - (void) addr_start; - (void) addr; - - if (err_block == NULL) - goto return_error; - - if (SLang_Error < 0) /* errors less than 0 are severe */ - goto return_error; - - save_err = Last_Error++; - slerr = SLang_Error; - SLang_Error = 0; - inner_interp (err_block->b.blk); - - if (Last_Error <= save_err) - { - /* Caught error and cleared it */ - Last_Error = save_err; - if ((Lang_Break_Condition == 0) - /* An error may have cleared the error and then caused the - * function to return. We will allow that but let's not allow - * 'break' nor 'continue' statements until later. - */ - || Lang_Return) - return 0; - - /* drop--- either a break or continue was called */ - } - - Last_Error = save_err; - SLang_Error = slerr; - - return_error: -#if _SLANG_HAS_DEBUG_CODE - while (addr >= addr_start) - { - if (addr->bc_main_type == _SLANG_BC_LINE_NUM) - { - char buf[256]; - sprintf (buf, "(Error occurred on line %lu)", addr->b.l_blk); - do_traceback (buf, 0, NULL); - break; - } - /* Special hack for 16 bit systems to prevent pointer wrapping. */ -#if defined(__16_BIT_SYSTEM__) - if (addr == addr_start) - break; -#endif - addr--; - } -#endif - return -1; -} - - -#define GATHER_STATISTICS 0 -#if GATHER_STATISTICS -static unsigned int Bytecodes[0xFFFF]; - -static void print_stats (void) -{ - unsigned int i; - unsigned long total; - FILE *fp = fopen ("stats.txt", "w"); - if (fp == NULL) - return; - - total = 0; - for (i = 0; i < 0xFFFF; i++) - total += Bytecodes[i]; - - if (total == 0) - total = 1; - - for (i = 0; i < 0xFFFF; i++) - { - if (Bytecodes[i]) - fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total); - } - fclose (fp); -} - -static void add_to_statistics (SLBlock_Type *b) -{ - unsigned short x, y; - - x = b->bc_main_type; - if (x == 0) - { - Bytecodes[0] += 1; - return; - } - b++; - y = b->bc_main_type; - - Bytecodes[(x << 8) | y] += 1; -} - -#endif - -/* inner interpreter */ -/* The return value from this function is only meaningful when it is used - * to process blocks for the switch statement. If it returns 0, the calling - * routine should pass the next block to it. Otherwise it will - * return non-zero, with or without error. - */ -static int inner_interp (SLBlock_Type *addr_start) -{ - SLBlock_Type *block, *err_block, *addr; -#if GATHER_STATISTICS - static int inited = 0; - - if (inited == 0) - { - (void) SLang_add_cleanup_function (print_stats); - inited = 1; - } -#endif - - /* for systems that have no real interrupt facility (e.g. go32 on dos) */ - if (SLang_Interrupt != NULL) (*SLang_Interrupt)(); - - block = err_block = NULL; - addr = addr_start; - -#if GATHER_STATISTICS - add_to_statistics (addr); -#endif - while (1) - { - switch (addr->bc_main_type) - { - case 0: - return 1; - case _SLANG_BC_LVARIABLE: - push_local_variable (addr->b.i_blk); - break; - case _SLANG_BC_GVARIABLE: - if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) - do_name_type_error (addr->b.nt_blk); - break; - - case _SLANG_BC_IVARIABLE: - case _SLANG_BC_RVARIABLE: - push_intrinsic_variable (addr->b.nt_ivar_blk); - break; - - case _SLANG_BC_INTRINSIC: - execute_intrinsic_fun (addr->b.nt_ifun_blk); - if (SLang_Error) - do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); - break; - - case _SLANG_BC_FUNCTION: - execute_slang_fun (addr->b.nt_fun_blk); - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_MATH_UNARY: - case _SLANG_BC_APP_UNARY: - /* Make sure we treat these like function calls since the - * parser took sin(x) to be a function call. - */ - if (0 == _SL_increment_frame_pointer ()) - { - do_app_unary (addr->b.nt_unary_blk); - (void) _SL_decrement_frame_pointer (); - } - break; - - case _SLANG_BC_ICONST: - SLclass_push_int_obj (SLANG_INT_TYPE, addr->b.iconst_blk->i); - break; - -#if SLANG_HAS_FLOAT - case _SLANG_BC_DCONST: - SLang_push_double (addr->b.dconst_blk->d); - break; -#endif - - case _SLANG_BC_PVARIABLE: - if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj)) - do_name_type_error (addr->b.nt_blk); - break; - - case _SLANG_BC_PFUNCTION: - execute_slang_fun (addr->b.nt_fun_blk); - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_BINARY: - do_binary (addr->b.i_blk); - break; - - case _SLANG_BC_LITERAL: -#if !_SLANG_OPTIMIZE_FOR_SPEED - case _SLANG_BC_LITERAL_INT: - case _SLANG_BC_LITERAL_STR: -#endif - { - SLang_Class_Type *cl = _SLclass_get_class (addr->bc_sub_type); - (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk); - } - break; -#if _SLANG_OPTIMIZE_FOR_SPEED - case _SLANG_BC_LITERAL_INT: - SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); - break; - - case _SLANG_BC_LITERAL_STR: - _SLang_dup_and_push_slstring (addr->b.s_blk); - break; -#endif - case _SLANG_BC_BLOCK: - switch (addr->bc_sub_type) - { - case _SLANG_BCST_ERROR_BLOCK: - err_block = addr; - break; - - case _SLANG_BCST_EXIT_BLOCK: - Exit_Block_Ptr = addr->b.blk; - break; - - case _SLANG_BCST_USER_BLOCK0: - case _SLANG_BCST_USER_BLOCK1: - case _SLANG_BCST_USER_BLOCK2: - case _SLANG_BCST_USER_BLOCK3: - case _SLANG_BCST_USER_BLOCK4: - User_Block_Ptr[addr->bc_sub_type - _SLANG_BCST_USER_BLOCK0] = addr->b.blk; - break; - - case _SLANG_BCST_LOOP: - case _SLANG_BCST_WHILE: - case _SLANG_BCST_FOR: - case _SLANG_BCST_FOREVER: - case _SLANG_BCST_CFOR: - case _SLANG_BCST_DOWHILE: - case _SLANG_BCST_FOREACH: - if (block == NULL) block = addr; - lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block)); - block = NULL; - break; - - case _SLANG_BCST_IFNOT: -#if _SLANG_OPTIMIZE_FOR_SPEED - { - int i; - - if ((0 == pop_ctrl_integer (&i)) && (i == 0)) - inner_interp (addr->b.blk); - } -#else - do_else_if (addr, NULL); -#endif - break; - - case _SLANG_BCST_IF: -#if _SLANG_OPTIMIZE_FOR_SPEED - { - int i; - - if ((0 == pop_ctrl_integer (&i)) && i) - inner_interp (addr->b.blk); - } -#else - do_else_if (NULL, addr); -#endif - break; - - case _SLANG_BCST_NOTELSE: - do_else_if (block, addr); - block = NULL; - break; - - case _SLANG_BCST_ELSE: - do_else_if (addr, block); - block = NULL; - break; - - case _SLANG_BCST_SWITCH: - if (Switch_Obj_Ptr == Switch_Obj_Max) - { - SLang_doerror("switch nesting too deep"); - break; - } - (void) SLang_pop (Switch_Obj_Ptr); - Switch_Obj_Ptr++; - - if (block == NULL) block = addr; - while ((SLang_Error == 0) - && (block <= addr) - && (Lang_Break_Condition == 0) - && (0 == inner_interp (block->b.blk))) - block++; - Switch_Obj_Ptr--; - SLang_free_object (Switch_Obj_Ptr); - Switch_Obj_Ptr->data_type = 0; - block = NULL; - break; - - case _SLANG_BCST_ANDELSE: - case _SLANG_BCST_ORELSE: - if (block == NULL) block = addr; - lang_do_and_orelse (addr->bc_sub_type, block, addr); - block = NULL; - break; - - default: - if (block == NULL) block = addr; - break; - } - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_RETURN: - Lang_Break_Condition = Lang_Return = Lang_Break = 1; return 1; - case _SLANG_BC_BREAK: - Lang_Break_Condition = Lang_Break = 1; return 1; - case _SLANG_BC_CONTINUE: - Lang_Break_Condition = /* Lang_Continue = */ 1; return 1; - - case _SLANG_BC_EXCH: - (void) SLreverse_stack (2); - break; - - case _SLANG_BC_LABEL: - { - int test; - if ((0 == SLang_pop_integer (&test)) - && (test == 0)) - return 0; - } - break; - - case _SLANG_BC_LOBJPTR: - (void)_SLang_push_ref (0, (VOID_STAR)(Local_Variable_Frame - addr->b.i_blk)); - break; - - case _SLANG_BC_GOBJPTR: - (void)_SLang_push_ref (1, (VOID_STAR)addr->b.nt_blk); - break; - - case _SLANG_BC_X_ERROR: - if (err_block != NULL) - { - inner_interp(err_block->b.blk); - if (SLang_Error) err_block = NULL; - } - else SLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK"); - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_X_USER0: - case _SLANG_BC_X_USER1: - case _SLANG_BC_X_USER2: - case _SLANG_BC_X_USER3: - case _SLANG_BC_X_USER4: - if (User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0] != NULL) - { - inner_interp(User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0]); - } - else SLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK"); - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_CALL_DIRECT: - (*addr->b.call_function) (); - break; - - case _SLANG_BC_CALL_DIRECT_FRAME: - do_bc_call_direct_frame (addr->b.call_function); - break; - - case _SLANG_BC_UNARY: - do_unary (addr->b.i_blk, _SLANG_BC_UNARY); - break; - - case _SLANG_BC_UNARY_FUNC: - /* Make sure we treat these like function calls since the - * parser took abs(x) to be a function call. - */ - if (0 == _SL_increment_frame_pointer ()) - { - do_unary (addr->b.i_blk, _SLANG_BC_UNARY); - (void) _SL_decrement_frame_pointer (); - } - break; - - case _SLANG_BC_DEREF_ASSIGN: - set_deref_lvalue (addr); - break; - case _SLANG_BC_SET_LOCAL_LVALUE: - set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk); - break; - case _SLANG_BC_SET_GLOBAL_LVALUE: - if (-1 == set_lvalue_obj (addr->bc_sub_type, &addr->b.nt_gvar_blk->obj)) - do_name_type_error (addr->b.nt_blk); - break; - case _SLANG_BC_SET_INTRIN_LVALUE: - set_intrin_lvalue (addr); - break; - case _SLANG_BC_SET_STRUCT_LVALUE: - set_struct_lvalue (addr); - break; - - case _SLANG_BC_FIELD: - (void) push_struct_field (addr->b.s_blk); - break; - - case _SLANG_BC_SET_ARRAY_LVALUE: - set_array_lvalue (addr->bc_sub_type); - break; - -#if _SLANG_HAS_DEBUG_CODE - case _SLANG_BC_LINE_NUM: - break; -#endif - - case _SLANG_BC_TMP: - tmp_variable_function (addr); - break; - -#if _SLANG_OPTIMIZE_FOR_SPEED - case _SLANG_BC_LVARIABLE_AGET: - if (0 == push_local_variable (addr->b.i_blk)) - do_bc_call_direct_frame (_SLarray_aget); - break; - - case _SLANG_BC_LVARIABLE_APUT: - if (0 == push_local_variable (addr->b.i_blk)) - do_bc_call_direct_frame (_SLarray_aput); - break; - case _SLANG_BC_INTEGER_PLUS: - if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) - do_binary (SLANG_PLUS); - break; - - case _SLANG_BC_INTEGER_MINUS: - if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk)) - do_binary (SLANG_MINUS); - break; -#endif -#if 0 - case _SLANG_BC_ARG_LVARIABLE: - (void) SLang_start_arg_list (); - push_local_variable (addr->b.i_blk); - break; -#endif - case _SLANG_BC_EARG_LVARIABLE: - push_local_variable (addr->b.i_blk); - (void) SLang_end_arg_list (); - break; - -#if USE_COMBINED_BYTECODES - case _SLANG_BC_CALL_DIRECT_INTRINSIC: - (*addr->b.call_function) (); - addr++; - execute_intrinsic_fun (addr->b.nt_ifun_blk); - if (SLang_Error) - do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); - break; - - case _SLANG_BC_INTRINSIC_CALL_DIRECT: - execute_intrinsic_fun (addr->b.nt_ifun_blk); - if (SLang_Error) - { - do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); - break; - } - addr++; - (*addr->b.call_function) (); - break; - - case _SLANG_BC_CALL_DIRECT_LSTR: - (*addr->b.call_function) (); - addr++; - _SLang_dup_and_push_slstring (addr->b.s_blk); - break; - - case _SLANG_BC_CALL_DIRECT_SLFUN: - (*addr->b.call_function) (); - addr++; - execute_slang_fun (addr->b.nt_fun_blk); - if (Lang_Break_Condition) goto handle_break_condition; - break; - - case _SLANG_BC_CALL_DIRECT_INTRSTOP: - (*addr->b.call_function) (); - addr++; - /* drop */ - case _SLANG_BC_INTRINSIC_STOP: - execute_intrinsic_fun (addr->b.nt_ifun_blk); - if (SLang_Error == 0) - return 1; - do_traceback(addr->b.nt_ifun_blk->name, 0, NULL); - break; - - case _SLANG_BC_CALL_DIRECT_EARG_LVAR: - (*addr->b.call_function) (); - addr++; - push_local_variable (addr->b.i_blk); - (void) SLang_end_arg_list (); - break; - - case _SLANG_BC_CALL_DIRECT_LINT: - (*addr->b.call_function) (); - addr++; - SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk); - break; - - case _SLANG_BC_CALL_DIRECT_LVAR: - (*addr->b.call_function) (); - addr++; - push_local_variable (addr->b.i_blk); - break; -#endif /* USE_COMBINED_BYTECODES */ - - default: - SLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type); - } - - /* Someday I plan to add a 'signal' intrinsic function. Then when a - * signal is caught, a variable will be set to one and that value of - * that variable will need to be monitored here, e.g., - * if (Handle_Signal) handle_signal (); - * It would be nice to check only one variable instead of Handle_Signal - * and SLang_Error. Perhaps I should phase out SLang_Error = xxx - * and used something like: SLang_set_error (code); Then, I could - * use: - * if (Handle_Condition) - * { - * Handle_Condition = 0; - * if (SLang_Error) .... - * else if (Handle_Signal) handle_signal (); - * else.... - * } - */ - if (SLang_Error) - { - if (-1 == do_inner_interp_error (err_block, addr_start, addr)) - return 1; - if (SLang_Error) - return 1; - - /* Otherwise, error cleared. Continue onto next bytecode. - * Someday I need to add something to indicate where the - * next statement begins since continuing on the next - * bytecode is not really what is desired. - */ - if (Lang_Break_Condition) goto handle_break_condition; - } - addr++; - } - - handle_break_condition: - /* Get here if Lang_Break_Condition != 0, which implies that either - * Lang_Return, Lang_Break, or Lang_Continue is non zero - */ - if (Lang_Return) - Lang_Break = 1; - - return 1; -} - -/*}}}*/ - -/* The functions below this point are used to implement the parsed token - * to byte-compiled code. - */ -/* static SLang_Name_Type **Static_Hash_Table; */ - -static SLang_Name_Type **Locals_Hash_Table; -static int Local_Variable_Number; -static unsigned int Function_Args_Number; -int _SLang_Auto_Declare_Globals = 0; -int (*SLang_Auto_Declare_Var_Hook) (char *); - -static SLang_NameSpace_Type *This_Static_NameSpace; -static SLang_NameSpace_Type *Global_NameSpace; - -#if _SLANG_HAS_DEBUG_CODE -static char *This_Compile_Filename; -#endif -static SLBlock_Type SLShort_Blocks[6]; -/* These are initialized in add_table below. I cannot init a Union!! */ - -static int Lang_Defining_Function; -static void (*Default_Variable_Mode) (_SLang_Token_Type *); -static void (*Default_Define_Function) (char *, unsigned long); - -static int push_compile_context (char *); -static int pop_compile_context (void); - -typedef struct -{ - int block_type; - SLBlock_Type *block; /* beginning of block definition */ - SLBlock_Type *block_ptr; /* current location */ - SLBlock_Type *block_max; /* end of definition */ - SLang_NameSpace_Type *static_namespace; -} -Block_Context_Type; - -static Block_Context_Type Block_Context_Stack [SLANG_MAX_BLOCK_STACK_LEN]; -static unsigned int Block_Context_Stack_Len; - -static SLBlock_Type *Compile_ByteCode_Ptr; -static SLBlock_Type *This_Compile_Block; -static SLBlock_Type *This_Compile_Block_Max; -static int This_Compile_Block_Type; -#define COMPILE_BLOCK_TYPE_FUNCTION 1 -#define COMPILE_BLOCK_TYPE_BLOCK 2 -#define COMPILE_BLOCK_TYPE_TOP_LEVEL 3 - -/* If it returns 0, DO NOT FREE p */ -static int lang_free_branch (SLBlock_Type *p) -{ - /* Note: we look at 0,2,4, since these blocks are 0 terminated */ - if ((p == SLShort_Blocks) - || (p == SLShort_Blocks + 2) - || (p == SLShort_Blocks + 4) - ) - return 0; - - while (1) - { - SLang_Class_Type *cl; - - switch (p->bc_main_type) - { - case _SLANG_BC_BLOCK: - if (lang_free_branch(p->b.blk)) - SLfree((char *)p->b.blk); - break; - - case _SLANG_BC_LITERAL: - case _SLANG_BC_LITERAL_STR: - /* No user types should be here. */ - cl = _SLclass_get_class (p->bc_sub_type); - (*cl->cl_byte_code_destroy) (p->bc_sub_type, (VOID_STAR) &p->b.ptr_blk); - break; - - case _SLANG_BC_FIELD: - case _SLANG_BC_SET_STRUCT_LVALUE: - SLang_free_slstring (p->b.s_blk); - break; - - default: - break; - - case 0: - return 1; - } - p++; - } -} - -static void free_function_header (_SLBlock_Header_Type *h) -{ - if (h->num_refs > 1) - { - h->num_refs--; - return; - } - - if (h->body != NULL) - { - if (lang_free_branch (h->body)) - SLfree ((char *) h->body); - } - - SLfree ((char *) h); -} - -static int push_block_context (int type) -{ - Block_Context_Type *c; - unsigned int num; - SLBlock_Type *b; - - if (Block_Context_Stack_Len == SLANG_MAX_BLOCK_STACK_LEN) - { - SLang_verror (SL_STACK_OVERFLOW, "Block stack overflow"); - return -1; - } - - num = 5; /* 40 bytes */ - if (NULL == (b = (SLBlock_Type *) SLcalloc (num, sizeof (SLBlock_Type)))) - return -1; - - c = Block_Context_Stack + Block_Context_Stack_Len; - c->block = This_Compile_Block; - c->block_ptr = Compile_ByteCode_Ptr; - c->block_max = This_Compile_Block_Max; - c->block_type = This_Compile_Block_Type; - c->static_namespace = This_Static_NameSpace; - - Compile_ByteCode_Ptr = This_Compile_Block = b; - This_Compile_Block_Max = b + num; - This_Compile_Block_Type = type; - - Block_Context_Stack_Len += 1; - return 0; -} - -static int pop_block_context (void) -{ - Block_Context_Type *c; - - if (Block_Context_Stack_Len == 0) - return -1; - - Block_Context_Stack_Len -= 1; - c = Block_Context_Stack + Block_Context_Stack_Len; - - This_Compile_Block = c->block; - This_Compile_Block_Max = c->block_max; - This_Compile_Block_Type = c->block_type; - Compile_ByteCode_Ptr = c->block_ptr; - This_Static_NameSpace = c->static_namespace; - - return 0; -} - -int _SLcompile_push_context (SLang_Load_Type *load_object) -{ - if (-1 == push_compile_context (load_object->name)) - return -1; - - if (NULL == (This_Static_NameSpace = _SLns_allocate_namespace (load_object->name, SLSTATIC_HASH_TABLE_SIZE))) - { - pop_compile_context (); - return -1; - } - - if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL)) - { - pop_compile_context (); - return -1; - } - - return 0; -} - -int _SLcompile_pop_context (void) -{ - if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - Compile_ByteCode_Ptr->bc_main_type = 0; - if (lang_free_branch (This_Compile_Block)) - SLfree ((char *) This_Compile_Block); - } - - (void) pop_block_context (); - (void) pop_compile_context (); - - if (This_Compile_Block == NULL) - return 0; - -#if 0 - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); - return -1; - } -#endif - - return 0; -} - -/*{{{ Hash and Name Table Functions */ - -static SLang_Name_Type *locate_name_in_table (char *name, unsigned long hash, - SLang_Name_Type **table, unsigned int table_size) -{ - SLang_Name_Type *t; - char ch; - - t = table [(unsigned int) (hash % table_size)]; - ch = *name++; - - while (t != NULL) - { - if ((ch == t->name[0]) - && (0 == strcmp (t->name + 1, name))) - break; - - t = t->next; - } - - return t; -} - -static SLang_Name_Type *locate_namespace_encoded_name (char *name, int err_on_bad_ns) -{ - char *ns, *ns1; - SLang_NameSpace_Type *table; - SLang_Name_Type *nt; - - ns = name; - name = strchr (name, '-'); - if ((name == NULL) || (name [1] != '>')) - name = ns; - - ns1 = SLang_create_nslstring (ns, (unsigned int) (name - ns)); - if (ns1 == NULL) - return NULL; - if (ns != name) - name += 2; - ns = ns1; - - if (*ns == 0) - { - /* Use Global Namespace */ - SLang_free_slstring (ns); - return locate_name_in_table (name, _SLcompute_string_hash (name), - Global_NameSpace->table, Global_NameSpace->table_size); - } - - if (NULL == (table = _SLns_find_namespace (ns))) - { - if (err_on_bad_ns) - SLang_verror (SL_SYNTAX_ERROR, "Unable to find namespace called %s", ns); - SLang_free_slstring (ns); - return NULL; - } - SLang_free_slstring (ns); - - /* FIXME: the hash table size should be stored in the hash table itself */ - nt = locate_name_in_table (name, _SLcompute_string_hash (name), - table->table, table->table_size); - if (nt == NULL) - return NULL; - - switch (nt->name_type) - { - /* These are private and cannot be accessed through the namespace. */ - case SLANG_PVARIABLE: - case SLANG_PFUNCTION: - return NULL; - } - return nt; -} - -static SLang_Name_Type *locate_hashed_name (char *name, unsigned long hash) -{ - SLang_Name_Type *t; - - if (Lang_Defining_Function) - { - t = locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE); - if (t != NULL) - return t; - } - - if ((This_Static_NameSpace != NULL) - && (NULL != (t = locate_name_in_table (name, hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size)))) - return t; - - t = locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); - if (NULL != t) - return t; - - return locate_namespace_encoded_name (name, 1); -} - -SLang_Name_Type *_SLlocate_name (char *name) -{ - return locate_hashed_name (name, _SLcompute_string_hash (name)); -} - -static SLang_Name_Type * -add_name_to_hash_table (char *name, unsigned long hash, - unsigned int sizeof_obj, unsigned char name_type, - SLang_Name_Type **table, unsigned int table_size, - int check_existing) -{ - SLang_Name_Type *t; - - if (check_existing) - { - t = locate_name_in_table (name, hash, table, table_size); - if (t != NULL) - return t; - } - - if (-1 == _SLcheck_identifier_syntax (name)) - return NULL; - - t = (SLang_Name_Type *) SLmalloc (sizeof_obj); - if (t == NULL) - return t; - - memset ((char *) t, 0, sizeof_obj); - if (NULL == (t->name = _SLstring_dup_hashed_string (name, hash))) - { - SLfree ((char *) t); - return NULL; - } - t->name_type = name_type; - - hash = hash % table_size; - t->next = table [(unsigned int)hash]; - table [(unsigned int) hash] = t; - - return t; -} - -static SLang_Name_Type * -add_global_name (char *name, unsigned long hash, - unsigned char name_type, unsigned int sizeof_obj, - SLang_NameSpace_Type *ns) -{ - SLang_Name_Type *nt; - SLang_Name_Type **table; - unsigned int table_size; - - table = ns->table; - table_size = ns->table_size; - - nt = locate_name_in_table (name, hash, table, table_size); - if (nt != NULL) - { - if (nt->name_type == name_type) - return nt; - - SLang_verror (SL_DUPLICATE_DEFINITION, "%s cannot be re-defined", name); - return NULL; - } - - return add_name_to_hash_table (name, hash, sizeof_obj, name_type, - table, table_size, 0); -} - -static int add_intrinsic_function (SLang_NameSpace_Type *ns, - char *name, FVOID_STAR addr, unsigned char ret_type, - unsigned int nargs, va_list ap) -{ - SLang_Intrin_Fun_Type *f; - unsigned int i; - - if (-1 == init_interpreter ()) - return -1; - - if (ns == NULL) ns = Global_NameSpace; - - if (nargs > SLANG_MAX_INTRIN_ARGS) - { - SLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name); - return -1; - } - - if (ret_type == SLANG_FLOAT_TYPE) - { - SLang_verror (SL_NOT_IMPLEMENTED, "Function %s is not permitted to return float", name); - return -1; - } - - f = (SLang_Intrin_Fun_Type *) add_global_name (name, _SLcompute_string_hash (name), - SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type), - ns); - - if (f == NULL) - return -1; - - f->i_fun = addr; - f->num_args = nargs; - f->return_type = ret_type; - - for (i = 0; i < nargs; i++) - f->arg_types [i] = va_arg (ap, unsigned int); - - return 0; -} - -int SLadd_intrinsic_function (char *name, FVOID_STAR addr, unsigned char ret_type, - unsigned int nargs, ...) -{ - va_list ap; - int status; - - va_start (ap, nargs); - status = add_intrinsic_function (NULL, name, addr, ret_type, nargs, ap); - va_end (ap); - - return status; -} - -int SLns_add_intrinsic_function (SLang_NameSpace_Type *ns, - char *name, FVOID_STAR addr, unsigned char ret_type, - unsigned int nargs, ...) -{ - va_list ap; - int status; - - va_start (ap, nargs); - status = add_intrinsic_function (ns, name, addr, ret_type, nargs, ap); - va_end (ap); - - return status; -} - -int SLns_add_intrinsic_variable (SLang_NameSpace_Type *ns, - char *name, VOID_STAR addr, unsigned char data_type, int ro) -{ - SLang_Intrin_Var_Type *v; - - if (-1 == init_interpreter ()) - return -1; - - if (ns == NULL) ns = Global_NameSpace; - - v = (SLang_Intrin_Var_Type *)add_global_name (name, - _SLcompute_string_hash (name), - (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE), - sizeof (SLang_Intrin_Var_Type), - ns); - if (v == NULL) - return -1; - - v->addr = addr; - v->type = data_type; - return 0; -} - -int SLadd_intrinsic_variable (char *name, VOID_STAR addr, unsigned char data_type, int ro) -{ - return SLns_add_intrinsic_variable (NULL, name, addr, data_type, ro); -} - -static int -add_slang_function (char *name, unsigned char type, unsigned long hash, - unsigned int num_args, unsigned int num_locals, -#if _SLANG_HAS_DEBUG_CODE - char *file, -#endif - _SLBlock_Header_Type *h, - SLang_NameSpace_Type *ns) -{ - _SLang_Function_Type *f; - -#if _SLANG_HAS_DEBUG_CODE - if ((file != NULL) - && (NULL == (file = SLang_create_slstring (file)))) - return -1; -#endif - - f = (_SLang_Function_Type *)add_global_name (name, hash, - type, - sizeof (_SLang_Function_Type), - ns); - if (f == NULL) - { -#if _SLANG_HAS_DEBUG_CODE - SLang_free_slstring (file); /* NULL ok */ -#endif - return -1; - } - - if (f->v.header != NULL) - { - if (f->nlocals == AUTOLOAD_NUM_LOCALS) - SLang_free_slstring ((char *)f->v.autoload_filename); /* autoloaded filename */ - else - free_function_header (f->v.header); - } - -#if _SLANG_HAS_DEBUG_CODE - if (f->file != NULL) SLang_free_slstring (f->file); - f->file = file; -#endif - f->v.header = h; - f->nlocals = num_locals; - f->nargs = num_args; - - return 0; -} - -int SLang_autoload (char *name, char *file) -{ - _SLang_Function_Type *f; - unsigned long hash; - - hash = _SLcompute_string_hash (name); - f = (_SLang_Function_Type *)locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size); - - if ((f != NULL) - && (f->name_type == SLANG_FUNCTION) - && (f->v.header != NULL) - && (f->nlocals != AUTOLOAD_NUM_LOCALS)) - { - /* already loaded */ - return 0; - } - - file = SLang_create_slstring (file); - if (-1 == add_slang_function (name, SLANG_FUNCTION, hash, 0, AUTOLOAD_NUM_LOCALS, -#if _SLANG_HAS_DEBUG_CODE - file, -#endif - (_SLBlock_Header_Type *) file, - Global_NameSpace)) - { - SLang_free_slstring (file); - return -1; - } - - return 0; -} - -SLang_Name_Type *_SLlocate_global_name (char *name) -{ - unsigned long hash; - - hash = _SLcompute_string_hash (name); - return locate_name_in_table (name, hash, Global_NameSpace->table, - Global_NameSpace->table_size); -} - -/*}}}*/ - -static void free_local_variable_table (void) -{ - unsigned int i; - SLang_Name_Type *t, *t1; - - for (i = 0; i < SLLOCALS_HASH_TABLE_SIZE; i++) - { - t = Locals_Hash_Table [i]; - while (t != NULL) - { - SLang_free_slstring (t->name); - t1 = t->next; - SLfree ((char *) t); - t = t1; - } - Locals_Hash_Table [i] = NULL; - } - Local_Variable_Number = 0; -} - -/* call inner interpreter or return for more */ -static void lang_try_now(void) -{ - Compile_ByteCode_Ptr++; - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) - return; - - Compile_ByteCode_Ptr->bc_main_type = 0; /* so next command stops after this */ - - /* now do it */ - inner_interp (This_Compile_Block); - (void) lang_free_branch (This_Compile_Block); - Compile_ByteCode_Ptr = This_Compile_Block; -} - -SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *ref) -{ - if (ref->is_global) - { - SLang_Name_Type *nt = ref->v.nt; - - switch (nt->name_type) - { - case SLANG_PFUNCTION: - case SLANG_FUNCTION: - case SLANG_INTRINSIC: - case SLANG_MATH_UNARY: - case SLANG_APP_UNARY: - return nt; - } - SLang_verror (SL_TYPE_MISMATCH, - "Reference to a function expected. Found &%s", - nt->name); - } - - SLang_verror (SL_TYPE_MISMATCH, - "Reference to a function expected"); - return NULL; -} - -int SLexecute_function (SLang_Name_Type *nt) -{ - unsigned char type; - char *name; - - if (SLang_Error) - return -1; - - type = nt->name_type; - name = nt->name; - - switch (type) - { - case SLANG_PFUNCTION: - case SLANG_FUNCTION: - execute_slang_fun ((_SLang_Function_Type *) nt); - break; - - case SLANG_INTRINSIC: - execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt); - break; - - case SLANG_MATH_UNARY: - case SLANG_APP_UNARY: - inner_interp_nametype (nt); - break; - - default: - SLang_verror (SL_TYPE_MISMATCH, "%s is not a function", name); - return -1; - } - - if (SLang_Error) - { - SLang_verror (SLang_Error, "Error while executing %s", name); - return -1; - } - - return 1; -} - -int SLang_execute_function (char *name) -{ - SLang_Name_Type *entry; - - if (NULL == (entry = SLang_get_function (name))) - return 0; - - return SLexecute_function (entry); -} - -/* return S-Lang function or NULL */ -SLang_Name_Type *SLang_get_function (char *name) -{ - SLang_Name_Type *entry; - - if (NULL == (entry = locate_namespace_encoded_name (name, 0))) - return NULL; - - if ((entry->name_type == SLANG_FUNCTION) - || (entry->name_type == SLANG_INTRINSIC)) - return entry; - - return NULL; -} - -static void lang_begin_function (void) -{ - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - SLang_verror (SL_SYNTAX_ERROR, "Function nesting is illegal"); - return; - } - Lang_Defining_Function = 1; - (void) push_block_context (COMPILE_BLOCK_TYPE_FUNCTION); -} - -#if USE_COMBINED_BYTECODES -static void optimize_block (SLBlock_Type *b) -{ - while (1) - { - switch (b->bc_main_type) - { - case 0: - return; - - default: - b++; - break; - - case _SLANG_BC_CALL_DIRECT: - b++; - switch (b->bc_main_type) - { - case 0: - return; - case _SLANG_BC_INTRINSIC: - if ((b+1)->bc_main_type == 0) - { - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRSTOP; - return; - } - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRINSIC; - b++; - break; - case _SLANG_BC_LITERAL_STR: - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LSTR; - b++; - break; - case _SLANG_BC_FUNCTION: - case _SLANG_BC_PFUNCTION: - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_SLFUN; - b++; - break; - case _SLANG_BC_EARG_LVARIABLE: - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_EARG_LVAR; - b++; - break; - case _SLANG_BC_LITERAL_INT: - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LINT; - b++; - break; - case _SLANG_BC_LVARIABLE: - (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LVAR; - b++; - break; - } - break; - - case _SLANG_BC_INTRINSIC: - b++; - switch (b->bc_main_type) - { - case _SLANG_BC_CALL_DIRECT: - (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_CALL_DIRECT; - b++; - break; -#if 0 - case _SLANG_BC_BLOCK: - (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_BLOCK; - b++; - break; -#endif - - case 0: - (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_STOP; - return; - } - break; - } - } -} - -#endif - - -/* name will be NULL if the object is to simply terminate the function - * definition. See SLang_restart. - */ -static int lang_define_function (char *name, unsigned char type, unsigned long hash, - SLang_NameSpace_Type *ns) -{ - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_FUNCTION) - { - SLang_verror (SL_SYNTAX_ERROR, "Premature end of function"); - return -1; - } - - /* terminate function */ - Compile_ByteCode_Ptr->bc_main_type = 0; - - if (name != NULL) - { - _SLBlock_Header_Type *h; - - h = (_SLBlock_Header_Type *)SLmalloc (sizeof (_SLBlock_Header_Type)); - if (h != NULL) - { - h->num_refs = 1; - h->body = This_Compile_Block; - -#if USE_COMBINED_BYTECODES - optimize_block (h->body); -#endif - - if (-1 == add_slang_function (name, type, hash, - Function_Args_Number, - Local_Variable_Number, -#if _SLANG_HAS_DEBUG_CODE - This_Compile_Filename, -#endif - h, ns)) - SLfree ((char *) h); - } - /* Drop through for clean-up */ - } - - free_local_variable_table (); - - Function_Args_Number = 0; - Lang_Defining_Function = 0; - - if (SLang_Error) return -1; - /* SLang_restart will finish this if there is a slang error. */ - - pop_block_context (); - - /* A function is only defined at top-level */ - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); - return -1; - } - Compile_ByteCode_Ptr = This_Compile_Block; - return 0; -} - -static void define_static_function (char *name, unsigned long hash) -{ - (void) lang_define_function (name, SLANG_FUNCTION, hash, This_Static_NameSpace); -} - -static void define_private_function (char *name, unsigned long hash) -{ - (void) lang_define_function (name, SLANG_PFUNCTION, hash, This_Static_NameSpace); -} - -static void define_public_function (char *name, unsigned long hash) -{ - (void) lang_define_function (name, SLANG_FUNCTION, hash, Global_NameSpace); -} - -static void lang_end_block (void) -{ - SLBlock_Type *node, *branch; - unsigned char mtype; - - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) - { - SLang_verror (SL_SYNTAX_ERROR, "Not defining a block"); - return; - } - - /* terminate the block */ - Compile_ByteCode_Ptr->bc_main_type = 0; - branch = This_Compile_Block; - - /* Try to save some space by using the cached blocks. */ - if (Compile_ByteCode_Ptr == branch + 1) - { - mtype = branch->bc_main_type; - if (((mtype == _SLANG_BC_BREAK) - || (mtype == _SLANG_BC_CONTINUE) - || (mtype == _SLANG_BC_RETURN)) - && (SLang_Error == 0)) - { - SLfree ((char *)branch); - branch = SLShort_Blocks + 2 * (int) (mtype - _SLANG_BC_RETURN); - } - } - -#if USE_COMBINED_BYTECODES - optimize_block (branch); -#endif - - pop_block_context (); - node = Compile_ByteCode_Ptr++; - - node->bc_main_type = _SLANG_BC_BLOCK; - node->bc_sub_type = 0; - node->b.blk = branch; -} - -static int lang_begin_block (void) -{ - return push_block_context (COMPILE_BLOCK_TYPE_BLOCK); -} - -static int lang_check_space (void) -{ - unsigned int n; - SLBlock_Type *p; - - if (NULL == (p = This_Compile_Block)) - { - SLang_verror (SL_INTERNAL_ERROR, "Top-level block not present"); - return -1; - } - - /* Allow 1 extra for terminator */ - if (Compile_ByteCode_Ptr + 1 < This_Compile_Block_Max) - return 0; - - n = (unsigned int) (This_Compile_Block_Max - p); - - /* enlarge the space by 2 objects */ - n += 2; - - if (NULL == (p = (SLBlock_Type *) SLrealloc((char *)p, n * sizeof(SLBlock_Type)))) - return -1; - - This_Compile_Block_Max = p + n; - n = (unsigned int) (Compile_ByteCode_Ptr - This_Compile_Block); - This_Compile_Block = p; - Compile_ByteCode_Ptr = p + n; - - return 0; -} - -/* returns positive number if name is a function or negative number if it - is a variable. If it is intrinsic, it returns magnitude of 1, else 2 */ -int SLang_is_defined(char *name) -{ - SLang_Name_Type *t; - - if (-1 == init_interpreter ()) - return -1; - - t = locate_namespace_encoded_name (name, 0); - if (t == NULL) - return 0; - - switch (t->name_type) - { - case SLANG_FUNCTION: - /* case SLANG_PFUNCTION: */ - return 2; - case SLANG_GVARIABLE: - /* case SLANG_PVARIABLE: */ - return -2; - - case SLANG_ICONSTANT: - case SLANG_DCONSTANT: - case SLANG_RVARIABLE: - case SLANG_IVARIABLE: - return -1; - - case SLANG_INTRINSIC: - default: - return 1; - } -} - -static int add_global_variable (char *name, char name_type, unsigned long hash, - SLang_NameSpace_Type *ns) -{ - SLang_Name_Type *g; - - /* Note the importance of checking if it is already defined or not. For example, - * suppose X is defined as an intrinsic variable. Then S-Lang code like: - * !if (is_defined("X")) { variable X; } - * will not result in a global variable X. On the other hand, this would - * not be an issue if 'variable' statements always were not processed - * immediately. That is, as it is now, 'if (0) {variable ZZZZ;}' will result - * in the variable ZZZZ being defined because of the immediate processing. - * The current solution is to do: if (0) { eval("variable ZZZZ;"); } - */ - /* hash = _SLcompute_string_hash (name); */ - g = locate_name_in_table (name, hash, ns->table, ns->table_size); - - if (g != NULL) - { - if (g->name_type == name_type) - return 0; - } - - if (NULL == add_global_name (name, hash, name_type, - sizeof (SLang_Global_Var_Type), ns)) - return -1; - - return 0; -} - -int SLadd_global_variable (char *name) -{ - if (-1 == init_interpreter ()) - return -1; - - return add_global_variable (name, SLANG_GVARIABLE, - _SLcompute_string_hash (name), - Global_NameSpace); -} - -static int add_local_variable (char *name, unsigned long hash) -{ - SLang_Local_Var_Type *t; - - /* local variable */ - if (Local_Variable_Number >= SLANG_MAX_LOCAL_VARIABLES) - { - SLang_verror (SL_SYNTAX_ERROR, "Too many local variables"); - return -1; - } - - if (NULL != locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE)) - { - SLang_verror (SL_SYNTAX_ERROR, "Local variable %s has already been defined", name); - return -1; - } - - t = (SLang_Local_Var_Type *) - add_name_to_hash_table (name, hash, - sizeof (SLang_Local_Var_Type), SLANG_LVARIABLE, - Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE, 0); - if (t == NULL) - return -1; - - t->local_var_number = Local_Variable_Number; - Local_Variable_Number++; - return 0; -} - -static void (*Compile_Mode_Function) (_SLang_Token_Type *); -static void compile_basic_token_mode (_SLang_Token_Type *); - -/* if an error occurs, discard current object, block, function, etc... */ -void SLang_restart (int localv) -{ - int save = SLang_Error; - - SLang_Error = SL_UNKNOWN_ERROR; - - _SLcompile_ptr = _SLcompile; - Compile_Mode_Function = compile_basic_token_mode; - - Lang_Break = /* Lang_Continue = */ Lang_Return = 0; - Trace_Mode = 0; - - while (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) - lang_end_block(); - - if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_FUNCTION) - { - /* Terminate function definition and free variables */ - lang_define_function (NULL, SLANG_FUNCTION, 0, Global_NameSpace); - if (lang_free_branch (This_Compile_Block)) - SLfree((char *)This_Compile_Block); - } - Lang_Defining_Function = 0; - - SLang_Error = save; - - if (SLang_Error == SL_STACK_OVERFLOW) - { - /* This loop guarantees that the stack is properly cleaned. */ - while (_SLStack_Pointer != _SLRun_Stack) - { - SLdo_pop (); - } - } - - while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) - && (0 == pop_block_context ())) - ; - - if (localv) - { - Next_Function_Num_Args = SLang_Num_Function_Args = 0; - Local_Variable_Frame = Local_Variable_Stack; - Recursion_Depth = 0; - Frame_Pointer = _SLStack_Pointer; - Frame_Pointer_Depth = 0; - Switch_Obj_Ptr = Switch_Objects; - while (Switch_Obj_Ptr < Switch_Obj_Max) - { - SLang_free_object (Switch_Obj_Ptr); - Switch_Obj_Ptr++; - } - Switch_Obj_Ptr = Switch_Objects; - } -} - -static void compile_directive (unsigned char sub_type) -{ - /* This function is called only from compile_directive_mode which is - * only possible when a block is available. - */ - - /* use BLOCK */ - Compile_ByteCode_Ptr--; - Compile_ByteCode_Ptr->bc_sub_type = sub_type; - - lang_try_now (); -} - -static void compile_unary (int op, unsigned char mt) -{ - Compile_ByteCode_Ptr->bc_main_type = mt; - Compile_ByteCode_Ptr->b.i_blk = op; - Compile_ByteCode_Ptr->bc_sub_type = 0; - - lang_try_now (); -} - - -static void compile_binary (int op) -{ - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_BINARY; - Compile_ByteCode_Ptr->b.i_blk = op; - Compile_ByteCode_Ptr->bc_sub_type = 0; - - lang_try_now (); -} - -#if _SLANG_OPTIMIZE_FOR_SPEED -static int try_compressed_bytecode (unsigned char last_bc, unsigned char bc) -{ - if (Compile_ByteCode_Ptr != This_Compile_Block) - { - SLBlock_Type *b; - b = Compile_ByteCode_Ptr - 1; - if (b->bc_main_type == last_bc) - { - Compile_ByteCode_Ptr = b; - b->bc_main_type = bc; - lang_try_now (); - return 0; - } - } - return -1; -} -#endif - -static void compile_fast_binary (int op, unsigned char bc) -{ -#if _SLANG_OPTIMIZE_FOR_SPEED - if (0 == try_compressed_bytecode (_SLANG_BC_LITERAL_INT, bc)) - return; -#else - (void) bc; -#endif - compile_binary (op); -} - -/* This is a hack */ -typedef struct _Special_NameTable_Type -{ - char *name; - int (*fun) (struct _Special_NameTable_Type *, _SLang_Token_Type *); - VOID_STAR blk_data; - unsigned char main_type; -} -Special_NameTable_Type; - -static int handle_special (Special_NameTable_Type *nt, _SLang_Token_Type *tok) -{ - (void) tok; - Compile_ByteCode_Ptr->bc_main_type = nt->main_type; - Compile_ByteCode_Ptr->b.ptr_blk = nt->blk_data; - return 0; -} - -static int handle_special_file (Special_NameTable_Type *nt, _SLang_Token_Type *tok) -{ - char *name; - - (void) nt; (void) tok; - - if (This_Static_NameSpace == NULL) name = "***Unknown***"; - else - name = This_Static_NameSpace->name; - - name = SLang_create_slstring (name); - if (name == NULL) - return -1; - - Compile_ByteCode_Ptr->b.s_blk = name; - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; - Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; - return 0; -} - -static int handle_special_line (Special_NameTable_Type *nt, _SLang_Token_Type *tok) -{ - (void) nt; - -#if _SLANG_HAS_DEBUG_CODE - Compile_ByteCode_Ptr->b.l_blk = (long) tok->line_number; -#endif - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; - Compile_ByteCode_Ptr->bc_sub_type = SLANG_UINT_TYPE; - - return 0; -} - -static Special_NameTable_Type Special_Name_Table [] = -{ - {"EXECUTE_ERROR_BLOCK", handle_special, NULL, _SLANG_BC_X_ERROR}, - {"X_USER_BLOCK0", handle_special, NULL, _SLANG_BC_X_USER0}, - {"X_USER_BLOCK1", handle_special, NULL, _SLANG_BC_X_USER1}, - {"X_USER_BLOCK2", handle_special, NULL, _SLANG_BC_X_USER2}, - {"X_USER_BLOCK3", handle_special, NULL, _SLANG_BC_X_USER3}, - {"X_USER_BLOCK4", handle_special, NULL, _SLANG_BC_X_USER4}, - {"__FILE__", handle_special_file, NULL, 0}, - {"__LINE__", handle_special_line, NULL, 0}, -#if 0 - {"__NAMESPACE__", handle_special_namespace, NULL, 0}, -#endif - {NULL, NULL, NULL, 0} -}; - -static void compile_hashed_identifier (char *name, unsigned long hash, _SLang_Token_Type *tok) -{ - SLang_Name_Type *entry; - unsigned char name_type; - - entry = locate_hashed_name (name, hash); - - if (entry == NULL) - { - Special_NameTable_Type *nt = Special_Name_Table; - - while (nt->name != NULL) - { - if (strcmp (name, nt->name)) - { - nt++; - continue; - } - - if (0 == (*nt->fun)(nt, tok)) - lang_try_now (); - return; - } - - SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); - return; - } - - name_type = entry->name_type; - Compile_ByteCode_Ptr->bc_main_type = name_type; - - if (name_type == SLANG_LVARIABLE) - Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; - else - Compile_ByteCode_Ptr->b.nt_blk = entry; - - lang_try_now (); -} - -static void compile_tmp_variable (char *name, unsigned long hash) -{ - SLang_Name_Type *entry; - unsigned char name_type; - - if (NULL == (entry = locate_hashed_name (name, hash))) - { - SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); - return; - } - - name_type = entry->name_type; - switch (name_type) - { - case SLANG_LVARIABLE: - Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number; - break; - - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - Compile_ByteCode_Ptr->b.nt_blk = entry; - break; - - default: - SLang_verror (SL_SYNTAX_ERROR, "__tmp(%s) does not specifiy a variable", name); - return; - } - - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_TMP; - Compile_ByteCode_Ptr->bc_sub_type = name_type; - - lang_try_now (); -} - -static void compile_simple (unsigned char main_type) -{ - Compile_ByteCode_Ptr->bc_main_type = main_type; - Compile_ByteCode_Ptr->bc_sub_type = 0; - Compile_ByteCode_Ptr->b.blk = NULL; - lang_try_now (); -} - -static void compile_identifier (char *name, _SLang_Token_Type *tok) -{ - compile_hashed_identifier (name, _SLcompute_string_hash (name), tok); -} - -static void compile_call_direct (int (*f) (void), unsigned char byte_code) -{ - Compile_ByteCode_Ptr->b.call_function = f; - Compile_ByteCode_Ptr->bc_main_type = byte_code; - Compile_ByteCode_Ptr->bc_sub_type = 0; - lang_try_now (); -} - -static void compile_lvar_call_direct (int (*f)(void), unsigned char bc, - unsigned char frame_op) -{ -#if _SLANG_OPTIMIZE_FOR_SPEED - if (0 == try_compressed_bytecode (_SLANG_BC_LVARIABLE, bc)) - return; -#else - (void) bc; -#endif - - compile_call_direct (f, frame_op); -} - -static void compile_integer (long i, unsigned char bc_main_type, unsigned char bc_sub_type) -{ - Compile_ByteCode_Ptr->b.l_blk = i; - Compile_ByteCode_Ptr->bc_main_type = bc_main_type; - Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type; - - lang_try_now (); -} - -#if SLANG_HAS_FLOAT -static void compile_double (char *str, unsigned char type) -{ - double d; - unsigned int factor = 1; - double *ptr; - -#if 1 - d = _SLang_atof (str); -#else - if (1 != sscanf (str, "%lf", &d)) - { - SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to double", str); - return; - } -#endif - -#if SLANG_HAS_COMPLEX - if (type == SLANG_COMPLEX_TYPE) factor = 2; -#endif - if (NULL == (ptr = (double *) SLmalloc(factor * sizeof(double)))) - return; - - Compile_ByteCode_Ptr->b.double_blk = ptr; -#if SLANG_HAS_COMPLEX - if (type == SLANG_COMPLEX_TYPE) - *ptr++ = 0; -#endif - *ptr = d; - - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; - Compile_ByteCode_Ptr->bc_sub_type = type; - lang_try_now (); -} - -static void compile_float (char *s) -{ - float x; - -#if 1 - x = (float) _SLang_atof (s); -#else - if (1 != sscanf (s, "%f", &x)) - { - SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to float", s); - return; - } -#endif - Compile_ByteCode_Ptr->b.float_blk = x; - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; - Compile_ByteCode_Ptr->bc_sub_type = SLANG_FLOAT_TYPE; - lang_try_now (); -} - -#endif - -static void compile_string (char *s, unsigned long hash) -{ - if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (s, hash))) - return; - - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR; - Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE; - - lang_try_now (); -} - -static void compile_bstring (SLang_BString_Type *s) -{ - if (NULL == (Compile_ByteCode_Ptr->b.bs_blk = SLbstring_dup (s))) - return; - - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL; - Compile_ByteCode_Ptr->bc_sub_type = SLANG_BSTRING_TYPE; - - lang_try_now (); -} - -/* assign_type is one of _SLANG_BCST_ASSIGN, ... values */ -static void compile_assign (unsigned char assign_type, - char *name, unsigned long hash) -{ - SLang_Name_Type *v; - unsigned char main_type; - SLang_Class_Type *cl; - - v = locate_hashed_name (name, hash); - if (v == NULL) - { - if ((_SLang_Auto_Declare_Globals == 0) - || (NULL != strchr (name, '-')) /* namespace->name form */ - || Lang_Defining_Function - || (assign_type != _SLANG_BCST_ASSIGN) - || (This_Static_NameSpace == NULL)) - { - SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); - return; - } - /* Note that function local variables are not at top level */ - - /* Variables that are automatically declared are given static - * scope. - */ - if ((NULL != SLang_Auto_Declare_Var_Hook) - && (-1 == (*SLang_Auto_Declare_Var_Hook) (name))) - return; - - if ((-1 == add_global_variable (name, SLANG_GVARIABLE, hash, This_Static_NameSpace)) - || (NULL == (v = locate_hashed_name (name, hash)))) - return; - } - - switch (v->name_type) - { - case SLANG_LVARIABLE: - main_type = _SLANG_BC_SET_LOCAL_LVALUE; - Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; - break; - - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - main_type = _SLANG_BC_SET_GLOBAL_LVALUE; - Compile_ByteCode_Ptr->b.nt_blk = v; - break; - - case SLANG_IVARIABLE: - cl = _SLclass_get_class (((SLang_Intrin_Var_Type *)v)->type); - if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) - { - SLang_verror (SL_SYNTAX_ERROR, "Assignment to %s is not allowed", name); - return; - } - main_type = _SLANG_BC_SET_INTRIN_LVALUE; - Compile_ByteCode_Ptr->b.nt_blk = v; - break; - - case SLANG_RVARIABLE: - SLang_verror (SL_READONLY_ERROR, "%s is read-only", name); - return; - - default: - SLang_verror (SL_DUPLICATE_DEFINITION, "%s may not be used as an lvalue", name); - return; - } - - Compile_ByteCode_Ptr->bc_sub_type = assign_type; - Compile_ByteCode_Ptr->bc_main_type = main_type; - - lang_try_now (); -} - -static void compile_deref_assign (char *name, unsigned long hash) -{ - SLang_Name_Type *v; - - v = locate_hashed_name (name, hash); - - if (v == NULL) - { - SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); - return; - } - - switch (v->name_type) - { - case SLANG_LVARIABLE: - Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number; - break; - - case SLANG_GVARIABLE: - case SLANG_PVARIABLE: - Compile_ByteCode_Ptr->b.nt_blk = v; - break; - - default: - /* FIXME: Priority=low - * This could be made to work. It is not a priority because - * I cannot imagine application intrinsics which are references. - */ - SLang_verror (SL_NOT_IMPLEMENTED, "Deref assignment to %s is not allowed", name); - return; - } - - Compile_ByteCode_Ptr->bc_sub_type = v->name_type; - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_DEREF_ASSIGN; - - lang_try_now (); -} - -static void -compile_struct_assign (_SLang_Token_Type *t) -{ - Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _STRUCT_ASSIGN_TOKEN); - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_STRUCT_LVALUE; - Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (t->v.s_val, t->hash); - lang_try_now (); -} - -static void -compile_array_assign (_SLang_Token_Type *t) -{ - Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _ARRAY_ASSIGN_TOKEN); - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_ARRAY_LVALUE; - Compile_ByteCode_Ptr->b.s_blk = NULL; - lang_try_now (); -} - -static void compile_dot(_SLang_Token_Type *t) -{ - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_FIELD; - Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string(t->v.s_val, t->hash); - lang_try_now (); -} - -static void compile_ref (char *name, unsigned long hash) -{ - SLang_Name_Type *entry; - unsigned char main_type; - - if (NULL == (entry = locate_hashed_name (name, hash))) - { - SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); - return; - } - - main_type = entry->name_type; - - if (main_type == SLANG_LVARIABLE) - { - main_type = _SLANG_BC_LOBJPTR; - Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *)entry)->local_var_number; - } - else - { - main_type = _SLANG_BC_GOBJPTR; - Compile_ByteCode_Ptr->b.nt_blk = entry; - } - - Compile_ByteCode_Ptr->bc_main_type = main_type; - lang_try_now (); -} - -static void compile_break (unsigned char break_type, - int requires_block, int requires_fun, - char *str) -{ - if ((requires_fun - && (Lang_Defining_Function == 0)) - || (requires_block - && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK))) - { - SLang_verror (SL_SYNTAX_ERROR, "misplaced %s", str); - return; - } - - Compile_ByteCode_Ptr->bc_main_type = break_type; - Compile_ByteCode_Ptr->bc_sub_type = 0; - - lang_try_now (); -} - -static void compile_public_variable_mode (_SLang_Token_Type *t) -{ - if (t->type == IDENT_TOKEN) - { - /* If the variable is already defined in the static hash table, - * generate an error. - */ - if ((This_Static_NameSpace != NULL) - && (NULL != locate_name_in_table (t->v.s_val, t->hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size))) - { - SLang_verror (SL_DUPLICATE_DEFINITION, - "%s already has static or private linkage in this unit", - t->v.s_val); - return; - } - add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, Global_NameSpace); - } - else if (t->type == CBRACKET_TOKEN) - Compile_Mode_Function = compile_basic_token_mode; - else - SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); -} - -static void compile_local_variable_mode (_SLang_Token_Type *t) -{ - if (t->type == IDENT_TOKEN) - add_local_variable (t->v.s_val, t->hash); - else if (t->type == CBRACKET_TOKEN) - Compile_Mode_Function = compile_basic_token_mode; - else - SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); -} - -static void compile_static_variable_mode (_SLang_Token_Type *t) -{ - if (t->type == IDENT_TOKEN) - add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, This_Static_NameSpace); - else if (t->type == CBRACKET_TOKEN) - Compile_Mode_Function = compile_basic_token_mode; - else - SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); -} - -static void compile_private_variable_mode (_SLang_Token_Type *t) -{ - if (t->type == IDENT_TOKEN) - add_global_variable (t->v.s_val, SLANG_PVARIABLE, t->hash, This_Static_NameSpace); - else if (t->type == CBRACKET_TOKEN) - Compile_Mode_Function = compile_basic_token_mode; - else - SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list"); -} - -static void compile_function_mode (_SLang_Token_Type *t) -{ - if (-1 == lang_check_space ()) - return; - - if (t->type != IDENT_TOKEN) - SLang_verror (SL_SYNTAX_ERROR, "Expecting function name"); - else - lang_define_function (t->v.s_val, SLANG_FUNCTION, t->hash, Global_NameSpace); - - Compile_Mode_Function = compile_basic_token_mode; -} - -/* An error block is not permitted to contain continue or break statements. - * This restriction may be removed later but for now reject them. - */ -static int check_error_block (void) -{ - SLBlock_Type *p; - unsigned char t; - - /* Back up to the block and then scan it. */ - p = (Compile_ByteCode_Ptr - 1)->b.blk; - - while (0 != (t = p->bc_main_type)) - { - if ((t == _SLANG_BC_BREAK) - || (t == _SLANG_BC_CONTINUE)) - { - SLang_verror (SL_SYNTAX_ERROR, - "An ERROR_BLOCK is not permitted to contain continue or break statements"); - return -1; - } - p++; - } - return 0; -} - -/* The only allowed tokens are the directives and another block start. - * The mode is only active if a block is available. The inner_interp routine - * expects such safety checks. - */ -static void compile_directive_mode (_SLang_Token_Type *t) -{ - int bc_sub_type; - - if (-1 == lang_check_space ()) - return; - - bc_sub_type = -1; - - switch (t->type) - { - case FOREVER_TOKEN: - bc_sub_type = _SLANG_BCST_FOREVER; - break; - - case IFNOT_TOKEN: - bc_sub_type = _SLANG_BCST_IFNOT; - break; - - case IF_TOKEN: - bc_sub_type = _SLANG_BCST_IF; - break; - - case ANDELSE_TOKEN: - bc_sub_type = _SLANG_BCST_ANDELSE; - break; - - case SWITCH_TOKEN: - bc_sub_type = _SLANG_BCST_SWITCH; - break; - - case EXITBLK_TOKEN: - if (Lang_Defining_Function == 0) - { - SLang_verror (SL_SYNTAX_ERROR, "misplaced EXIT_BLOCK"); - break; - } - bc_sub_type = _SLANG_BCST_EXIT_BLOCK; - break; - - case ERRBLK_TOKEN: - if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - SLang_verror (SL_SYNTAX_ERROR, "misplaced ERROR_BLOCK"); - break; - } - if (0 == check_error_block ()) - bc_sub_type = _SLANG_BCST_ERROR_BLOCK; - break; - - case USRBLK0_TOKEN: - case USRBLK1_TOKEN: - case USRBLK2_TOKEN: - case USRBLK3_TOKEN: - case USRBLK4_TOKEN: - if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) - { - SLang_verror (SL_SYNTAX_ERROR, "misplaced USER_BLOCK"); - break; - } - bc_sub_type = _SLANG_BCST_USER_BLOCK0 + (t->type - USRBLK0_TOKEN); - break; - - case NOTELSE_TOKEN: - bc_sub_type = _SLANG_BCST_NOTELSE; - break; - - case ELSE_TOKEN: - bc_sub_type = _SLANG_BCST_ELSE; - break; - - case LOOP_TOKEN: - bc_sub_type = _SLANG_BCST_LOOP; - break; - - case DOWHILE_TOKEN: - bc_sub_type = _SLANG_BCST_DOWHILE; - break; - - case WHILE_TOKEN: - bc_sub_type = _SLANG_BCST_WHILE; - break; - - case ORELSE_TOKEN: - bc_sub_type = _SLANG_BCST_ORELSE; - break; - - case _FOR_TOKEN: - bc_sub_type = _SLANG_BCST_FOR; - break; - - case FOR_TOKEN: - bc_sub_type = _SLANG_BCST_CFOR; - break; - - case FOREACH_TOKEN: - bc_sub_type = _SLANG_BCST_FOREACH; - break; - - case OBRACE_TOKEN: - lang_begin_block (); - break; - - default: - SLang_verror (SL_SYNTAX_ERROR, "Expecting directive token. Found 0x%X", t->type); - break; - } - - /* Reset this pointer first because compile_directive may cause a - * file to be loaded. - */ - Compile_Mode_Function = compile_basic_token_mode; - - if (bc_sub_type != -1) - compile_directive (bc_sub_type); -} - -static unsigned int Assign_Mode_Type; -static void compile_assign_mode (_SLang_Token_Type *t) -{ - if (t->type != IDENT_TOKEN) - { - SLang_verror (SL_SYNTAX_ERROR, "Expecting identifier for assignment"); - return; - } - - compile_assign (Assign_Mode_Type, t->v.s_val, t->hash); - Compile_Mode_Function = compile_basic_token_mode; -} - -static void compile_basic_token_mode (_SLang_Token_Type *t) -{ - if (-1 == lang_check_space ()) - return; - - switch (t->type) - { - case PUSH_TOKEN: - case NOP_TOKEN: - case EOF_TOKEN: - case READONLY_TOKEN: - case DO_TOKEN: - case VARIABLE_TOKEN: - case SEMICOLON_TOKEN: - default: - SLang_verror (SL_SYNTAX_ERROR, "Unknown or unsupported token type 0x%X", t->type); - break; - - case DEREF_TOKEN: - compile_call_direct (dereference_object, _SLANG_BC_CALL_DIRECT); - break; - - case STRUCT_TOKEN: - compile_call_direct (_SLstruct_define_struct, _SLANG_BC_CALL_DIRECT); - break; - - case TYPEDEF_TOKEN: - compile_call_direct (_SLstruct_define_typedef, _SLANG_BC_CALL_DIRECT); - break; - - case TMP_TOKEN: - compile_tmp_variable (t->v.s_val, t->hash); - break; - - case DOT_TOKEN: /* X . field */ - compile_dot (t); - break; - - case COMMA_TOKEN: - break; /* do nothing */ - - case IDENT_TOKEN: - compile_hashed_identifier (t->v.s_val, t->hash, t); - break; - - case _REF_TOKEN: - compile_ref (t->v.s_val, t->hash); - break; - - case ARG_TOKEN: - compile_call_direct (SLang_start_arg_list, _SLANG_BC_CALL_DIRECT); - break; - - case EARG_TOKEN: - compile_lvar_call_direct (SLang_end_arg_list, _SLANG_BC_EARG_LVARIABLE, _SLANG_BC_CALL_DIRECT); - break; - - case COLON_TOKEN: - if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK) - compile_simple (_SLANG_BC_LABEL); - else SLang_Error = SL_SYNTAX_ERROR; - break; - - case POP_TOKEN: - compile_call_direct (SLdo_pop, _SLANG_BC_CALL_DIRECT); - break; - - case CASE_TOKEN: - if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK) - SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case'"); - else - compile_call_direct (case_function, _SLANG_BC_CALL_DIRECT); - break; - - case CHAR_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_CHAR_TYPE); - break; - case SHORT_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_SHORT_TYPE); - break; - case INT_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_INT_TYPE); - break; - case UCHAR_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_UCHAR_TYPE); - break; - case USHORT_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_USHORT_TYPE); - break; - case UINT_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_UINT_TYPE); - break; - case LONG_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_LONG_TYPE); - break; - case ULONG_TOKEN: - compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_ULONG_TYPE); - break; - -#if SLANG_HAS_FLOAT - case FLOAT_TOKEN: - compile_float (t->v.s_val); - break; - - case DOUBLE_TOKEN: - compile_double (t->v.s_val, SLANG_DOUBLE_TYPE); - break; -#endif -#if SLANG_HAS_COMPLEX - case COMPLEX_TOKEN: - compile_double (t->v.s_val, SLANG_COMPLEX_TYPE); - break; -#endif - - case STRING_TOKEN: - compile_string (t->v.s_val, t->hash); - break; - - case _BSTRING_TOKEN: - compile_bstring (SLbstring_create ((unsigned char *)t->v.s_val, (unsigned int) t->hash)); - break; - - case BSTRING_TOKEN: - compile_bstring (t->v.b_val); - break; - - case _NULL_TOKEN: - compile_identifier ("NULL", t); - break; - - case _INLINE_WILDCARD_ARRAY_TOKEN: - compile_call_direct (_SLarray_wildcard_array, _SLANG_BC_CALL_DIRECT); - break; - - case _INLINE_ARRAY_TOKEN: - compile_call_direct (_SLarray_inline_array, _SLANG_BC_CALL_DIRECT_FRAME); - break; - - case _INLINE_IMPLICIT_ARRAY_TOKEN: - compile_call_direct (_SLarray_inline_implicit_array, _SLANG_BC_CALL_DIRECT_FRAME); - break; - - case ARRAY_TOKEN: - compile_lvar_call_direct (_SLarray_aget, _SLANG_BC_LVARIABLE_AGET, _SLANG_BC_CALL_DIRECT_FRAME); - break; - - /* Note: I need to add the other _ARRAY assign tokens. */ - case _ARRAY_PLUSEQS_TOKEN: - case _ARRAY_MINUSEQS_TOKEN: - case _ARRAY_TIMESEQS_TOKEN: - case _ARRAY_DIVEQS_TOKEN: - case _ARRAY_BOREQS_TOKEN: - case _ARRAY_BANDEQS_TOKEN: - case _ARRAY_POST_MINUSMINUS_TOKEN: - case _ARRAY_MINUSMINUS_TOKEN: - case _ARRAY_POST_PLUSPLUS_TOKEN: - case _ARRAY_PLUSPLUS_TOKEN: - compile_array_assign (t); - break; - - case _ARRAY_ASSIGN_TOKEN: - compile_lvar_call_direct (_SLarray_aput, _SLANG_BC_LVARIABLE_APUT, _SLANG_BC_CALL_DIRECT_FRAME); - break; - - case _STRUCT_ASSIGN_TOKEN: - case _STRUCT_PLUSEQS_TOKEN: - case _STRUCT_MINUSEQS_TOKEN: - case _STRUCT_TIMESEQS_TOKEN: - case _STRUCT_DIVEQS_TOKEN: - case _STRUCT_BOREQS_TOKEN: - case _STRUCT_BANDEQS_TOKEN: - case _STRUCT_POST_MINUSMINUS_TOKEN: - case _STRUCT_MINUSMINUS_TOKEN: - case _STRUCT_POST_PLUSPLUS_TOKEN: - case _STRUCT_PLUSPLUS_TOKEN: - compile_struct_assign (t); - break; - - case _SCALAR_ASSIGN_TOKEN: - case _SCALAR_PLUSEQS_TOKEN: - case _SCALAR_MINUSEQS_TOKEN: - case _SCALAR_TIMESEQS_TOKEN: - case _SCALAR_DIVEQS_TOKEN: - case _SCALAR_BOREQS_TOKEN: - case _SCALAR_BANDEQS_TOKEN: - case _SCALAR_POST_MINUSMINUS_TOKEN: - case _SCALAR_MINUSMINUS_TOKEN: - case _SCALAR_POST_PLUSPLUS_TOKEN: - case _SCALAR_PLUSPLUS_TOKEN: - compile_assign (_SLANG_BCST_ASSIGN + (t->type - _SCALAR_ASSIGN_TOKEN), - t->v.s_val, t->hash); - break; - - case _DEREF_ASSIGN_TOKEN: - compile_deref_assign (t->v.s_val, t->hash); - break; - - /* For processing RPN tokens */ - case ASSIGN_TOKEN: - case PLUSEQS_TOKEN: - case MINUSEQS_TOKEN: - case TIMESEQS_TOKEN: - case DIVEQS_TOKEN: - case BOREQS_TOKEN: - case BANDEQS_TOKEN: - case POST_MINUSMINUS_TOKEN: - case MINUSMINUS_TOKEN: - case POST_PLUSPLUS_TOKEN: - case PLUSPLUS_TOKEN: - Compile_Mode_Function = compile_assign_mode; - Assign_Mode_Type = _SLANG_BCST_ASSIGN + (t->type - ASSIGN_TOKEN); - break; - - case LT_TOKEN: - compile_binary (SLANG_LT); - break; - - case LE_TOKEN: - compile_binary (SLANG_LE); - break; - - case GT_TOKEN: - compile_binary (SLANG_GT); - break; - - case GE_TOKEN: - compile_binary (SLANG_GE); - break; - - case EQ_TOKEN: - compile_binary (SLANG_EQ); - break; - - case NE_TOKEN: - compile_binary (SLANG_NE); - break; - - case AND_TOKEN: - compile_binary (SLANG_AND); - break; - - case ADD_TOKEN: - compile_fast_binary (SLANG_PLUS, _SLANG_BC_INTEGER_PLUS); - break; - - case SUB_TOKEN: - compile_fast_binary (SLANG_MINUS, _SLANG_BC_INTEGER_MINUS); - break; - - case TIMES_TOKEN: - compile_binary (SLANG_TIMES); - break; - - case DIV_TOKEN: - compile_binary (SLANG_DIVIDE); - break; - - case POW_TOKEN: - compile_binary (SLANG_POW); - break; - - case BXOR_TOKEN: - compile_binary (SLANG_BXOR); - break; - - case BAND_TOKEN: - compile_binary (SLANG_BAND); - break; - - case BOR_TOKEN: - compile_binary (SLANG_BOR); - break; - - case SHR_TOKEN: - compile_binary (SLANG_SHR); - break; - - case SHL_TOKEN: - compile_binary (SLANG_SHL); - break; - - case MOD_TOKEN: - compile_binary (SLANG_MOD); - break; - - case OR_TOKEN: - compile_binary (SLANG_OR); - break; - - case NOT_TOKEN: - compile_unary (SLANG_NOT, _SLANG_BC_UNARY); - break; - - case BNOT_TOKEN: - compile_unary (SLANG_BNOT, _SLANG_BC_UNARY); - break; - - case MUL2_TOKEN: - compile_unary (SLANG_MUL2, _SLANG_BC_UNARY_FUNC); - break; - - case CHS_TOKEN: - compile_unary (SLANG_CHS, _SLANG_BC_UNARY_FUNC); - break; - - case ABS_TOKEN: - compile_unary (SLANG_ABS, _SLANG_BC_UNARY_FUNC); - break; - - case SQR_TOKEN: - compile_unary (SLANG_SQR, _SLANG_BC_UNARY_FUNC); - break; - - case SIGN_TOKEN: - compile_unary (SLANG_SIGN, _SLANG_BC_UNARY_FUNC); - break; - - case BREAK_TOKEN: - compile_break (_SLANG_BC_BREAK, 1, 0, "break"); - break; - - case RETURN_TOKEN: - compile_break (_SLANG_BC_RETURN, 0, 1, "return"); - break; - - case CONT_TOKEN: - compile_break (_SLANG_BC_CONTINUE, 1, 0, "continue"); - break; - - case EXCH_TOKEN: - compile_break (_SLANG_BC_EXCH, 0, 0, ""); /* FIXME: Priority=low */ - break; - - case STATIC_TOKEN: - if (Lang_Defining_Function == 0) - Compile_Mode_Function = compile_static_variable_mode; - else - SLang_verror (SL_NOT_IMPLEMENTED, "static variables not permitted in functions"); - break; - - case PRIVATE_TOKEN: - if (Lang_Defining_Function == 0) - Compile_Mode_Function = compile_private_variable_mode; - else - SLang_verror (SL_NOT_IMPLEMENTED, "private variables not permitted in functions"); - break; - - case PUBLIC_TOKEN: - if (Lang_Defining_Function == 0) - Compile_Mode_Function = compile_public_variable_mode; - else - SLang_verror (SL_NOT_IMPLEMENTED, "public variables not permitted in functions"); - break; - - case OBRACKET_TOKEN: - if (Lang_Defining_Function == 0) - Compile_Mode_Function = Default_Variable_Mode; - else - Compile_Mode_Function = compile_local_variable_mode; - break; - - case OPAREN_TOKEN: - lang_begin_function (); - break; - - case DEFINE_STATIC_TOKEN: - if (Lang_Defining_Function) - define_static_function (t->v.s_val, t->hash); - else SLang_Error = SL_SYNTAX_ERROR; - break; - - case DEFINE_PRIVATE_TOKEN: - if (Lang_Defining_Function) - define_private_function (t->v.s_val, t->hash); - else SLang_Error = SL_SYNTAX_ERROR; - break; - - case DEFINE_PUBLIC_TOKEN: - if (Lang_Defining_Function) - define_public_function (t->v.s_val, t->hash); - else SLang_Error = SL_SYNTAX_ERROR; - break; - - case DEFINE_TOKEN: - if (Lang_Defining_Function) - (*Default_Define_Function) (t->v.s_val, t->hash); - else - SLang_Error = SL_SYNTAX_ERROR; - break; - - case CPAREN_TOKEN: - if (Lang_Defining_Function) - Compile_Mode_Function = compile_function_mode; - else SLang_Error = SL_SYNTAX_ERROR; - break; - - case CBRACE_TOKEN: - lang_end_block (); - Compile_Mode_Function = compile_directive_mode; - break; - - case OBRACE_TOKEN: - lang_begin_block (); - break; - - case FARG_TOKEN: - Function_Args_Number = Local_Variable_Number; - break; - -#if _SLANG_HAS_DEBUG_CODE - case LINE_NUM_TOKEN: - Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LINE_NUM; - Compile_ByteCode_Ptr->b.l_blk = t->v.long_val; - lang_try_now (); - break; -#endif - case POUND_TOKEN: - compile_call_direct (_SLarray_matrix_multiply, _SLANG_BC_CALL_DIRECT); - break; - } -} - -void _SLcompile (_SLang_Token_Type *t) -{ - if (SLang_Error == 0) - { - if (Compile_Mode_Function != compile_basic_token_mode) - { - if (Compile_Mode_Function == NULL) - Compile_Mode_Function = compile_basic_token_mode; -#if _SLANG_HAS_DEBUG_CODE - if (t->type == LINE_NUM_TOKEN) - { - compile_basic_token_mode (t); - return; - } -#endif - } - - (*Compile_Mode_Function) (t); - } - - if (SLang_Error) - { - Compile_Mode_Function = compile_basic_token_mode; - SLang_restart (0); - } -} - -void (*_SLcompile_ptr)(_SLang_Token_Type *) = _SLcompile; - -typedef struct _Compile_Context_Type -{ - struct _Compile_Context_Type *next; - SLang_NameSpace_Type *static_namespace; - void (*compile_variable_mode) (_SLang_Token_Type *); - void (*define_function) (char *, unsigned long); - int lang_defining_function; - int local_variable_number; - unsigned int function_args_number; - SLang_Name_Type **locals_hash_table; - void (*compile_mode_function)(_SLang_Token_Type *); -#if _SLANG_HAS_DEBUG_CODE - char *compile_filename; -#endif -} -Compile_Context_Type; - -static Compile_Context_Type *Compile_Context_Stack; - -/* The only way the push/pop_context functions can get called is via - * an eval type function. That can only happen when executed from a - * top level block. This means that Compile_ByteCode_Ptr can always be - * rest back to the beginning of a block. - */ - -static int pop_compile_context (void) -{ - Compile_Context_Type *cc; - - if (NULL == (cc = Compile_Context_Stack)) - return -1; - - This_Static_NameSpace = cc->static_namespace; - Compile_Context_Stack = cc->next; - Default_Variable_Mode = cc->compile_variable_mode; - Default_Define_Function = cc->define_function; - Compile_Mode_Function = cc->compile_mode_function; - - Lang_Defining_Function = cc->lang_defining_function; - Local_Variable_Number = cc->local_variable_number; - Function_Args_Number = cc->function_args_number; - -#if _SLANG_HAS_DEBUG_CODE - SLang_free_slstring (This_Compile_Filename); - This_Compile_Filename = cc->compile_filename; -#endif - - SLfree ((char *) Locals_Hash_Table); - Locals_Hash_Table = cc->locals_hash_table; - - SLfree ((char *) cc); - - return 0; -} - -static int push_compile_context (char *name) -{ - Compile_Context_Type *cc; - SLang_Name_Type **lns; - - cc = (Compile_Context_Type *)SLmalloc (sizeof (Compile_Context_Type)); - if (cc == NULL) - return -1; - memset ((char *) cc, 0, sizeof (Compile_Context_Type)); - - lns = (SLang_Name_Type **) SLcalloc (sizeof (SLang_Name_Type *), SLLOCALS_HASH_TABLE_SIZE); - if (lns == NULL) - { - SLfree ((char *) cc); - return -1; - } - -#if _SLANG_HAS_DEBUG_CODE - if ((name != NULL) - && (NULL == (name = SLang_create_slstring (name)))) - { - SLfree ((char *) cc); - SLfree ((char *) lns); - return -1; - } - - cc->compile_filename = This_Compile_Filename; - This_Compile_Filename = name; -#endif - - cc->static_namespace = This_Static_NameSpace; - cc->compile_variable_mode = Default_Variable_Mode; - cc->define_function = Default_Define_Function; - cc->locals_hash_table = Locals_Hash_Table; - - cc->lang_defining_function = Lang_Defining_Function; - cc->local_variable_number = Local_Variable_Number; - cc->function_args_number = Function_Args_Number; - cc->locals_hash_table = Locals_Hash_Table; - cc->compile_mode_function = Compile_Mode_Function; - - cc->next = Compile_Context_Stack; - Compile_Context_Stack = cc; - - Compile_Mode_Function = compile_basic_token_mode; - Default_Variable_Mode = compile_public_variable_mode; - Default_Define_Function = define_public_function; - Lang_Defining_Function = 0; - Local_Variable_Number = 0; - Function_Args_Number = 0; - Locals_Hash_Table = lns; - return 0; -} - -static int init_interpreter (void) -{ - SLang_NameSpace_Type *ns; - - if (Global_NameSpace != NULL) - return 0; - - if (NULL == (ns = _SLns_allocate_namespace ("***GLOBAL***", SLGLOBALS_HASH_TABLE_SIZE))) - return -1; - if (-1 == _SLns_set_namespace_name (ns, "Global")) - return -1; - Global_NameSpace = ns; - - _SLRun_Stack = (SLang_Object_Type *) SLcalloc (SLANG_MAX_STACK_LEN, - sizeof (SLang_Object_Type)); - if (_SLRun_Stack == NULL) - return -1; - - _SLStack_Pointer = _SLRun_Stack; - _SLStack_Pointer_Max = _SLRun_Stack + SLANG_MAX_STACK_LEN; - - SLShort_Blocks[0].bc_main_type = _SLANG_BC_RETURN; - SLShort_Blocks[2].bc_main_type = _SLANG_BC_BREAK; - SLShort_Blocks[4].bc_main_type = _SLANG_BC_CONTINUE; - - Num_Args_Stack = (int *) SLmalloc (sizeof (int) * SLANG_MAX_RECURSIVE_DEPTH); - if (Num_Args_Stack == NULL) - { - SLfree ((char *) _SLRun_Stack); - return -1; - } - Recursion_Depth = 0; - Frame_Pointer_Stack = (unsigned int *) SLmalloc (sizeof (unsigned int) * SLANG_MAX_RECURSIVE_DEPTH); - if (Frame_Pointer_Stack == NULL) - { - SLfree ((char *) _SLRun_Stack); - SLfree ((char *)Num_Args_Stack); - return -1; - } - Frame_Pointer_Depth = 0; - Frame_Pointer = _SLRun_Stack; - - Default_Variable_Mode = compile_public_variable_mode; - Default_Define_Function = define_public_function; - return 0; -} - -static int add_generic_table (SLang_NameSpace_Type *ns, - SLang_Name_Type *table, char *pp_name, - unsigned int entry_len) -{ - SLang_Name_Type *t, **ns_table; - char *name; - unsigned int table_size; - - if (-1 == init_interpreter ()) - return -1; - - if (ns == NULL) - ns = Global_NameSpace; - - ns_table = ns->table; - table_size = ns->table_size; - - if ((pp_name != NULL) - && (-1 == SLdefine_for_ifdef (pp_name))) - return -1; - - t = table; - while (NULL != (name = t->name)) - { - unsigned long hash; - - /* Backward compatibility: '.' WAS used as hash marker */ - if (*name == '.') - { - name++; - t->name = name; - } - - if (NULL == (name = SLang_create_slstring (name))) - return -1; - - t->name = name; - - hash = _SLcompute_string_hash (name); - hash = hash % table_size; - - t->next = ns_table [(unsigned int) hash]; - ns_table [(unsigned int) hash] = t; - - t = (SLang_Name_Type *) ((char *)t + entry_len); - } - - return 0; -} - -int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); -} - -int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); -} - -int SLadd_app_unary_table (SLang_App_Unary_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); -} - -int SLadd_math_unary_table (SLang_Math_Unary_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); -} - -int SLadd_iconstant_table (SLang_IConstant_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); -} - -#if SLANG_HAS_FLOAT -int SLadd_dconstant_table (SLang_DConstant_Type *tbl, char *pp) -{ - return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); -} -#endif - -/* ----------- */ -int SLns_add_intrin_fun_table (SLang_NameSpace_Type *ns, SLang_Intrin_Fun_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type)); -} - -int SLns_add_intrin_var_table (SLang_NameSpace_Type *ns, SLang_Intrin_Var_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type)); -} - -int SLns_add_app_unary_table (SLang_NameSpace_Type *ns, SLang_App_Unary_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type)); -} - -int SLns_add_math_unary_table (SLang_NameSpace_Type *ns, SLang_Math_Unary_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); -} - -int SLns_add_iconstant_table (SLang_NameSpace_Type *ns, SLang_IConstant_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type)); -} - -#if SLANG_HAS_FLOAT -int SLns_add_dconstant_table (SLang_NameSpace_Type *ns, SLang_DConstant_Type *tbl, char *pp) -{ - return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type)); -} -#endif - -/* what is a bitmapped value: - * 1 intrin fun - * 2 user fun - * 4 intrin var - * 8 user defined var - */ -SLang_Array_Type *_SLang_apropos (char *namespace_name, char *pat, unsigned int what) -{ - SLang_NameSpace_Type *ns; - - if (namespace_name == NULL) - namespace_name = "Global"; - - if (*namespace_name == 0) - ns = This_Static_NameSpace; - else ns = _SLns_find_namespace (namespace_name); - - return _SLnspace_apropos (ns, pat, what); -} - -void _SLang_implements_intrinsic (char *name) -{ - if (This_Static_NameSpace == NULL) - { - SLang_verror (SL_INTRINSIC_ERROR, "No namespace available"); - return; - } - - (void) _SLns_set_namespace_name (This_Static_NameSpace, name); - - Default_Define_Function = define_static_function; - Default_Variable_Mode = compile_static_variable_mode; -} - -void _SLang_use_namespace_intrinsic (char *name) -{ - SLang_NameSpace_Type *ns; - - if (NULL == (ns = _SLns_find_namespace (name))) - { - SLang_verror (SL_INTRINSIC_ERROR, "Namespace %s does not exist", name); - return; - } - This_Static_NameSpace = ns; - if (Global_NameSpace == ns) - { - Default_Define_Function = define_public_function; - Default_Variable_Mode = compile_public_variable_mode; - } - else - { - Default_Define_Function = define_static_function; - Default_Variable_Mode = compile_static_variable_mode; - } -} - - -char *_SLang_cur_namespace_intrinsic (void) -{ - if (This_Static_NameSpace == NULL) - return "Global"; - - if (This_Static_NameSpace->namespace_name == NULL) - return ""; - - return This_Static_NameSpace->namespace_name; -} |