sltypes.c

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

/* Ref type */
int SLang_pop_ref (SLang_Ref_Type **ref)
{
   return SLclass_pop_ptr_obj (SLANG_REF_TYPE, (VOID_STAR *)ref);
}

/* Note: This is ok if ptr is NULL.  Some routines rely on this behavior */
int _SLang_push_ref (int is_global, VOID_STAR ptr)
{
   SLang_Ref_Type *r;

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

   r = (SLang_Ref_Type *) SLmalloc (sizeof (SLang_Ref_Type));
   if (r == NULL) return -1;

   r->is_global = is_global;
   r->v.nt = (SLang_Name_Type *) ptr;

   if (-1 == SLclass_push_ptr_obj (SLANG_REF_TYPE, (VOID_STAR) r))
     {
	SLfree ((char *) r);
	return -1;
     }
   return 0;
}

static void ref_destroy (unsigned char type, VOID_STAR ptr)
{
   (void) type;
   SLfree ((char *) *(SLang_Ref_Type **)ptr);
}

void SLang_free_ref (SLang_Ref_Type *ref)
{
   SLfree ((char *) ref);
}

static int ref_push (unsigned char type, VOID_STAR ptr)
{
   SLang_Ref_Type *ref;

   (void) type;

   ref = *(SLang_Ref_Type **) ptr;

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

   return _SLang_push_ref (ref->is_global, (VOID_STAR) ref->v.nt);
}

int SLang_assign_to_ref (SLang_Ref_Type *ref, SLtype type, VOID_STAR v)
{
   SLang_Object_Type *stkptr;
   SLang_Class_Type *cl;
   
   cl = _SLclass_get_class (type);

   /* Use apush since this function is passing ``array'' bytes rather than the
    * address of the data.  I need to somehow make this more consistent.  To
    * see what I mean, consider:
    * 
    *    double z[2];
    *    char *s = "silly";
    *    char bytes[10];  BAD--- Don't do this
    *    int i;
    * 
    *    SLang_assign_to_ref (ref, SLANG_INT_TYPE,    &i);
    *    SLang_assign_to_ref (ref, SLANG_STRING_TYPE, &s);
    *    SLang_assign_to_ref (ref, SLANG_COMPLEX_TYPE, z);
    * 
    * That is, all external routines that take a VOID_STAR argument need to
    * be documented such that how the function should be called with the
    * various class_types.
    */
   if (-1 == (*cl->cl_apush) (type, v))
     return -1;

   stkptr = _SLang_get_run_stack_pointer ();
   if (0 == _SLang_deref_assign (ref))
     return 0;

   if (stkptr != _SLang_get_run_stack_pointer ())
     SLdo_pop ();

   return -1;
}

static char *ref_string (unsigned char type, VOID_STAR ptr)
{
   SLang_Ref_Type *ref;

   (void) type;
   ref = *(SLang_Ref_Type **) ptr;
   if (ref->is_global)
     {
	char *name, *s;

	name = ref->v.nt->name;
	if ((name != NULL)
	    && (NULL != (s = SLmalloc (strlen(name) + 2))))
	  {
	     *s = '&';
	     strcpy (s + 1, name);
	     return s;
	  }
	
	return NULL;
     }
   return SLmake_string ("Local Variable Reference");
}

static int ref_dereference (unsigned char unused, VOID_STAR ptr)
{
   (void) unused;
   return _SLang_dereference_ref (*(SLang_Ref_Type **) ptr);
}

static int ref_cmp (unsigned char type, VOID_STAR a, VOID_STAR b, int *c)
{
   SLang_Ref_Type *ra, *rb;

   (void) type;
   
   ra = *(SLang_Ref_Type **)a;
   rb = *(SLang_Ref_Type **)b;
   
   if (ra == NULL)
     {
	if (rb == NULL) *c = 0;
	else *c = -1;
	return 0;
     }
   if (rb == NULL)
     {
	*c = 1;
	return 0;
     }
	
   if (ra->v.nt == rb->v.nt)
     *c = 0;
   else *c = strcmp (ra->v.nt->name, rb->v.nt->name);
   return 0;
}

   
SLang_Name_Type *SLang_pop_function (void)
{
   SLang_Ref_Type *ref;
   SLang_Name_Type *f;

   if (SLang_peek_at_stack () == SLANG_STRING_TYPE)
     {
	char *name;
	
	if (-1 == SLang_pop_slstring (&name))
	  return NULL;
	
	if (NULL == (f = SLang_get_function (name)))
	  {
	     SLang_verror (SL_UNDEFINED_NAME, "Function %s does not exist", name);
	     SLang_free_slstring (name);
	     return NULL;
	  }
	SLang_free_slstring (name);
	return f;
     }

   if (-1 == SLang_pop_ref (&ref))
     return NULL;

   f = SLang_get_fun_from_ref (ref);
   SLang_free_ref (ref);
   return f;
}

/* This is a placeholder for version 2 */
void SLang_free_function (SLang_Name_Type *f)
{
   (void) f;
}

/* NULL type */
int SLang_push_null (void)
{
   return SLclass_push_ptr_obj (SLANG_NULL_TYPE, NULL);
}

int SLang_pop_null (void)
{
   SLang_Object_Type obj;
   return _SLang_pop_object_of_type (SLANG_NULL_TYPE, &obj, 0);
}

static int null_push (unsigned char unused, VOID_STAR ptr_unused)
{
   (void) unused; (void) ptr_unused;
   return SLang_push_null ();
}

static int null_pop (unsigned char type, VOID_STAR ptr)
{
   (void) type;

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

   *(char **) ptr = NULL;
   return 0;
}

/* Implement foreach (NULL) using (whatever) to do nothing.  This is useful
 * because suppose that X is a list but is NULL in some situations.  Then
 * when it is NULL, we want foreach(X) to do nothing.
 */
static SLang_Foreach_Context_Type *
null_foreach_open (unsigned char type, unsigned int num)
{
   (void) type;
   SLdo_pop_n (num + 1);
   return (SLang_Foreach_Context_Type *)1;
}

static void null_foreach_close (unsigned char type, SLang_Foreach_Context_Type *c)
{
   (void) type;
   (void) c;
}

static int null_foreach (unsigned char type, SLang_Foreach_Context_Type *c)
{
   (void) type;
   (void) c;
   return 0;
}

static int null_to_bool (unsigned char type, int *t)
{
   (void) type;
   *t = 0;
   return SLang_pop_null ();
}

/* AnyType */
int _SLanytype_typecast (unsigned char a_type, VOID_STAR ap, unsigned int na,
			 unsigned char b_type, VOID_STAR bp)
{
   SLang_Class_Type *cl;
   SLang_Any_Type **any;
   unsigned int i;
   unsigned int sizeof_type;

   (void) b_type;

   any = (SLang_Any_Type **) bp;
   
   cl = _SLclass_get_class (a_type);
   sizeof_type = cl->cl_sizeof_type;

   for (i = 0; i < na; i++)
     {
	if ((-1 == (*cl->cl_apush) (a_type, ap))
	    || (-1 == SLang_pop_anytype (&any[i])))
	  {
	     while (i != 0)
	       {
		  i--;
		  SLang_free_anytype (any[i]);
		  any[i] = NULL;
	       }
	     return -1;
	  }
	ap = (VOID_STAR)((char *)ap + sizeof_type);
     }

   return 1;
}

int SLang_pop_anytype (SLang_Any_Type **any)
{
   SLang_Object_Type *obj;

   *any = NULL;

   if (NULL == (obj = (SLang_Object_Type *) SLmalloc (sizeof (SLang_Object_Type))))
     return -1;

   if (-1 == SLang_pop (obj))
     {
	SLfree ((char *) obj);
	return -1;
     }
   *any = (SLang_Any_Type *)obj;
   return 0;
}

/* This function will result in an object that is represented by the
 * anytype object.
 */
int SLang_push_anytype (SLang_Any_Type *any)
{
   return _SLpush_slang_obj ((SLang_Object_Type *)any);
}

/* After this call, the stack will contain an Any_Type object */
static int anytype_push (unsigned char type, VOID_STAR ptr)
{
   SLang_Any_Type *obj;

   /* Push the object onto the stack, then pop it back off into our anytype
    * container.  That way, any memory managing associated with the type
    * will be performed automatically.  Another way to think of it is that
    * pushing an Any_Type onto the stack will create another copy of the
    * object represented by it.
    */
   if (-1 == _SLpush_slang_obj (*(SLang_Object_Type **)ptr))
     return -1;

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

   /* There is no need to reference count the anytype objects since every
    * push results in a new anytype container.
    */
   if (-1 == SLclass_push_ptr_obj (type, (VOID_STAR) obj))
     {
	SLang_free_anytype (obj);
	return -1;
     }

   return 0;
}

static void anytype_destroy (unsigned char type, VOID_STAR ptr)
{
   SLang_Object_Type *obj;

   (void) type;
   obj = *(SLang_Object_Type **)ptr;
   SLang_free_object (obj);
   SLfree ((char *) obj);
}

void SLang_free_anytype (SLang_Any_Type *any)
{
   if (any != NULL)
     anytype_destroy (SLANG_ANY_TYPE, (VOID_STAR) &any);
}

static int anytype_dereference (unsigned char unused, VOID_STAR ptr)
{
   (void) unused;
   return _SLpush_slang_obj (*(SLang_Object_Type **) ptr);
}

#if 0
/* This function performs a deref since we may want the symmetry
 *  a = Any_Type[1];  a[x] = "foo"; bar = a[x]; ==> bar == "foo"
 * That is, we do not want bar to be an Any_Type.
 * 
 * Unfortunately, this does not work because of the use of the transfer
 * buffer by both slarray.c and sltypecast.c.  I can work around that 
 * but I am not sure that I like typeof(Any_Type[0]) != Any_Type.
 */
static int anytype_apush (SLtype type, VOID_STAR ptr)
{
   (void) type;
   return _SLpush_slang_obj (*(SLang_Object_Type **)ptr);
}
#endif

/* SLANG_INTP_TYPE */
static int intp_push (unsigned char unused, VOID_STAR ptr)
{
   (void) unused;
   return SLclass_push_int_obj (SLANG_INT_TYPE, **(int **)ptr);
}

static int intp_pop (unsigned char unused, VOID_STAR ptr)
{
   (void) unused;
   return SLang_pop_integer (*(int **) ptr);
}

static int undefined_push (unsigned char t, VOID_STAR p)
{
   (void) t; (void) p;
   if (SLang_Error == 0)
     SLang_Error = SL_VARIABLE_UNINITIALIZED;
   return -1;
}

int _SLregister_types (void)
{
   SLang_Class_Type *cl;

#if 1
   /* A good compiler should optimize this code away. */
   if ((sizeof(short) != SIZEOF_SHORT)
       || (sizeof(int) != SIZEOF_INT)
       || (sizeof(long) != SIZEOF_LONG)
       || (sizeof(float) != SIZEOF_FLOAT)
       || (sizeof(double) != SIZEOF_DOUBLE))
     SLang_exit_error ("S-Lang Library not built properly.  Fix SIZEOF_* in config.h and recompile");
#endif
   if (-1 == _SLclass_init ())
     return -1;

   /* Undefined Type */
   if (NULL == (cl = SLclass_allocate_class ("Undefined_Type")))
     return -1;
   (void) SLclass_set_push_function (cl, undefined_push);
   (void) SLclass_set_pop_function (cl, undefined_push);
   if (-1 == SLclass_register_class (cl, SLANG_UNDEFINED_TYPE, sizeof (int),
				     SLANG_CLASS_TYPE_SCALAR))
     return -1;
   /* Make Void_Type a synonym for Undefined_Type.  Note that this does 
    * not mean that Void_Type represents SLANG_VOID_TYPE.  Void_Type is 
    * used by array_map to indicate no array is to be created.
    */
   if (-1 == SLclass_create_synonym ("Void_Type", SLANG_UNDEFINED_TYPE))
     return -1;

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

   /* SLANG_INTP_TYPE */
   if (NULL == (cl = SLclass_allocate_class ("_IntegerP_Type")))
     return -1;
   (void) SLclass_set_push_function (cl, intp_push);
   (void) SLclass_set_pop_function (cl, intp_pop);
   if (-1 == SLclass_register_class (cl, SLANG_INTP_TYPE, sizeof (int),
				     SLANG_CLASS_TYPE_SCALAR))
     return -1;

   /* String Type */

   if (NULL == (cl = SLclass_allocate_class ("String_Type")))
     return -1;
   (void) SLclass_set_destroy_function (cl, string_destroy);
   (void) SLclass_set_push_function (cl, string_push);
   (void) SLclass_set_acopy_function (cl, string_acopy);
   cl->cl_foreach_open = string_foreach_open;
   cl->cl_foreach_close = string_foreach_close;
   cl->cl_foreach = string_foreach;
   cl->cl_cmp = string_cmp;
   if (-1 == SLclass_register_class (cl, SLANG_STRING_TYPE, sizeof (char *),
				     SLANG_CLASS_TYPE_PTR))
     return -1;

   /* ref Type */
   if (NULL == (cl = SLclass_allocate_class ("Ref_Type")))
     return -1;
   cl->cl_dereference = ref_dereference;
   cl->cl_push = ref_push;
   cl->cl_destroy = ref_destroy;
   cl->cl_string = ref_string;
   cl->cl_cmp = ref_cmp;
   if (-1 == SLclass_register_class (cl, SLANG_REF_TYPE,
				     sizeof (SLang_Ref_Type *),
				     SLANG_CLASS_TYPE_PTR))
     return -1;

   /* NULL Type */

   if (NULL == (cl = SLclass_allocate_class ("Null_Type")))
     return -1;
   cl->cl_push = null_push;
   cl->cl_pop = null_pop;
   cl->cl_foreach_open = null_foreach_open;
   cl->cl_foreach_close = null_foreach_close;
   cl->cl_foreach = null_foreach;
   cl->cl_to_bool = null_to_bool;
   if (-1 == SLclass_register_class (cl, SLANG_NULL_TYPE, sizeof (char *),
				     SLANG_CLASS_TYPE_SCALAR))
     return -1;

   /* AnyType */
   if (NULL == (cl = SLclass_allocate_class ("Any_Type")))
     return -1;
   (void) SLclass_set_push_function (cl, anytype_push);
   (void) SLclass_set_destroy_function (cl, anytype_destroy);
#if 0
   (void) SLclass_set_apush_function (cl, anytype_apush);
#endif
   cl->cl_dereference = anytype_dereference;
   if (-1 == SLclass_register_class (cl, SLANG_ANY_TYPE, sizeof (VOID_STAR),
				     SLANG_CLASS_TYPE_PTR))
     return -1;

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

   if ((-1 == SLclass_add_typecast (SLANG_STRING_TYPE, SLANG_INT_TYPE, string_to_int, 0))
       || (-1 == SLclass_add_binary_op (SLANG_STRING_TYPE, SLANG_STRING_TYPE, string_string_bin_op, string_string_bin_op_result)))
     return -1;

   return 0;
}