/* -*- 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 <stdio.h>
#if SLANG_HAS_FLOAT
# include <math.h>
#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;
}
