slang.c

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

{
   if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
     {
	Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - _SLRun_Stack);
	Frame_Pointer = _SLStack_Pointer;
	Frame_Pointer_Depth++;
	Next_Function_Num_Args = 0;
	return 0;
     }

   SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow");
   return -1;
}

_INLINE_
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;
}

_INLINE_
static int do_bc_call_direct_frame (int (*f)(void))
{
   if ((0 == SLang_end_arg_list ())
       && (0 == _SL_increment_frame_pointer ()))
     {
	(void) (*f) ();
	_SL_decrement_frame_pointer ();
     }
   if (SLang_Error)
     return -1;
   return 0;
}

static int do_name_type_error (SLang_Name_Type *nt)
{
   char buf[256];
   if (nt != NULL)
     {
	(void) _SLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name);
	do_traceback (buf, 0, NULL);
     }
   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;

#if _SLANG_OPTIMIZE_FOR_SPEED
   if (Is_Arith_Type[a_data_type]
       && Is_Arith_Type[b_data_type])
     {
	int status;
	status = _SLarith_bin_op (obja, objb, op);
	if (status != 1)
	  return status;
	/* drop and try it the hard way */
     }
#endif

   a_cl = _SLclass_get_class (a_data_type);
   if (a_data_type == b_data_type)
     b_cl = a_cl;
   else
     b_cl = _SLclass_get_class (b_data_type);

   if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1)))
     return -1;

   c_data_type = c_cl->cl_data_type;

#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR == Class_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 (SLANG_CLASS_TYPE_SCALAR == Class_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 (SLANG_CLASS_TYPE_SCALAR != Class_Type [c_data_type])
#endif
     (*c_cl->cl_adestroy)(c_data_type, pc);

   return ret;
}

_INLINE_
static int do_binary_ab_inc_ref (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
{
   int ret;
#if _SLANG_USE_TMP_OPTIMIZATION
   int inc = 0;
   
   if (obja->data_type == SLANG_ARRAY_TYPE)
     {
	inc |= 1;
	obja->v.array_val->num_refs++;
     }
   if (objb->data_type == SLANG_ARRAY_TYPE)
     {
	inc |= 2;
	objb->v.array_val->num_refs++;
     }
#endif
   ret = do_binary_ab (op, obja, objb);

#if _SLANG_USE_TMP_OPTIMIZATION
   if (inc & 1) obja->v.array_val->num_refs--;
   if (inc & 2) objb->v.array_val->num_refs--;
#endif
   
   return ret;
}

_INLINE_
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 (SLANG_CLASS_TYPE_SCALAR != Class_Type [obja.data_type])
#endif
	  SLang_free_object (&obja);
     }
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR != Class_Type [objb.data_type])
#endif
     SLang_free_object (&objb);
}

_INLINE_
static void do_binary_b (int op, SLang_Object_Type *bp)
{
   SLang_Object_Type a;

   if (SLang_pop (&a)) return;
   (void) do_binary_ab (op, &a, bp);
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR != Class_Type [a.data_type])
#endif
     SLang_free_object (&a);
}

_INLINE_
static void do_binary_b_inc_ref (int op, SLang_Object_Type *bp)
{
   SLang_Object_Type a;

   if (SLang_pop (&a)) return;
#if _SLANG_USE_TMP_OPTIMIZATION
   if (bp->data_type == SLANG_ARRAY_TYPE)
     {
	bp->v.array_val->num_refs++;
	(void) do_binary_ab (op, &a, bp);
	bp->v.array_val->num_refs--;
     }
   else
#endif
     (void) do_binary_ab (op, &a, bp);
#if _SLANG_OPTIMIZE_FOR_SPEED
   if (SLANG_CLASS_TYPE_SCALAR != Class_Type [a.data_type])
#endif
     SLang_free_object (&a);
}

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 (SLANG_CLASS_TYPE_SCALAR == Class_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 (SLANG_CLASS_TYPE_SCALAR != Class_Type [b_type])
#endif
     (*b_cl->cl_adestroy)(b_type, pb);

   return ret;
}

_INLINE_
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 (SLANG_CLASS_TYPE_SCALAR != Class_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 (SLANG_CLASS_TYPE_SCALAR != Class_Type [objb.data_type])
#endif
     SLang_free_object (&objb);
   return ret;
}

/* The order of these is assumed to match the binary operators
 * defined in slang.h
 */
static int
map_assignment_op_to_binary (unsigned char op_type, int *op, int *is_unary)
{
   *is_unary = 0;
   switch (op_type)
     {
      case _SLANG_BCST_PLUSEQS:
      case _SLANG_BCST_MINUSEQS:
      case _SLANG_BCST_TIMESEQS:
      case _SLANG_BCST_DIVEQS:
	*op = SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS);
	break;

      case _SLANG_BCST_BOREQS:
	*op = SLANG_BOR;
	break;

      case _SLANG_BCST_BANDEQS:
	*op = SLANG_BAND;
	break;

      case _SLANG_BCST_POST_MINUSMINUS:
      case _SLANG_BCST_MINUSMINUS:
	*op = SLANG_MINUS;
	*is_unary = 1;
	break;

      case _SLANG_BCST_PLUSPLUS:
      case _SLANG_BCST_POST_PLUSPLUS:
	*op = SLANG_PLUS;
	*is_unary = 1;
	break;

      default:
	SLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented");
	return -1;
     }
   return 0;
}

static int
perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr)
{
   switch (op_type)
     {
      case _SLANG_BCST_ASSIGN:
	break;

	/* The order of these is assumed to match the binary operators
	 * defined in slang.h
	 */
      case _SLANG_BCST_PLUSEQS:
      case _SLANG_BCST_MINUSEQS:
      case _SLANG_BCST_TIMESEQS:
      case _SLANG_BCST_DIVEQS:
	if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS), obja_ptr))
	  return -1;
	break;

      case _SLANG_BCST_BOREQS:
	if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr))
	  return -1;
	break;

      case _SLANG_BCST_BANDEQS:
	if (-1 == do_assignment_binary (SLANG_BAND, 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 SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_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 SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_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;
}

_INLINE_
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 (SLANG_CLASS_TYPE_SCALAR != Class_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)
{
   int type;
   SLang_Class_Type *cl;
   char *name;
   int op;

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

   cl = _SLclass_get_class (type);
   if ((cl->cl_sput == NULL)
       || (cl->cl_sget == NULL))
     {
	SLang_verror (SL_NOT_IMPLEMENTED,
		      "%s does not support structure access",
		      cl->cl_name);
	SLdo_pop_n (2);		       /* object plus what was to be assigned */
	return -1;
     }
   name = bc_blk->b.s_blk;
   op = bc_blk->bc_sub_type;

   if (op != _SLANG_BCST_ASSIGN)
     {
	/* We have something like (A.x += b) or (A.x++).  In either case,
	 * we need A.x.
	 */
	SLang_Object_Type obj_A;
	SLang_Object_Type obj;

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

	if ((-1 == _SLpush_slang_obj (&obj_A))
	    || (-1 == cl->cl_sget ((unsigned char) type, name))
	    || (-1 == SLang_pop (&obj)))
	  {
	     SLang_free_object (&obj_A);
	     return -1;
	  }
	/* Now the value of A.x is in obj. */
	if (-1 == perform_lvalue_operation (op, &obj))
	  {
	     SLang_free_object (&obj);
	     SLang_free_object (&obj_A);
	     return -1;
	  }
	SLang_free_object (&obj);
	/* The result of the operation is now on the stack.
	 * Perform assignment */
	if (-1 == SLang_push (&obj_A))
	  {
	     SLang_free_object (&obj_A);
	     return -1;
	  }
     }

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

static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u)
{
   unsigned char type;
   
   type = a->data_type;
   if (type == SLANG_ARRAY_TYPE)
     type = a->v.array_val->data_type;
   
   u->data_type = type;
   switch (type)
     {
      case SLANG_UCHAR_TYPE:
      case SLANG_CHAR_TYPE:
	u->v.char_val = 1;
	break;

      case SLANG_SHORT_TYPE:
      case SLANG_USHORT_TYPE:
	u->v.short_val = 1;
	break;

      case SLANG_LONG_TYPE:
      case SLANG_ULONG_TYPE:
	u->v.long_val = 1;
	break;

#if SLANG_HAS_FLOAT
      case SLANG_FLOAT_TYPE:
	u->v.float_val = 1;
	break;
	
      case SLANG_COMPLEX_TYPE:
	u->data_type = SLANG_DOUBLE_TYPE;
      case SLANG_DOUBLE_TYPE:
	u->v.double_val = 1;
	break;
#endif
      default:
	u->data_type = SLANG_INT_TYPE;
	u->v.int_val = 1;
     }
   return 0;
}


/* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'.  The code that
 * has been generated is:  X __args i A __aput-op
 * where __aput-op represents this function.  We need to generate:
 * __args i A __eargs __aget X op __args i A __eargs __aput
 * Here, __eargs implies a call to do_bc_call_direct_frame with either
 * the aput or aget function.  In addition, __args represents a call to 
 * SLang_start_arg_list.  Of course, i represents a set of indices.
 * 
 * Note: If op is an unary operation (e.g., ++ or --), then X will not
 * b present an will have to be taken to be 1.
 * 
 * Implementation note: For efficiency, calls to setup the frame, start
 * arg list will be omitted and SLang_Num_Function_Args will be set.
 * This is ugly but the alternative is much less efficient rendering these
 * assignment operators useless.  So, the plan is to roll the stack to get X,
 * then duplicate the next N values, call __aget followed by op X, finally
 * calling __aput.  Hence, the sequence is:
 * 
 *     start:   X i .. j A 
 *      dupN:   X i .. j A i .. j A
 *    __aget:   X i .. j A Y
 *      roll:   i .. j A Y X
 *        op:   i .. j A Z
 *      roll:   Z i .. j A
 *    __aput:
 */
static int
set_array_lvalue (int op)
{
   SLang_Object_Type x, y;
   int num_args, is_unary;

   if (-1 == map_assignment_op_to_binary (op, &op, &is_unary))
     return -1;

   /* Grab the indices and the array.  Do not start a new frame. */
   if (-1 == SLang_end_arg_list ())
     return -1;
   num_args = Next_Function_Num_Args;
   Next_Function_Num_Args = 0;

   if (-1 == SLdup_n (num_args))
     return -1;

   SLang_Num_Function_Args = num_args;
   if (-1 == _SLarray_aget ())
     return -1;

   if (-1 == SLang_pop (&y))
     return -1;
   
   if (is_unary == 0)
     {
	if ((-1 == SLroll_stack (-(num_args + 1)))
	    || (-1 == SLang_pop (&x)))
	  {
	     SLang_free_object (&y);