diff options
Diffstat (limited to 'mdk-stage1/slang/slstd.c')
| -rw-r--r-- | mdk-stage1/slang/slstd.c | 724 |
1 files changed, 0 insertions, 724 deletions
diff --git a/mdk-stage1/slang/slstd.c b/mdk-stage1/slang/slstd.c deleted file mode 100644 index b05dfcddb..000000000 --- a/mdk-stage1/slang/slstd.c +++ /dev/null @@ -1,724 +0,0 @@ -/* -*- mode: C; mode: fold; -*- */ -/* Standard intrinsic functions for S-Lang. Included here are string - and array operations */ -/* Copyright (c) 1992, 1999, 2001 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 lang_print_stack (void) /*{{{*/ -{ - char buf[32]; - unsigned int n; - - n = (unsigned int) (_SLStack_Pointer - _SLRun_Stack); - while (n) - { - n--; - sprintf (buf, "(%u)", n); - _SLdump_objects (buf, _SLRun_Stack + n, 1, 1); - } -} - -/*}}}*/ - -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) -{ - if (NULL == _SLang_Current_Function_Name) - return ""; - return _SLang_Current_Function_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_file (char *s) -{ - if (-1 == SLang_load_file (s)) - return 0; - return 1; -} - -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); - str_len += len; - } - - fclose (fp); - - (void) SLang_push_malloced_string (str); -} - -static int push_string_array_elements (SLang_Array_Type *at) -{ - char **strs; - unsigned int num; - unsigned int i; - - if (at == NULL) - return -1; - - strs = (char **)at->data; - num = at->num_elements; - for (i = 0; i < num; i++) - { - if (-1 == SLang_push_string (strs[i])) - { - SLdo_pop_n (i); - return -1; - } - } - SLang_push_integer ((int) num); - return 0; -} - - -static void intrin_apropos (void) -{ - int num_args; - char *pat; - char *namespace_name; - unsigned int flags; - SLang_Array_Type *at; - - num_args = SLang_Num_Function_Args; - - if (-1 == SLang_pop_uinteger (&flags)) - return; - if (-1 == SLang_pop_slstring (&pat)) - return; - - namespace_name = NULL; - at = NULL; - if (num_args == 3) - { - if (-1 == SLang_pop_slstring (&namespace_name)) - goto free_and_return; - } - - at = _SLang_apropos (namespace_name, pat, flags); - if (num_args == 3) - { - (void) SLang_push_array (at, 0); - goto free_and_return; - } - - /* Maintain compatibility with old version of the function. That version - * did not take three arguments and returned everything to the stack. - * Yuk. - */ - (void) push_string_array_elements (at); - - free_and_return: - /* NULLs ok */ - SLang_free_slstring (namespace_name); - SLang_free_slstring (pat); - SLang_free_array (at); -} - -static int intrin_get_defines (void) -{ - int n = 0; - char **s = _SLdefines; - - while (*s != NULL) - { - if (-1 == SLang_push_string (*s)) - { - SLdo_pop_n ((unsigned int) n); - return -1; - } - s++; - n++; - } - return n; -} - -static void intrin_get_reference (char *name) -{ - _SLang_push_ref (1, (VOID_STAR) _SLlocate_name (name)); -} - -#ifdef HAVE_SYS_UTSNAME_H -# include <sys/utsname.h> -#endif - -static void uname_cmd (void) -{ -#ifdef HAVE_UNAME - struct utsname u; - char *field_names [6]; - unsigned char field_types[6]; - VOID_STAR field_values [6]; - char *ptrs[6]; - int i; - - if (-1 == uname (&u)) - (void) SLang_push_null (); - - field_names[0] = "sysname"; ptrs[0] = u.sysname; - field_names[1] = "nodename"; ptrs[1] = u.nodename; - field_names[2] = "release"; ptrs[2] = u.release; - field_names[3] = "version"; ptrs[3] = u.version; - field_names[4] = "machine"; ptrs[4] = u.machine; - - for (i = 0; i < 5; i++) - { - field_types[i] = SLANG_STRING_TYPE; - field_values[i] = (VOID_STAR) &ptrs[i]; - } - - if (0 == SLstruct_create_struct (5, field_names, field_types, field_values)) - return; -#endif - - SLang_push_null (); -} - -static void uninitialize_ref_intrin (SLang_Ref_Type *ref) -{ - (void) _SLang_uninitialize_ref (ref); -} - -static SLang_Intrin_Fun_Type SLang_Basic_Table [] = /*{{{*/ -{ - MAKE_INTRINSIC_1("__is_initialized", _SLang_is_ref_initialized, SLANG_INT_TYPE, SLANG_REF_TYPE), - MAKE_INTRINSIC_S("__get_reference", intrin_get_reference, SLANG_VOID_TYPE), - MAKE_INTRINSIC_1("__uninitialize", uninitialize_ref_intrin, SLANG_VOID_TYPE, SLANG_REF_TYPE), - MAKE_INTRINSIC_SS("get_doc_string_from_file", get_doc_string, SLANG_VOID_TYPE), - MAKE_INTRINSIC_SS("autoload", SLang_autoload, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("is_defined", SLang_is_defined, SLANG_INT_TYPE), - MAKE_INTRINSIC_0("string", _SLstring_intrinsic, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("uname", uname_cmd, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("getenv", intrin_getenv_cmd, SLANG_VOID_TYPE), -#ifdef HAVE_PUTENV - MAKE_INTRINSIC_0("putenv", intrin_putenv, SLANG_VOID_TYPE), -#endif - MAKE_INTRINSIC_S("evalfile", load_file, SLANG_INT_TYPE), - MAKE_INTRINSIC_I("char", char_cmd, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("eval", SLang_load_string, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("dup", do_dup, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("integer", intrin_integer, SLANG_INT_TYPE), - MAKE_INTRINSIC_S("system", SLsystem, SLANG_INT_TYPE), - MAKE_INTRINSIC_0("_apropos", intrin_apropos, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("_trace_function", _SLang_trace_fun, SLANG_VOID_TYPE), -#if SLANG_HAS_FLOAT - MAKE_INTRINSIC_S("atof", _SLang_atof, SLANG_DOUBLE_TYPE), - MAKE_INTRINSIC_0("double", intrin_double, SLANG_VOID_TYPE), -#endif - MAKE_INTRINSIC_0("int", intrin_int, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("typecast", intrin_typecast, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("_stkdepth", _SLstack_depth, SLANG_INT_TYPE), - MAKE_INTRINSIC_I("_stk_reverse", intrin_reverse_stack, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("typeof", intrin_type_info, VOID_TYPE), - MAKE_INTRINSIC_0("_typeof", intrin_type_info1, VOID_TYPE), - MAKE_INTRINSIC_I("_pop_n", intrin_pop_n, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("_print_stack", lang_print_stack, SLANG_VOID_TYPE), - MAKE_INTRINSIC_I("_stk_roll", intrin_roll_stack, SLANG_VOID_TYPE), - MAKE_INTRINSIC_SI("byte_compile_file", byte_compile_file, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("_clear_error", _SLang_clear_error, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("_function_name", intrin_function_name, SLANG_STRING_TYPE), -#if SLANG_HAS_FLOAT - MAKE_INTRINSIC_S("set_float_format", _SLset_double_format, SLANG_VOID_TYPE), -#endif - MAKE_INTRINSIC_S("_slang_guess_type", guess_type, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("error", intrin_error, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("message", intrin_message, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("__get_defined_symbols", intrin_get_defines, SLANG_INT_TYPE), - MAKE_INTRINSIC_I("__pop_args", _SLstruct_pop_args, SLANG_VOID_TYPE), - MAKE_INTRINSIC_1("__push_args", _SLstruct_push_args, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE), - MAKE_INTRINSIC_0("usage", usage, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("implements", _SLang_implements_intrinsic, SLANG_VOID_TYPE), - MAKE_INTRINSIC_S("use_namespace", _SLang_use_namespace_intrinsic, SLANG_VOID_TYPE), - MAKE_INTRINSIC_0("current_namespace", _SLang_cur_namespace_intrinsic, SLANG_STRING_TYPE), - MAKE_INTRINSIC_0("length", length_cmd, SLANG_INT_TYPE), - SLANG_END_INTRIN_FUN_TABLE -}; - -/*}}}*/ - -#ifdef SLANG_DOC_DIR -char *SLang_Doc_Dir = SLANG_DOC_DIR; -#else -char *SLang_Doc_Dir = ""; -#endif - -static SLang_Intrin_Var_Type Intrin_Vars[] = -{ - MAKE_VARIABLE("_debug_info", &_SLang_Compile_Line_Num_Info, SLANG_INT_TYPE, 0), - MAKE_VARIABLE("_auto_declare", &_SLang_Auto_Declare_Globals, SLANG_INT_TYPE, 0), - MAKE_VARIABLE("_traceback", &SLang_Traceback, SLANG_INT_TYPE, 0), - MAKE_VARIABLE("_slangtrace", &_SLang_Trace, SLANG_INT_TYPE, 0), - MAKE_VARIABLE("_slang_version", &SLang_Version, SLANG_INT_TYPE, 1), - MAKE_VARIABLE("_slang_version_string", &SLang_Version_String, SLANG_STRING_TYPE, 1), - MAKE_VARIABLE("_NARGS", &SLang_Num_Function_Args, SLANG_INT_TYPE, 1), - MAKE_VARIABLE("_slang_doc_dir", &SLang_Doc_Dir, SLANG_STRING_TYPE, 1), - MAKE_VARIABLE("NULL", NULL, SLANG_NULL_TYPE, 1), - SLANG_END_INTRIN_VAR_TABLE -}; - -int SLang_init_slang (void) /*{{{*/ -{ - char name[3]; - unsigned int i; - char **s; - static char *sys_defines [] = - { -#if defined(__os2__) - "OS2", -#endif -#if defined(__MSDOS__) - "MSDOS", -#endif -#if defined(__WIN16__) - "WIN16", -#endif -#if defined (__WIN32__) - "WIN32", -#endif -#if defined(__NT__) - "NT", -#endif -#if defined (VMS) - "VMS", -#endif -#ifdef REAL_UNIX_SYSTEM - "UNIX", -#endif -#if SLANG_HAS_FLOAT - "SLANG_DOUBLE_TYPE", -#endif - NULL - }; - - if (-1 == _SLregister_types ()) return -1; - - if ((-1 == SLadd_intrin_fun_table(SLang_Basic_Table, NULL)) - || (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL)) - || (-1 == _SLang_init_slstrops ()) - || (-1 == _SLang_init_sltime ()) - || (-1 == _SLstruct_init ()) -#if SLANG_HAS_COMPLEX - || (-1 == _SLinit_slcomplex ()) -#endif -#if SLANG_HAS_ASSOC_ARRAYS - || (-1 == SLang_init_slassoc ()) -#endif - ) - return -1; - - SLadd_global_variable (SLANG_SYSTEM_NAME); - - s = sys_defines; - while (*s != NULL) - { - if (-1 == SLdefine_for_ifdef (*s)) return -1; - s++; - } - - /* give temp global variables $0 --> $9 */ - name[2] = 0; name[0] = '$'; - for (i = 0; i < 10; i++) - { - name[1] = (char) (i + '0'); - SLadd_global_variable (name); - } - - SLang_init_case_tables (); - - /* Now add a couple of macros */ - SLang_load_string (".(_NARGS 1 - Sprintf error)verror"); - SLang_load_string (".(_NARGS 1 - Sprintf message)vmessage"); - - if (SLang_Error) - return -1; - - return 0; -} - -/*}}}*/ - -int SLang_set_argc_argv (int argc, char **argv) -{ - static int this_argc; - static char **this_argv; - int i; - - if (argc < 0) argc = 0; - this_argc = argc; - - if (NULL == (this_argv = (char **) SLmalloc ((argc + 1) * sizeof (char *)))) - return -1; - memset ((char *) this_argv, 0, sizeof (char *) * (argc + 1)); - - for (i = 0; i < argc; i++) - { - if (NULL == (this_argv[i] = SLang_create_slstring (argv[i]))) - goto return_error; - } - - if (-1 == SLadd_intrinsic_variable ("__argc", (VOID_STAR)&this_argc, - SLANG_INT_TYPE, 1)) - goto return_error; - - if (-1 == SLang_add_intrinsic_array ("__argv", SLANG_STRING_TYPE, 1, - (VOID_STAR) this_argv, 1, argc)) - goto return_error; - - return 0; - - return_error: - for (i = 0; i < argc; i++) - SLang_free_slstring (this_argv[i]); /* NULL ok */ - SLfree ((char *) this_argv); - - return -1; -} |