/* Basic string functions for S-Lang */
/* 

   Copyright (C) 1993 John E. Davis (davis@amy.tch.harvard.edu)
   All rights reserved.

   This file is part of S-Lang.

   S-Lang is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY.  No author or distributor accepts responsibility to
   anyone for the consequences of using it or for whether it serves any
   particular purpose or works at all, unless he says so in writing.
   Refer to the S-Lang General Public License for full details.

   Everyone is granted permission to copy, modify and redistribute
   S-Lang, but only under the conditions described in the S-Lang General
   Public License.  A copy of this license is supposed to have been given
   to you along with S-Lang so you can know your rights and
   responsibilities.  It should be in a file named COPYING.  Among other
   things, the copyright notice and this notice must be preserved on all
   copies.

*/

#include <stdio.h>
#include "slang.h"
#include "_slang.h"
#include "slarray.h"

extern int system();

/* 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)
     {
	if ((NULL != (c = 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) FREE(a);
   if (bdata) 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 */
   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) FREE(a);
}

/* 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 = strstr(a, b))) n = 0; else n = 1 + (int) (c - a);

   if (adata) FREE(a);
   if (bdata) 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) 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) 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) 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) 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) FREE(a);
   if (bdata) 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) FREE(a);
   if (bdata) 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) 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)
     {
	i = (int) *(unsigned char *) x.value;
	if (IS_DATA_STRING(x)) 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);
}
/* 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) 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, "%.6g",  (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);
}

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, "%g", *(float *) &v); 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 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 '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) 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) 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 = 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);
}

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. */
   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_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, 1),
   /* 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'. */

   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(".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),
   
   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;
   if (!SLang_add_table(SLang_Basic_Table, "_Basic")) return(0);
   SLadd_variable(SLANG_SYSTEM_NAME);
   
   /* 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);
}
