slang.c

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

	if ((nt->name_type != SLANG_GVARIABLE)
	    && (nt->name_type != SLANG_PVARIABLE))
	  return -1;
	obj = &((SLang_Global_Var_Type *)nt)->obj;
     }
   SLang_free_object (obj);
   obj->data_type = SLANG_UNDEFINED_TYPE;
   obj->v.ptr_val = NULL;
   return 0;
}

void (*SLang_Interrupt)(void);
static int Last_Error;
void (*SLang_User_Clear_Error)(void);
void _SLang_clear_error (void)
{
   if (Last_Error <= 0)
     {
	Last_Error = 0;
	return;
     }
   Last_Error--;
   if (SLang_User_Clear_Error != NULL) (*SLang_User_Clear_Error)();
}

int _SLpush_slang_obj (SLang_Object_Type *obj)
{
   unsigned char subtype;
   SLang_Class_Type *cl;

   if (obj == NULL) return SLang_push_null ();

   subtype = obj->data_type;

#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR == Class_Type[subtype])
     return SLang_push (obj);
#endif

   cl = _SLclass_get_class (subtype);
   return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
}

_INLINE_
static int push_local_variable (int i)
{
   SLang_Class_Type *cl;
   SLang_Object_Type *obj;
   unsigned char subtype;

   obj = Local_Variable_Frame - i;
   subtype = obj->data_type;

#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR == Class_Type[subtype])
     return SLang_push (obj);
   if (subtype == SLANG_STRING_TYPE)
     return _SLang_dup_and_push_slstring (obj->v.s_val);
#endif

   cl = _SLclass_get_class (subtype);
   return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
}

static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar)
{
   SLang_Class_Type *cl;
   unsigned char stype;

   stype = ivar->type;
   cl = _SLclass_get_class (stype);

   if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr))
     {
	do_name_type_error ((SLang_Name_Type *) ivar);
	return -1;
     }
   return 0;
}

static int dereference_object (void)
{
   SLang_Object_Type obj;
   SLang_Class_Type *cl;
   unsigned char type;
   int ret;

   if (-1 == SLang_pop (&obj))
     return -1;

   type = obj.data_type;

   cl = _SLclass_get_class (type);
   ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v);

   SLang_free_object (&obj);
   return ret;
}

static int case_function (void)
{
   unsigned char type;
   SLang_Object_Type obj;
   SLang_Object_Type *swobjptr;

   swobjptr = Switch_Obj_Ptr - 1;

   if ((swobjptr < Switch_Objects)
       || (0 == (type = swobjptr->data_type)))
     {
	SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword");
	return -1;
     }

   if (-1 == SLang_pop (&obj))
     return -1;

   if (obj.data_type != type)
     {
	SLang_Class_Type *a_cl, *b_cl;

	a_cl = _SLclass_get_class (obj.data_type);
	b_cl = _SLclass_get_class (type);

	if (NULL == _SLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &a_cl, 0))
	  {
	     (void) SLclass_push_int_obj (SLANG_INT_TYPE, 0);
	     SLang_free_object (&obj);
	     return 0;
	  }
     }

   (void) do_binary_ab (SLANG_EQ, swobjptr, &obj);
   SLang_free_object (&obj);
   return 0;
}

static void tmp_variable_function (SLBlock_Type *addr)
{
   SLang_Object_Type *obj;

   switch (addr->bc_sub_type)
     {
      case SLANG_GVARIABLE:
      case SLANG_PVARIABLE:
	obj = &addr->b.nt_gvar_blk->obj;
	break;

      case SLANG_LVARIABLE:
	obj = Local_Variable_Frame - addr->b.i_blk;
	break;

      default:
	SLang_Error = SL_INTERNAL_ERROR;
	return;
     }

   /* There is no need to go through higher level routines since we are
    * not creating or destroying extra copies.
    */
   if (-1 == SLang_push (obj))
     return;

   obj->data_type = SLANG_UNDEFINED_TYPE;
   obj->v.ptr_val = NULL;
}


static int
do_inner_interp_error (SLBlock_Type *err_block,
		       SLBlock_Type *addr_start,
		       SLBlock_Type *addr)
{
   int save_err, slerr;

   /* Someday I can use the these variable to provide extra information
    * about what went wrong.
    */
   (void) addr_start;
   (void) addr;

   if (err_block == NULL)
     goto return_error;

   if (SLang_Error < 0)		       /* errors less than 0 are severe */
     goto return_error;

   save_err = Last_Error++;
   slerr = SLang_Error;
   SLang_Error = 0;
   inner_interp (err_block->b.blk);

   if (Last_Error <= save_err)
     {
	/* Caught error and cleared it */
	Last_Error = save_err;
	if ((Lang_Break_Condition == 0)
	    /* An error may have cleared the error and then caused the
	     * function to return.  We will allow that but let's not allow
	     * 'break' nor 'continue' statements until later.
	     */
	    || Lang_Return)
	  return 0;

	/* drop--- either a break or continue was called */
     }

   Last_Error = save_err;
   SLang_Error = slerr;

   return_error:
#if _SLANG_HAS_DEBUG_CODE
   while (addr >= addr_start)
     {
	if (addr->bc_main_type == _SLANG_BC_LINE_NUM)
	  {
	     char buf[256];
	     sprintf (buf, "(Error occurred on line %lu)", addr->b.l_blk);
	     do_traceback (buf, 0, NULL);
	     break;
	  }
	/* Special hack for 16 bit systems to prevent pointer wrapping. */
#if defined(__16_BIT_SYSTEM__)
	if (addr == addr_start)
	  break;
#endif
	addr--;
     }
#endif
   return -1;
}


#define GATHER_STATISTICS 0
#if GATHER_STATISTICS
static unsigned int Bytecodes[0xFFFF];

static void print_stats (void)
{
   unsigned int i;
   unsigned long total;
   FILE *fp = fopen ("stats.txt", "w");
   if (fp == NULL)
     return;
   
   total = 0;
   for (i = 0; i < 0xFFFF; i++)
     total += Bytecodes[i];
   
   if (total == 0)
     total = 1;

   for (i = 0; i < 0xFFFF; i++)
     {
	if (Bytecodes[i])
	  fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total);
     }
   fclose (fp);
}

static void add_to_statistics (SLBlock_Type *b)
{
   unsigned short x, y;
   
   x = b->bc_main_type;
   if (x == 0)
     {
	Bytecodes[0] += 1;
	return;
     }
   b++;
   y = b->bc_main_type;

   Bytecodes[(x << 8) | y] += 1;
}

#endif

/* inner interpreter */
/* The return value from this function is only meaningful when it is used
 * to process blocks for the switch statement.  If it returns 0, the calling
 * routine should pass the next block to it.  Otherwise it will
 * return non-zero, with or without error.
 */
static int inner_interp (SLBlock_Type *addr_start)
{
   SLBlock_Type *block, *err_block, *addr;
#if GATHER_STATISTICS
   static int inited = 0;

   if (inited == 0)
     {
	(void) SLang_add_cleanup_function (print_stats);
	inited = 1;
     }
#endif

   /* for systems that have no real interrupt facility (e.g. go32 on dos) */
   if (SLang_Interrupt != NULL) (*SLang_Interrupt)();

   block = err_block = NULL;
   addr = addr_start;

#if GATHER_STATISTICS
   add_to_statistics (addr);
#endif
   while (1)
     {
	switch (addr->bc_main_type)
	  {
	   case 0:
	     return 1;
	   case _SLANG_BC_LVARIABLE:
	     push_local_variable (addr->b.i_blk);
	     break;
	   case _SLANG_BC_GVARIABLE:
	     if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
	       do_name_type_error (addr->b.nt_blk);
	     break;

	   case _SLANG_BC_IVARIABLE:
	   case _SLANG_BC_RVARIABLE:
	     push_intrinsic_variable (addr->b.nt_ivar_blk);
	     break;

	   case _SLANG_BC_INTRINSIC:
	     execute_intrinsic_fun (addr->b.nt_ifun_blk);
	     if (SLang_Error)
	       do_traceback(addr->b.nt_ifun_blk->name, 0, NULL);
	     break;

	   case _SLANG_BC_FUNCTION:
	     execute_slang_fun (addr->b.nt_fun_blk);
	     if (Lang_Break_Condition) goto handle_break_condition;
	     break;

	   case _SLANG_BC_MATH_UNARY:
	   case _SLANG_BC_APP_UNARY:
	     /* Make sure we treat these like function calls since the
	      * parser took sin(x) to be a function call.
	      */
	     if (0 == _SL_increment_frame_pointer ())
	       {
		  do_app_unary (addr->b.nt_unary_blk);
		  (void) _SL_decrement_frame_pointer ();
	       }
	     break;

	   case _SLANG_BC_ICONST:
	     SLclass_push_int_obj (SLANG_INT_TYPE, addr->b.iconst_blk->i);
	     break;

#if SLANG_HAS_FLOAT
	   case _SLANG_BC_DCONST:
	     SLclass_push_double_obj (SLANG_DOUBLE_TYPE, addr->b.dconst_blk->d);
	     break;
#endif

	   case _SLANG_BC_PVARIABLE:
	     if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
	       do_name_type_error (addr->b.nt_blk);
	     break;

	   case _SLANG_BC_PFUNCTION:
	     execute_slang_fun (addr->b.nt_fun_blk);
	     if (Lang_Break_Condition) goto handle_break_condition;
	     break;

	   case _SLANG_BC_BINARY:
	     do_binary (addr->b.i_blk);
	     break;
	     
	   case _SLANG_BC_LITERAL:
#if !_SLANG_OPTIMIZE_FOR_SPEED
	   case _SLANG_BC_LITERAL_INT:
	   case _SLANG_BC_LITERAL_STR:
	   case _SLANG_BC_LITERAL_DBL:
#endif
	       {
		  SLang_Class_Type *cl = _SLclass_get_class (addr->bc_sub_type);
		  (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk);
	       }
	     break;
#if _SLANG_OPTIMIZE_FOR_SPEED
	   case _SLANG_BC_LITERAL_INT:
	     SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk);
	     break;
#if SLANG_HAS_FLOAT
	   case _SLANG_BC_LITERAL_DBL:
	     SLclass_push_double_obj (addr->bc_sub_type, *addr->b.double_blk);
	     break;
#endif
	   case _SLANG_BC_LITERAL_STR:
	     _SLang_dup_and_push_slstring (addr->b.s_blk);
	     break;
#endif
	   case _SLANG_BC_BLOCK:
	     switch (addr->bc_sub_type)
	       {
		case _SLANG_BCST_ERROR_BLOCK:
		  err_block = addr;
		  break;

		case _SLANG_BCST_EXIT_BLOCK:
		  Exit_Block_Ptr = addr->b.blk;
		  break;

		case _SLANG_BCST_USER_BLOCK0:
		case _SLANG_BCST_USER_BLOCK1:
		case _SLANG_BCST_USER_BLOCK2:
		case _SLANG_BCST_USER_BLOCK3:
		case _SLANG_BCST_USER_BLOCK4:
		  User_Block_Ptr[addr->bc_sub_type - _SLANG_BCST_USER_BLOCK0] = addr->b.blk;
		  break;

		case _SLANG_BCST_LOOP:
		case _SLANG_BCST_WHILE:
		case _SLANG_BCST_FOR:
		case _SLANG_BCST_FOREVER:
		case _SLANG_BCST_CFOR:
		case _SLANG_BCST_DOWHILE:
		case _SLANG_BCST_FOREACH:
		  if (block == NULL) block = addr;
		  lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block));
		  block = NULL;
		  break;

		case _SLANG_BCST_IFNOT:
#if _SLANG_OPTIMIZE_FOR_SPEED
		    {
		       int i;
		       
		       if ((0 == pop_ctrl_integer (&i)) && (i == 0))
			 inner_interp (addr->b.blk);
		    }
#else
		  do_else_if (addr, NULL);
#endif
		  break;

		case _SLANG_BCST_IF:
#if _SLANG_OPTIMIZE_FOR_SPEED
		    {
		       int i;
		       
		       if ((0 == pop_ctrl_integer (&i)) && i)
			 inner_interp (addr->b.blk);
		    }
#else
		  do_else_if (NULL, addr);
#endif
		  break;

		case _SLANG_BCST_NOTELSE:
		  do_else_if (block, addr);
		  block = NULL;
		  break;

		case _SLANG_BCST_ELSE:
		  do_else_if (addr, block);
		  block = NULL;
		  break;

		case _SLANG_BCST_SWITCH:
		  if (Switch_Obj_Ptr == Switch_Obj_Max)
		    {
		       SLang_doerror("switch nesting too deep");
		       break;
		    }
		  (void) SLang_pop (Switch_Obj_Ptr);
		  Switch_Obj_Ptr++;

		  if (block == NULL) block = addr;
		  while ((SLang_Error == 0)
			 && (block <= addr)
			 && (Lang_Break_Condition == 0)
			 && (0 == inner_interp (block->b.blk)))
		    block++;
		  Switch_Obj_Ptr--;
		  SLang_free_object (Switch_Obj_Ptr);
		  Switch_Obj_Ptr->data_type = 0;
		  block = NULL;
		  break;

		case _SLANG_BCST_ANDELSE:
		case _SLANG_BCST_ORELSE:
		  if (block == NULL) block = addr;
		  lang_do_and_orelse (addr->bc_sub_type, block, addr);
		  block = NULL;
		  break;

		default:
		  if (block == NULL) block =  addr;
		  break;
	       }
	     if (Lang_Break_Condition) goto handle_break_condition;
	     break;

	   case _SLANG_BC_RETURN:
	     Lang_Break_Condition = Lang_Return = Lang_Break = 1; return 1;
	   case _SLANG_BC_BREAK:
	     Lang_Break_Condition = Lang_Break = 1; return 1;
	   case _SLANG_BC_CONTINUE:
	     Lang_Break_Condition = /* Lang_Continue = */ 1; return 1;

	   case _SLANG_BC_EXCH:
	     (void) SLreverse_stack (2);
	     break;

	   case _SLANG_BC_LABEL:
	       {
		  int test;
		  if ((0 == SLang_pop_integer (&test))
		      && (test == 0))
		    return 0;
	       }
	     break;

	   case _SLANG_BC_LOBJPTR:
	     (void)_SLang_push_ref (0, (VOID_STAR)(Local_Variable_Frame - addr->b.i_blk));
	     break;

	   case _SLANG_BC_GOBJPTR:
	     (void)_SLang_push_ref (1, (VOID_STAR)addr->b.nt_blk);
	     break;

	   case _SLANG_BC_X_ERROR:
	     if (err_block != NULL)
	       {
		  inner_interp(err_block->b.blk);
		  if (SLang_Error) err_block = NULL;
	       }
	     else SLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK");
	     if (Lang_Break_Condition) goto handle_break_condition;
	     break;

	   case _SLANG_BC_X_USER0:
	   case _SLANG_BC_X_USER1:
	   case _SLANG_BC_X_USER2:
	   case _SLANG_BC_X_USER3:
	   case _SLANG_BC_X_USER4:
	     if (User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0] != NULL)
	       {
		  inner_interp(User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0]);
	       }
	     else SLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK");
	     if (Lang_Break_Condition) goto handle_break_condition;
	     break;

	   case _SLANG_BC_CALL_DIRECT:
	     (*addr->b.call_function) ();
	     break;

	   case _SLANG_BC_CALL_DIRECT_FRAME:
	     do_bc_call_direct_frame (addr->b.call_function);
	     break;

	   case _SLANG_BC_UNARY:
	     do_unary (addr->b.i_blk, _SLANG_BC_UNARY);
	     break;
	     
	   case _SLANG_BC_UNARY_FUNC:
	     /* Make sure we treat these like function calls since the
	      * parser took abs(x) to be a function call.
	      */
	     if (0 == _SL_increment_frame_pointer ())
	       {
		  do_unary (addr