slang.c

一个C格式的脚本处理函数库源代码,可让你的C程序具有执行C格式的脚本文件

/* -*- mode: C; mode: fold; -*- */
/* slang.c  --- guts of S-Lang interpreter */
/* Copyright (c) 1992, 1999, 2001, 2002, 2003 John E. Davis
 * This file is part of the S-Lang library.
 *
 * You may distribute under the terms of either the GNU General Public
 * License or the Perl Artistic License.
 */

#include "slinclud.h"

#if SLANG_HAS_FLOAT
# include <math.h>
#endif

#include "slang.h"
#include "_slang.h"

#define USE_COMBINED_BYTECODES	1

struct _SLBlock_Type;

typedef struct
{
   struct _SLBlock_Type *body;
   unsigned int num_refs;
}
_SLBlock_Header_Type;

typedef struct
{
   char *name;
   SLang_Name_Type *next;
   char name_type;

   union
     {
	_SLBlock_Header_Type *header;    /* body of function */
	char *autoload_filename;
     }
   v;
#if _SLANG_HAS_DEBUG_CODE
   char *file;
#endif
#define SLANG_MAX_LOCAL_VARIABLES 254
#define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1)
   unsigned char nlocals;	       /* number of local variables */
   unsigned char nargs;		       /* number of arguments */
}
_SLang_Function_Type;

typedef struct
{
   char *name;
   SLang_Name_Type *next;
   char name_type;

   SLang_Object_Type obj;
}
SLang_Global_Var_Type;

typedef struct
{
   char *name;
   SLang_Name_Type *next;
   char name_type;

   int local_var_number;
}
SLang_Local_Var_Type;

typedef struct _SLBlock_Type
{
   unsigned char bc_main_type;
   unsigned char bc_sub_type;
   union
     {
	struct _SLBlock_Type *blk;
	int i_blk;

	SLang_Name_Type *nt_blk;
	SLang_App_Unary_Type *nt_unary_blk;
	SLang_Intrin_Var_Type *nt_ivar_blk;
	SLang_Intrin_Fun_Type *nt_ifun_blk;
	SLang_Global_Var_Type *nt_gvar_blk;
	SLang_IConstant_Type *iconst_blk;
	SLang_DConstant_Type *dconst_blk;
	_SLang_Function_Type *nt_fun_blk;

	VOID_STAR ptr_blk;
	char *s_blk;
	SLang_BString_Type *bs_blk;

#if SLANG_HAS_FLOAT
	double *double_blk;		       /*literal double is a pointer */
#endif
	float float_blk;
	long l_blk;
	struct _SLang_Struct_Type *struct_blk;
	int (*call_function)(void);
     }
   b;
}
SLBlock_Type;

static SLBlock_Type SLShort_Blocks[6];
/* These are initialized in add_table below.  I cannot init a Union!! */

/* Do not change these.  Odd values are for termination */
#define SHORT_BLOCK_RETURN_INDX		0
#define SHORT_BLOCK_BREAK_INDX		2
#define SHORT_BLOCK_CONTINUE_INDX	4

/* Debugging and tracing variables */

void (*SLang_Enter_Function)(char *) = NULL;
void (*SLang_Exit_Function)(char *) = NULL;
/* If non null, these call C functions before and after a slang function. */

int _SLang_Trace = 0;
/* If _SLang_Trace = -1, do not trace intrinsics */
static int Trace_Mode = 0;

static char *Trace_Function;	       /* function to be traced */
int SLang_Traceback = 0;
/* non zero means do traceback.  If less than 0, do not show local variables */

/* These variables handle _NARGS processing by the parser */
int SLang_Num_Function_Args;
static int *Num_Args_Stack;
static unsigned int Recursion_Depth;
static SLang_Object_Type *Frame_Pointer;
static int Next_Function_Num_Args;
static unsigned int Frame_Pointer_Depth;
static unsigned int *Frame_Pointer_Stack;

static int Lang_Break_Condition = 0;
/* true if any one below is true.  This keeps us from testing 3 variables.
 * I know this can be perfomed with a bitmapped variable, but...
 */
static int Lang_Break = 0;
static int Lang_Return = 0;
/* static int Lang_Continue = 0; */

static SLang_Object_Type *_SLRun_Stack;
static SLang_Object_Type *_SLStack_Pointer;
static SLang_Object_Type *_SLStack_Pointer_Max;

/* Might want to increase this. */
static SLang_Object_Type Local_Variable_Stack[SLANG_MAX_LOCAL_STACK];
static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack;

static void free_function_header (_SLBlock_Header_Type *);

#if _SLANG_OPTIMIZE_FOR_SPEED
static SLtype Class_Type [256];
#endif
/* If 0, not an arith type.  Otherwise it is.  Also, value implies precedence 
 * See slarith.c for how this is used.
 */
static unsigned char Is_Arith_Type [256];

void (*SLang_Dump_Routine)(char *);

static void call_dump_routine (char *fmt, ...)
{
   char buf[1024];
   va_list ap;

   va_start (ap, fmt);
   if (SLang_Dump_Routine != NULL)
     {
	(void) _SLvsnprintf (buf, sizeof (buf), fmt, ap);
	(*SLang_Dump_Routine) (buf);
     }
   else
     {
	vfprintf (stderr, fmt, ap);
	fflush (stderr);
     }
   va_end (ap);
}

static void do_traceback (char *, unsigned int, char *);
static int init_interpreter (void);

/*{{{ push/pop/etc stack manipulation functions */

/* This routine is assumed to work even in the presence of a SLang_Error. */
_INLINE_
int SLang_pop (SLang_Object_Type *x)
{
   register SLang_Object_Type *y;

   y = _SLStack_Pointer;
   if (y == _SLRun_Stack)
     {
	if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW;
	x->data_type = 0;
	return -1;
     }
   y--;
   *x = *y;

   _SLStack_Pointer = y;
   return 0;
}

_INLINE_
int SLang_peek_at_stack (void)
{
   if (_SLStack_Pointer == _SLRun_Stack)
     {
	if (SLang_Error == 0)
	  SLang_Error = SL_STACK_UNDERFLOW;
	return -1;
     }

   return (_SLStack_Pointer - 1)->data_type;
}

static int pop_ctrl_integer (int *i)
{
   int type;
   SLang_Class_Type *cl;
#if _SLANG_OPTIMIZE_FOR_SPEED
   register SLang_Object_Type *y;

   /* Most of the time, either an integer or a char will be on the stack.
    * Optimize these cases.
    */
   y = _SLStack_Pointer;
   if (y == _SLRun_Stack)
     {
	if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW;
	return -1;
     }
   y--;
   
   type = y->data_type;
   if (type == SLANG_INT_TYPE)
     {
	_SLStack_Pointer = y;   
	*i = y->v.int_val;
	return 0;
     }
   if (type == SLANG_CHAR_TYPE)
     {
	_SLStack_Pointer = y;   
	*i = y->v.char_val;
	return 0;
     }
#else
   if (-1 == (type = SLang_peek_at_stack ()))
     return -1;
#endif

   cl = _SLclass_get_class ((unsigned char) type);
   if (cl->cl_to_bool == NULL)
     {
	SLang_verror (SL_TYPE_MISMATCH,
		      "%s cannot be used in a boolean context",
		      cl->cl_name);
	return -1;
     }
   return cl->cl_to_bool ((unsigned char) type, i);
}

int SLang_peek_at_stack1 (void)
{
   int type;

   type = SLang_peek_at_stack ();
   if (type == SLANG_ARRAY_TYPE)
     type = (_SLStack_Pointer - 1)->v.array_val->data_type;

   return type;
}

_INLINE_
void SLang_free_object (SLang_Object_Type *obj)
{
   unsigned char data_type;
   SLang_Class_Type *cl;

   if (obj == NULL) return;
   data_type = obj->data_type;
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR == Class_Type [data_type])
     return;
   if (data_type == SLANG_STRING_TYPE)
     {
	SLang_free_slstring (obj->v.s_val);
	return;
     }
#endif
   cl = _SLclass_get_class (data_type);
#if !_SLANG_OPTIMIZE_FOR_SPEED
   if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR)
#endif
     (*cl->cl_destroy) (data_type, (VOID_STAR) &obj->v);
}

_INLINE_
int SLang_push (SLang_Object_Type *x)
{
   register SLang_Object_Type *y;
   y = _SLStack_Pointer;

   /* if there is a SLang_Error, probably not much harm will be done
    if it is ignored here */
   /* if (SLang_Error) return; */

   /* flag it now */
   if (y >= _SLStack_Pointer_Max)
     {
	if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW;
	return -1;
     }

   *y = *x;
   _SLStack_Pointer = y + 1;
   return 0;
}

/* _INLINE_ */
int SLclass_push_ptr_obj (unsigned char type, VOID_STAR pval)
{
   register SLang_Object_Type *y;
   y = _SLStack_Pointer;

   if (y >= _SLStack_Pointer_Max)
     {
	if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW;
	return -1;
     }

   y->data_type = type;
   y->v.ptr_val = pval;

   _SLStack_Pointer = y + 1;
   return 0;
}

_INLINE_
int SLclass_push_int_obj (unsigned char type, int x)
{
   register SLang_Object_Type *y;
   y = _SLStack_Pointer;

   if (y >= _SLStack_Pointer_Max)
     {
	if (!SLang_Error) SLang_Error = SL_STACK_OVERFLOW;
	return -1;
     }

   y->data_type = type;
   y->v.int_val = x;

   _SLStack_Pointer = y + 1;
   return 0;
}

#if SLANG_HAS_FLOAT
_INLINE_
int SLclass_push_double_obj (unsigned char type, double x)
{
   SLang_Object_Type obj;
   obj.data_type = type;
   obj.v.double_val = x;
   return SLang_push (&obj);
}
#endif

_INLINE_
int _SLang_pop_object_of_type (unsigned char type, SLang_Object_Type *obj,
			       int allow_arrays)
{
   register SLang_Object_Type *y;

   y = _SLStack_Pointer;
   if (y == _SLRun_Stack)
     return SLang_pop (obj);
   y--;
   if (y->data_type != type)
     {
#if _SLANG_OPTIMIZE_FOR_SPEED
	/* This is an implicit typecast.  We do not want to typecast
	 * floats to ints implicitly.  
	 */
	if (Is_Arith_Type [type]
	    && Is_Arith_Type [y->data_type]
	    && (Is_Arith_Type [type] >= Is_Arith_Type[y->data_type]))
	  {
	     /* This should not fail */
	     (void) _SLarith_typecast (y->data_type, (VOID_STAR)&y->v, 1, 
				       type, (VOID_STAR)&obj->v);
	     obj->data_type = type;
	     _SLStack_Pointer = y;
	     return 0;
	  }
#endif
	
	if ((allow_arrays == 0)
	    || (y->data_type != SLANG_ARRAY_TYPE)
	    || (y->v.array_val->data_type != type))
	  if (-1 == SLclass_typecast (type, 1, 0))
	    return -1;
     }
   *obj = *y;
   _SLStack_Pointer = y;
   return 0;
}

/*  This function reverses the top n items on the stack and returns a
 *  an offset from the start of the stack to the last item.
 */
int SLreverse_stack (int n)
{
   SLang_Object_Type *otop, *obot, tmp;

   otop = _SLStack_Pointer;
   if ((n > otop - _SLRun_Stack) || (n < 0))
     {
	SLang_Error = SL_STACK_UNDERFLOW;
	return -1;
     }
   obot = otop - n;
   otop--;
   while (otop > obot)
     {
	tmp = *obot;
	*obot = *otop;
	*otop = tmp;
	otop--;
	obot++;
     }
   return (int) ((_SLStack_Pointer - n) - _SLRun_Stack);
}

_INLINE_
int SLroll_stack (int np)
{
   int n, i;
   SLang_Object_Type *otop, *obot, tmp;

   if ((n = abs(np)) <= 1) return 0;    /* identity */

   obot = otop = _SLStack_Pointer;
   i = n;
   while (i != 0)
     {
	if (obot <= _SLRun_Stack)
	  {
	     SLang_Error = SL_STACK_UNDERFLOW;
	     return -1;
	  }
	obot--;
	i--;
     }
   otop--;

   if (np > 0)
     {
	/* Put top on bottom and roll rest up. */
	tmp = *otop;
	while (otop > obot)
	  {
	     *otop = *(otop - 1);
	     otop--;
	  }
	*otop = tmp;
     }
   else
     {
	/* Put bottom on top and roll rest down. */
	tmp = *obot;
	while (obot < otop)
	  {
	     *obot = *(obot + 1);
	     obot++;
	  }
	*obot = tmp;
     }
   return 0;
}

int _SLstack_depth (void)
{
   return (int) (_SLStack_Pointer - _SLRun_Stack);
}

int SLdup_n (int n)
{
   SLang_Object_Type *bot, *top;

   if (n <= 0)
     return 0;
   
   top = _SLStack_Pointer;
   if (top < _SLRun_Stack + n)
     {
	if (SLang_Error == 0)
	  SLang_Error = SL_STACK_UNDERFLOW;
	return -1;
     }
   if (top + n > _SLStack_Pointer_Max)
     {
	if (SLang_Error == 0)
	  SLang_Error = SL_STACK_OVERFLOW;
	return -1;
     }
   bot = top - n;

   while (bot < top)
     {
	SLang_Class_Type *cl;
	unsigned char data_type = bot->data_type;

#if _SLANG_OPTIMIZE_FOR_SPEED
	if (SLANG_CLASS_TYPE_SCALAR == Class_Type [data_type])
	  {
	     *_SLStack_Pointer++ = *bot++;
	     continue;
	  }
#endif
	cl = _SLclass_get_class (data_type);
	if (-1 == (*cl->cl_push) (data_type, (VOID_STAR) &bot->v))
	  return -1;
	bot++;
     }
   return 0;
}

/*}}}*/

/*{{{ inner interpreter and support functions */

_INLINE_
int _SL_increment_frame_pointer (void)
{
   if (Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH)
     {
	SLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow");
	return -1;
     }
   Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args;

   SLang_Num_Function_Args = Next_Function_Num_Args;
   Next_Function_Num_Args = 0;
   Recursion_Depth++;
   return 0;
}

_INLINE_
int _SL_decrement_frame_pointer (void)
{
   if (Recursion_Depth == 0)
     {
	SLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow");
	return -1;
     }

   Recursion_Depth--;
   if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH)
     SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth];

   return 0;
}

_INLINE_
int SLang_start_arg_list (void)