/* -*- 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 <stdio.h>
#include <time.h>
#ifndef __QNX__
# if defined(__GO32__) || defined(__WATCOMC__)
# include <dos.h>
# include <bios.h>
# endif
#endif
#include "slang.h"
#include "_slang.h"
#if SLANG_HAS_FLOAT
#include <math.h>
#endif
#include <string.h>
#include <stdarg.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) /*{{{*/
{
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 <time.h>
#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;
}
/*}}}*/
