From 98a18b797c63ea9baab31768ed720ad32c0004e8 Mon Sep 17 00:00:00 2001 From: Guillaume Cottenceau Date: Mon, 14 May 2001 21:47:42 +0000 Subject: i can compile slang and newt with dietlibc now --- mdk-stage1/slang/slstd.c | 724 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 724 insertions(+) create mode 100644 mdk-stage1/slang/slstd.c (limited to 'mdk-stage1/slang/slstd.c') diff --git a/mdk-stage1/slang/slstd.c b/mdk-stage1/slang/slstd.c new file mode 100644 index 000000000..b05dfcddb --- /dev/null +++ b/mdk-stage1/slang/slstd.c @@ -0,0 +1,724 @@ +/* -*- 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 + +#ifndef __QNX__ +# if defined(__GO32__) || defined(__WATCOMC__) +# include +# include +# endif +#endif + +#if SLANG_HAS_FLOAT +# include +#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 +#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; +} -- cgit v1.2.1