From 98a18b797c63ea9baab31768ed720ad32c0004e8 Mon Sep 17 00:00:00 2001 From: Guillaume Cottenceau Date: Mon, 14 May 2001 21:47:42 +0000 Subject: i can compile slang and newt with dietlibc now --- mdk-stage1/slang/slang.c | 5547 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 5547 insertions(+) create mode 100644 mdk-stage1/slang/slang.c (limited to 'mdk-stage1/slang/slang.c') diff --git a/mdk-stage1/slang/slang.c b/mdk-stage1/slang/slang.c new file mode 100644 index 000000000..6edc7df37 --- /dev/null +++ b/mdk-stage1/slang/slang.c @@ -0,0 +1,5547 @@ +/* -*- 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 +#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; +} -- cgit v1.2.1