slstd.c

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

/* -*- mode: C; mode: fold; -*- */
/* Standard intrinsic functions for S-Lang.  Included here are string
   and array operations */
/* 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"
/*{{{ Include Files */

#include <time.h>

#ifndef __QNX__
# if defined(__GO32__) || defined(__WATCOMC__)
#  include <dos.h>
#  include <bios.h>
# endif
#endif

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

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

/*}}}*/

/* builtin stack manipulation functions */
int SLdo_pop(void) /*{{{*/
{
   return SLdo_pop_n (1);
}

/*}}}*/

int SLdo_pop_n (unsigned int n)
{
   SLang_Object_Type x;

   while (n--)
     {
	if (SLang_pop(&x)) return -1;
	SLang_free_object (&x);
     }

   return 0;
}

static void do_dup(void) /*{{{*/
{
   (void) SLdup_n (1);
}

/*}}}*/

static int length_cmd (void)
{
   SLang_Class_Type *cl;
   SLang_Object_Type obj;
   VOID_STAR p;
   unsigned int length;
   int len;

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

   cl = _SLclass_get_class (obj.data_type);
   p = _SLclass_get_ptr_to_value (cl, &obj);

   len = 1;
   if (cl->cl_length != NULL)
     {
	if (0 == (*cl->cl_length)(obj.data_type, p, &length))
	  len = (int) length;
	else
	  len = -1;
     }

   SLang_free_object (&obj);
   return len;
}

/* convert integer to a string of length 1 */
static void char_cmd (int *x) /*{{{*/
{
   char ch, buf[2];

   ch = (char) *x;
   buf[0] = ch;
   buf[1] = 0;
   SLang_push_string (buf);
}

/*}}}*/

/* format object into a string and returns slstring */
char *_SLstringize_object (SLang_Object_Type *obj) /*{{{*/
{
   SLang_Class_Type *cl;
   unsigned char stype;
   VOID_STAR p;
   char *s, *s1;

   stype = obj->data_type;
   p = (VOID_STAR) &obj->v.ptr_val;

   cl = _SLclass_get_class (stype);

   s = (*cl->cl_string) (stype, p);
   if (s != NULL)
     {
	s1 = SLang_create_slstring (s);
	SLfree (s);
	s = s1;
     }
   return s;
}
/*}}}*/

int SLang_run_hooks(char *hook, unsigned int num_args, ...)
{
   unsigned int i;
   va_list ap;

   if (SLang_Error) return -1;

   if (0 == SLang_is_defined (hook))
     return 0;

   (void) SLang_start_arg_list ();
   va_start (ap, num_args);
   for (i = 0; i < num_args; i++)
     {
	char *arg;

	arg = va_arg (ap, char *);
	if (-1 == SLang_push_string (arg))
	  break;
     }
   va_end (ap);
   (void) SLang_end_arg_list ();

   if (SLang_Error) return -1;
   return SLang_execute_function (hook);
}

static void intrin_getenv_cmd (char *s)
{
   SLang_push_string (getenv (s));
}

#ifdef HAVE_PUTENV
static void intrin_putenv (void) /*{{{*/
{
   char *s;

   /* Some putenv implementations required malloced strings. */
   if (SLpop_string(&s)) return;

   if (putenv (s))
     {
	SLang_Error = SL_INTRINSIC_ERROR;
	SLfree (s);
     }

   /* Note that s is NOT freed */
}

/*}}}*/

#endif

static void byte_compile_file (char *f, int *m)
{
   SLang_byte_compile_file (f, *m);
}

static void intrin_type_info1 (void)
{
   SLang_Object_Type obj;
   unsigned int type;

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

   type = obj.data_type;
   if (type == SLANG_ARRAY_TYPE)
     type = obj.v.array_val->data_type;

   SLang_free_object (&obj);

   SLang_push_datatype (type);
}

static void intrin_type_info (void)
{
   SLang_Object_Type obj;

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

   SLang_push_datatype (obj.data_type);
   SLang_free_object (&obj);
}

void _SLstring_intrinsic (void) /*{{{*/
{
   SLang_Object_Type x;
   char *s;

   if (SLang_pop (&x)) return;
   if (NULL != (s = _SLstringize_object (&x)))
     _SLang_push_slstring (s);

   SLang_free_object (&x);
}

/*}}}*/

static void intrin_typecast (void)
{
   unsigned char to_type;
   if (0 == SLang_pop_datatype (&to_type))
     (void) SLclass_typecast (to_type, 0, 1);
}

#if SLANG_HAS_FLOAT
static void intrin_double (void)
{
   (void) SLclass_typecast (SLANG_DOUBLE_TYPE, 0, 1);
}

#endif

static void intrin_int (void) /*{{{*/
{
   (void) SLclass_typecast (SLANG_INT_TYPE, 0, 1);
}

/*}}}*/

static char *
intrin_function_name (void)
{
   char *name;
   if (NULL == (name = _SLang_current_function_name ()))
     return "";
   return name;
}

static void intrin_message (char *s)
{
   SLang_vmessage ("%s", s);
}

static void intrin_error (char *s)
{
   SLang_verror (SL_USER_ERROR, "%s", s);
}

static void intrin_pop_n (int *n)
{
   SLdo_pop_n ((unsigned int) *n);
}

static void intrin_reverse_stack (int *n)
{
   SLreverse_stack (*n);
}

static void intrin_roll_stack (int *n)
{
   SLroll_stack (*n);
}

static void usage (void)
{
   char *msg;

   _SLstrops_do_sprintf_n (SLang_Num_Function_Args - 1);   /* do not include format */

   if (-1 == SLang_pop_slstring (&msg))
     return;

   SLang_verror (SL_USAGE_ERROR, "Usage: %s", msg);
   SLang_free_slstring (msg);
}

/* Convert string to integer */
static int intrin_integer (char *s)
{
   int i;

   i = SLatoi ((unsigned char *) s);

   if (SLang_Error)
     SLang_verror (SL_TYPE_MISMATCH, "Unable to convert string to integer");
   return i;
}
/*}}}*/

static void guess_type (char *s)
{
   SLang_push_datatype (SLang_guess_type(s));
}


static int load_string_or_file (int (*f) (char *, char *))
{
   char *file;
   char *ns = NULL;
   int status;

   if (SLang_Num_Function_Args == 2)
     {
	if (-1 == SLang_pop_slstring (&ns))
	  return -1;
     }

   if (-1 == SLang_pop_slstring (&file))
     {
	SLang_free_slstring (ns);
	return -1;
     }
   
   status = (*f) (file, ns);
   SLang_free_slstring (file);
   SLang_free_slstring (ns);
   return status;
}

static int load_file (void)
{
   return (0 == load_string_or_file (SLns_load_file));
}

static void load_string (void)
{
   /* FIXME: This should use the namespace of the currently executing code */
   (void) load_string_or_file (SLns_load_string);
}

static void get_doc_string (char *file, char *topic)
{
   FILE *fp;
   char line[1024];
   unsigned int topic_len, str_len;
   char *str;
   char ch;

   if (NULL == (fp = fopen (file, "r")))
     {
	SLang_push_null ();
	return;
     }

   topic_len = strlen (topic);
   ch = *topic;

   while (1)
     {
	if (NULL == fgets (line, sizeof(line), fp))
	  {
	     fclose (fp);
	     (void) SLang_push_null ();
	     return;
	  }

	if ((ch == *line)
	    && (0 == strncmp (line, topic, topic_len))
	    && ((line[topic_len] == '\n') || (line [topic_len] == 0)
		|| (line[topic_len] == ' ') || (line[topic_len] == '\t')))
	  break;
     }

   if (NULL == (str = SLmake_string (line)))
     {
	fclose (fp);
	(void) SLang_push_null ();
	return;
     }
   str_len = strlen (str);

   while (NULL != fgets (line, sizeof (line), fp))
     {
	unsigned int len;
	char *new_str;

	ch = *line;
	if (ch == '#') continue;
	if (ch == '-') break;

	len = strlen (line);
	if (NULL == (new_str = SLrealloc (str, str_len + len + 1)))
	  {
	     SLfree (str);
	     str = NULL;
	     break;
	  }
	str = new_str;
	strcpy (str + str_len, line);