/* -*- mode: C; mode: fold; -*- */ /* Standard intrinsic functions for S-Lang. Included here are string and array operations */ /* Copyright (c) 1992, 1995 John E. Davis * All rights reserved. * * You may distribute under the terms of either the GNU General Public * License or the Perl Artistic License. */ #include "config.h" #include "sl-feat.h" /*{{{ Include Files */ #include #include #ifndef __QNX__ # if defined(__GO32__) || defined(__WATCOMC__) # include # include # endif #endif #include "slang.h" #include "_slang.h" #if SLANG_HAS_FLOAT #include #endif #include #include /*}}}*/ /* 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) /*{{{*/ { SLang_Class_Type *cl; SLang_Object_Type x; if (-1 == SLang_pop(&x)) return; SLang_push(&x); cl = _SLclass_get_class (x.data_type); (*cl->cl_push) (x.data_type, (VOID_STAR) &x.v.p_val); } /*}}}*/ static char Utility_Char_Table [256]; static void set_utility_char_table (char *pos) /*{{{*/ { register char *t = Utility_Char_Table, *tmax; register unsigned char ch; tmax = t + 256; while (t < tmax) *t++ = 0; t = Utility_Char_Table; while ((ch = (unsigned char) *pos++) != 0) t[ch] = 1; } /*}}}*/ static void SLdo_strcat (char *a, char *b) /*{{{*/ { char *c; c = SLang_concat_slstrings (a, b); if (c != NULL) _SLang_push_slstring (c); /* frees upon error */ } /*}}}*/ static int do_trim (char **beg, char **end, char *white) /*{{{*/ { int len; char *a, *b; set_utility_char_table (white); a = *beg; len = strlen (a); b = a + (len - 1); while (Utility_Char_Table[(unsigned char) *a]) a++; while ((b >= a) && (Utility_Char_Table[(unsigned char) *b])) b--; b++; len = (int) (b - a); *beg = a; *end = b; return len; } /*}}}*/ static void SLdo_strtrim(void) /*{{{*/ { char *a, *beg, *end; /* Go through SLpop_string to get a private copy since it will be * modified. */ if (SLpop_string(&a)) return; beg = a; (void) do_trim (&beg, &end, " \t\n"); /* Since a is a malloced string that will be freed, massage it. */ *end = 0; SLang_push_string (beg); SLfree (a); } /*}}}*/ static void SLdo_strcompress (void) /*{{{*/ { char *str, *white, *c; unsigned char *s, *beg, *end; unsigned int len; if (SLpop_string (&white)) return; if (SLpop_string (&str)) { SLfree (white); return; } beg = (unsigned char *) str; (void) do_trim ((char **) &beg, (char **) &end, white); SLfree (white); /* Determine the effective length */ len = 0; s = (unsigned char *) beg; while (s < end) { len++; if (Utility_Char_Table[*s++]) { while ((s < end) && Utility_Char_Table[*s]) s++; } } if (NULL != (c = SLmalloc (len + 1))) { s = (unsigned char *) c; while (beg < end) { *s++ = *beg; if (Utility_Char_Table[*beg++]) { while ((beg < end) && Utility_Char_Table[*beg]) beg++; } } *s = 0; SLang_push_malloced_string(c); } SLfree(str); } /*}}}*/ static int str_replace (char *orig, char *match, char *rep) /*{{{*/ { char *s, *newstr; int ret; unsigned int rep_len, match_len, new_len; new_len = strlen (orig); if ((NULL != (s = strstr (orig, match))) && (NULL != (newstr = SLmake_nstring (orig, new_len)))) { match_len = strlen (match); rep_len = strlen (rep); if (rep_len > match_len) { new_len += rep_len - match_len; newstr = (char *) SLrealloc (newstr, new_len + 1); /* SLrealloc will set SLang_Error upon failure. */ } if (!SLang_Error) { char *s1 = newstr + (int) (s - orig); strcpy (s1 + rep_len, s + match_len); SLMEMCPY (s1, rep, rep_len); SLang_push_malloced_string (newstr); } ret = 1; } else ret = 0; return ret; } /*}}}*/ /* This routine returns the string with text removed between single character comment delimiters from the set b and e. */ static void uncomment_string (char *str, char *b, char *e) /*{{{*/ { unsigned char chb, che; unsigned char *s, *cbeg, *mark; if (strlen(b) != strlen(e)) { SLang_doerror ("Comment delimiter length mismatch."); return; } set_utility_char_table (b); if (NULL == (str = (char *) SLmake_string(str))) return; s = (unsigned char *) str; while ((chb = *s++) != 0) { if (Utility_Char_Table [chb] == 0) continue; mark = s - 1; cbeg = (unsigned char *) b; while (*cbeg != chb) cbeg++; che = (unsigned char) *(e + (int) (cbeg - (unsigned char *) b)); while (((chb = *s++) != 0) && (chb != che)); if (chb == 0) { /* end of string and end not found. Just truncate it a return; */ *mark = 0; break; } strcpy ((char *) mark, (char *)s); s = mark; } SLang_push_malloced_string (str); } /*}}}*/ static void SLquote_string (char *str, char *quotes, int *slash_ptr) /*{{{*/ { char *q; int slash; unsigned int len; register char *t, *s, *q1; register unsigned char ch; slash = *slash_ptr; if ((slash > 255) || (slash < 0)) { SLang_Error = SL_INVALID_PARM; return; } /* setup the utility table to have 1s at quote char postitions. */ set_utility_char_table (quotes); t = Utility_Char_Table; t[(unsigned int) slash] = 1; /* calculate length */ s = str; len = 0; while ((ch = (unsigned char) *s++) != 0) if (t[ch]) len++; len += (unsigned int) (s - str); if (NULL != (q = SLmalloc(len))) { s = str; q1 = q; while ((ch = (unsigned char) *s++) != 0) { if (t[ch]) *q1++ = slash; *q1++ = (char) ch; } *q1 = 0; SLang_push_malloced_string(q); } } /*}}}*/ /* returns the position of substrin in a string or null */ static int intrin_issubstr (char *a, char *b) /*{{{*/ { char *c; if (NULL == (c = (char *) strstr(a, b))) return 0; return 1 + (int) (c - a); } /*}}}*/ /* returns to stack string at pos n to n + m of a */ static void SLdo_substr (char *a, int *n_ptr, int *m_ptr) /*{{{*/ { char *b; int n, m; int lena; n = *n_ptr; m = *m_ptr; lena = strlen (a); if (n > lena) n = lena + 1; if (n < 1) { SLang_Error = SL_INVALID_PARM; return; } n--; if (m < 0) m = lena; if (n + m > lena) m = lena - n; b = SLang_create_nslstring (a + n, (unsigned int) m); if (b != NULL) _SLang_push_slstring (b); } /*}}}*/ /* substitute char m at positin string n in string*/ static void SLdo_strsub (int *nptr, int *mptr) /*{{{*/ { char *a; int n, m; unsigned int lena; if (-1 == SLpop_string (&a)) return; n = *nptr; m = *mptr; lena = strlen (a); if ((n <= 0) || (lena < (unsigned int) n)) { SLang_Error = SL_INVALID_PARM; SLfree(a); return; } a[n - 1] = (char) m; SLang_push_malloced_string (a); } /*}}}*/ static void SLdo_strup(void) /*{{{*/ { unsigned char c, *a; char *str; if (SLpop_string (&str)) return; a = (unsigned char *) str; while ((c = *a) != 0) { /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ *a = UPPER_CASE(c); a++; } SLang_push_malloced_string (str); } /*}}}*/ static int do_upper (int *ch) /*{{{*/ { return UPPER_CASE(*ch); } /*}}}*/ static int do_lower (int *ch) /*{{{*/ { return LOWER_CASE(*ch); } /*}}}*/ static void SLdo_strlow (void) /*{{{*/ { unsigned char c, *a; char *str; if (SLpop_string(&str)) return; a = (unsigned char *) str; while ((c = *a) != 0) { /* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */ *a = LOWER_CASE(c); a++; } SLang_push_malloced_string ((char *) str); } /*}}}*/ static int do_strchop (char *str, int *delim_ptr, int *quote_ptr) /*{{{*/ { int delim, quote, count; char *s0, *elm; register char *s1; register unsigned char ch; int quoted; quote = *quote_ptr; delim = *delim_ptr; if ((quote < 0) || (quote > 255) || (delim <= 0) || (delim > 255)) { SLang_Error = SL_TYPE_MISMATCH; return 0; } s1 = s0 = str; quoted = 0; count = 0; while (1) { ch = (unsigned char) *s1; if ((ch == quote) && quote) { s1++; quoted = 1; if (*s1 != 0) s1++; } else if ((ch == delim) || (ch == 0)) { if (NULL == (elm = SLmake_nstring (s0, (unsigned int)(s1 - s0)))) break; /* Now unquote it */ if (quoted) { register char ch1, *p, *p1; p = p1 = elm; do { ch1 = *p1++; if (ch1 == '\\') ch1 = *p1++; *p++ = ch1; } while (ch1 != 0); quoted = 0; } SLang_push_malloced_string (elm); if (SLang_Error) break; count++; if (ch == 0) break; s1++; /* skip past delim */ s0 = s1; /* and reset */ } else s1++; } if (SLang_Error) { while (count != 0) { count--; SLdo_pop (); } count = 0; } return count; } /*}}}*/ static int do_strchopr (char *str, int *q, int *d) /*{{{*/ { int count; count = do_strchop (str, q, d); if (count <= 0) return count; _SLreverse_stack (count); return count; } /*}}}*/ static int intrin_strcmp (char *a, char *b) /*{{{*/ { return strcmp(a, b); } /*}}}*/ static int intrin_strncmp (char *a, char *b, int *n) /*{{{*/ { return strncmp(a, b, (unsigned int) *n); } /*}}}*/ static int intrin_strlen (char *s) /*{{{*/ { return (int) strlen (s); } /*}}}*/ static int intrin_isdigit (char *what) /*{{{*/ { return ((*what >= '0') && (*what <= '9')); } /*}}}*/ /* convert integer to a string of length 1 */ static void SLdo_char (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.p_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)); } static void intrin_extract_element (char *list, int *nth_ptr, int *delim_ptr) { char buf[1024], *b; b = buf; if (-1 == SLextract_list_element (list, *nth_ptr, *delim_ptr, buf, sizeof(buf))) b = NULL; SLang_push_string (b); } #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) /*{{{*/ { SLang_Object_Type *x = _SLStack_Pointer; char buf[32]; while (--x >= _SLRun_Stack) { sprintf (buf, "(%d)", (int)(x - _SLRun_Stack)); _SLdump_objects (buf, x, 1, 1); } } /*}}}*/ /* sprintf functionality for S-Lang */ static char *SLdo_sprintf (char *fmt) /*{{{*/ { register char *p = fmt, ch; char *out = NULL, *outp = NULL; char dfmt[80]; /* used to hold part of format */ char *f; VOID_STAR varp; int var, want_width, width, precis, use_varp; unsigned int len = 0, malloc_len = 0, dlen; int do_free, guess_size; #if SLANG_HAS_FLOAT int tmp1, tmp2, use_double; double x; #endif while (1) { while ((ch = *p) != 0) { if (ch == '%') break; p++; } /* p points at '%' or 0 */ dlen = (unsigned int) (p - fmt); if (len + dlen >= malloc_len) { malloc_len = len + dlen; if (out == NULL) outp = SLmalloc(malloc_len + 1); else outp = SLrealloc(out, malloc_len + 1); if (NULL == outp) return out; out = outp; outp = out + len; } strncpy(outp, fmt, dlen); len += dlen; outp = out + len; *outp = 0; if (ch == 0) break; /* bump it beyond '%' */ ++p; fmt = p; f = dfmt; *f++ = ch; /* handle flag char */ ch = *p++; if ((ch == '-') || (ch == '+') || (ch == ' ') || (ch == '#')) { *f++ = ch; ch = *p++; } /* width */ /* I have got to parse it myself so that I can see how big it needs to be. */ want_width = width = 0; if (ch == '*') { if (SLang_pop_integer(&width)) return (out); want_width = 1; ch = *p++; } else { if (ch == '0') { *f++ = '0'; ch = *p++; } while ((ch <= '9') && (ch >= '0')) { width = width * 10 + (ch - '0'); ch = *p++; want_width = 1; } } if (want_width) { sprintf(f, "%d", width); while (*f) f++; } precis = 0; /* precision -- also indicates max number of chars from string */ if (ch == '.') { *f++ = ch; ch = *p++; want_width = 0; if (ch == '*') { if (SLang_pop_integer(&precis)) return (out); ch = *p++; want_width = 1; } else while ((ch <= '9') && (ch >= '0')) { precis = precis * 10 + (ch - '0'); ch = *p++; want_width = 1; } if (want_width) { sprintf(f, "%d", precis); while (*f) f++; } else precis = 0; } /* not supported */ if ((ch == 'l') || (ch == 'h')) ch = *p++; var = 0; varp = NULL; guess_size = 32; #if SLANG_HAS_FLOAT use_double = 0; #endif use_varp = 0; do_free = 0; /* Now the actual format specifier */ switch (ch) { case 's': if (SLang_pop_slstring((char **) &varp)) return (out); do_free = 1; guess_size = strlen((char *) varp); use_varp = 1; break; #if 1 case '%': guess_size = 1; do_free = 0; use_varp = 1; varp = (VOID_STAR) "%"; break; #endif case 'c': guess_size = 1; /* drop */ case 'd': case 'i': case 'o': case 'u': case 'X': case 'x': if (SLang_pop_integer(&var)) return(out); break; case 'f': case 'e': case 'g': case 'E': case 'G': #if SLANG_HAS_FLOAT if (SLang_pop_double(&x, &tmp1, &tmp2)) return (out); use_double = 1; guess_size = 64; (void) tmp1; (void) tmp2; break; #endif case 'p': guess_size = 32; /* Pointer type?? Why?? */ if (-1 == SLdo_pop ()) return out; varp = (VOID_STAR) _SLStack_Pointer; use_varp = 1; break; default: SLang_doerror("Invalid Format."); return(out); } *f++ = ch; *f = 0; width = width + precis; if (width > guess_size) guess_size = width; if (len + guess_size > malloc_len) { outp = (char *) SLrealloc(out, len + guess_size + 1); if (outp == NULL) { SLang_Error = SL_MALLOC_ERROR; return (out); } out = outp; outp = out + len; malloc_len = len + guess_size; } if (use_varp) { sprintf(outp, dfmt, varp); if (do_free) SLang_free_slstring ((char *)varp); } #if SLANG_HAS_FLOAT else if (use_double) sprintf(outp, dfmt, x); #endif else sprintf(outp, dfmt, var); len += strlen(outp); outp = out + len; fmt = p; } if (out != NULL) { outp = SLrealloc (out, (unsigned int) (outp - out) + 1); if (outp != NULL) out = outp; } return (out); } /*}}}*/ static int do_sprintf_n (int n) /*{{{*/ { char *p; char *fmt; SLang_Object_Type *ptr; int ofs; if (-1 == (ofs = _SLreverse_stack (n + 1))) return -1; ptr = _SLRun_Stack + ofs; if (SLang_pop_slstring(&fmt)) return -1; p = SLdo_sprintf (fmt); SLang_free_slstring (fmt); while (_SLStack_Pointer > ptr) SLdo_pop (); if (SLang_Error || (-1 == SLang_push_malloced_string (p))) { SLfree(p); return -1; } return 0; } /*}}}*/ static void intrin_sprintf (void) { do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */ } /* converts string s to a form that can be used in an eval */ static void make_printable_string(char *s) /*{{{*/ { unsigned int len; register char *s1 = s, ch, *ss1; char *ss; /* compute length */ len = 3; while ((ch = *s1++) != 0) { if ((ch == '\n') || (ch == '\\') || (ch == '"')) len++; len++; } if (NULL == (ss = SLmalloc(len))) return; s1 = s; ss1 = ss; *ss1++ = '"'; while ((ch = *s1++) != 0) { if (ch == '\n') { ch = 'n'; *ss1++ = '\\'; } else if ((ch == '\\') || (ch == '"')) { *ss1++ = '\\'; } *ss1++ = ch; } *ss1++ = '"'; *ss1 = 0; if (-1 == SLang_push_string (ss)) SLfree (ss); } /*}}}*/ static int intrin_is_list_element (char *list, char *elem, int *d_ptr) { char ch; int d, n; unsigned int len; char *lbeg, *lend; d = *d_ptr; len = strlen (elem); n = 1; lend = list; while (1) { lbeg = lend; while ((0 != (ch = *lend)) && (ch != (char) d)) lend++; if ((lbeg + len == lend) && (0 == strncmp (elem, lbeg, len))) break; if (ch == 0) { n = 0; break; } lend++; /* skip delim */ n++; } return n; } /*}}}*/ /* Regular expression routines for strings */ static SLRegexp_Type regexp_reg; static int intrin_string_match (char *str, char *pat, int *nptr) /*{{{*/ { int n; unsigned int len; unsigned char rbuf[512], *match; n = *nptr; regexp_reg.case_sensitive = 1; regexp_reg.buf = rbuf; regexp_reg.pat = (unsigned char *) pat; regexp_reg.buf_len = sizeof (rbuf); if (SLang_regexp_compile (®exp_reg)) { SLang_verror (SL_INVALID_PARM, "Unable to compile pattern"); return -1; } n--; len = strlen(str); if ((n < 0) || ((unsigned int) n >= len)) { /* SLang_Error = SL_INVALID_PARM; */ return 0; } str += n; len -= n; if (NULL == (match = SLang_regexp_match((unsigned char *) str, len, ®exp_reg))) return 0; /* adjust offsets */ regexp_reg.offset = n; return (1 + (int) ((char *) match - str)); } /*}}}*/ static int intrin_string_match_nth (int *nptr) /*{{{*/ { int n, beg; n = *nptr; if ((n < 0) || (n > 9) || (regexp_reg.pat == NULL) || ((beg = regexp_reg.beg_matches[n]) == -1)) { SLang_Error = SL_INVALID_PARM; return -1; } SLang_push_integer(beg + regexp_reg.offset); return regexp_reg.end_matches[n]; } /*}}}*/ #include #if defined(__GO32__) static char *djgpp_current_time (void) /*{{{*/ { union REGS rg; unsigned int year; unsigned char month, day, weekday, hour, minute, sec; char days[] = "SunMonTueWedThuFriSat"; char months[] = "JanFebMarAprMayJunJulAugSepOctNovDec"; static char the_date[26]; rg.h.ah = 0x2A; #ifndef __WATCOMC__ int86(0x21, &rg, &rg); year = rg.x.cx & 0xFFFF; #else int386(0x21, &rg, &rg); year = rg.x.ecx & 0xFFFF; #endif month = 3 * (rg.h.dh - 1); day = rg.h.dl; weekday = 3 * rg.h.al; rg.h.ah = 0x2C; #ifndef __WATCOMC__ int86(0x21, &rg, &rg); #else int386(0x21, &rg, &rg); #endif hour = rg.h.ch; minute = rg.h.cl; sec = rg.h.dh; /* we want this form: Thu Apr 14 15:43:39 1994\n */ sprintf(the_date, "%.3s %.3s%3d %02d:%02d:%02d %d\n", days + weekday, months + month, day, hour, minute, sec, year); return the_date; } /*}}}*/ #endif char *SLcurrent_time_string (void) /*{{{*/ { char *the_time; #ifndef __GO32__ time_t myclock; myclock = time((time_t *) 0); the_time = (char *) ctime(&myclock); #else the_time = djgpp_current_time (); #endif /* returns the form Sun Sep 16 01:03:52 1985\n\0 */ the_time[24] = '\0'; return(the_time); } /*}}}*/ static void byte_compile_file (char *f, int *m) { SLang_byte_compile_file (f, *m); } 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); } static void intrin_string(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); } #ifndef HAVE_STDLIB_H /* Oh dear. Where is the prototype for atof? If not in stdlib, then * I do not know where. Not in math.h onsome systems either. */ extern double atof (); #endif static double intrin_atof (char *s) { return atof (s); } #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_sprintf_n (int *n) { do_sprintf_n (*n); } static void intrin_roll_stack (int *n) { _SLroll_stack (*n); } /* 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); if (-1 == SLang_push_malloced_string (str)) SLfree (str); } static int intrin_apropos (char *s, int *what) { return _SLang_apropos (s, (unsigned int) *what); } static void intrin_create_delimited_string (int *nptr) { unsigned int n, i, delim_len; char **strings; unsigned int len; char *delim, *str; str = NULL; n = 1 + (unsigned int) *nptr; /* n includes delimiter */ if (NULL == (strings = (char **)SLmalloc (n * sizeof (char *)))) { SLdo_pop_n (n); return; } SLMEMSET((char *)strings, 0, n * sizeof (char *)); i = n; while (i != 0) { i--; if (-1 == SLang_pop_slstring (strings + i)) goto return_error; } len = 1; /* for \0 */ for (i = 1; i < n; i++) len += strlen (strings[i]); delim = strings[0]; delim_len = strlen (delim); if (n > 1) len += (n - 1) * delim_len; if (NULL == (str = SLmalloc (len))) goto return_error; *str = 0; if (n > 1) { char *s = str; unsigned int n1 = n - 1; for (i = 1; i < n1; i++) { strcpy (s, strings[i]); s += strlen (strings[i]); strcpy (s, delim); s += delim_len; } strcpy (s, strings[n1]); } /* drop */ return_error: for (i = 0; i < n; i++) SLang_free_slstring (strings[i]); SLfree ((char *)strings); if (str != NULL) { /* Means no error */ if (-1 == SLang_push_malloced_string (str)) SLfree (str); } } static SLang_Intrin_Fun_Type SLang_Basic_Table [] = /*{{{*/ { MAKE_INTRINSIC_I("create_delimited_string", intrin_create_delimited_string, SLANG_VOID_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_SS("strcmp", intrin_strcmp, SLANG_INT_TYPE), MAKE_INTRINSIC_SSI("strncmp", intrin_strncmp, SLANG_INT_TYPE), MAKE_INTRINSIC_SS("strcat", SLdo_strcat, SLANG_VOID_TYPE), MAKE_INTRINSIC_S("strlen", intrin_strlen, SLANG_INT_TYPE), MAKE_INTRINSIC_SII("strchop", do_strchop, SLANG_INT_TYPE), MAKE_INTRINSIC_SII("strchopr", do_strchopr, SLANG_INT_TYPE), MAKE_INTRINSIC_SSS("str_replace", str_replace, SLANG_INT_TYPE), MAKE_INTRINSIC_S("is_defined", SLang_is_defined, SLANG_INT_TYPE), MAKE_INTRINSIC("string", intrin_string, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_S("getenv", intrin_getenv_cmd, SLANG_VOID_TYPE), #ifdef HAVE_PUTENV MAKE_INTRINSIC("putenv", intrin_putenv, SLANG_VOID_TYPE, 0), #endif MAKE_INTRINSIC_S("evalfile", load_file, SLANG_INT_TYPE), MAKE_INTRINSIC_1("char", SLdo_char, SLANG_VOID_TYPE, SLANG_INT_TYPE), MAKE_INTRINSIC_S("eval", SLang_load_string, SLANG_VOID_TYPE), MAKE_INTRINSIC("dup", do_dup, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_SII("substr", SLdo_substr, SLANG_VOID_TYPE), MAKE_INTRINSIC_S("integer", intrin_integer, SLANG_INT_TYPE), MAKE_INTRINSIC_SS("is_substr", intrin_issubstr, SLANG_INT_TYPE), MAKE_INTRINSIC_II("strsub", SLdo_strsub, SLANG_VOID_TYPE), MAKE_INTRINSIC_SII("extract_element", intrin_extract_element, SLANG_VOID_TYPE), MAKE_INTRINSIC_SSI("is_list_element", intrin_is_list_element, SLANG_INT_TYPE), MAKE_INTRINSIC_SSI("string_match", intrin_string_match, SLANG_INT_TYPE), MAKE_INTRINSIC_I("string_match_nth", intrin_string_match_nth, SLANG_INT_TYPE), MAKE_INTRINSIC_S("system", SLsystem, SLANG_INT_TYPE), MAKE_INTRINSIC_SI("_apropos", intrin_apropos, SLANG_INT_TYPE), MAKE_INTRINSIC_S("_trace_function", _SLang_trace_fun, SLANG_VOID_TYPE), MAKE_INTRINSIC("strlow", SLdo_strlow, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_I("tolower", do_lower, SLANG_INT_TYPE), MAKE_INTRINSIC_I("toupper", do_upper, SLANG_INT_TYPE), MAKE_INTRINSIC("strup", SLdo_strup, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_S("isdigit", intrin_isdigit, SLANG_INT_TYPE), MAKE_INTRINSIC("strtrim", SLdo_strtrim, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC("strcompress", SLdo_strcompress, SLANG_VOID_TYPE, 0), #if SLANG_HAS_FLOAT MAKE_INTRINSIC_S("atof", intrin_atof, SLANG_DOUBLE_TYPE), MAKE_INTRINSIC("double", intrin_double, SLANG_VOID_TYPE, 0), #endif MAKE_INTRINSIC("int", intrin_int, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC("typecast", intrin_typecast, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC("_stkdepth", _SLstack_depth, SLANG_INT_TYPE, 0), MAKE_INTRINSIC_I("_stk_reverse", intrin_reverse_stack, SLANG_VOID_TYPE), MAKE_INTRINSIC("typeof", intrin_type_info, VOID_TYPE, 0), MAKE_INTRINSIC_I("_pop_n", intrin_pop_n, SLANG_VOID_TYPE), MAKE_INTRINSIC("_print_stack", lang_print_stack, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_I("_stk_roll", intrin_roll_stack, SLANG_VOID_TYPE), MAKE_INTRINSIC_I("Sprintf", intrin_sprintf_n, SLANG_VOID_TYPE), MAKE_INTRINSIC("sprintf", intrin_sprintf, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC_SI("byte_compile_file", byte_compile_file, SLANG_VOID_TYPE), MAKE_INTRINSIC_S("make_printable_string", make_printable_string, SLANG_VOID_TYPE), MAKE_INTRINSIC_SSI("str_quote_string", SLquote_string, SLANG_VOID_TYPE), MAKE_INTRINSIC_SSS("str_uncomment_string", uncomment_string, SLANG_VOID_TYPE), MAKE_INTRINSIC_II("define_case", SLang_define_case, SLANG_VOID_TYPE), MAKE_INTRINSIC("_clear_error", _SLang_clear_error, SLANG_VOID_TYPE, 0), MAKE_INTRINSIC("_function_name", intrin_function_name, SLANG_STRING_TYPE, 0), #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("time", SLcurrent_time_string, SLANG_STRING_TYPE, 0), MAKE_INTRINSIC_S("error", intrin_error, SLANG_VOID_TYPE), MAKE_INTRINSIC_S("message", intrin_message, SLANG_VOID_TYPE), SLANG_END_TABLE }; /*}}}*/ static SLang_Intrin_Var_Type Intrin_Vars[] = { MAKE_VARIABLE("_debug_info", &_SLang_Compile_Line_Num_Info, 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("_NARGS", &SLang_Num_Function_Args, SLANG_INT_TYPE, 1), MAKE_VARIABLE("NULL", NULL, SLANG_NULL_TYPE, 1), SLANG_END_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 (__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 == _SLstruct_init ()) #if SLANG_HAS_COMPLEX || (-1 == _SLinit_slcomplex ()) #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; } /*}}}*/