/* Basic string functions for S-Lang */
/* 
 * Copyright (c) 1992, 1994 John E. Davis 
 * All rights reserved.
 *
 * Permission is hereby granted, without written agreement and without
 * license or royalty fees, to use, copy, and distribute this
 * software and its documentation for any purpose, provided that the
 * above copyright notice and the following two paragraphs appear in
 * all copies of this software.
 *
 * IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT,
 * INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF
 * THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS
 * HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 * JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
 * BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE,
 * SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 */


#include <stdio.h>
#ifdef __cplusplus
#include <stdlib.h>
#else
extern int system();
#endif

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


/* Standard intrinsic functions for S-Lang.  Included here are string
   and array operations */
      
/* builtin stack manipulation functions */

void SLdo_pop(void)
{
   SLang_Object_Type x;
   if (SLang_pop(&x)) return;

   if (IS_DATA_STRING(x)) FREE(x.value);
}

int SLdo_dup(void)
{
   SLang_Object_Type x;
   if (SLang_pop(&x)) return(0);
   SLang_push(&x);
   if ((x.type >> 8) == STRING_TYPE) SLang_push_string((char *) x.value); 
   else SLang_push (&x);
   
   return(1);
}
   

void SLdo_strcat(void)
{
   char *a, *b, *c;
   int len, lena;
   int adata, bdata;

   if (SLang_pop_string(&b, &bdata) || SLang_pop_string(&a, &adata)) return;

   lena = strlen(a);
   len = lena + strlen(b) + 1;
   if (adata == 1)
     {
	if ((NULL != (c = (char *) REALLOC(a, len))))
	  {
	     strcpy (c + lena, b);
	     adata = 0;
	  }
	else
	  {
	     SLang_Error = SL_MALLOC_ERROR;
	     return;
	  }
     }
   else if (NULL != (c = (char *) MALLOC(len)))
     {
	strcpy(c, a);
	strcpy(c + lena, b);
     }
   else 
     {
	SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Lang Malloc error."); */
	return;
     }
   
   /* instead of going throug push string, push it directly */
   SLang_push_malloced_string(c);
   if (adata == 1) FREE(a);
   if (bdata == 1) FREE(b);
}

void SLdo_strtrim(void)
{
   char *a, *beg, *end, *c, *neew, ch;
   int len;
   int adata;

   if (SLang_pop_string(&a, &adata)) return;

   len = strlen(a);
   beg = a;
   end = a + (len - 1);
   while (ch = *beg, (ch == ' ') || (ch == '\t') || (ch == '\n')) beg++;
   while (end >= beg)
     {
	ch = *end;
	if ((ch == ' ') || (ch == '\t') || (ch == '\n')) end--;
	else break;
     }
   end++;
   len = (int) (end - beg);
   /* instead of going throug push string, push it directly.  This is because
    * the string that is being copied might be a constant. */
   if (NULL != (c = (char *) MALLOC(len + 1)))
     {
	neew = c;
	while (beg < end) *c++ = *beg++;
	*c = 0;

	SLang_push_malloced_string(neew);
     }
   else SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Lang Malloc error."); */
   
   if (adata == 1) FREE(a);
}

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;
}

/* This routine returns the string with text removed between single character
   comment delimeters 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 delimeter 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);
}

   
   
void SLquote_string ()
{
   char *str, *quotes, *q;
   int sdata, qdata;
   int slash, n;
   register char *t, *s, *q1;
   register unsigned char ch;
   
   if ((SLang_pop_integer (&slash))    /* quote char */
       || (SLang_pop_string (&quotes, &qdata))) return;   /* chars to quote */
   if (SLang_pop_string (&str, &sdata))  /* string to quote */
     {
	if (qdata == 1) FREE (quotes);
	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;
   n = 0;
   while ((ch = (unsigned char) *s++) != 0) if (t[ch]) n++;
   n += (int) (s - str);
   
   if (NULL != (q = (char *) MALLOC(n)))
     {
	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);
     }
   else SLang_Error = SL_MALLOC_ERROR;
   
   if (qdata == 1) FREE (quotes);
   if (sdata == 1) FREE (str);
}


/* returns the position of substrin in a string or null */
void SLdo_issubstr(void)
{
   char *a, *b, *c;
   int adata, bdata, n;

   if (SLang_pop_string(&b, &bdata) || SLang_pop_string(&a, &adata)) return;

   if (NULL == (c = (char *) strstr(a, b))) n = 0; else n = 1 + (int) (c - a);

   if (adata == 1) FREE(a);
   if (bdata == 1) FREE(b);
   SLang_push_integer (n);
}

/* returns to stack string at pos n to n + m of a */
void SLdo_substr(void)
{
   char *a;
   int adata, n, m;
   char b[256];

   if (SLang_pop_integer(&m) || SLang_pop_integer(&n) || (SLang_pop_string(&a, &adata))) return;

   *b = 0;
   if (m > 0)
     {
	strncpy(b, a + (n - 1), 254);
	if (m > 255) m = 255;
	b[m] = 0;
     }
   if (adata == 1) FREE(a);
   SLang_push_string(b);
}
/* substitute char m at positin string n in string*/
void SLdo_strsub(void)
{
   char *a;
   int adata, n, m;
   char b[256];

   if (SLang_pop_integer(&m) || SLang_pop_integer(&n) || (SLang_pop_string(&a, &adata))) return;

   strncpy(b, a, 254);
   b[254] = 0;
   if (adata == 1) FREE(a);
   if ((n < 1) || (n > 254)) n = 254;
   b[n-1] = (char) m;
   SLang_push_string(b);
}

void SLdo_strup(void)
{
   unsigned char c, *a;
   int adata;

   if (SLang_pop_string((char **) &a, &adata)) return;
   SLang_push_string((char *) a);
   if (adata == 1) FREE(a);
   
   a = (unsigned char *) (SLStack_Pointer - 1)->value;
   while ((c = *a) != 0)
     {
	/* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */
	*a = UPPER_CASE(c);
	a++;
     }
}

void SLdo_strlow(void)
{
   unsigned char c, *a;
   int adata;

   if (SLang_pop_string((char **) &a, &adata)) return;
   SLang_push_string((char *) a);
   if (adata == 1) FREE(a);
   a = (unsigned char *) (SLStack_Pointer - 1)->value;
   
   while ((c = *a) != 0)
     {
	/* if ((*a >= 'a') && (*a <= 'z')) *a -= 32; */
	*a = LOWER_CASE(c);
	a++;
     }
}

void SLdo_strcmp(void)
{
   char *a, *b;
   int adata, bdata, i;

   if (SLang_pop_string(&b, &bdata) || SLang_pop_string(&a, &adata)) return;

   i = strcmp(a, b);

   if (adata == 1) FREE(a);
   if (bdata == 1) FREE(b);
   SLang_push_integer (i);
}

void SLdo_strncmp(void)
{
   char *a, *b;
   int adata, bdata, i, n;
   
   if (SLang_pop_integer(&n) || SLang_pop_string(&b, &bdata) || SLang_pop_string(&a, &adata)) return;

   i = strncmp(a, b, n);

   if (adata == 1) FREE(a);
   if (bdata == 1) FREE(b);
   SLang_push_integer (i);
}

void SLdo_strlen(void)
{
   char *a;
   int adata, i;

   if (SLang_pop_string(&a, &adata)) return;

   i = strlen(a);

   if (adata == 1) FREE(a);
   SLang_push_integer (i);
}

int SLdo_isdigit(char *what)
{
   if ((*what >= '0') && (*what <= '9')) return(1); else return(0);
}

/* convert object to integer form */
void SLdo_int(void)
{
   SLang_Object_Type x;
   int i;
   unsigned char stype;

   if (SLang_pop(&x)) return;
   stype = x.type >> 8;

   if (stype == INT_TYPE)
     {
	SLang_push(&x);
	return;
     }

   else if (stype == STRING_TYPE)
     {
	stype = x.type & 0xFF;
	i = (int) *(unsigned char *) x.value;
	
	if (stype == LANG_DATA) FREE(x.value);
     }
#ifdef FLOAT_TYPE
   else if (stype == FLOAT_TYPE)
     {
	i = (int) *(FLOAT *) &x.value;
     }
#endif
   else
     {
	SLang_Error = TYPE_MISMATCH;
	return;
     }
   SLang_push_integer(i);
}

static char Float_Format[16] = "%f";

static void set_float_format (char *s)
{
   strncpy (Float_Format, s, 15);
   Float_Format[15] = 0;
}


/* Conver string to integer */
void SLdo_integer(void)
{
   char *a;
   int adata, i;

   if (SLang_pop_string(&a, &adata)) return;

   /* Should check for parse error here but later */
   i = SLatoi((unsigned char *) a);

   if (adata == 1) FREE(a);
   SLang_push_integer (i);
}

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

   if (SLang_pop_integer(&x)) return;

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

/* format object into a string */
void SLdo_string(void)
{
   SLang_Object_Type x;
   char buf[256];
   unsigned char type;
   if (SLang_pop(&x)) return;

   type = (x.type >> 8);
   if (type == STRING_TYPE)
     {
	SLang_push(&x);
	return;
     }
#ifndef FLOAT_TYPE
   sprintf(buf, "%d", (int) x.value);
#else
   if (type == INT_TYPE)
     {
	sprintf(buf, "%d", (int) x.value);
     }
   else
     {
	sprintf(buf, Float_Format,  (FLOAT) *(FLOAT *) &x.value);
     }
#endif
   SLang_push_string((char *) buf);
}
/* probably more useful to have a argc, argv thing */
int SLang_run_hooks(char *hook, char *opt1, char *opt2)
{
   int ret = 0;

   if (SLang_Error || !SLang_is_defined(hook)) return(0);
   if (opt1 != NULL) SLang_push_string(opt1);
   if (opt2 != NULL) SLang_push_string(opt2);
   if (!SLang_Error) ret = SLang_execute_function(hook);
   return (ret && !SLang_Error);
}

static void lang_getenv_cmd(char *s)
{
   char *t;
   if (NULL == (t = getenv(s))) t = "";
   SLang_push_string(t);
}

#ifndef VMS
static void lang_putenv_cmd(void)
{
   char *s;
   int d;
   if (SLang_pop_string(&s, &d)) return;

   if (putenv (s))
     {
	SLang_Error = INTRINSIC_ERROR;
	if (d == 1) FREE (s);
     }
   
   /* Note that s is NOT freed */
}
#endif
int lang_apropos1(char *s, SLang_Name_Type *table, int max)
{
   int all = 0, n = 0;
   char *nm;
   SLang_Object_Type obj;

   if (*s == 0) all = 1;

   while(max && (nm = table->name, *nm != 0))
     {
	nm++;  /* lose hash */
	if ((*nm != 1) && (all || (NULL != strstr(nm, s))))
	  {
	     n++;
	     /* since string is static, make it literal */
	     obj.type = LANG_LITERAL | (STRING_TYPE << 8);
	     obj.value = (long) nm;
	     SLang_push(&obj);
	     if (SLang_Error) return(1);
	  }
	table++;
	max--;
     }
   return n;
}

void lang_apropos(char *s)
{
   int n;
   SLName_Table *nt;
   
   n = lang_apropos1(s, SLang_Name_Table, LANG_MAX_SYMBOLS);
   nt = SLName_Table_Root;
   while (nt != NULL)
     {
	n += lang_apropos1(s, nt->table, nt->n);
	nt = nt->next;
     }
   SLang_push_integer(n);
}

void lang_print_stack()
{
   SLang_Object_Type *x = SLStack_Pointer;
   int n;
   char *b, *t;
   char buf[132];
   char buf2[40];
   long v;
   
   while (--x >= SLRun_Stack)
     {
	b = buf;
	n = (int) (x - SLRun_Stack);
	v = x->value;
	switch (x->type >> 8)
	  {
	   case STRING_TYPE: 
	     b = (char *) v;
	     t = "(Str)"; break;
	   case INT_TYPE: sprintf(buf, "%d", (int) v); t = "(Int)"; break;
#ifdef FLOAT_TYPE
	   case FLOAT_TYPE: 
	     sprintf(buf, Float_Format, *(FLOAT *) &x->value); t = "(float)"; break;
#endif
	   case LANG_OBJ_TYPE: 
	     b = (char *) ((SLang_Name_Type *)v)->name + 1;
	     t = "(Ptr)";
	     break;
	   case ARRAY_TYPE:
	     *buf = 0;		       /* I could give some info here */
	     t = "(Array)";
	     break;
	   default: t = "(Unknown)"; *buf = 0;
	  }
	sprintf(buf2, "(%d) %s:", n, t);
	
	(*SLang_Dump_Routine)(buf2);
	(*SLang_Dump_Routine)(b);
	*buf = '\n'; *(buf + 1) = 0;
	(*SLang_Dump_Routine)(buf);
     }
}


/* sprintf functionality for S-Lang */
static char *Null_String = "";

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;
   unsigned short stmp;
   long *varp;
   int var, want_width, width, precis, use_varp;
   int len = 0, malloc_len = 0, dlen, do_free, guess_size;
#ifdef FLOAT_TYPE
   int tmp1, tmp2, use_float;
   FLOAT x;
#endif
   
   
   while (1)
     {
	while (ch = *p, ch && (ch != '%')) p++;
		  
	/* p points at '%' */
	
	dlen = (int) (p - fmt);
	
	if (len + dlen >= malloc_len)
	  {
	     malloc_len = len + dlen;
	     if (out == NULL) outp = (char *) MALLOC(malloc_len + 1);
	     else outp = (char *) REALLOC(out, malloc_len + 1);
	     if (NULL == outp)
	       {
		  SLang_Error = SL_MALLOC_ERROR;
		  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 = 0;
	guess_size = 32;
#ifdef FLOAT_TYPE
	use_float = 0;
#endif
	use_varp = 0;
	do_free = 0;
	
	/* Now the actual format specifier */
	switch(ch)
	  {
	     case 's': 
	     if (SLang_pop_string((char **) &varp, &do_free)) return (out);
	     guess_size = strlen((char *) varp);
	     use_varp = 1;
	     break;
	     
	   case '%': 
	     guess_size = 1;
	     do_free = 0;
	     use_varp = 1;
	     varp = (long *) "%";
	     break;
	     
	     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': 
#ifdef FLOAT_TYPE
	     if (SLang_pop_float(&x, &tmp1, &tmp2)) return (out);
	     use_float = 1;
	     guess_size = 64;
	     (void) tmp1; (void) tmp2;
	     break;
#endif
	     case 'p': 
	     guess_size = 32;
	     if (NULL == (varp = SLang_pop_pointer(&stmp, &do_free)))
	       {
		  return (out);
	       }
	     (void) stmp;
	     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 *) REALLOC(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 == 1) FREE(varp);
	  }
#ifdef FLOAT_TYPE
	else if (use_float) sprintf(outp, dfmt, x);
#endif
	else sprintf(outp, dfmt, var);
	
	len += strlen(outp);
	outp = out + len;
	fmt = p;
     }

   if (out != NULL)
     {
	outp = (char *) REALLOC(out, (int) (outp - out) + 1);
	if (outp != NULL) out = outp;
     }
   
   return (out);
}
   


char *SLsprintf(void)
{
   register char *p, ch, *b;
   char buf[256], ch1, *fmt;
   int n = 1, do_free;
   SLang_Object_Type *ptr;

   if (NULL == (ptr = SLreverse_stack(&n))) return(NULL);
   if (SLang_pop_string(&fmt, &do_free)) return (NULL);
   strncpy(buf, fmt, 255);
   if (do_free == 1) FREE(fmt);

   buf[255] = 0;
   p = b = buf;
   
   while ((ch = *p++) != 0)
     {
	if (ch == '\\')
	  {
	     p = SLexpand_escaped_char(p, &ch1);
	     if (SLang_Error) return Null_String;
	     ch = ch1;
	  }
	/* else if ((ch == '%') && (*p == '%')) p++; */
	*b++ = ch;
     }
   *b = 0;

   p = SLdo_sprintf(buf);
   
   while (SLStack_Pointer > ptr) SLdo_pop();
   
   if (SLang_Error)
     {
	if (p != NULL) FREE(p);
	p = NULL;
     }
   return p;
}


/* converts string s to a form that can be used in an eval */

static void make_printable_string(char *s)
{
   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 = (char *) MALLOC(len))) 
     {
	SLang_Error = SL_MALLOC_ERROR;
	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;
   SLang_push_string(ss);
}

   
char *SLang_extract_list_element(char *list, int *nth, int *delim)
{
   int d = *delim, n = *nth;
   static char elem[256];
   char *el = elem;
   
   while (n-- > 0)
     {
	while (*list && (*list != (char) d)) list++;
	if (*list) list++;
     }
   n = 255;
   while (n-- && *list && (*list != (char) d)) *el++ = *list++;
   *el = 0;
   return (elem);
}

/* Regular expression routines for strings */
static SLRegexp_Type regexp_reg;

int string_match (char *str, char *pat, int *np)
{
   int n = *np, len;
   unsigned char rbuf[512], *match;

   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 (&regexp_reg))
     {
	SLang_doerror ("Unable to compile pattern.");
	return 0;
     }
   
   n--;
   len = strlen(str);
   if ((n < 0) || (n >= len))
     {
	SLang_Error = SL_INVALID_PARM;
	return 0;
     }
   str += n;
   len -= n;
   
   if (NULL == (match = SLang_regexp_match((unsigned char *) str, len, &regexp_reg))) return 0;
   
   /* adjust offsets */
   regexp_reg.offset = n;
   
   return (1 + (int) ((char *) match - str));
}

int string_match_nth(int *np)
{
   int n = *np, beg;
   
   if ((n < 0) || (n > 9) || (regexp_reg.pat == NULL)
       || ((beg = regexp_reg.beg_matches[n]) == -1))
     {
	SLang_Error = SL_INVALID_PARM;
	return 0;
     }
   SLang_push_integer(beg + regexp_reg.offset);
   return regexp_reg.end_matches[n];
}


SLang_Name_Type SLang_Basic_Table[] =
{
   MAKE_INTRINSIC(".autoload",  SLang_autoload, VOID_TYPE, 2),
   /*  Syntax:  Void autoload(String function, String file);
    Automatically load 'function' from 'file'. */
   MAKE_INTRINSIC(".pop",  SLdo_pop, VOID_TYPE, 0),
   /* pop object from stack */
   MAKE_INTRINSIC(".strcmp",  SLdo_strcmp, VOID_TYPE, 0),
   /* Usage:  "string_1"  "string_2" strcmp
      returns > 0, = 0, or < 0 if "string_1" is greater than, equal to 
      or less than "string_2"  in a lexicographic sense. */
   MAKE_INTRINSIC(".strcat",  SLdo_strcat, VOID_TYPE, 0),
   /* Usage:  string_1 string_2  strcat
      concatenates string_1 and string_2. */
   MAKE_INTRINSIC(".strlen",  SLdo_strlen, VOID_TYPE, 0),
   /* returns the length of a STRING. */
   MAKE_INTRINSIC(".is_defined",  SLang_is_defined, INT_TYPE, 1),
   /* returns 0 if arg is not defined.
      return +1 if arg is an intrinsic function 
	     +2 if user defined function
	     -1 if intrinsic variable
	     -2 if user defined variable */
   MAKE_INTRINSIC(".string",  SLdo_string, VOID_TYPE, 0),
   /* converts argument to a string form.  For example,
      12.34 string ---> "12.34"  */
   MAKE_INTRINSIC(".getenv",  lang_getenv_cmd, VOID_TYPE, 1),
   /* Returns value of an environment VARIABLE as a string.  The Null_String
      "" is returned if the VARIABLE is not defined. */
#ifndef VMS
   MAKE_INTRINSIC(".putenv",  lang_putenv_cmd, VOID_TYPE, 0),
   /*Prototype: Void putenv(String s);
     This functions adds string 's' to the environment.  Typically, 's' should
     be a String of the form "name=value".  It signals an error upon failure.
     */
#endif
   MAKE_INTRINSIC(".evalfile",  SLang_load_file, INT_TYPE, 1),
   /* load FILE of S-Lang code returning TRUE if FILE loaded. */
   MAKE_INTRINSIC(".char",  SLdo_char, VOID_TYPE, 0),
   /* convert INTEGER to a 1 character string.  INTEGER is regarded as an 
      ascii value for the character, e.g., 1 char ===> Control-A ("\1"). */
   MAKE_INTRINSIC(".eval",  SLang_load_string, VOID_TYPE, 1),
   /* evaluate STRING as an S-Lang expression. */
   MAKE_INTRINSIC(".dup",  SLdo_dup, VOID_TYPE, 0),
   /* duplicate top object on the stack. */
   MAKE_INTRINSIC(".substr",  SLdo_substr, VOID_TYPE, 0),
   /* Syntax: "string" n len substr
       returns a substring with length len of string beginning at position n.
     */
   MAKE_INTRINSIC(".integer",  SLdo_integer, VOID_TYPE, 0),
   /* Convert from a string representation to integer.  For example,
      "1234" integer returns 1234 to stack. */
   MAKE_INTRINSIC(".is_substr",  SLdo_issubstr, VOID_TYPE, 0),
   /* Syntax: "a" "b" is_substr
      returns the position of "b" in "a".  If "b" does not occur in "a"
      it returns 0--- the first position is 1 */
   MAKE_INTRINSIC(".strsub",  SLdo_strsub, VOID_TYPE, 0),
   /* Syntax:  "string"  n ascii_value strsub
     This forces string to have a char who asciii value is ascii_val at
     the nth position.  The first character in the string is at position
     1. */

   MAKE_INTRINSIC(".extract_element", SLang_extract_list_element, STRING_TYPE, 3),
   /* Takes 3 parms: LIST (STRING), NTH (INTEGER), DELIM (INTEGER).
   Returns NTH element in LIST where DELIM separates elements of the list.
   DELIM is an Ascii value.  
   
   For example:
   "element 0, element 1, element 2"   1   ','   extract_element
   returns the string " element 2".
   */
   
   MAKE_INTRINSIC(".string_match", string_match, INT_TYPE, 3),
   /*Prototype Integer string_match(String str, String pat, Integer pos);
     Returns 0 if 'str' does not match regular expression specified by
     'pat'. This function performs the match starting at position 'pos' in
     'str'.  The first character of 'str' corresponds to 'pos' equal to one.
     This function returns the position of the start of the match.  To find
     the exact substring actually matched, use 'string_match_nth'. 
     See also: string_match_nth, strcmp, strncmp */

   MAKE_INTRINSIC(".string_match_nth", string_match_nth, INT_TYPE, 1),
   /*Prototype: Integer Integer string_match_nth(Integer nth);
     This function returns 2 integers describing the result of the last
     call to 'string_match'.  It returns both the offset into the string 
     and the length of characters matches by the 'nth' submatch.  
     By convention, 'nth' equal to zero means the entire match.  Otherwise,
     'nth' must be an integer, 1 to 9, and refers to the set of characters
     matched by the 'nth' regular expression given by \(...\).
     For example, consider:
     
        variable matched, pos, len;
        matched = string_match("hello world", "\\([a-z]+\\) \\([a-z]+\\)", 1);
	if (matched) {
           string_match_nth(2); =len; =pos;
	}
     
     This will set 'matched' to 1 since a match will be found at the first
     position, 'pos' to 7 since 'w' is the 7th character of the string, and
     len to 5 since "world" is 5 characters long. */

   MAKE_VARIABLE("._traceback", &SLang_Traceback, INT_TYPE, 0),
   /* If non-zero, dump S-Lang tracback on error. */
   
   MAKE_VARIABLE("._slangtrace", &SLang_Trace, INT_TYPE, 0),
   /* If non-zero, begin tracing when function declared by 
      lang_trace_function is entered.  This does not trace intrinsic functions.
      */
   /* these are rarely ever referred to so make them last. */
   /* If non-zero, dump S-Lang tracback on error. */
   MAKE_INTRINSIC(".system",  system, INT_TYPE, 1),
   MAKE_INTRINSIC(".slapropos",  lang_apropos, VOID_TYPE, 1),
   MAKE_INTRINSIC(".slang_trace_function",  SLang_trace_fun, VOID_TYPE, 1),
   /* only argument is a string that specifies a function name that is 
      to be traced. See also the variable _slangtrace. */
   
   /* array ops: */
   MAKE_INTRINSIC(".create_array",  SLcreate_array, VOID_TYPE, 0),
   /* Syntax: 'type' i_1 i_2 ... i_dim dim create_array
      returns ARRAY object to stack with dimension dim.  i_n is
      an integer which specifies the maximum size of array in direction n.
      'type' is a control integer which specifies the type of the array.
      Types are:  's' : array of strings
                  'f' : array of floats
                  'i' : array of integers
		  'c' : array of characters
      At this point, dim cannot be larger than 3.
      Also note that space is dynamically allocated for the array and that
      copies of the array are NEVER put on the stack.  Rather, references to
      the array are put on the stack.  When the array is no longer needed, it
      must be freed with 'free_array' */
   MAKE_INTRINSIC(".free_array",  SLfree_array, VOID_TYPE, 0),
   /* Syntax: ARRAY free_array
      Frees up the space which array occupies.  All reference to this space
      will now be meaningless. */
   MAKE_INTRINSIC(".aget",  SLarray_getelem, VOID_TYPE, 0),
   /* Syntax: i j ... k  ARRAY aget
      returns ARRAY[i][j]...[k] */
   MAKE_INTRINSIC(".aput",  SLarray_putelem, VOID_TYPE, 0),
   /* Syntax: x i j ... k  ARRAY put
      sets ARRAY[i][j]...[k] = x */

   MAKE_INTRINSIC(".strncmp",  SLdo_strncmp, VOID_TYPE, 0),
   /* like strcmp but takes an extra argument--- number of characters to
    compare.  Example, "apple"  "appliance"  3 strcmp --> 0 */
   MAKE_INTRINSIC(".strlow", SLdo_strlow, VOID_TYPE, 0),
   /* Takes a string off the stack a replaces it with all characters
      in lowercase. */
   MAKE_INTRINSIC(".strup", SLdo_strup, VOID_TYPE, 0),
   /* Takes a string off the stack a replaces it with all characters
      in uppercase. */
   MAKE_INTRINSIC(".isdigit",  SLdo_isdigit, INT_TYPE, 1),
   /* returns TRUE if CHAR (string of length 1) is a digit. */
   MAKE_INTRINSIC(".strtrim", SLdo_strtrim, VOID_TYPE, 0),
   /* Trims leading and trailing whitespace from a string.  WHitespace
      is defined to be spaces, tabs, and newline chars. */

   MAKE_INTRINSIC(".int",  SLdo_int, VOID_TYPE, 0),
   /* returns ascii value of the first character of a string. */
   MAKE_INTRINSIC(".array_sort", SLarray_sort, VOID_TYPE, 1),
   /* Requires an array on the stack as well as a function name to call 
    for the comparison.  The array to be placed on the stack is the
    array to be sorted.  The routine returns an integer index array which 
    indicates the result of the sort.  The first array is unchanged. */
   
   /* misc stuff */
   MAKE_INTRINSIC("._stkdepth", SLstack_depth, INT_TYPE, 0),
   /* returns number of items on stack */
   MAKE_INTRINSIC(".print_stack", lang_print_stack, VOID_TYPE, 0),
   /* dumps tha S-Lang stack */
   
   MAKE_INTRINSIC(".Sprintf", SLsprintf, STRING_TYPE, 0),
   /* Usage:  String Sprintf(String format, ..., int n);
      Sprintf formats a string from 'n' objects according to 'format'.  
      Unlike its C counterpart, Sprintf requires the number of items to
      format.  For example.
      
          Sprintf("%f is greater than %f but %s is better than %s\n",
		   PI, E, "Cake" "Pie", 4);
		   
      The final argument to Sprintf is the number of items to format; in
      this case, there are 4 items. */
   
   MAKE_INTRINSIC(".init_char_array", SLinit_char_array, VOID_TYPE, 0),
   /* Usage:  init_char_array(Array_Type a, String s);
              a is an array of type 'c' (character array) and s is a string.
	      */

   MAKE_INTRINSIC(".byte_compile_file", SLang_byte_compile_file, VOID_TYPE, 2),
   /*Prototype Void byte_compile_file (String file, Integer method);
     byte compiles 'file' producing a new file with the same name except 
     a 'c' is added to the output file name.  For example, 
          byte_compile_file("site.sl");
     produces a new file named 'site.slc'.  If 'method' is non-zero, the 
     file is preprocessed only.  Note that the resulting bytecompiled file
     must only be used by the executable that produced it.  Set 'method' to 
     a non-zero value to use the byte compiled file with more than one 
     executable. */

   MAKE_INTRINSIC(".make_printable_string", make_printable_string, VOID_TYPE, 1),
   /*Prototype: String make_printable_string(String str);
     Takes input string 'str' and creates a new string that may be used by the
     interpreter as an argument to the 'eval' function.  The resulting string is
     identical to 'str' except that it is enclosed in double quotes and the
     backslash, newline, and double quote characters are expanded. 
     See also: eval */

   MAKE_INTRINSIC(".str_quote_string", SLquote_string, VOID_TYPE, 0),
   /*Prototype: String str_quote_string(String str, String qlis, Integer quote);
     Return a string identical to 'str' except that all characters in the 
     string 'qlis' are escaped with the 'quote' character including the quote
     character itself. */
   
   MAKE_INTRINSIC(".str_uncomment_string", uncomment_string, VOID_TYPE, 3),
   /*Prototype: String str_uncomment_string(String s, String beg, String end);
     'beg' and 'end' are strings whose characters define a set of comment 
     delimeters.  This function removes comments defined by the delimeter set
     from the input string 's' and returns it.  For example,
    
       str_uncommen_string ("Hello (testing) 'example' World", "'(", "')");
    
     returns the string: "Hello  World"; 
     
    This routine does not handle multicharacter comment delimeters and it
    assumes that comments are not nested.
    */
     
   MAKE_INTRINSIC(".define_case", SLang_define_case, VOID_TYPE, 2),
   /* Two parameters are integers in the range 0 to 255.  The first
      integer is the ascii value of the upprcase character and the 2nd
      integer is the value of its lowercase counterpart.  For example, to
      define X as the uppercase of Y, do:
        X Y define_case */
   
   MAKE_INTRINSIC("._clear_error", SLang_clear_error, VOID_TYPE, 0),
   /* May be used in error blocks to clear the error that triggered the
      error block.  Execution resumes following the statement
      triggering the block. */
	
   MAKE_VARIABLE("._slang_version", SLang_Version, STRING_TYPE, 1),
   MAKE_INTRINSIC(".set_float_format", set_float_format, VOID_TYPE, 1),
   /*Prototype: Void set_float_format (String fmt);
     This function is used to set the floating point format to be used
     when floating point numbers are printed.  The routines that use this
     are the traceback routines and the 'string' function. The default
     value is "%f".
    */
   
   SLANG_END_TABLE
};

/* 8bit clean upper and lowercase macros */
unsigned char Chg_LCase_Lut[256];
unsigned char Chg_UCase_Lut[256];

void SLang_define_case(int *u, int *l)
{
   unsigned char up = (unsigned char) *u, dn = (unsigned char) *l;
   
   Chg_LCase_Lut[up] = dn;
   Chg_UCase_Lut[dn] = up;
}

int init_SLang()
{
   char name[3];
   int i, j;
#ifdef pc_system
# ifdef __os2__ 
   char *s = "OS2";
# else
   char *s = "MSDOS";
# endif
#else
# ifdef VMS
   char *s = "VMS";
# else
   char *s = "UNIX";
# endif
#endif

   if (!SLang_add_table(SLang_Basic_Table, "_Basic")) return(0);
   SLadd_variable(SLANG_SYSTEM_NAME);
   if (!SLdefine_for_ifdef (s)) return 0;
   
   /* give temp global variables $0 --> $9 */
   name[2] = 0; name[0] = '$';
   for (i = 0; i < 10; i++)
     {
	name[1] = (char) (i + '0');
	SLadd_variable(name);
     }
   
   SLstupid_hash();
      
   /* Change case Lut.  Do it now so it can be used */
   for (i = 0; i < 256; i++) 
     {
	Chg_UCase_Lut[i] = i;
	Chg_LCase_Lut[i] = i;
     }
   
   for (i = 'A'; i <= 'Z'; i++) 
     {
	j = i + 32;
	Chg_UCase_Lut[j] = i;
	Chg_LCase_Lut[i] = j;
     }
#ifdef msdos
   /* Initialize for DOS code page 437. */
   Chg_UCase_Lut[135] = 128; Chg_LCase_Lut[128] = 135;
   Chg_UCase_Lut[132] = 142; Chg_LCase_Lut[142] = 132;
   Chg_UCase_Lut[134] = 143; Chg_LCase_Lut[143] = 134;
   Chg_UCase_Lut[130] = 144; Chg_LCase_Lut[144] = 130;
   Chg_UCase_Lut[145] = 146; Chg_LCase_Lut[146] = 145;
   Chg_UCase_Lut[148] = 153; Chg_LCase_Lut[153] = 148;
   Chg_UCase_Lut[129] = 154; Chg_LCase_Lut[154] = 129;
   Chg_UCase_Lut[164] = 165; Chg_LCase_Lut[165] = 164;
#else
   /* ISO Latin */
   for (i = 192; i <= 221; i++) 
     {
	j = i + 32;
	Chg_UCase_Lut[j] = i;
	Chg_LCase_Lut[i] = j;
     }
   Chg_UCase_Lut[215] = 215; Chg_LCase_Lut[215] = 215;
   Chg_UCase_Lut[223] = 223; Chg_LCase_Lut[223] = 223;
   Chg_UCase_Lut[247] = 247; Chg_LCase_Lut[247] = 247;
   Chg_UCase_Lut[255] = 255; Chg_LCase_Lut[255] = 255;
#endif

   return (1);
}
