slang.c

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

	     return -1;
	  }
     }
   else if (-1 == make_unit_object (&y, &x))
     {
	SLang_free_object (&y);
	return -1;
     }
   
   if (-1 == do_binary_ab (op, &y, &x))
     {
	SLang_free_object (&y);
	SLang_free_object (&x);
	return -1;
     }
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR != Class_Type [y.data_type])
#endif
     SLang_free_object (&y);
   
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR != Class_Type [x.data_type])
#endif
     SLang_free_object (&x);

   if (-1 == SLroll_stack (num_args + 1))
     return -1;

   SLang_Num_Function_Args = num_args;
   return _SLarray_aput ();
}


static int
set_intrin_lvalue (SLBlock_Type *bc_blk)
{
   unsigned char op_type;
   SLang_Object_Type obja;
   SLang_Class_Type *cl;
   SLang_Intrin_Var_Type *ivar;
   VOID_STAR intrinsic_addr;
   unsigned char intrinsic_type;

   ivar = bc_blk->b.nt_ivar_blk;

   intrinsic_type = ivar->type;
   intrinsic_addr = ivar->addr;

   op_type = bc_blk->bc_sub_type;

   cl = _SLclass_get_class (intrinsic_type);

   if (op_type != _SLANG_BCST_ASSIGN)
     {
	/* We want to get the current value into obja.  This is the
	 * easiest way.
	 */
	if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr))
	    || (-1 == SLang_pop (&obja)))
	  return -1;

	(void) perform_lvalue_operation (op_type, &obja);
	SLang_free_object (&obja);

	if (SLang_Error)
	  return -1;
     }

   return (*cl->cl_pop) (intrinsic_type, intrinsic_addr);
}

int _SLang_deref_assign (SLang_Ref_Type *ref)
{
   SLang_Object_Type *objp;
   SLang_Name_Type *nt;
   SLBlock_Type blk;

   if (ref->is_global == 0)
     {
	objp = ref->v.local_obj;
	if (objp > Local_Variable_Frame)
	  {
	     SLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope");
	     return -1;
	  }
	return set_lvalue_obj (_SLANG_BCST_ASSIGN, objp);
     }

   nt = ref->v.nt;
   switch (nt->name_type)
     {
      case SLANG_GVARIABLE:
      case SLANG_PVARIABLE:
	if (-1 == set_lvalue_obj (_SLANG_BCST_ASSIGN,
				  &((SLang_Global_Var_Type *)nt)->obj))
	  {
	     do_name_type_error (nt);
	     return -1;
	  }
	break;

      case SLANG_IVARIABLE:
	blk.b.nt_blk = nt;
	blk.bc_sub_type = _SLANG_BCST_ASSIGN;
	if (-1 == set_intrin_lvalue (&blk))
	  {
	     do_name_type_error (nt);
	     return -1;
	  }
	break;

      case SLANG_LVARIABLE:
	SLang_Error = SL_INTERNAL_ERROR;
	/* set_intrin_lvalue (&blk); */
	return -1;

      case SLANG_RVARIABLE:
      default:
	SLang_verror (SL_READONLY_ERROR, "deref assignment to %s not allowed", nt->name);
	return -1;
     }

   return 0;
}

static void set_deref_lvalue (SLBlock_Type *bc_blk)
{
   SLang_Object_Type *objp;
   SLang_Ref_Type *ref;

   switch (bc_blk->bc_sub_type)
     {
      case SLANG_LVARIABLE:
	objp =  (Local_Variable_Frame - bc_blk->b.i_blk);
	break;
      case SLANG_GVARIABLE:
      case SLANG_PVARIABLE:
	objp = &bc_blk->b.nt_gvar_blk->obj;
	break;
      default:
	SLang_Error = SL_INTERNAL_ERROR;
	return;
     }

   if (-1 == _SLpush_slang_obj (objp))
     return;

   if (-1 == SLang_pop_ref (&ref))
     return;
   (void) _SLang_deref_assign (ref);
   SLang_free_ref (ref);
}

static int push_struct_field (char *name)
{
   int type;
   SLang_Class_Type *cl;

   if (-1 == (type = SLang_peek_at_stack ()))
     return -1;

   cl = _SLclass_get_class ((unsigned char) type);
   if (cl->cl_sget == NULL)
     {
	SLang_verror (SL_NOT_IMPLEMENTED,
		      "%s does not permit structure access",
		      cl->cl_name);
	SLdo_pop_n (2);
	return -1;
     }

   return (*cl->cl_sget) ((unsigned char) type, name);
}

static void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir)
{
   unsigned int len;
   char prefix [52];

   len = Trace_Mode - 1;
   if (len + 2 >= sizeof (prefix))
     len = sizeof (prefix) - 2;

   SLMEMSET (prefix, ' ', len);
   prefix[len] = 0;

   call_dump_routine (prefix);
   call_dump_routine (format, name, n);

   if (n > 0)
     {
	prefix[len] = ' ';
	len++;
	prefix[len] = 0;

	_SLdump_objects (prefix, objs, n, dir);
     }
}

/*  Pop a data item from the stack and return a pointer to it.
 *  Strings are not freed from stack so use another routine to do it.
 */
static VOID_STAR pop_pointer (SLang_Object_Type *obj, unsigned char type)
{
#ifndef _SLANG_OPTIMIZE_FOR_SPEED
   SLang_Class_Type *cl;
#endif

   SLang_Array_Type *at;

   /* Arrays are special.  Allow scalars to automatically convert to arrays.
    */
   if (type == SLANG_ARRAY_TYPE)
     {
	if (-1 == SLang_pop_array (&at, 1))
	  return NULL;
	obj->data_type = SLANG_ARRAY_TYPE;
	return obj->v.ptr_val = (VOID_STAR) at;
     }

   if (type == 0)
     {
	/* This happens when an intrinsic is declared without any information
	 * regarding parameter types.
	 */
	if (-1 == SLang_pop (obj))
	  return NULL;
	type = obj->data_type;
     }
   else if (-1 == _SLang_pop_object_of_type (type, obj, 0))
     return NULL;

#if _SLANG_OPTIMIZE_FOR_SPEED
   type = Class_Type [type];
#else
   type = _SLclass_get_class (type)->cl_class_type;
#endif

   if (type == SLANG_CLASS_TYPE_SCALAR)
     return (VOID_STAR) &obj->v;
   else if (type == SLANG_CLASS_TYPE_MMT)
     return SLang_object_from_mmt (obj->v.ref);
   else
     return obj->v.ptr_val;
}

/* This is ugly.  Does anyone have a advice for a cleaner way of doing
 * this??
 */
typedef void (*VF0_Type)(void);
typedef void (*VF1_Type)(VOID_STAR);
typedef void (*VF2_Type)(VOID_STAR, VOID_STAR);
typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef long (*LF0_Type)(void);
typedef long (*LF1_Type)(VOID_STAR);
typedef long (*LF2_Type)(VOID_STAR, VOID_STAR);
typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
#if SLANG_HAS_FLOAT
typedef double (*FF0_Type)(void);
typedef double (*FF1_Type)(VOID_STAR);
typedef double (*FF2_Type)(VOID_STAR, VOID_STAR);
typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
#endif

static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf)
{
#if SLANG_HAS_FLOAT
   double xf;
#endif
   VOID_STAR p[SLANG_MAX_INTRIN_ARGS];
   SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS];
   long ret;
   unsigned char type;
   unsigned int argc;
   unsigned int i;
   FVOID_STAR fptr;
   unsigned char *arg_types;
   int stk_depth;

   fptr = objf->i_fun;
   argc = objf->num_args;
   type = objf->return_type;
   arg_types = objf->arg_types;

   if (argc > SLANG_MAX_INTRIN_ARGS)
     {
	SLang_verror(SL_APPLICATION_ERROR,
		     "Intrinsic function %s requires too many parameters", objf->name);
	return -1;
     }

   if (-1 == _SL_increment_frame_pointer ())
     return -1;

   stk_depth = -1;
   if (Trace_Mode && (_SLang_Trace > 0))
     {
	int nargs;

	stk_depth = _SLstack_depth ();

	nargs = SLang_Num_Function_Args;
	if (nargs == 0)
	  nargs = (int)argc;

	stk_depth -= nargs;

	if (stk_depth >= 0)
	  trace_dump (">>%s (%d args)\n",
		      objf->name,
		      _SLStack_Pointer - nargs,
		      nargs,
		      1);
     }

   i = argc;
   while (i != 0)
     {
	i--;
	if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i])))
	  {
	     i++;
	     goto free_and_return;
	  }
     }

   ret = 0;
#if SLANG_HAS_FLOAT
   xf = 0.0;
#endif

   switch (argc)
     {
      case 0:
	if (type == SLANG_VOID_TYPE) ((VF0_Type) fptr) ();
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)();
#endif
	else ret = ((LF0_Type) fptr)();
	break;

      case 1:
	if (type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf =  ((FF1_Type) fptr)(p[0]);
#endif
	else ret =  ((LF1_Type) fptr)(p[0]);
	break;

      case 2:
	if (type == SLANG_VOID_TYPE)  ((VF2_Type) fptr)(p[0], p[1]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]);
#endif
	else ret = ((LF2_Type) fptr)(p[0], p[1]);
	break;

      case 3:
	if (type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]);
#endif
	else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]);
	break;

      case 4:
	if (type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]);
#endif
	else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]);
	break;

      case 5:
	if (type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
#endif
	else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
	break;

      case 6:
	if (type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
#endif
	else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
	break;

      case 7:
	if (type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
#if SLANG_HAS_FLOAT
	else if (type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
#endif
	else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
	break;
     }

   switch (type)
     {
      case SLANG_VOID_TYPE:
	break;
	
#if SLANG_HAS_FLOAT
      case SLANG_DOUBLE_TYPE:
	(void) SLclass_push_double_obj (SLANG_DOUBLE_TYPE, xf);
	break;
#endif
      case SLANG_UINT_TYPE:
      case SLANG_INT_TYPE: (void) SLclass_push_int_obj (type, (int) ret);
	break;
	
      case SLANG_CHAR_TYPE:
      case SLANG_UCHAR_TYPE: (void) SLclass_push_char_obj (type, (char) ret);
	break;

      case SLANG_SHORT_TYPE:
      case SLANG_USHORT_TYPE: (void) SLclass_push_short_obj (type, (short) ret);
	break;

      case SLANG_LONG_TYPE:
      case SLANG_ULONG_TYPE: (void) SLclass_push_long_obj (type, ret);
	break;
	
      case SLANG_STRING_TYPE:
	if (NULL == (char *)ret)
	  {
	     if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR;
	  }
	else (void) SLang_push_string ((char *)ret);
	break;
	
      default:
	SLang_verror (SL_NOT_IMPLEMENTED,
		      "Support for intrinsic functions returning %s is not provided",
		      SLclass_get_datatype_name (type));
     }

   if (stk_depth >= 0)
     {
	stk_depth = _SLstack_depth () - stk_depth;

	trace_dump ("<<%s (returning %d values)\n",
		      objf->name,
		      _SLStack_Pointer - stk_depth,
		      stk_depth,
		      1);
     }

   free_and_return:
   while (i < argc)
     {
	SLang_free_object (objs + i);
	i++;
     }

   return _SL_decrement_frame_pointer ();
}

static int inner_interp(register SLBlock_Type *);

/* Switch_Obj_Ptr points to the NEXT available free switch object */
static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH];
static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects;
static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH;

static void
lang_do_loops (unsigned char stype, SLBlock_Type *block, unsigned int num_blocks)
{
   int i, ctrl;
   int first, last;
   SLBlock_Type *blks[4];
   char *loop_name;
   SLang_Foreach_Context_Type *foreach_context;
   SLang_Class_Type *cl;
   int type;
   unsigned int j;

   j = 0;
   for (i = 0; i < (int) num_blocks; i++)
     {
	if (block[i].bc_main_type != _SLANG_BC_BLOCK)
	  {
	     if (block[i].bc_main_type == _SLANG_BC_LINE_NUM)
	       continue;

	     SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block");
	     return;
	  }
	blks[j] = block[i].b.blk;
	j++;
     }

   num_blocks = j;
   block = blks[0];

   switch (stype)
     {
	int next_fn_args;

      case _SLANG_BCST_FOREACH:
	loop_name = "foreach";
	if (num_blocks != 1)
	  goto wrong_num_blocks_error;

	/* We should find Next_Function_Num_Args + 1 items on the stack.
	 * The first Next_Function_Num_Args items represent the arguments to
	 * to USING.  The last item (deepest in stack) is the object to loop
	 * over.  So, roll the stack up and grab it.
	 */
	next_fn_args = Next_Function_Num_Args;
	Next_Function_Num_Args = 0;
	if ((-1 == SLroll_stack (-(next_fn_args + 1)))
	    || (-1 == (type = SLang_peek_at_stack ())))
	  goto return_error;

	cl = _SLclass_get_class ((unsigned char) type);
	if ((cl->cl_foreach == NULL)
	    || (cl->cl_foreach_open == NULL)
	    || (cl->cl_foreach_close == NULL))
	  {
	     SLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name);
	     SLdo_pop_n (next_fn_args + 1);
	     goto return_error;
	  }

	if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, next_fn_args)))
	  goto return_error;

	while (1)
	  {
	     int status;

	     if (SLang_Error)
	       {
		  (*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
		  goto return_error;
	       }

	     status = (*cl->cl_foreach) ((unsigned char) type, foreach_context);
	     if (status <= 0)
	       {
		  if (status == 0)
		    break;

		  (*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
		  goto return_error;
	       }

	     inner_interp (block);
	     if (Lang_Break) break;
	     Lang_Break_Condition = /* Lang_Continue = */ 0;
	  }
	(*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
	break;

      case _SLANG_BCST_WHILE:
	loop_name = "while";

	if (num_blocks != 2)