/* -*- mode: C; mode: fold; -*- */ /* slang.c --- guts of S-Lang interpreter */ /* Copyright (c) 1992, 1995 John E. Davis * All rights reserved. * * You may distribute under the terms of either the GNU General Public * License or the Perl Artistic License. */ #include "config.h" #include "sl-feat.h" #include #if SLANG_HAS_FLOAT # include #endif #include "slang.h" #include "_slang.h" int SLang_Version = SLANG_VERSION; struct _SLBlock_Type; typedef struct { char *name; SLang_Name_Type *next; char name_type; struct _SLBlock_Type *addr; /* address of function */ 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; #define SLANG_MAX_LOCAL_VARIABLES 254 #define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1) 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_Function_Type *nt_fun_blk; VOID_STAR ptr_blk; char *s_blk; #if SLANG_HAS_FLOAT double *f_blk; /*literal double is a pointer */ #endif 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 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 lang_dump(char *s) { while (*s) { if (*s == '\n') fputc ('\r', stderr); fputc (*s, stderr); s++; } } void (*SLang_Dump_Routine)(char *) = lang_dump; static void do_traceback (char *, unsigned int); /*{{{ push/pop/etc stack manipulation functions */ /* This routine is assumed to work even in the presence of a SLang_Error. */ 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; _SLStack_Pointer = _SLRun_Stack; x->data_type = 0; return -1; } y--; *x = *y; _SLStack_Pointer = y; return 0; } int _SLang_pop_i_val (unsigned char type, int *i_val) { register SLang_Object_Type *y; y = _SLStack_Pointer; if (y == _SLRun_Stack) { if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW; _SLStack_Pointer = _SLRun_Stack; return -1; } y--; _SLStack_Pointer = y; if (y->data_type != type) { _SLclass_type_mismatch_error (type, y->data_type); SLang_free_object (y); return -1; } *i_val = y->v.i_val; return 0; } 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; } void SLang_free_object (SLang_Object_Type *obj) { unsigned char data_type; SLang_Class_Type *cl; data_type = obj->data_type; #if _SLANG_OPTIMIZE_FOR_SPEED if (_SLclass_is_scalar_type [data_type]) return; #endif cl = _SLclass_get_class (data_type); if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR) (*cl->cl_destroy) (data_type, (VOID_STAR) &obj->v); } 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; } int _SLang_push_void_star (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.p_val = pval; _SLStack_Pointer = y + 1; return 0; } int _SLang_push_i_val (unsigned char type, int i_val) { 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.i_val = i_val; _SLStack_Pointer = y + 1; return 0; } int _SLang_pop_object_of_type (unsigned char type, SLang_Object_Type *obj) { if (-1 == SLang_pop (obj)) return -1; if (obj->data_type != type) { _SLclass_type_mismatch_error (type, obj->data_type); SLang_free_object (obj); return -1; } 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); } 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); } /*}}}*/ /*{{{ inner interpreter and support functions */ static int 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; } static int 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; } static int do_name_type_error (SLang_Name_Type *nt) { char buf[256]; if (nt != NULL) { sprintf (buf, "(Error occurred processing %s)", nt->name); do_traceback (buf, 0); } 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; a_cl = _SLclass_get_class (a_data_type); b_cl = _SLclass_get_class (b_data_type); if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl))) return -1; c_data_type = c_cl->cl_data_type; #if _SLANG_OPTIMIZE_FOR_SPEED if (_SLclass_is_scalar_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 (_SLclass_is_scalar_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 (0 == _SLclass_is_scalar_type [c_data_type]) #endif (*c_cl->cl_adestroy)(c_data_type, pc); return ret; } 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 (0 == _SLclass_is_scalar_type [obja.data_type]) #endif SLang_free_object (&obja); } #if _SLANG_OPTIMIZE_FOR_SPEED if (0 == _SLclass_is_scalar_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 (_SLclass_is_scalar_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 (0 == _SLclass_is_scalar_type [b_type]) #endif (*b_cl->cl_adestroy)(b_type, pb); return ret; } 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 (0 == _SLclass_is_scalar_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 (0 == _SLclass_is_scalar_type [objb.data_type]) #endif SLang_free_object (&objb); return ret; } static int perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr) { switch (op_type) { case _SLANG_BCST_ASSIGN: break; case _SLANG_BCST_PLUSEQS: if (-1 == do_assignment_binary (SLANG_PLUS, obja_ptr)) return -1; break; case _SLANG_BCST_MINUSEQS: if (-1 == do_assignment_binary (SLANG_MINUS, 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 _SLang_push_i_val (SLANG_INT_TYPE, obja_ptr->v.i_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 _SLang_push_i_val (SLANG_INT_TYPE, obja_ptr->v.i_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; } 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 (0 == _SLclass_is_scalar_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) { SLang_Object_Type *obja_ptr; if (NULL == (obja_ptr = _SLstruct_get_assign_obj (bc_blk->b.s_blk))) return -1; return set_lvalue_obj (bc_blk->bc_sub_type, obja_ptr); } 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: 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: 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 void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir) { unsigned int len; char buf[256]; char prefix [52]; len = Trace_Mode - 1; if (len + 2 >= sizeof (prefix)) len = sizeof (prefix) - 2; SLMEMSET (prefix, ' ', len); prefix[len] = 0; (SLang_Dump_Routine) (prefix); sprintf (buf, format, name, n); (*SLang_Dump_Routine) (buf); 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) { if (-1 == SLang_pop (obj)) return NULL; if (type != obj->data_type) { if (type != 0) { SLang_push (obj); if (-1 == _SLclass_typecast (type, 1, 0)) return NULL; if (-1 == SLang_pop (obj)) return NULL; } type = obj->data_type; } if ( #if _SLANG_OPTIMIZE_FOR_SPEED _SLclass_is_scalar_type [type] #else SLANG_CLASS_TYPE_SCALAR == _SLclass_get_class (type)->cl_class_type #endif ) return (VOID_STAR) &obj->v; else return obj->v.p_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]; SLang_Class_Type *cl; 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 == 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]))) 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; } if (type != SLANG_VOID_TYPE) { cl = _SLclass_get_class (type); switch (cl->cl_class_type) { case SLANG_CLASS_TYPE_SCALAR: #if SLANG_HAS_FLOAT if (type == SLANG_DOUBLE_TYPE) (void) SLang_push_double (xf); else #endif (void) (*cl->cl_push) (type, (VOID_STAR) &ret); break; default: if ((VOID_STAR) ret == NULL) { if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR; } else (void) (*cl->cl_push) (type, (VOID_STAR) &ret); } } 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 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; for (i = 0; i < (int) num_blocks; i++) { if (block[i].bc_main_type != _SLANG_BC_BLOCK) { SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block"); return; } blks[i] = block[i].b.blk; } block = blks[0]; switch (stype) { case _SLANG_BCST_WHILE: loop_name = "while"; if (num_blocks != 2) goto wrong_num_blocks_error; while (1) { if (SLang_Error) goto return_error; inner_interp (block); if (Lang_Break) break; if (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &ctrl)) goto return_error; if (ctrl == 0) break; 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; inner_interp (blks[1]); if (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &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 == _SLang_pop_i_val (SLANG_INT_TYPE, &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_i_val (SLANG_INT_TYPE, &ctrl)) || (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &last)) || (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &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; _SLang_push_i_val (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_i_val (SLANG_INT_TYPE, &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); } 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) { inner_interp (addr->b.blk); if (SLang_Error || Lang_Break_Condition || (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &test))) return; if (is_or == (test != 0)) break; /* if (((stype == _SLANG_BCST_ANDELSE) && (test == 0)) * || ((stype == _SLANG_BCST_ORELSE) && test)) * break; */ addr++; } _SLang_push_i_val (SLANG_INT_TYPE, test); } static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block) { int test; if (-1 == _SLang_pop_i_val (SLANG_INT_TYPE, &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 buf[256]; char *s; SLang_Class_Type *cl; while (n) { cl = _SLclass_get_class (x->data_type); (*SLang_Dump_Routine) (prefix); sprintf (buf, "[%s]:", cl->cl_name); (*SLang_Dump_Routine)(buf); if (NULL != (s = _SLstringize_object (x))) (*SLang_Dump_Routine)(s); (*SLang_Dump_Routine)("\n"); 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_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; increment_frame_pointer (); /* need loaded? */ if (fun->nlocals == AUTOLOAD_NUM_LOCALS) { if (-1 == SLang_load_file((char *) fun->addr)) 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; val = fun->addr; /* 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; } 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(val); 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(val); 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); /* free local variables.... */ lvf = Local_Variable_Frame; while (lvf > frame) { #if _SLANG_OPTIMIZE_FOR_SPEED if (0 == _SLclass_is_scalar_type [lvf->data_type]) #endif SLang_free_object (lvf); lvf--; } Local_Variable_Frame = lvf; 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; decrement_frame_pointer (); if (SLang_Error) return -1; return 0; } static void do_traceback (char *name, unsigned int locals) { char buf[512]; char *s; unsigned int i; SLang_Object_Type *objp; unsigned short stype; if (SLang_Traceback == 0) return; sprintf(buf, "S-Lang Traceback: %s\n", name); (*SLang_Dump_Routine)(buf); if ((locals == 0) || (SLang_Traceback < 0)) return; (*SLang_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; sprintf (buf, "\t$%d: Type: %s,\tValue:\t", i, class_name); (*SLang_Dump_Routine)(buf); if (s == NULL) (*SLang_Dump_Routine)("??"); else { if (SLANG_STRING_TYPE == stype) (*SLang_Dump_Routine) ("\""); (*SLang_Dump_Routine)(s); if (SLANG_STRING_TYPE == stype) (*SLang_Dump_Routine) ("\""); SLang_free_slstring (s); } (*SLang_Dump_Routine)("\n"); } } 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); } int _SLang_dereference_ref (_SLang_Ref_Type *ref) { SLBlock_Type bc_blks[2]; SLang_Name_Type *nt; 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); } nt = ref->v.nt; bc_blks[0].b.nt_blk = nt; bc_blks[0].bc_main_type = nt->name_type; bc_blks[1].bc_main_type = 0; inner_interp(bc_blks); return 0; } #ifdef SLANG_STATS static unsigned long stat_counts[256]; #endif 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; subtype = obj->data_type; #if _SLANG_OPTIMIZE_FOR_SPEED if (_SLclass_is_scalar_type[subtype]) return SLang_push (obj); #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) (void) _SLang_push_i_val (SLANG_INT_TYPE, 0); else (void) do_binary_ab (SLANG_EQ, swobjptr, &obj); SLang_free_object (&obj); return 0; } 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; } else SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow"); Frame_Pointer_Depth++; Next_Function_Num_Args = 0; if (SLang_Error) return -1; return 0; } 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; } 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) return 0; } else { 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 occured on line %u)", addr->b.i_blk); do_traceback (buf, 0); break; } addr--; } #endif return -1; } /* 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; /* 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; while (1) { switch (addr->bc_main_type) { case 0: return 1; case _SLANG_BC_CALL_DIRECT: (*addr->b.call_function) (); break; case _SLANG_BC_CALL_DIRECT_FRAME: if ((0 == SLang_end_arg_list ()) && (0 == increment_frame_pointer ())) { (*addr->b.call_function) (); decrement_frame_pointer (); } break; case _SLANG_BC_LVARIABLE: _SLpush_slang_obj (Local_Variable_Frame - addr->b.i_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); 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_BINARY: do_binary (addr->b.i_blk); break; case _SLANG_BC_UNARY: do_unary (addr->b.i_blk, _SLANG_BC_UNARY); break; case _SLANG_BC_MATH_UNARY: case _SLANG_BC_APP_UNARY: do_app_unary (addr->b.nt_unary_blk); break; #if _SLANG_OPTIMIZE_FOR_SPEED case _SLANG_BC_LITERAL_INT: _SLang_push_i_val (SLANG_INT_TYPE, addr->b.i_blk); break; case _SLANG_BC_LITERAL_STR: SLang_push_string (addr->b.s_blk); break; #else case _SLANG_BC_LITERAL_STR: case _SLANG_BC_LITERAL_INT: #endif case _SLANG_BC_LITERAL: { 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; 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: 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: do_else_if (addr, NULL); break; case _SLANG_BCST_IF: do_else_if (NULL, addr); 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_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_STRUCT_LVALUE: set_struct_lvalue (addr); break; case _SLANG_BC_SET_INTRIN_LVALUE: set_intrin_lvalue (addr); break; case _SLANG_BC_DEREF_ASSIGN: set_deref_lvalue (addr); 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_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_i_val (SLANG_INT_TYPE, &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_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_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_FIELD: (void) _SLstruct_get_field (addr->b.s_blk); break; #if _SLANG_HAS_DEBUG_CODE case _SLANG_BC_LINE_NUM: break; #endif default : SLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type); } if (SLang_Error) { if (-1 == do_inner_interp_error (err_block, addr_start, addr)) 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. */ } 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 *Globals_Hash_Table [SLGLOBALS_HASH_TABLE_SIZE]; static SLang_Name_Type *Locals_Hash_Table [SLLOCALS_HASH_TABLE_SIZE]; static int Local_Variable_Number; static unsigned int Function_Args_Number; int _SLang_Auto_Declare_Globals = 0; static SLBlock_Type SLShort_Blocks[3]; /* These are initialized in add_table below. I cannot init a Union!! */ static int Lang_Defining_Function; 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 */ } 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) { if ((p == SLShort_Blocks) || (p == SLShort_Blocks + 1) || (p == SLShort_Blocks + 2) ) 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 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; 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; return 0; } /* 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. */ int _SLcompile_push_context (void) { if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL)) 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); } if (-1 == pop_block_context ()) return -1; if (This_Compile_Block == NULL) return 0; if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) { SLang_verror (SL_INTERNAL_ERROR, "Not at top-level"); return -1; } 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; } /* check syntax. Allowed chars are: $!_?AB..Zab..z0-9 */ static int lang_check_name (char *name) { register char *p, ch; p = name; while ((ch = *p++) != 0) { if ((ch >= 'a') && (ch <= 'z')) continue; if ((ch >= 'A') && (ch <= 'Z')) continue; if ((ch >= '0') && (ch <= '9')) continue; if ((ch == '_') || (ch == '$') || (ch == '!') || (ch == '?')) continue; SLang_verror (SL_SYNTAX_ERROR, "%s: bad name syntax", name); return -1; } return 0; } 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; } return locate_name_in_table (name, hash, Globals_Hash_Table, SLGLOBALS_HASH_TABLE_SIZE); } 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 == lang_check_name(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_Name_Type *nt; nt = locate_name_in_table (name, hash, Globals_Hash_Table, SLGLOBALS_HASH_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, Globals_Hash_Table, SLGLOBALS_HASH_TABLE_SIZE, 0); } int SLadd_intrinsic_function (char *name, FVOID_STAR addr, unsigned char ret_type, unsigned int nargs, ...) { SLang_Intrin_Fun_Type *f; va_list ap; unsigned int i; if (nargs > SLANG_MAX_INTRIN_ARGS) { SLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name); return -1; } f = (SLang_Intrin_Fun_Type *) add_global_name (name, _SLcompute_string_hash (name), SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type)); if (f == NULL) return -1; f->i_fun = addr; f->num_args = nargs; f->return_type = ret_type; va_start (ap, nargs); for (i = 0; i < nargs; i++) f->arg_types [i] = va_arg (ap, unsigned int); va_end (ap); return 0; } int SLadd_intrinsic_variable (char *name, VOID_STAR addr, unsigned char data_type, int ro) { SLang_Intrin_Var_Type *v; v = (SLang_Intrin_Var_Type *)add_global_name (name, _SLcompute_string_hash (name), (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE), sizeof (SLang_Intrin_Var_Type)); if (v == NULL) return -1; v->addr = addr; v->type = data_type; return 0; } static int add_slang_function (char *name, unsigned long hash, unsigned int num_args, unsigned int num_locals, SLBlock_Type *addr) { _SLang_Function_Type *f; f = (_SLang_Function_Type *)add_global_name (name, hash, SLANG_FUNCTION, sizeof (_SLang_Function_Type)); if (f == NULL) return -1; if (f->addr != NULL) { if (f->nlocals == AUTOLOAD_NUM_LOCALS) SLang_free_slstring ((char *)f->addr); /* autoloaded filename */ else if (lang_free_branch(f->addr)) SLfree((char *)f->addr); } f->addr = addr; 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, Globals_Hash_Table, SLGLOBALS_HASH_TABLE_SIZE); if ((f != NULL) && (f->name_type == SLANG_FUNCTION) && (f->addr != NULL) && (f->nlocals != AUTOLOAD_NUM_LOCALS)) { /* already loaded */ return 0; } file = SLang_create_slstring (file); if (-1 == add_slang_function (name, hash, 0, AUTOLOAD_NUM_LOCALS, (SLBlock_Type *) file)) { SLang_free_slstring (file); return -1; } return 0; } static SLang_Name_Type *locate_global_name (char *name) { unsigned long hash; hash = _SLcompute_string_hash (name); return locate_name_in_table (name, hash, Globals_Hash_Table, SLGLOBALS_HASH_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; } int SLexecute_function (SLang_Name_Type *nt) { unsigned char type; char *name; type = nt->name_type; name = nt->name; if (type == SLANG_FUNCTION) execute_slang_fun ((_SLang_Function_Type *) nt); else if (type == SLANG_INTRINSIC) execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt); else { 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 = locate_global_name (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_global_name (name))) 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); } /* 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 long hash) { 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) { (void) add_slang_function (name, hash, Function_Args_Number, Local_Variable_Number, This_Compile_Block); } 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 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 + (int) (mtype - _SLANG_BC_RETURN); } } 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 (NULL == (t = locate_global_name (name))) return 0; switch (t->name_type) { case SLANG_FUNCTION: return 2; case SLANG_GVARIABLE: return -2; case SLANG_RVARIABLE: case SLANG_IVARIABLE: return -1; case SLANG_INTRINSIC: default: return 1; } } static int add_global_variable (char *name, unsigned long hash) { 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, Globals_Hash_Table, SLGLOBALS_HASH_TABLE_SIZE); if ((g != NULL) && (g->name_type == SLANG_GVARIABLE)) return 0; if (NULL == add_global_name (name, hash, SLANG_GVARIABLE, sizeof (SLang_Global_Var_Type))) return -1; return 0; } int SLadd_global_variable (char *name) { return add_global_variable (name, _SLcompute_string_hash (name)); } static int add_hashed_variable (char *name, unsigned long hash) { SLang_Local_Var_Type *t; if (Lang_Defining_Function == 0) return add_global_variable (name, hash); /* 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, 0); 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) { Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_UNARY; 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 (); } static void compile_hashed_identifier (char *name, unsigned long hash) { SLang_Name_Type *entry; unsigned char name_type; entry = locate_hashed_name (name, hash); if (entry == NULL) { int i = 0; /* Perhaps it is a user/error block */ if (0 == strcmp (name, "EXECUTE_ERROR_BLOCK")) name_type = _SLANG_BC_X_ERROR; else if ((0 == strncmp ("X_USER_BLOCK", name, 12)) && ((i = name[12]) < '5') && (i >= '0') && (name[13] == 0)) name_type = _SLANG_BC_X_USER0 + (i - '0'); else { SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); return; } Compile_ByteCode_Ptr->bc_main_type = name_type; Compile_ByteCode_Ptr->b.blk = NULL; lang_try_now (); 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_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) { compile_hashed_identifier (name, _SLcompute_string_hash (name)); } 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_integer (int i) { Compile_ByteCode_Ptr->b.i_blk = i; Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_INT; Compile_ByteCode_Ptr->bc_sub_type = SLANG_INT_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 != sscanf (str, "%lf", &d)) { SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to double", str); return; } #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.f_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 (); } #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 (); } /* 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) || (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL) || (assign_type != _SLANG_BCST_ASSIGN)) { SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name); return; } if ((-1 == add_hashed_variable (name, hash)) || (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: 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 already defined", 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: Compile_ByteCode_Ptr->b.nt_blk = v; break; default: /* FIXME!! 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_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_variable_mode (_SLang_Token_Type *t) { if (t->type == IDENT_TOKEN) add_hashed_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_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, t->hash); Compile_Mode_Function = compile_basic_token_mode; } /* 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; } 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 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 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 STATIC_TOKEN: case PUSH_TOKEN: case NOP_TOKEN: case EOF_TOKEN: case READONLY_TOKEN: case DO_TOKEN: case VARIABLE_TOKEN: case DEFINE_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 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); 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_call_direct (SLang_end_arg_list, _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: case INT_TOKEN: compile_integer (t->v.i_val); break; #if SLANG_HAS_FLOAT 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 _NULL_TOKEN: compile_identifier ("NULL"); 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_call_direct (_SLarray_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_POST_MINUSMINUS_TOKEN: case _ARRAY_MINUSMINUS_TOKEN: case _ARRAY_POST_PLUSPLUS_TOKEN: case _ARRAY_PLUSPLUS_TOKEN: SLang_verror (SL_NOT_IMPLEMENTED, "Array assignment op not implemented"); break; case _ARRAY_ASSIGN_TOKEN: compile_call_direct (_SLarray_aput, _SLANG_BC_CALL_DIRECT_FRAME); break; case _STRUCT_ASSIGN_TOKEN: case _STRUCT_PLUSEQS_TOKEN: case _STRUCT_MINUSEQS_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_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 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_binary (SLANG_PLUS); break; case SUB_TOKEN: compile_binary (SLANG_MINUS); break; case MUL_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 MUL2_TOKEN: compile_unary (SLANG_MUL2); break; case NOT_TOKEN: compile_unary (SLANG_NOT); break; case ABS_TOKEN: compile_unary (SLANG_ABS); break; case BNOT_TOKEN: compile_unary (SLANG_BNOT); break; case CHS_TOKEN: compile_unary (SLANG_CHS); break; case SQR_TOKEN: compile_unary (SLANG_SQR); break; case SIGN_TOKEN: compile_unary (SLANG_SIGN); 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!! */ break; case OBRACKET_TOKEN: Compile_Mode_Function = compile_variable_mode; break; case OPAREN_TOKEN: lang_begin_function (); 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.i_blk = t->v.i_val; lang_try_now (); break; #endif } } 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; static int init_interpreter (void) { _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[1].bc_main_type = _SLANG_BC_BREAK; SLShort_Blocks[2].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; return 0; } static int add_generic_table (SLang_Name_Type *table, char *pp_name, unsigned int entry_len) { SLang_Name_Type *t; char *name; static int init = 0; if (init == 0) { if (-1 == init_interpreter ()) return -1; init = 1; } 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 == SLang_create_static_slstring (name)) return -1; hash = _SLcompute_string_hash (name); hash = hash % SLGLOBALS_HASH_TABLE_SIZE; t->next = Globals_Hash_Table [(unsigned int) hash]; Globals_Hash_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 ((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 ((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 ((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 ((SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type)); } /* what is a bitmapped value: * 1 intrin fun * 2 user fun * 4 intrin var * 8 user defined var */ int _SLang_apropos (char *s, unsigned int what) { SLang_Name_Type *t; unsigned int i, n; int all; all = (*s == 0); n = 0; for (i = 0; i < SLGLOBALS_HASH_TABLE_SIZE; i++) { t = Globals_Hash_Table [i]; while (t != NULL) { char *name; name = t->name; if (all || (NULL != strstr (name, s))) { unsigned int ok; switch (t->name_type) { case SLANG_GVARIABLE: ok = (what & 8); break; case SLANG_IVARIABLE: case SLANG_RVARIABLE: ok = (what & 4); break; case SLANG_FUNCTION: ok = (what & 2); break; default: ok = (what & 1); break; } if (ok) { if (-1 == SLang_push_string (name)) { SLang_free_slstring (s); SLdo_pop_n (n); return -1; } n++; } } t = t->next; } } return n; }