/* slang.c  --- guts of S-Lang interpreter */
/* 

   Copyright (C) 1992, 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>

#ifdef FLOAT_TYPE
char SLang_Version[] = "F0.95.2";
#include <math.h>
#else
char SLang_Version[] = "0.95.2";
#endif

/* not ready yet */
/* #define SL_BYTE_COMPILING */

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

/* If non null, these call C functions before and after a slang function. */
void (*SLang_Enter_Function)(char *) = NULL;
void (*SLang_Exit_Function)(char *) = NULL;

int SLang_Trace = 0;
char SLang_Trace_Function[32];


SLang_Name_Type SLang_Name_Table[LANG_MAX_SYMBOLS];
SLName_Table *SLName_Table_Root;


SLang_Name_Type *Lang_Local_Variable_Table;
int Local_Variable_Number;
#define MAX_LOCAL_VARIABLES 50

int Lang_Break_Condition = 0;	       /* true if any one below is true */
int Lang_Break = 0;
int Lang_Return = 0;
int Lang_Continue = 0;

/* this stack is used by the inner interpreter to execute top level
   interpreter commands which by definition are immediate so stack is
   only of maximum 10; sorry... */
SLang_Object_Type Lang_Interp_Stack_Static[10];
SLang_Object_Type *Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static;
SLang_Object_Type *Lang_Interp_Stack = Lang_Interp_Stack_Static;

/* maximum size of run time stack */
#define LANG_MAX_STACK_LEN 1000
SLang_Object_Type SLRun_Stack[LANG_MAX_STACK_LEN];
SLang_Object_Type *SLStack_Pointer = SLRun_Stack;
SLang_Object_Type *SLStack_Pointer_Max = SLRun_Stack + LANG_MAX_STACK_LEN;

/* Might want to increase this. */
#define MAX_LOCAL_STACK 200
SLang_Object_Type Local_Variable_Stack[MAX_LOCAL_STACK];

SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack;

volatile int SLang_Error = 0;
int SLang_Traceback = 0;		       /* non zero means do traceback */

extern int inner_interp(register SLang_Object_Type *addr);

int Lang_Defining_Function = 0;   /* true if defining a function */
SLang_Object_Type *Lang_Function_Body;
SLang_Object_Type *Lang_FBody_Ptr;
int Lang_FBody_Size = 0;

#define LANG_MAX_BLOCKS 30
/* max number of nested blocks--- was 10 but I once exceeded it! */

typedef struct Lang_Block_Type
  {
     int size;                         /* current nuber of objects malloced */
     SLang_Object_Type *body;           /* beginning of body definition */
     SLang_Object_Type *ptr;            /* current location */
  }
Lang_Block_Type;

int Lang_Defining_Block = 0;   /* true if defining a block */
Lang_Block_Type Lang_Block_Stack[LANG_MAX_BLOCKS];
SLang_Object_Type *Lang_Block_Body;
int Lang_BBody_Size;

int Lang_Block_Depth = -1;

SLang_Object_Type *Lang_Object_Ptr = Lang_Interp_Stack_Static;
/* next location for compiled obj -- points to interpreter stack initially */

#ifdef VMS
int (*SLang_Error_Routine)(char *) = NULL;
#else
int (*SLang_Error_Routine)(char *) = (int (*)(char *)) NULL;
#endif

void SLang_doerror(char *error)
{
   char err[80]; char *str;

   if (!SLang_Error) SLang_Error = UNKNOWN_ERROR;
   *err = 0;
   switch(SLang_Error)
     {
	case (UNDEFINED_NAME): str = "Undefined_Name"; break;
	case (SYNTAX_ERROR): str = "Syntax_Error"; break;
	case (STACK_OVERFLOW): str = "Stack_Overflow"; break;
	case (STACK_UNDERFLOW): str = "Stack_Underflow"; break;
	case (DUPLICATE_DEFINITION): str = "Duplicate_Definition"; break;
	case (TYPE_MISMATCH): str = "Type_Mismatch"; break;
	case(READONLY_ERROR): str = "Variable is read only."; break;
	case (SL_MALLOC_ERROR) : str = "S-Lang: Malloc Error."; break;
      case USER_BREAK: strcpy(err, "User Break!"); break;
	case (INTRINSIC_ERROR): str = "Intrinsic Error"; break;
      case DIVIDE_ERROR: str = "Divide by zero."; break;
	/* application code should handle this */
	default: if (error != NULL) str = error; else str = "Unknown Error.";
     }

   if (*err == 0) sprintf(err, "S-Lang Error: %s", str);
   
   if (SLang_Error_Routine == NULL)
     {
	if (error != NULL) 
	  {
	     fputs(error, stderr);
	     putc('\n', stderr);
	  }
	
	if (err != error) 
	  {
	     fputs(err, stderr);
	     putc('\n', stderr);
	  }
     }
   else
     {	if (error != NULL) (*SLang_Error_Routine)(error);
	if (err != error) (*SLang_Error_Routine)(err);
     }
}


int SLang_pop(SLang_Object_Type *x)
{
   register SLang_Object_Type *y;
   
   y = SLStack_Pointer;
   if (y == SLRun_Stack)
     {
	x->type = 0;
	SLang_Error = STACK_UNDERFLOW;
	SLStack_Pointer = SLRun_Stack;
	return 1;
     }
   y--;
   x->type = y->type;
   x->value = y->value;
   SLStack_Pointer = y;
   return(0);
}

void SLang_push(SLang_Object_Type *x)
{
   register SLang_Object_Type *y;
   y = SLStack_Pointer;
   
   /* if there is a SLang_Error, probably not much harm will be done
      if it is ignored here */
   /* if (SLang_Error) return; */
   
   /* flag it now */
   if (y >= SLStack_Pointer_Max)
     {
	if (!SLang_Error) SLang_Error = STACK_OVERFLOW;
	return;
     }
   
   y->type = x->type;
   y->value = x->value;
   SLStack_Pointer = y + 1;
}

void lang_free_branch(SLang_Object_Type *p)
{
   short type; /* s_type = LANG_LITERAL | (STRING_TYPE << 8); */
   
   while(1)
     {
        type = (p->type);
	if ((type & 0xFF) == LANG_BLOCK)
	  {
	     lang_free_branch((SLang_Object_Type *) p->value);
	     FREE(p->value);
	  }
	/* else if (type == s_type) FREE(p->value);
	 This fails because objects may be attached to these strings */
	else if (type == 0) break;
	p++;
     }
}

int SLang_pop_integer(int *i)
{
   SLang_Object_Type obj;

   if (SLang_pop(&obj) ||  ((obj.type >> 8) != INT_TYPE))
     {
	if (!SLang_Error) SLang_Error = TYPE_MISMATCH;
	return(1);
     }

   *i = (int) obj.value;
   return(0);
}

#ifdef FLOAT_TYPE
int SLang_pop_float(float *x, int *convert, int *ip)
{
   SLang_Object_Type obj;
   register unsigned char stype;

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

   if (stype == FLOAT_TYPE) 
     {
	*x = *(float *) &obj.value;
	*convert = 0;
     }
   else if (stype == INT_TYPE) 
     {
	*ip = (int) obj.value;
	*x = (float) *ip;
	*convert = 1;
     }
   else
     {
	SLang_Error = TYPE_MISMATCH;
	return(1);
     }
   return(0);
}

void SLang_push_float(float x)
{
   SLang_Object_Type obj;

   obj.type = LANG_DATA | (FLOAT_TYPE << 8);
   obj.value = *(long *) &x;
   SLang_push (&obj);
}

#endif

int SLang_pop_string(char **s, int *data)
{
   SLang_Object_Type obj;

   if (SLang_pop(&obj) || ((obj.type >> 8) != STRING_TYPE))
     {
	if (!SLang_Error) SLang_Error = TYPE_MISMATCH;
	return(1);
     }

   *s = (char *) obj.value;
   /* return whether or not this should be freed after its use. */
   if ((obj.type & 0xFF) == LANG_DATA) *data = 1; else *data = 0;
   return(0);
}

void SLang_push_integer(int i)
{
   SLang_Object_Type obj;

   obj.type = LANG_DATA | (INT_TYPE << 8);
   obj.value = (long) i;
   SLang_push (&obj);
}

long SLmake_string(char *str)
{
   char *ptr;
   int n = strlen(str);
   
   if (NULL == (ptr = (char *) MALLOC(n + 1)))
     {
	SLang_Error = SL_MALLOC_ERROR;
	/* SLang_doerror("malloc error in lang_make_string."); */
	return((long) NULL);
     }
   strcpy((char *) ptr, str);
   return((long) ptr);
}

void SLang_push_string(char *t)
{
   SLang_Object_Type obj;

   if ((long) NULL == (obj.value = (long) SLmake_string((char *) t))) return;
   obj.type = LANG_DATA | (STRING_TYPE << 8);
   SLang_push(&obj);
}



void SLang_push_malloced_string(char *c)
{
   SLang_Object_Type obj;
   
   obj.type = LANG_DATA | (STRING_TYPE << 8);
   obj.value = (long) c;
   SLang_push(&obj);
}


int SLatoi(unsigned char *s)
{
   register unsigned char ch;
   register unsigned int i, ich;
   register int base;
   
   if (*s != '0') return atoi((char *) s);

   /* look for 'x' which indicates hex */
   s++;
   if (*s == 'x') 
     {
	base = 4;
	s++;
     }
   else base = 3;
   i = 0;
   while ((ch = *s++) != 0)
     {
	if (ch > 64) ich = ch - 55; else ich = ch - 48;
	i = (i << base) | ich;
     }
   return (int) i;
}



static void call_funptr(SLang_Name_Type *);

void SLang_push_variable(SLang_Object_Type *obj)
{
   register unsigned char subtype;
   register unsigned short stype;
   SLang_Object_Type neew;
   long value;

   stype = obj->type;   subtype = stype >> 8;
   value = obj->value;

   if (subtype == STRING_TYPE)
     {
	SLang_push_string((char *) value);
	return;
     }
   else if (subtype == LANG_OBJ_TYPE)
     {
	call_funptr((SLang_Name_Type *) value);
	return;
     }
   
   neew.type = stype; 
   neew.value = value;
   SLang_push(&neew);
}

/* This routine pops an integer off the stack.  It then adds dn to the 
   value producing n. The it reverses the
   next n items on the stack.  Some functions may require this.
   This returns a pointer to the last item.
*/
SLang_Object_Type *SLreverse_stack(int *dn)
{
   int n;
   SLang_Object_Type *otop, *obot;
   long value;
   unsigned short type;
   
   if (SLang_pop_integer(&n)) return(NULL);
   n += *dn;
   
   otop = SLStack_Pointer;
   if ((n > otop - SLRun_Stack) || (n < 0))
     {
	SLang_Error = STACK_UNDERFLOW;
	return (NULL);
     }
   obot = otop - n;
   otop--;
   while (otop > obot)
     {
	value = obot->value; type = obot->type;
	obot->value = otop->value; obot->type = otop->type;
	otop->value = value; otop->type = type;
	otop--;
	obot++;
     }
   return (SLStack_Pointer - n);
}

   


/* local and global variable assignments */

/* value contains either the offset of data for local variables or
   location of object_type for global ones.  For strings, we have to be
   careful.  Literal (constant) strings which are already attached to these
   variables are not to be freed--- only those of type data (dynamic).
   There is no need to create new strings since they come from the stack.

   Note that strings appear on the stack in two forms:  literal and dynamic.
   Literal strings are constants.  Dynamic ones are created by, say, dup, etc.
   They are freed only by routines which eat them.  These routines must
   check to see if they are not literal types before freeing them.  The only
   other way they are freed is when they are on the local variable stack, e.g.,
   (assigned to local variables) and the function exits freeing them.

   Define Macro to do this:  (defined above)

#define IS_DATA_STRING(obj)\
   ((((obj).type & 0xFF) == LANG_DATA) && (((obj).type >> 8) == STRING_TYPE))
*/


/* pop a data item from the stack and return a pointer to it.
   Strings are not freed from stack so use another routine to do it.

   In addition, I need to make this work with the array types.  */

long *SLang_pop_pointer(unsigned short *type, int *do_free)
{
   SLang_Object_Type obj;
   register SLang_Object_Type *p;
   long *val;

   if (SLang_pop(&obj)) return(NULL);
   p = SLStack_Pointer;

   /* use this because the stack is static but obj is not.
      do not even try to make it static either. See the intrinsic
      routine for details */
   val = (long *) &p->value;
   *type = p->type;

   /* The assumption is that only data and literals are on stack */
   if ((*type >> 8) == STRING_TYPE) 
     {
	if ((*type & 0xFF) == LANG_DATA) *do_free = 1;
	return((long *) *val);
     }
   *do_free = 0;
   return((long *) val);
}

void lang_do_eqs(SLang_Object_Type *obj)
{
   int y;
   register unsigned char type;
   register SLang_Object_Type *addr;
   register long val;
   

   type = obj->type >> 8;
   val = (long) obj->value;   
   
   /* calculate address */
   if ((type ==  LANG_LEQS) || (type ==  LANG_LMM) || (type ==  LANG_LPP)
       || (type ==  LANG_LPEQS)
       || (type ==  LANG_LMEQS)) addr = Local_Variable_Frame - (int) val;
   
   else if ((type ==  LANG_GEQS) || (type ==  LANG_GPP) || 
	    (type ==  LANG_GMM) || (type ==  LANG_GPEQS) || 
	    (type ==  LANG_GMEQS))
     {
	
	val = ((SLang_Name_Type *) val)->obj.value;
	addr = (SLang_Object_Type *) val;
     }
   else
     {
	addr = &((SLang_Name_Type *) val)->obj;
	val = addr->value;
     }

   if ((type == LANG_LEQS) || (type == LANG_GEQS))
     {
	if (IS_DATA_STRING(*addr)) FREE(addr->value);
        SLang_pop(addr);
	return;
     }
     
   /* everything else applies to integers -- later I will extend to float */
   
   if (INT_TYPE != (addr->type >> 8))
     {
	SLang_Error = TYPE_MISMATCH;
	return;
     }

   /* make this fast for local variables avoiding switch bottleneck */
   if (type == LANG_LPP)
     {
	addr->value += 1;
	return;
     }
   else if (type == LANG_LMM)
     {
	addr->value -= 1;
	return;
     }

   y = 1;
   switch (type)
     {
      case LANG_LPEQS: 
      case LANG_GPEQS:
	if (SLang_pop_integer(&y)) return;
	/* drop */
      case LANG_GPP: 
	addr->value += y;
	break;
	
      case LANG_GMEQS: 
      case LANG_LMEQS: 
	if (SLang_pop_integer(&y)) return;
	/* drop */
      case LANG_GMM: 
	addr->value -= y;
	break;
	
      case LANG_IEQS: 
	if (SLang_pop_integer(&y)) return;
	*(int *) val = y;
	break;
	
      case LANG_IPEQS: 
	if (SLang_pop_integer(&y)) return;
	/* drop */
      case LANG_IPP: 
	*(int *) val += y;
	break;
	
      case LANG_IMEQS:
	if (SLang_pop_integer(&y)) return;
	/* drop */
      case LANG_IMM: 
	*(int *) val -= y;
	break;
      default: 
	SLang_Error = UNKNOWN_ERROR;
     }
}

/* lower 4 bits represent the return type, e.g., void, int, etc... 
   The next 4 bits represent the number of parameters, 0 -> 15 */
#define LANG_INTRINSIC_ARGC(f) ((f).type >> 12)
#define LANG_INTRINSIC_TYPE(f) (((f).type & 0x0F00) >> 8)


/* intrinsic functions are passed parameters by reference. The function
   pointer is given by obj->value. */
void lang_do_intrinsic(SLang_Object_Type *objf)
{
   long (*f)();
   void (*fv)();
   long ret;
   char *p1, *p2, *p3, *p4, *p5;
   unsigned short tmp;
   int free_p5 = 0, free_p4 = 0, free_p3 = 0, free_p2 = 0, free_p1 = 0;
   unsigned char type;
   int argc;
#ifdef FLOAT_TYPE
   float xf;
   float (*ff)();
   ff = (float (*)()) objf->value;
#endif

   f = (long (*)()) objf->value;
   fv = (void (*)()) objf->value;

   argc = LANG_INTRINSIC_ARGC(*objf);
   type = LANG_INTRINSIC_TYPE(*objf);

   switch (argc)
     {
	case 5: p5 = (char *) SLang_pop_pointer(&tmp, &free_p5);
	case 4: p4 = (char *) SLang_pop_pointer(&tmp, &free_p4);
	case 3: p3 = (char *) SLang_pop_pointer(&tmp, &free_p3);
	case 2: p2 = (char *) SLang_pop_pointer(&tmp, &free_p2);
	case 1: p1 = (char *) SLang_pop_pointer(&tmp, &free_p1);
     }
   
   (void) tmp;
   /* I need to put a setjmp here so to catch any long jmps that occur
      in the user program */
   if (!SLang_Error) switch (argc)
     {

	case 0:
	  if (type == VOID_TYPE) (void) (*fv)();
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)();
#endif
	  else ret = (*f)();
	  break;

	case 1:
	  if (type == VOID_TYPE) (void) (*fv)(p1);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)(p1);
#endif
	  else ret = (*f)(p1);
	  break;

	case 2:
	  if (type == VOID_TYPE) (void) (*fv)(p1, p2);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)(p1, p2);
#endif
	  else ret = (*f)(p1, p2);
	  break;

	case 3:
	  if (type == VOID_TYPE) (void) (*fv)(p1, p2, p3);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)(p1, p2, p3);
#endif
	  else ret = (*f)(p1, p2, p3);
	  break;

	case 4:
	  if (type == VOID_TYPE) (void) (*fv)(p1, p2, p3, p4);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)(p1, p2, p3, p4);
#endif
	  else ret = (*f)(p1, p2, p3, p4);
	  break;

	case 5:
	  if (type == VOID_TYPE) (void) (*fv)(p1, p2, p3, p4, p5);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = (*ff)(p1, p2, p3, p4, p5);
#endif
	  else ret = (*f)(p1, p2, p3, p4, p5);
	  break;

      default: 
	SLang_doerror("Function requires too many parameters");
	SLang_Error = UNKNOWN_ERROR;
	break;
     }

   if (!SLang_Error) switch(type)
     {
      case STRING_TYPE:
	if (NULL == (char *) ret)
	  {
	     if (!SLang_Error) SLang_Error = INTRINSIC_ERROR;
	  }
	else SLang_push_string((char *) ret); break;
      case INT_TYPE:
	/* For msdos, longs are 4 bytes and ints are two.  Take this
	   approach: */
	SLang_push_integer(*(int*) &ret); break;
      case VOID_TYPE: break;
#ifdef FLOAT_TYPE
      case FLOAT_TYPE: SLang_push_float(* (float *) &xf); break;
#endif
      default: SLang_Error = TYPE_MISMATCH;
     }
   /* I free afterword because functions that return char * may point to this
      space. */
   if (free_p5) FREE(p5);
   if (free_p4) FREE(p4);
   if (free_p3) FREE(p3);
   if (free_p2) FREE(p2);
   if (free_p1) FREE(p1);
}

/* this is a more readable version of the previous function but there is no
   guarantee that it will run on all platforms. */

#if 0
void lang_do_intrinsic(SLang_Object_Type *objf)
{
   int (*fi)(), iret;
   void (*fv)();
   char * (*fs)(), *sret;
#ifdef FLOAT_TYPE
   float fret;
   float (*ff)();
#endif

   char *p1, *p2, *p3, *p4, *p5;
   unsigned short p1type, p2type, p3type, p4type, p5type;
   unsigned char type;
   int argc;


   p5type = p4type = p3type = p2type = p1type = 0;
   argc = LANG_INTRINSIC_ARGC(*objf);
   type = LANG_INTRINSIC_TYPE(*objf);

   switch (argc)
     {
	case 5: p5 = (char *) SLang_pop_pointer(&p5type);
	case 4: p4 = (char *) SLang_pop_pointer(&p4type);
	case 3: p3 = (char *) SLang_pop_pointer(&p3type);
	case 2: p2 = (char *) SLang_pop_pointer(&p2type);
	case 1: p1 = (char *) SLang_pop_pointer(&p1type);
     }
   
   /* I need to put a setjmp here so to catch any long jmps that occur
      in the user program */
   
   if (!SLang_Error)
     {
	if (type == VOID_TYPE)
	  {
	     fv = (void (*)()) objf->value;
	     (void) (*fv)(p1, p2, p3, p4, p5);
	  }
	else if (type == INT_TYPE)
	  {
	     fi = (int (*)()) objf->value;
	     iret = (*fi)(p1, p2, p3, p4, p5);
	     SLang_push_integer(iret);
	  }
	else if (type == STRING_TYPE)
	  {
	     fs = (char *(*)()) objf->value;
	     sret = (*fs)(p1, p2, p3, p4, p5);
	     SLang_push_string(sret);
	  }
#ifdef FLOAT_TYPE
	else if (type == FLOAT_TYPE)
	  {
	     ff = (float (*)()) objf->value;
	     fret = (*ff)(p1, p2, p3, p4, p5);
	     SLang_push_float(fret);
	  }
#endif
     }
   
   /* I free afterword because functions that return char * may point to this
      space. */
   if (((p5type & 0xFF) == LANG_DATA) && ((p5type >> 8) == STRING_TYPE)) FREE(p5);
   if (((p4type & 0xFF) == LANG_DATA) && ((p4type >> 8) == STRING_TYPE)) FREE(p4);
   if (((p1type & 0xFF) == LANG_DATA) && ((p1type >> 8) == STRING_TYPE)) FREE(p1);
   if (((p2type & 0xFF) == LANG_DATA) && ((p2type >> 8) == STRING_TYPE)) FREE(p2);
   if (((p3type & 0xFF) == LANG_DATA) && ((p3type >> 8) == STRING_TYPE)) FREE(p3);
}
#endif

void lang_do_loops(unsigned char type, long addr)
{
   register int i, ctrl;
   int ctrl1;
   int first, last, one = 0;
   register SLang_Object_Type *obj1, *obj2, *obj3, *block;

   block = (SLang_Object_Type *) addr;
   obj1 = (SLang_Object_Type *) block->value;

   switch (type)
     {
      case LANG_WHILE:
      case LANG_DOWHILE:

	/* we need 2 blocks: first is the control, the second is code */
	block++;
	if ((block->type) != LANG_BLOCK)
	  {
	     SLang_doerror("Block needed for while.");
	     return;
	  }
	obj2 = (SLang_Object_Type *) block->value;

	if (type == LANG_WHILE)
	  {
	     while(!SLang_Error)
	       {
		  inner_interp(obj1);
		  if (Lang_Break) break;
		  if (SLang_pop_integer(&ctrl1)) return;
		  if (!ctrl1) break;
		  inner_interp(obj2);
		  if (Lang_Break) break;
		  Lang_Break_Condition = Lang_Continue = 0;
	       }
	  }
	else while(!SLang_Error)
	  {
	     Lang_Break_Condition = Lang_Continue = 0;
	     inner_interp(obj1);
	     if (Lang_Break) break;
	     inner_interp(obj2);
	     if (SLang_pop_integer(&ctrl1)) return;
	     if (!ctrl1) break;
	  }
	break;

      case LANG_CFOR:

	/* we need 4 blocks: first 3 control, the last is code */
	inner_interp(obj1);

	block++;
	if ((block->type) != LANG_BLOCK) goto cfor_err;
	obj1 = (SLang_Object_Type *) block->value;
	
	block++;
	if ((block->type) != LANG_BLOCK) goto cfor_err;
	obj2 = (SLang_Object_Type *) block->value;
	
	block++;
	if ((block->type) != LANG_BLOCK) goto cfor_err;
	obj3 = (SLang_Object_Type *) block->value;
	
	while(!SLang_Error)
	  {
	     inner_interp(obj1);       /* test */
	     if (SLang_pop_integer(&ctrl1)) return;
	     if (!ctrl1) break;
	     inner_interp(obj3);       /* code */
	     if (Lang_Break) break;
	     inner_interp(obj2);       /* bump */
	     Lang_Break_Condition = Lang_Continue = 0;
	  }
	break;
	
	cfor_err:
	SLang_doerror("Block needed for for.");
	return;


      case LANG_FOR:  /* 3 elements: first, last, step */
	if (SLang_pop_integer(&ctrl1)) return;
	if (SLang_pop_integer(&last)) return;
	if (SLang_pop_integer(&first)) return;
	ctrl = ctrl1;
	if (ctrl >= 0)
	  {	     
	     for (i = first; i <= last; i += ctrl)
	       {
		  if (SLang_Error) return;
		  SLang_push_integer(i);
		  inner_interp(obj1);
		  if (Lang_Break) break;
		  Lang_Break_Condition = Lang_Continue = 0;
	       }
	  }
	else
	  {
	     for (i = first; i >= last; i += ctrl)
	       {
		  if (SLang_Error) return;
		  SLang_push_integer(i);
		  inner_interp(obj1);
		  if (Lang_Break) break;
		  Lang_Break_Condition = Lang_Continue = 0;
	       }
	  }
	
	break;

      case LANG_LOOP:
	if (SLang_pop_integer(&ctrl1)) return;
	ctrl = ctrl1;
      case LANG_FOREVER:
	if (type == LANG_FOREVER) one = 1;
	while (one || (ctrl-- > 0))
	  {
	     if (SLang_Error) break;
	     inner_interp(obj1);
	     if (Lang_Break) break;
	     Lang_Break_Condition = Lang_Continue = 0;
	  }
	break;

      default:  SLang_doerror("Unknown loop type.");
     }
   Lang_Break = Lang_Continue = 0;
   Lang_Break_Condition = Lang_Return;
}

void lang_do_ifs(register SLang_Object_Type *addr)
{
   register unsigned char type;
   long val;
   int test;

   type = addr->type >> 8;
   if (SLang_pop_integer(&test)) return;
   if (type == LANG_IF)
     {
	if (!test) return;
     }
   else if (type == LANG_IFNOT)
     {
	if (test) return;
     }
   else if (test) addr--;   /* LANG_ELSE */
   
   addr--;
   if (addr->type != LANG_BLOCK)  /* was & 0xFF as well */
     {
	SLang_doerror("Block needed.");
	return;
     }
   val = addr->value;
   inner_interp((SLang_Object_Type *) val);
}

void lang_do_else(unsigned char type, long addr)
{
   long val;
   int test, status;
   char *str = NULL;
   SLang_Object_Type *obj, cobj;

   obj = (SLang_Object_Type *) addr;

   if (type == LANG_SWITCH)
     {
	if (SLang_pop(&cobj)) return;
	if (IS_DATA_STRING(cobj)) str = (char *) cobj.value;
     }

   while((obj->type == LANG_BLOCK) != 0)
     {
	val = obj->value;
	if (type == LANG_SWITCH)
	  {
	     if (str == NULL) SLang_push(&cobj); else SLang_push_string(str);
	  }

	status = inner_interp((SLang_Object_Type *) val);
	if (SLang_Error || Lang_Break_Condition) return;
	if (type == LANG_SWITCH)
	  {
	     if (status) break;
	  }

	else if (SLang_pop_integer(&test)) return;
	if (((type == LANG_ANDELSE) && !test)
	    || ((type == LANG_ORELSE) && test)) break;
	obj++;
     }
   if (type != LANG_SWITCH) SLang_push_integer(test);
   else if (str != NULL) FREE(str);
   return;
}

void lang_dump(char *s)
{
   fputs(s, stderr);
}

void (*SLang_Dump_Routine)(char *) = lang_dump;

extern void do_traceback(SLang_Name_Type *nt, int locals);

void SLexecute_function(SLang_Name_Type *entry1)
{
   register int i;
   register SLang_Object_Type *frame, *lvf;
   register int n_locals;
   register SLang_Name_Type *entry = entry1;
   long val;
   char buf[40];
   static int trace = 0;
   
   n_locals = (entry->obj.type) >> 8;

   /* need loaded?  */
   if (n_locals == 255)
     {
	if (!SLang_load_file((char *) entry->obj.value)) return;
	n_locals = (entry->obj.type) >> 8;
	if (n_locals == 255)
	  {
	     SLang_doerror("Function did not autoload!");
             return;
	  }
     }
   
   /* let the lang error propagate through since it will do no harm
      and allow us to restore stack. */
   val = entry->obj.value;
   /* set new stack frame */
   lvf = frame = Local_Variable_Frame;
   i = n_locals;
   if ((lvf + i) - Local_Variable_Stack > MAX_LOCAL_STACK)
     {
	SLang_doerror("Local Variable Stack Overflow!");
	return;
     }
   while(i--)
     {
	lvf++;
	lvf->type = 0;
     }
   Local_Variable_Frame = lvf;
   
   if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(entry->name + 1);
   if (SLang_Trace)
     {
	if ((*SLang_Trace_Function == *entry->name)
	    && !strcmp(SLang_Trace_Function, entry->name)) trace = 1;
	
	if (trace)
	  {
	     sprintf(buf, ">>%s\n", entry->name + 1);
	     (*SLang_Dump_Routine)(buf);
	     trace++;
	  }
	
	inner_interp((SLang_Object_Type *) val);
	if (trace) 
	  {
	     sprintf(buf, "<<%s\n", entry->name + 1);
	     (*SLang_Dump_Routine)(buf);
	     trace--;
	     if (trace == 1) trace = 0;
	  }
     }
   else inner_interp((SLang_Object_Type *) val);

   if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(entry->name + 1);
   
   if (SLang_Error && SLang_Traceback)
     {
	do_traceback(entry, n_locals);
     }
   /* free local variables.... */
   lvf = Local_Variable_Frame;
   while(lvf > frame)
     {
	if (IS_DATA_STRING(*lvf)) FREE (lvf->value);
	lvf--;
     }
   Local_Variable_Frame = lvf;
   Lang_Break_Condition = Lang_Return = Lang_Break = 0;
}



void do_traceback(SLang_Name_Type *nt, int locals)
{
   char buf[80];
   int i;
   SLang_Object_Type *objp;
   long val;
   unsigned short stype;
   
   sprintf(buf, "S-Lang Traceback: %s\n",nt->name + 1);
   (*SLang_Dump_Routine)(buf);
   if (!locals) return;
   (*SLang_Dump_Routine)("  Local Variables:\n");
   
   for (i = 0; i < locals; i++)
     {
	objp = Local_Variable_Frame - i;
	stype = objp->type >> 8;
	val = objp->value;
	
	if (STRING_TYPE == stype)
	  {
	     sprintf(buf, "\t$%d: \"", i);
	     (*SLang_Dump_Routine)(buf);
	     (*SLang_Dump_Routine)((char *) val);
	     (*SLang_Dump_Routine)("\"\n");
	     continue;
	  }
	else if (INT_TYPE == stype)
	  {
	     sprintf(buf, "\t$%d: %d\n", i, (int) val);
	  }
#ifdef FLOAT_TYPE
	else if (stype == FLOAT_TYPE)
	  {
	     sprintf(buf,"\t$%d: %g\n", i, (float) *(float *) &val);
	  }
#endif
	else sprintf(buf, "\t$%d: ??\n", i);
	(*SLang_Dump_Routine)(buf);
     }
}

static void call_funptr(SLang_Name_Type *optr)
{
   SLang_Object_Type objs[2];
   
   if (optr == NULL)
     {
	SLang_doerror("Object Ptr is Nil!");
	return;
     }
   
   objs[0].value = (long) optr;
   objs[0].type = optr->obj.type;
   objs[1].type = 0;
   objs[1].value = 0;
   inner_interp(objs);
}


#ifdef SLANG_STATS
static unsigned long stat_counts[256];
#endif

void (*SLang_Interrupt)(void);

static int Last_Error;
void (*user_clear_error)(void);
void SLang_clear_error(void)
{
   if (Last_Error <= 0)
     {
	Last_Error = 0;
	return;
     }
   Last_Error--;
   if (user_clear_error != NULL) (*user_clear_error)();
}



/* inner interpreter */
int inner_interp(SLang_Object_Type *addr1)
{
   register int bc = 0;
   register SLang_Object_Type *addr = addr1;
   SLang_Object_Type obj1, obj2;
   register unsigned short type;
   register unsigned char stype, ttype;
   int x, y, z;
   register long val, value;
   long block = 0;
   SLang_Name_Type *name_entry;
   SLang_Object_Type *err_block = NULL, *objp;
   int save_err, slerr;
   
#ifdef FLOAT_TYPE
   float xf, yf, zf;
   int xc, yc;
#endif

   /* for systems that have no real interrupt facility (e.g. go32 on dos) */
   if (SLang_Interrupt != NULL) (*SLang_Interrupt)();
   
   if (addr == NULL)
     {
	SLang_Error = UNKNOWN_ERROR;
     }
   
   while (((type = addr->type) != 0) && !SLang_Error)
     {
	if (bc)
	  {
	     if (Lang_Return || Lang_Break)
	       {
		  Lang_Break = 1;
		  return(1);
	       }
	     if (Lang_Continue) return(1);
	  }
	
	val = addr->value;
	stype = type >> 8;
	ttype = type & 0xFF;
		
#ifdef SLANG_STATS
	stat_counts[(unsigned char) (type & 0xFF)] += 1;
#endif	
	if (ttype == LANG_LVARIABLE)
	  {
	     /* make val point to local stack */
	     val = (long) (Local_Variable_Frame - (int) val);
	     /* SLang_push_variable(SLang_Object_Type *) val); */

	     /* inline push_variable here -- save function call */
	     type = ((SLang_Object_Type *) val) -> type;
	     stype = type >> 8;
	     value = ((SLang_Object_Type *) val) -> value;
	     
	     if (stype == STRING_TYPE) SLang_push_string((char *) value);
	     else if (stype == LANG_OBJ_TYPE) call_funptr((SLang_Name_Type *) value);
	     else
	       {
		  obj1.type = type;
		  obj1.value = value;
		  SLang_push(&obj1);
	       }
	  }
	else if (ttype <= LANG_BINARY)  /* ONLY LANG_CMP satisfies this as well */
	  {
	     z = 0;
#ifndef FLOAT_TYPE
	     if (SLang_pop_integer(&y) || SLang_pop_integer(&x)) return(0);
#else
	     if (SLang_pop_float(&yf, &yc, &y) || SLang_pop_float(&xf, &xc, &x)) return(0);
	     if (yc && xc)
	       {
#endif
		  switch (stype)
		    {
		       case LANG_EQ: if (x == y) z = 1; break;
		       case LANG_NE: if (x != y) z = 1; break;
		       case LANG_GT: if (x > y) z = 1; break;
		       case LANG_GE: if (x >= y) z = 1; break;
		       case LANG_LT: if (x < y) z = 1; break;
		       case LANG_LE: if (x <= y) z = 1; break;
		       case LANG_OR: if (x || y) z = 1; break;
		       case LANG_AND: if (x && y) z = 1; break;
		       case LANG_BAND: z = x & y; break;
		       case LANG_BXOR: z = x ^ y; break;
		       case LANG_MOD: z = x % y; break;
		       case LANG_BOR: z = x | y; break;
		       case LANG_PLUS: z = x + y; break;
		       case LANG_MINUS: z = x - y; break;
		       case LANG_TIMES: z = x * y; break;
		       case LANG_DIVIDE: 
		       if (y == 0) 
			 {
			    SLang_Error = DIVIDE_ERROR;
			    return(0);
			 }
		       z = x / y; break;   /* y == 0? */
		       case LANG_SHL: z = x << y; break;
		       case LANG_SHR: z = x >> y; break;
		       default: SLang_Error = INTERNAL_ERROR;
		       return(0);
		    }
		  SLang_push_integer(z);
		  /* binary */
#ifdef FLOAT_TYPE
	       }
	     else 
	       {
		  switch (stype)
		    {
		       case LANG_SHR: 
		       case LANG_SHL: SLang_Error = TYPE_MISMATCH; return(0);
		       
		       case LANG_EQ: if (xf == yf) z = 1; break;
		       case LANG_NE: if (xf != yf) z = 1; break;
		       case LANG_GT: if (xf > yf) z = 1; break;
		       case LANG_GE: if (xf >= yf) z = 1; break;
		       case LANG_LT: if (xf < yf) z = 1; break;
		       case LANG_LE: if (xf <= yf) z = 1; break;
		       case LANG_OR: if (xf || yf) z = 1; break;
		       case LANG_AND: if (xf && yf) z = 1; break;
		       case LANG_PLUS: zf = xf + yf; break;
		       case LANG_MINUS: zf = xf - yf; break;
		       case LANG_TIMES: zf = xf * yf; break;
		       case LANG_DIVIDE:
		       if (yf == 0.0)
			 {
			    SLang_Error = DIVIDE_ERROR;
			    return(0);
			 }
		       zf = xf / yf; break;   /* y == 0? */
		       default:
		       SLang_Error = INTERNAL_ERROR;
		       return(0);
		    }
		  if (ttype == LANG_CMP) SLang_push_integer(z);
		  else SLang_push_float(zf);
	       }
	     
	     /* binary */
#endif /* float */
	  }
	else if (ttype == LANG_INTRINSIC)
	  {
	     name_entry = (SLang_Name_Type *) val;
	     lang_do_intrinsic((SLang_Object_Type *) &name_entry->obj);
	     if (SLang_Error && SLang_Traceback)
	       {
		  do_traceback(name_entry, 0);
	       }
	  }
	else if (ttype == LANG_LITERAL)        /* a constant */
	  {
	     SLang_push(addr);
	  }
	else if (ttype == LANG_BLOCK)
	  {	     
	     if (stype == ERROR_BLOCK) err_block = addr;
	     else if (!block) block = (long) addr;
	  }
	else if (ttype == LANG_DIRECTIVE)
	  {
	     if (stype & LANG_EQS_MASK)
	       {
		  lang_do_eqs(addr);
	       }
	     else if (!block) SLang_doerror("No Blocks!");
	     else if (stype & LANG_IF_MASK) lang_do_ifs(addr);
	     else if (stype & LANG_ELSE_MASK) lang_do_else(stype, block);
	     else if (stype & LANG_LOOP_MASK) lang_do_loops(stype, block);
	     /* else SLang_doerror("Unknown directive!"); */
	     block = 0;
	     bc = Lang_Break_Condition;
	  }
	else if (ttype == LANG_UNARY)
	  {
#ifndef FLOAT_TYPE
	     if (SLang_pop_integer(&z)) return(0);
	     switch (stype)
	       {
		  case LANG_SQR: z = z * z; break;
		  case LANG_MUL2: z = z * 2; break;
		  case LANG_NOT:  z = !z; break;
		  case LANG_BNOT:  z = ~z; break;
		  case LANG_CHS:  z = -z; break;
		  case LANG_ABS: z = abs(z); break;
		  case LANG_SIGN: z = (z >= 0) ? 1 :  -1; break;
		  default: SLang_Error = INTERNAL_ERROR; return(0);
	       }
	     SLang_push_integer(z);
#else
	     if (stype == LANG_CHS)
	       {
		  if (SLang_pop_float(&zf, &xc, &z)) return(0);
		  if (xc) SLang_push_integer(-z); else SLang_push_float(-zf);
	       }
	     else if (stype == LANG_SQR)
	       {
		  if (SLang_pop_float(&zf, &xc, &z)) return(0);
		  if (xc) SLang_push_integer(z * z); else SLang_push_float(zf * zf);
	       }
	     else if (stype == LANG_MUL2)
	       {
		  if (SLang_pop_float(&zf, &xc, &z)) return(0);
		  if (xc) SLang_push_integer(z << 1); else SLang_push_float(2.0 * zf);
	       }
	     else if (stype == LANG_ABS)
	       {
		  if (SLang_pop_float(&zf, &xc, &z)) return(0);
		  if (xc) SLang_push_integer(abs(z)); 
		  else SLang_push_float((float) fabs((float) zf));
	       }
	     
	     else
	       {
		  if (SLang_pop_integer(&z)) return(0);
		  if (stype == LANG_NOT) z = !z;
		  else if (stype == LANG_BNOT) z = ~z;
		  else
		    {
		       SLang_Error = INTERNAL_ERROR;
		       return(0);
		    }
		  SLang_push_integer(z);
	       }
#endif
	  }
	else if (ttype == LANG_FUNCTION)
	  {
	     /* val is a reference to the name table, so get its obj: */
	     name_entry = (SLang_Name_Type *) val;
	     SLexecute_function(name_entry);
	     bc = Lang_Break_Condition;
	  }
	
	else  switch (ttype)
	  {
	   case LANG_GVARIABLE: 
	       val = ((SLang_Name_Type *) val)->obj.value;
	       SLang_push_variable((SLang_Object_Type *) val);
	       break;
	     
	     case LANG_IVARIABLE:
	     case LANG_RVARIABLE:
	       val = ((SLang_Name_Type *) val)->obj.value;
	       switch(stype)
	       {
		  case STRING_TYPE: SLang_push_string((char *) val); break;
		  case INT_TYPE: SLang_push_integer(*(int *) val); break;
#ifdef FLOAT_TYPE
		case FLOAT_TYPE: SLang_push_float(*(float *) val); break;
#endif
		  default: SLang_doerror("Unsupported Type!");
	       }

	       break;

	   case LANG_RETURN: 
	     Lang_Break_Condition = Lang_Return = Lang_Break = 1; return(1);
	   case LANG_BREAK: 
	     Lang_Break_Condition = Lang_Break = 1; return(1);
	   case LANG_CONTINUE: 
	     Lang_Break_Condition = Lang_Continue = 1; return(1);
	     
	   case LANG_EXCH: if (SLang_pop(&obj1) || SLang_pop(&obj2)) return(1);
	     SLang_push(&obj1); SLang_push(&obj2);
	     break;

	   case LANG_LABEL:
	     if (SLang_pop_integer(&z) || !z) return(0);
	     break;

	   case LANG_LOBJPTR:
	     val = (long) (Local_Variable_Frame - (int) val);
	     objp = (SLang_Object_Type *) val;
	     if (objp->type == 0)
	       {
		  SLang_doerror("Local variable pointer not initialized.");
		  break;
	       }
	     
	     obj1.value = objp->value;
	     obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
	     SLang_push(&obj1);
	     break;
	     
	   case LANG_GOBJPTR:
	     obj1.value = val;
	     obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
	     SLang_push(&obj1);
	     break;
	     	     
	   case LANG_X_ERROR: 
	     if (err_block != NULL) 
	       {
		  inner_interp((SLang_Object_Type *)(err_block->value));
		  if (SLang_Error) err_block = NULL;
	       }
	     else SLang_doerror("No Error Block");
	     bc = Lang_Break_Condition;
	     break;
	     default: SLang_doerror("Run time error.");
	  }
	/* if (SLang_Error) break; --- moved to top */
	addr++;
     }
   if ((SLang_Error) && (err_block != NULL) && 
       ((SLang_Error == USER_BREAK) || (SLang_Error == INTRINSIC_ERROR)))
     {
	save_err = Last_Error++;
        slerr = SLang_Error;
	SLang_Error = 0;
	inner_interp((SLang_Object_Type *)(err_block->value));
	if (Last_Error <= save_err)
	  {
	     /* Caught error and cleared it */
	     Last_Error = save_err;
	     if (Lang_Break_Condition == 0) inner_interp(addr);
	  }
	else 
	  {
	     Last_Error = save_err;
	     SLang_Error = slerr;
	  }
     }
   
   return(1);
}

/* Hash value of current item to search in table */
static unsigned char Hash;

static unsigned char compute_hash(unsigned char *s)
{
   register unsigned char *ss = s;
   register unsigned char h = 0;
   while (*ss) h += *ss++ + (h << 2);
   if (!h) h = *s;
   return(Hash = h);
}

SLang_Name_Type *SLang_locate_name_in_table(char *name, SLang_Name_Type *table, SLang_Name_Type *t0, int max)
{
   register SLang_Name_Type *t = t0, *tmax = table + max;
   register char h = Hash, h1;
   
   /* while(t != tmax) && (nm = t->name, (h1 = *nm) != 0)) */
   while(t != tmax)
     {
	h1 = *t->name;
	/* h is never 0 */
	if ((h1 == h) && !strcmp(t->name + 1,name))
	  {
#ifdef SLANG_STATS
	     t->n++;
#endif
	     return(t);
	  }
	else if (h1 == 0) break;
	t++;
     }
   if (t == tmax) return(NULL);
   return(t);
}

void SLang_trace_fun(char *f)
{
   SLang_Trace = 1;
   compute_hash((unsigned char *) f);
   *SLang_Trace_Function = Hash;
   strcpy((char *) SLang_Trace_Function + 1, f);
}

#ifdef SLANG_STATS
int lang_dump_stats(char *file)
{
   SLang_Name_Type *t = Lang_Intrinsic_Name_Table;
   int i;
   FILE *fp;
   if ((fp = fopen(file, "w")) == NULL) return(0);
   while (*t->name != 0)
     {
	fprintf(fp, "%3d\t%3d\t%s\n", t->n, (int) (unsigned char) *t->name, t->name + 1);
	t++;
     }
   for (i = 0; i < 256; i++) fprintf(fp, "Count %d: %lu\n", i, stat_counts[i]);

   fclose(fp);
   return(1);
}
#endif

/* before calling this routine, make sure that Hash is up to date */
SLang_Name_Type *SLang_locate_global_name(char *name)
{   
   SLName_Table *nt;
   SLang_Name_Type *t;
   int ofs;
   
   nt = SLName_Table_Root;
   while (nt != NULL)
     {
	t = nt->table;
	
	if ((ofs = nt->ofs[Hash]) != -1)
	  {
	     t = SLang_locate_name_in_table(name, t, t + ofs, nt->n);
	     if ((t != NULL) && (*t->name != 0)) return(t);
	  }
	
	nt = nt->next;
     }
		
   return SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table, LANG_MAX_SYMBOLS);
}



SLang_Name_Type *SLang_locate_name(char *name)
{
   SLang_Name_Type *t;

   (void) compute_hash((unsigned char *) name);
   
   t = Lang_Local_Variable_Table;

   if (t != NULL)
     {
	t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number);
	/* MAX_LOCAL_VARIABLES */
     }
   
   if ((t == NULL) || (*t->name == 0)) t = SLang_locate_global_name(name);
   return(t);
}


/* check syntax.  Allowed chars are: $!_?AB..Zab..z0-9 */
static int lang_check_name(char *name)
{
   register char *p, ch;
   char *err = "Name Syntax";
   
   p = name;
   while ((ch = *p++) != 0)
     {
	if ((ch >= 'a') && (ch <= 'z')) continue;
	if ((ch >= 'A') && (ch <= 'Z')) continue;
	if ((ch >= '0') && (ch <= '9')) continue;
	if ((ch == '_') || (ch == '$') || (ch == '!') || (ch == '?')) continue;
	SLang_doerror(err);
	return(0);
     }

   p--;
   if ((int) (p - name) > LANG_MAX_NAME_LEN)
     {
	SLang_doerror("Name too long.");
	return(0);
     }
   return (1);
}



void SLadd_name(char *name, long addr, unsigned short type)
{
   SLang_Name_Type *entry;
   unsigned char stype;
   
   if (!lang_check_name(name)) return;
   if (NULL == (entry = SLang_locate_name(name)))
     {
	SLang_doerror("Table size exceeded!");
	return;  /* table full */
     }
   
   stype = entry->obj.type & 0xFF;
   
   if ((stype == LANG_INTRINSIC) || (stype == LANG_IVARIABLE)
       || (stype == LANG_RVARIABLE))
     {
	SLang_Error = DUPLICATE_DEFINITION;
	return;
     }   

   if (*entry->name != 0)
     {
#if 0
	if ((stype != LANG_INTRINSIC) && (stype != LANG_GVARIABLE)
	    && (stype != LANG_IVARIABLE) && (stype != LANG_RVARIABLE))
	  {
	     /* free its function or block definition only if not autoloaded */
	     if (! ((stype == LANG_FUNCTION) && ((entry->obj.type >> 8) == 255)))
	       lang_free_branch((SLang_Object_Type *) entry->obj.value);

	     FREE(entry->obj.value);
	  }
#endif
	/* 255 denotes that the function needs autoloaded. */
	if (stype == LANG_FUNCTION)
	  {
	     if ((entry->obj.type >> 8) != 255)
	       lang_free_branch((SLang_Object_Type *) entry->obj.value);
	     FREE(entry->obj.value);
	  }
     }
   else 
     {
	strcpy(entry->name + 1, name);
	*entry->name = (char) Hash;
     }
   

   entry->obj.value = (long) addr;
   entry->obj.type = type;
}

void SLang_autoload(char *name, char *file)
{
   unsigned short type;
   long f;

   type = LANG_FUNCTION | (255 << 8);
   f = SLmake_string(file);

   SLadd_name(name, f, type);
}

void lang_define_function(char *name)
{
   long addr;
   unsigned short type;
   
   addr = (long) Lang_Function_Body;
   type = LANG_FUNCTION | (Local_Variable_Number << 8);
   
   if (name != NULL)
     {
	SLadd_name(name, addr, type);
     }
   
   /* terminate function */
   Lang_Object_Ptr->type = 0;
   
   if (SLang_Error) return;
   Lang_Defining_Function = 0;
   if (Lang_Local_Variable_Table != NULL) FREE(Lang_Local_Variable_Table);
   Lang_Local_Variable_Table = NULL;
   Local_Variable_Number = 0;

   Lang_Object_Ptr = Lang_Interp_Stack_Ptr;   /* restore pointer */
}

/* call inner interpreter or return for more */
void lang_try_now(void)
{
   SLang_Object_Type *old_stack, *old_stack_ptr, *old_int_stack_ptr;
   SLang_Object_Type new_stack[4];
   int i;

   if (Lang_Defining_Function || Lang_Defining_Block)
     {
	Lang_Object_Ptr++;
	return;
     }

   /* This is the entry point into the inner interpreter.  As a result, it
      is also the exit point of the inner interpreter.  So it is necessary to
      clean up if there was an error.
    */

   (Lang_Object_Ptr + 1)->type = 0;  /* so next command stops after this */

   /* now before entering the inner interpreter, we make a new stack so that
      we are able to be reentrant */
   
   for (i = 1; i < 4; i++)
     {
	new_stack[i].type = 0;
	new_stack[i].value = 0;
     }
   
   /* remember these values */
   old_int_stack_ptr = Lang_Interp_Stack_Ptr;
   old_stack_ptr = Lang_Object_Ptr;
   old_stack = Lang_Interp_Stack;

   /* new values for reentrancy */
   Lang_Interp_Stack_Ptr = Lang_Object_Ptr = Lang_Interp_Stack = new_stack;

   /* now do it */
   inner_interp(old_stack);

   /* we are back so restore old pointers */
   Lang_Interp_Stack_Ptr = old_int_stack_ptr;
   Lang_Object_Ptr = old_stack_ptr;
   Lang_Interp_Stack = old_stack;

   /* now free blocks from the current interp_stack.  There can only 
      be blocks since they are only objects not evaluated immediately */

   while(Lang_Object_Ptr != Lang_Interp_Stack)
     {
	/* note that top object is not freed since it was not malloced */
	Lang_Object_Ptr--;
	/* FREE(Lang_Object_Ptr->value); */
	lang_free_branch((SLang_Object_Type *) Lang_Object_Ptr->value);
     }

   /* now free up the callocd stack. 
   FREE(new_stack); */
}


#define eqs(a,b) ((*(a) == *(b)) && !strcmp(a,b))
int SLang_execute_function(char *name)
{
   unsigned char type;
   SLang_Name_Type *entry;
   if ((NULL == (entry = SLang_locate_name(name))) || (*entry->name == 0)) return(0);
   type = entry->obj.type & 0xFF;
   if (type == LANG_FUNCTION) SLexecute_function(entry);
   else if (type == LANG_INTRINSIC)
     lang_do_intrinsic((SLang_Object_Type *) &(entry->obj));
   else return(0);
   if (SLang_Error) SLang_doerror(NULL);
   return(1);
}

#if 0
static void make_name_ptr(char *name)
{
   SLang_Name_Type *n;
   SLang_Object_Type obj;
   
   n = SLang_locate_name(name);
   
   if ((n == NULL) || (*n->name == 0))
     {
	SLang_doerror("Object is undefined.");
	return;
     }
   
   obj.type = LANG_DATA | (LANG_OBJ_TYPE << 8);
   
   if ((n->obj.type >> 8) == LANG_OBJ_TYPE) obj.value = n->obj.value;
   else obj.value = (long) n;
   SLang_push (&obj);
}
#endif

static int lang_exec(char *name)
{
   SLang_Name_Type *entry;
   short type;
   int ptr_type = 0;
   
   
   if (eqs(name, "EXECUTE_ERROR_BLOCK"))
     {
	Lang_Object_Ptr->type = LANG_X_ERROR;
	Lang_Object_Ptr->value = 0;
     }
   else
     {
	if (*name == '&')
	  {
	     name++;
	     ptr_type = 1;
	  }
	
	if (NULL == (entry = SLang_locate_name(name))) return(0);
	if (*entry->name == 0) return(0); 
		     
	type = entry->obj.type;
	if (ptr_type)
	  {
	     Lang_Object_Ptr->type = type == LANG_LVARIABLE ?
	        LANG_LOBJPTR : LANG_GOBJPTR;
	  }
	else
	  {
	     Lang_Object_Ptr->type = type;
	  }
	
	if (type == LANG_LVARIABLE)
	  {
	     Lang_Object_Ptr->value = entry->obj.value;
	  }
	else
	  {
	     Lang_Object_Ptr->value = (long) entry;
	  }
     }
   
   lang_try_now();
   return(1);
}



int lang_try_binary(char *t)
{
   int ssub;
   unsigned char sub, type;
   ssub = 0;

   if (0 == (ssub = slang_eqs_name(t, Lang_Binaries))) return(0);

   if (ssub < 0)
     {
	ssub = -ssub;
	type = LANG_BINARY;
     }
   else type = LANG_CMP;
   sub = (unsigned char) ssub;

   Lang_Object_Ptr->type = type | (sub << 8);
   Lang_Object_Ptr->value = 0;         /* not used */

   lang_try_now();
   return(1);
}

int lang_try_unary(char *t)
{
   unsigned char ssub, type;

   if (eqs(t, "~")) ssub = LANG_BNOT;
   else if (eqs(t, "not")) ssub = LANG_NOT;
   else if (eqs(t, "chs")) ssub = LANG_CHS;
   else if (eqs(t, "sign")) ssub = LANG_SIGN;
   else if (eqs(t, "abs")) ssub = LANG_ABS;
   else if (eqs(t, "sqr")) ssub = LANG_SQR;
   else if (eqs(t, "mul2")) ssub = LANG_MUL2;
   else return(0);

   type = LANG_UNARY;

   Lang_Object_Ptr->type = type | (ssub << 8);
   Lang_Object_Ptr->value = 0;         /* not used */

   lang_try_now();
   return(1);
}

void lang_begin_function(void)
{
   if (Lang_Defining_Function || Lang_Defining_Block)
     {
	SLang_doerror("Function nesting illegal.");
	return;
     }

   Lang_Defining_Function = 1;

   /* make initial size for 3 things */
   Lang_FBody_Size = 3; 
   if (NULL == (Lang_Function_Body = (SLang_Object_Type *)
          CALLOC(Lang_FBody_Size, sizeof(SLang_Object_Type))))
     {
	SLang_doerror("Calloc error defining function.");
	return;
     }
   /* function definitions should be done only at top level so it should be
      safe to do this: */
   Lang_Interp_Stack_Ptr = Lang_Object_Ptr;
   Lang_Object_Ptr = Lang_FBody_Ptr = Lang_Function_Body;
   return;
}

void lang_end_block(void)
{
   SLang_Object_Type *node, *branch;
   Lang_Block_Depth--;

   /* terminate the block */
   Lang_Object_Ptr->type = 0;

   branch = Lang_Block_Body;

   if (Lang_Block_Depth == -1)         /* done */
     {
	if (Lang_Defining_Function)
	  {
	     node = Lang_FBody_Ptr++;
	  }
	else node = Lang_Interp_Stack_Ptr;   /* on small stack */
     }
   else                                /* pop previous block */
     {
	Lang_BBody_Size = Lang_Block_Stack[Lang_Block_Depth].size;
	Lang_Block_Body = Lang_Block_Stack[Lang_Block_Depth].body;
	node = Lang_Block_Stack[Lang_Block_Depth].ptr;
     }

   node->type = LANG_BLOCK;
   node->value = (long) branch;
   Lang_Object_Ptr = node + 1;
   Lang_Defining_Block--;
}

void lang_begin_block(void)
{
   if (Lang_Block_Depth == LANG_MAX_BLOCKS - 1)
     {
	SLang_doerror("Block Nesting too deep.");
	SLang_Error = UNKNOWN_ERROR;
	return;
     }
   /* push the current block onto the stack */
   if (Lang_Block_Depth > -1)
     {
	Lang_Block_Stack[Lang_Block_Depth].size = Lang_BBody_Size;
	Lang_Block_Stack[Lang_Block_Depth].body = Lang_Block_Body;
	Lang_Block_Stack[Lang_Block_Depth].ptr = Lang_Object_Ptr;
     }

   /* otherwise this is first block so save function pointer */
   else if (Lang_Defining_Function) Lang_FBody_Ptr = Lang_Object_Ptr;
   else Lang_Interp_Stack_Ptr = Lang_Object_Ptr;

   Lang_BBody_Size = 5;    /* 40 bytes */
   if (NULL == (Lang_Block_Body = (SLang_Object_Type *)
                   CALLOC(Lang_BBody_Size, sizeof(SLang_Object_Type))))
      {
	 SLang_Error = SL_MALLOC_ERROR;
	 /* SLang_doerror("Malloc error defining block."); */
	 return;
      }
   Lang_Block_Depth++;
   Lang_Defining_Block++;
   Lang_Object_Ptr = Lang_Block_Body;
   return;
}


/* see if token is a directive, and add it to current block/function */
static Lang_Name2_Type Lang_Directives[] =
{
   {"!if", LANG_IFNOT},
   {"if", LANG_IF},
   {"else", LANG_ELSE},
   {"forever", LANG_FOREVER},
   {"while", LANG_WHILE},
   {"for", LANG_CFOR},
   {"_for", LANG_FOR},
   {"loop", LANG_LOOP},
   {"switch", LANG_SWITCH},
   {"do_while", LANG_DOWHILE},
   {"andelse", LANG_ANDELSE},
   {"orelse", LANG_ORELSE},
   {NULL, NULL}   
};


static int try_directive(char *t, int *flag)
{  
   unsigned char sub = 0;
   unsigned short type = LANG_DIRECTIVE;
   SLang_Object_Type *lop;
   int flag_save;
   
   if ((sub = (unsigned char) slang_eqs_name(t, Lang_Directives)) != 0); /* null */
   else if (*flag && eqs(t, "ERROR_BLOCK"))
     {
	lop = Lang_Object_Ptr - 1;
	if (lop->type != LANG_BLOCK) SLang_doerror("Internal Error with error_block!");
	else lop->type = LANG_BLOCK | (ERROR_BLOCK << 8);
	return(1);
     }
   /* rest valid only if flag is zero */
   else if (*flag) return(0);
   else
     {
	if (Lang_Defining_Block && eqs(t, "continue")) type = LANG_CONTINUE;
	else if (Lang_Defining_Block && eqs(t, "break")) type = LANG_BREAK;
	else if (Lang_Defining_Function && eqs(t, "return")) type = LANG_RETURN;
	/* why is exch here? */
	else if (eqs(t, "exch")) type = LANG_EXCH;
	else return(0);
	*flag = 1;
     }

   Lang_Object_Ptr->type = type | (sub << 8);
   Lang_Object_Ptr->value = 0;         /* not used */

   flag_save = *flag; *flag = 0;
   lang_try_now();
   *flag = flag_save;

   return(1);
}

long lang_make_object(void)
{
   SLang_Object_Type *obj;

   obj = (SLang_Object_Type *) MALLOC(sizeof(SLang_Object_Type));
   if (NULL == obj)
     {
	SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Lang: malloc error."); */
	return(0);
     }
   obj->type = 0;
   obj->value = 0;
   return (long) obj;
}

int interp_variable_eqs(char *name)
{
   SLang_Name_Type *v;
   SLang_Object_Type obj;
   unsigned short type;
   unsigned char stype;
   char ch;
   long value;
   int offset;
   int eq, pe, me, pp, mm;
   
   eq = LANG_GEQS - LANG_GEQS;
   pe = LANG_GPEQS - LANG_GEQS;
   me = LANG_GMEQS - LANG_GEQS;
   pp = LANG_GPP - LANG_GEQS;
   mm = LANG_GMM - LANG_GEQS;

   /* Name must be prefixed by one of:  =, ++, --, +=, -= 
      all of which have ascii codes less than or equal to 61 ('=') */
   
   offset = -1;
   ch = *name++;
   switch (ch)
     {
      case '=': offset = eq; break;
      case '+': 
	ch = *name++;
	if (ch == '+') offset = pp; else if (ch == '=') offset = pe;
	break;
      case '-':
	ch = *name++;
	if (ch == '-') offset = mm; else if (ch == '=') offset = me;
	break;
     }
   
   if (offset == -1) return 0;
   
   v = SLang_locate_name(name);
   if ((v == NULL) || *(v->name) == 0)
     {
	SLang_Error = UNDEFINED_NAME;
	SLang_doerror(name);
	return(1);
     }

   type = (v->obj.type) & 0xFF;
   if (type == LANG_RVARIABLE)
     {
	SLang_Error = READONLY_ERROR;
	return(1);
     }

   if ((type != LANG_GVARIABLE) && (type != LANG_LVARIABLE)
       && (type != LANG_IVARIABLE))
     {
	SLang_Error = DUPLICATE_DEFINITION;
	return(1);
     }

   /* its value is location of object in name table */
   value = (long) v;

   if (type == LANG_IVARIABLE)
     {
	if ((v->obj.type >> 8) == STRING_TYPE)
	  {
	     SLang_Error = READONLY_ERROR;
	     return(1);
	  }

	stype = LANG_IEQS;
     }

   else if (type == LANG_GVARIABLE) stype = LANG_GEQS;
   else
     {
	stype = LANG_LEQS;
	value = v->obj.value;
     }

   stype += offset;
   
   if (Lang_Defining_Function || Lang_Defining_Block)
     {
	Lang_Object_Ptr->type = LANG_DIRECTIVE | (stype << 8);
	Lang_Object_Ptr->value = value;
	Lang_Object_Ptr++;
	return (1);
     }

   /* create an object with the required properties for next call */
   obj.type = LANG_DIRECTIVE | (stype << 8);
   obj.value = value;
   lang_do_eqs(&obj);
   return(1);
}

unsigned char is_number(char *t)
{
   char *p;
   register char ch;

   p = t;
   if (*p == '-') p++;
#ifdef FLOAT_TYPE
   if (*p != '.') 
     {
#endif
	while ((*p >= '0') && (*p <= '9')) p++;
	if (t == p) return(STRING_TYPE);
	if (*p == 'x')
	  {
	     p++;
	     while (ch = *p, 
		    ((ch >= '0') && (ch <= '9'))
		    || ((ch >= 'A') && (ch <= 'F'))) p++;
	  }
	if (*p == 0) return(INT_TYPE);
#ifndef FLOAT_TYPE
	return(STRING_TYPE);
#else
     }
   
   /* now down to float case */
   if (*p == '.')
     {
	p++;
	while ((*p >= '0') && (*p <= '9')) p++;
     }
   if (*p == 0) return(FLOAT_TYPE);
   if ((*p != 'e') && (*p != 'E')) return(STRING_TYPE);
   p++;
   if (*p == '-') p++;
   while ((*p >= '0') && (*p <= '9')) p++;
   if (*p != 0) return(STRING_TYPE); else return(FLOAT_TYPE);
#endif
}

   


/* a literal */
int interp_push_number(char *t)
{
   int i;
   unsigned char stype;
   long value = 0;
#ifdef FLOAT_TYPE
   float x;
#endif

   stype = is_number(t);
   if (stype == STRING_TYPE) return(0);
   if (stype == INT_TYPE)
     {
	i = SLatoi((unsigned char *) t);
	value = (long) i;
     }

#ifdef FLOAT_TYPE
   else if (stype == FLOAT_TYPE)
     {
	x = atof(t);
	value = *(long *) &x;
     }
#endif

   if (!Lang_Defining_Block && !Lang_Defining_Function)
     {
#ifdef FLOAT_TYPE
	if (stype == INT_TYPE)
	  {
#endif
	     SLang_push_integer(i);
#ifdef FLOAT_TYPE
	  }
	else SLang_push_float(x);
#endif
	return(1);
     }
   /* a literal */
   Lang_Object_Ptr->type = LANG_LITERAL | (stype << 8);
   Lang_Object_Ptr->value = value;
   Lang_Object_Ptr++;
   return(1);
}

/* only supports non negative integers, use 'chs' to make negative number */

void lang_check_space(void)
{
   int n;
   SLang_Object_Type *p;

   if (Lang_Interp_Stack_Ptr - Lang_Interp_Stack >= 9)
     {
	SLang_doerror("Interpret stack overflow.");
	return;
     }

   if (Lang_Defining_Block)
     {
	n = (int) (Lang_Object_Ptr - Lang_Block_Body);
	if (n + 1 < Lang_BBody_Size) return;   /* extra for terminator */
	p = Lang_Block_Body;
     }
   else if (Lang_Defining_Function)
     {
	n = (int) (Lang_Object_Ptr - Lang_Function_Body);
	if (n + 1 < Lang_FBody_Size) return;
	p = Lang_Function_Body;
     }
   else return;

   /* enlarge the space by 2 objects */
   n += 2;
   if (NULL == (p = (SLang_Object_Type *) REALLOC(p, n * sizeof(SLang_Object_Type))))
     {
	SLang_doerror("Lang: realloc failure.");
	return;
     }

   if (Lang_Defining_Block)
     {
	Lang_BBody_Size = n;
	n = (int) (Lang_Object_Ptr - Lang_Block_Body);
	Lang_Block_Body = p;
	Lang_Object_Ptr = p + n;
     }
   else
     {
	Lang_FBody_Size = n;
	n = (int) (Lang_Object_Ptr - Lang_Function_Body);
	Lang_Function_Body = p;
	Lang_Object_Ptr = p + n;
     }
}

int Lang_Defining_Variables = 0;

/* returns positive number if name is a function or negative number if it 
   is a variable.  If it is intrinsic, it returns magnitude of 1, else 2 */
int SLang_is_defined(char *name)
{
   SLang_Name_Type *t;
   unsigned char stype;
   (void) compute_hash((unsigned char *) name);
   t = SLang_locate_global_name(name);
   
   if ((t == NULL) || (*t->name == 0)) return 0;
   
   stype = t->obj.type & 0xFF;
   switch (stype)
     {
      case LANG_FUNCTION: return(2);
      case LANG_INTRINSIC: return(1);
      case LANG_GVARIABLE: return (-2);
      default: 
	return(-1);
     }
}




char *SLang_find_name(char *name)
{
   SLang_Name_Type *n;
   
   compute_hash((unsigned char *) name);
   
   n = SLang_locate_global_name(name);
   if ((n != NULL) && (*n->name != 0))
     {
	return(n->name);
     }
   return(NULL);
}

void SLadd_variable(char *name)
{
   SLang_Name_Type *table;
   long value;

   if (!lang_check_name(name)) return;
   
   if (Lang_Defining_Function)	       /* local variable */
     {
	compute_hash((unsigned char *) name);
	table = Lang_Local_Variable_Table;
	if (!Local_Variable_Number)
	  {
	     table = (SLang_Name_Type *) CALLOC(MAX_LOCAL_VARIABLES, sizeof(SLang_Name_Type));
	     if (NULL == table)
	       {
		  SLang_doerror("Lang: calloc error.");
		  return;
	       }
	     Lang_Local_Variable_Table = table;
	  }
	strcpy(table[Local_Variable_Number].name + 1, name);
	*table[Local_Variable_Number].name = (char) Hash;
	table[Local_Variable_Number].obj.type = LANG_LVARIABLE;
	table[Local_Variable_Number].obj.value = Local_Variable_Number;
        Local_Variable_Number++;
     }
   else	if (!SLang_is_defined(name))
     {
	if (0 == (value = lang_make_object())) return;
	SLadd_name(name, value, LANG_GVARIABLE);
     }
}

void interp_push_string(char *t)
{
   int len;

   /* strings come in with the quotes attached-- knock em off */
   if (*t == '"')
     {
	len = strlen(t) - 1;
	if (*(t + len) == '"') *(t + len) = 0;
	t++;
     }

   if (!Lang_Defining_Block && !Lang_Defining_Function)
     {
	SLang_push_string(t);
	return;
     }

   if (NULL == (Lang_Object_Ptr->value 
		= (long) SLmake_string((char *) t))) return;

   /* a literal --- not to be freed */
   Lang_Object_Ptr->type = LANG_LITERAL | (STRING_TYPE << 8);
   Lang_Object_Ptr++;
}

/* if an error occurs, discard current object, block, function, etc... */
void SLang_restart(int localv)
{
   int save = SLang_Error;
   SLang_Error = UNKNOWN_ERROR;

   SLcompile_ptr = SLcompile;
   Lang_Break = Lang_Continue = Lang_Return = 0;
   while(Lang_Defining_Block)
     {
	lang_end_block();
     }

   if (Lang_Defining_Function)
     {
	if (Lang_Function_Body != NULL)
	  {
	     lang_define_function(NULL);
	     lang_free_branch(Lang_Function_Body);
	     FREE(Lang_Function_Body);
	  }
	if (Local_Variable_Number)
	  {
	     FREE(Lang_Local_Variable_Table);
	     Local_Variable_Number = 0;
	     Lang_Local_Variable_Table = NULL;
	  }
	Lang_Defining_Function = 0;
     }

   SLang_Error = save;
   /* --- warning--- I need to free things on the stack! */
   if (SLang_Error == STACK_OVERFLOW) SLStack_Pointer = SLRun_Stack;
   
   Lang_Interp_Stack = Lang_Object_Ptr = Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static;
   /* This should be handled automatically */
   
   if (localv) Local_Variable_Frame = Local_Variable_Stack;
   Lang_Defining_Variables = 0;
}

#ifdef SL_BYTE_COMPILING

static void try_byte_compiled(register char *s)
{
   SLang_Name_Type *entry, *table;
   register int n = 0;
   register char ch;
   char *name;
   
   while ((ch = *s++) != 0)
     {
	if ((ch > '9') || (ch < '0')) 
	  {
	     SLang_doerror("Illegal name.");
	     return;
	  }
	n = 10 * n + (ch - '0');
     }
   
   entry =  &(Lang_Intrinsic_Name_Table[n]);
   name = entry->name;
   Hash = (unsigned char) *name++;
   table = Lang_Local_Variable_Table;
   if (table != NULL)
     {
	table = SLang_locate_name_in_table(name, table, table, MAX_LOCAL_VARIABLES);
	if ((table != NULL) && (*table->name != 0))
	  {
	     if (!lang_exec(name)) SLang_Error = UNDEFINED_NAME;
	     return;
	  }
     }
   Lang_Object_Ptr->type = entry->obj.type;
   Lang_Object_Ptr->value = (long) entry;
   lang_try_now();
}
#endif


void SLcompile(char *t)
{
   static int flag = 0;
   int d = 0;
   char ch = *t;
   
   lang_check_space();                 /* make sure there is space for this */
   
   
   if (!SLang_Error
#ifdef BYTE_COMPILING
       && (ch != '@')
#endif
       )
     {
	if (ch == '{')
	  {
	     lang_begin_block();
	     d = 1;
	  }
	else
	  {
	     /* The purpose of this convoluted mess is to flag errors 
	      such as  '{block} statement'  where 'statement' is not 
	      somthing like 'if', '!if', 'while', ...  That is, something
	      which is not supposed to follow a block. */
	     d = try_directive(t, &flag);
	     if ((!flag && d) || (flag && !d)) SLang_Error = SYNTAX_ERROR;
	  }
	flag = 0;
     }

#ifdef SL_BYTE_COMPILING
   if (ch == '@') try_byte_compiled(t + 1);
   else
#endif
   if (SLang_Error || d);  /* null... */
   else if (Lang_Defining_Variables)
     {
	if (ch == ']') Lang_Defining_Variables = 0;
	else SLadd_variable(t);
     }
   else if (Lang_Defining_Function == -1) lang_define_function(t);
   else if (ch == '"') interp_push_string(t);
   else if ((ch == ':') && (Lang_Defining_Block))
     {
	Lang_Object_Ptr->type = LANG_LABEL;
	Lang_Object_Ptr->value = 0;
	Lang_Object_Ptr++;
     }

   else if ((ch == ')') && (Lang_Defining_Function == 1))
     {
	if (Lang_Defining_Block) SLang_doerror("Function nesting illegal.");
	else Lang_Defining_Function = -1;
     }

   else if (ch == '{')
     {
	lang_begin_block();
	flag = 0;
     }

   else if ((ch == '}') && Lang_Defining_Block)
     {
	lang_end_block();
	flag = 1;
     }

   else if (ch == '(')	lang_begin_function();

   else if (ch == '[') Lang_Defining_Variables = 1;
   else if (lang_try_binary(t));
   else if (lang_try_unary(t));

   /* note that order here is important */
   else if ((ch <= '9') && interp_push_number(t));
   else if ((ch <= '=') && interp_variable_eqs(t));
   else if (lang_exec(t));
   else 
     {
	SLang_Error = UNDEFINED_NAME;
     }
   

   if (SLang_Error) 
     {	
	SLang_restart(0);
	flag = 0;
     }
}






int SLstack_depth()
{
   return (int) (SLStack_Pointer - SLRun_Stack);
}


char *SLbyte_compile_name(char *name)
{
   return (name);
}




/* #define STRCHR(x, y) ((y >= 'a') && (y <= 'z') ? NULL : ((y) == 32) || strchr(x, y)) */


Lang_Name2_Type Lang_Binaries[] = 
{
   {"+", -LANG_PLUS},
   {"-", -LANG_MINUS},
   {"*", -LANG_TIMES},
   {"/", -LANG_DIVIDE},
   {"<", LANG_LT},
   {"<=", LANG_LE},
   {"==", LANG_EQ},
   {">", LANG_GT},
   {">=", LANG_GE},
   {"!=", LANG_NE},
   {"and", LANG_AND},
   {"or", LANG_OR},
   {"mod", LANG_MOD},
   {"&", LANG_BAND},
   {"shl", LANG_SHL},
   {"shr", LANG_SHR},
   {"xor", LANG_BXOR},
   {"|", LANG_BOR},
   {NULL, NULL}
};

static char Really_Stupid_Hash[256];

void SLstupid_hash()
{
   register unsigned char *p;
   register Lang_Name2_Type *d;
   
   d = Lang_Binaries;
   while ((p = (unsigned char *) (d->name)) != NULL)
     {
	Really_Stupid_Hash[*(p + 1)] = 1;
	d++;
     }
   d = Lang_Directives;
   while ((p = (unsigned char *) (d->name)) != NULL)
     {
	Really_Stupid_Hash[*(p + 1)] = 1;
	d++;
     }
}

   
   

int slang_eqs_name(char *t, Lang_Name2_Type *d_parm)
{
   register char *p;
   register char ch;
   register Lang_Name2_Type *d;

   ch = *t++;
   if (Really_Stupid_Hash[(unsigned char) *t] == 0) return(0);
   d = d_parm;
   while ((p = d->name) != NULL)
     {
	if ((ch == *p) && !strcmp(t, p + 1)) return(d->type);
	d++;
     }
   return(0);
}

/* There are 1s at positions " %\t{}[];():*,/" */
static unsigned char special_chars[256] = 
{
   0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,
   0,0,0,0,1,0,0,1,1,1,0,1,0,0,1,0,0,0,0,0,0,0,0,0,0,1,1,0,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
   0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
};

char *SLexpand_escaped_char(char *p, char *ch)
{
   char ch1;
   int num = 0;
   int base = 16, i = -1;
   int max = '9';
   ch1 = *p++;
   switch (ch1)
     {
      case 'n': ch1 = '\n'; break;
      case 't': ch1 = '\t'; break;
      case 'v': ch1 = '\v'; break;
      case 'b': ch1 = '\b'; break;
      case 'r': ch1 = '\r'; break;
      case 'f': ch1 = '\f'; break;
      case 'e': ch1 = 27; break;
      case 'a': ch1 = 7; break;
      case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': 
	max = '7'; base = 8; i = 2; num = ch1 - '0';
	/* fall */
	
      case 'd':			       /* decimal -- S-Lang extension */
	if (ch1 == 'd')
	  {
	     base = 10; i = 3;
	  }
	
      case 'x':
	
	while(i--)
	  {
	     ch1 = *p;
	     
	     if ((ch1 <= max) && (ch1 >= '0'))
	       {
		  num = base * num + (ch1 - '0');
	       }
	     else if ((base == 16) && (ch1 >= 'A'))
	       {
		  if (ch1 >= 'a') ch1 -= 32;
		  if (ch1 <= 'F')
		    {
		       num = base * num + 10 + (ch1 - 'A');
		    }
		  else break;
	       }
	     else break;
	     p++;
	  }
	ch1 = (char) num;
	
     }
   *ch = ch1;
   return p;
}
   
   
int extract_token(char **linep, char *word_parm)
{
   register char ch, *line, *word = word_parm;
   int byte_comp = ((long) SLcompile != (long) SLcompile_ptr);
   int string;
   char ch1;

    line = *linep;

    /* skip white space */
    while(ch = *line++, (ch == ' ') || (ch == '\t'));

    if ((!ch) || (ch == '\n'))
      {
	 *linep = line;
	 return(0);
      }

   *word++ = ch;
   if (ch == '"') string = 1; else string = 0;
   if (ch == '\'')
     {
	if ((ch = *line++) != 0)
	  {
	     if (ch == '\\') 
	       {
		  line = SLexpand_escaped_char(line, &ch1);
		  ch = ch1;
	       }
	     if (*line++ == '\'')
	       {
		  --word;
		  sprintf(word, "%d", (int) ((unsigned char) ch));
		  word += 4;
	       }
	     else SLang_Error = SYNTAX_ERROR;
	  }
	else SLang_Error = SYNTAX_ERROR;
     }
   else
    if (!special_chars[(unsigned char) ch])
   while(ch = *line++, (ch > '"') || ((ch != '\n') && (ch != 0) && (ch != '"')))
     {
	if (string)
	  {
	     if (ch == '\\')
	       {
		  ch = *line++;
		  if ((ch == 0) || (ch == '\n')) break;
		  if (byte_comp) *word++ = '\\';
		  else 
		    {
		       line = SLexpand_escaped_char(line - 1, &ch1);
		       ch = ch1;
		    }
	       }
	  }
	else if (special_chars[(unsigned char) ch])
	  {
	     line--;
	     break;
	  }
	
	*word++ = ch;
     }

   if ((!ch) || (ch == '\n')) line--;
   if ((ch == '"') && string) *word++ = '"'; else if (string) SLang_Error = SYNTAX_ERROR;
   *word = 0;
   *linep = line;
   /* massage variable-- and ++ into --variable, etc... */
   if (((int) (word - word_parm) > 2)
       && (ch = *(word - 1), (ch == '+') || (ch == '-'))
       && (ch == *(word - 2)))
     {
	word--;
	while (word >= word_parm + 2)
	  {
	     *word = *(word - 2);
	     word--;
	  }
	*word-- = ch;
	*word-- = ch;
     }
   return(1);
}

void (*SLcompile_ptr)(char *) = SLcompile;

int SLang_add_table(SLang_Name_Type *table, char *table_name)
{
   register int i;
   SLang_Name_Type *t;
   SLName_Table *nt;
   int *ofs;
   unsigned char h;
   char *name;
   
   if ((nt = (SLName_Table *) MALLOC(sizeof(SLName_Table))) == NULL) return(0);
   nt->table = table;
   nt->next = SLName_Table_Root;
   strcpy(nt->name, table_name);
   SLName_Table_Root = nt;
   ofs = nt->ofs;
   for (i = 0; i < 256; i++) ofs[i] = -1;
   
   /* compute hash for table */
   
   t = table;
   while (((name = t->name) != NULL) && (*name != 0))
     {
	h = compute_hash((unsigned char *) (name + 1));
	*name = (char) h;
	if (ofs[h] == -1)
	  {
	     ofs[h] = (int) (t - table);
	  }
	t++;
     }
   nt->n = (int) (t - table);
   return(1);
}

extern char *SLang_extract_list_element(char *, int *, int *);
