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

#include <stdio.h>

#ifdef FLOAT_TYPE
char SLang_Version[] = "F0.98.0";
#include <math.h>
#else
char SLang_Version[] = "0.98.0";
#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];
int SLang_Name_Table_Ofs[256];

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... */
#define SLANG_MAX_TOP_STACK 10
SLang_Object_Type Lang_Interp_Stack_Static[SLANG_MAX_TOP_STACK];
SLang_Object_Type *Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static;
SLang_Object_Type *Lang_Interp_Stack = Lang_Interp_Stack_Static;

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 = NULL;

   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 (SL_INVALID_PARM) : str = "S-Lang: Invalid Parameter."; 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;
#ifdef USE_DOUBLE
   x->extra = y->extra;
#endif

   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;
#ifdef USE_DOUBLE
   y->extra = x->extra;
#endif
   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;
#ifdef USE_DOUBLE
   obj.extra = *(1 + (long *) &x);
#endif
   SLang_push (&obj);
}

#endif

/* if *data = 1, string should be freed upon use.  If it is -1, do not free
   but if you use it, malloc a new one.  */
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;
   subtype = obj->type >> 8;

   if (subtype == STRING_TYPE)
     {
	SLang_push_string((char *) obj->value);
	return;
     }
   else if (subtype == LANG_OBJ_TYPE)
     {
	call_funptr((SLang_Name_Type *) obj->value);
	return;
     }
   
    SLang_push(obj); 
}

/* 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;
#ifdef USE_DOUBLE
   long extra;
#endif
   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;
#ifdef USE_DOUBLE
	extra = obot->extra;
#endif
	obot->value = otop->value; obot->type = otop->type;
	
#ifdef USE_DOUBLE
	obot->extra = otop->extra;
#endif
	
	otop->value = value; otop->type = type;
#ifdef USE_DOUBLE
	otop->extra = extra;
#endif
	
	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 2 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.  */
/* see pop string for discussion of do_free */
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 */
   *do_free = 0;
   if ((*type >> 8) == STRING_TYPE) 
     {
	if ((*type & 0xFF) == LANG_DATA) *do_free = 1; 
	return((long *) *val);
     }
   return((long *) val);
}

void lang_do_eqs(SLang_Object_Type *obj)
{
   int y;
#ifdef FLOAT_TYPE   
   int ifloat, float_convert;
#endif
   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_Object_Type *) &((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))
     {
#ifdef FLOAT_TYPE
	/* A quick hack for float */
	if ((FLOAT_TYPE == (addr->type >> 8)) && (type == LANG_IEQS))
	  {
	     SLang_pop_float ((FLOAT *) addr->value, &float_convert, &ifloat);
	     return;
	  }
	 
#endif
	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)

void lang_do_intrinsic(SLang_Object_Type *objf)
{
   typedef void (*VF0_Type)(void);
   typedef void (*VF1_Type)(char *);
   typedef void (*VF2_Type)(char *, char *);
   typedef void (*VF3_Type)(char *, char *, char *);
   typedef void (*VF4_Type)(char *, char *, char *, char *);
   typedef void (*VF5_Type)(char *, char *, char *, char *, char *);
   typedef long (*LF0_Type)(void);
   typedef long (*LF1_Type)(char *);
   typedef long (*LF2_Type)(char *, char *);
   typedef long (*LF3_Type)(char *, char *, char *);
   typedef long (*LF4_Type)(char *, char *, char *, char *);
   typedef long (*LF5_Type)(char *, char *, char *, char *, char *);
#ifdef FLOAT_TYPE
   typedef FLOAT (*FF0_Type)(void);
   typedef FLOAT (*FF1_Type)(char *);
   typedef FLOAT (*FF2_Type)(char *, char *);
   typedef FLOAT (*FF3_Type)(char *, char *, char *);
   typedef FLOAT (*FF4_Type)(char *, char *, char *, char *);
   typedef FLOAT (*FF5_Type)(char *, char *, char *, char *, char *);
#endif
   long ret, fptr;
   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;
#endif

   fptr = objf->value;

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

   p5 = p4 = p3 = p2 = p1 = NULL;      /* shuts up gcc, NOT needed */
   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) ((VF0_Type) fptr) ();
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = ((FF0_Type) fptr)();
#endif
	  else ret = ((LF0_Type) fptr)();
	  break;

	case 1:
	  if (type == VOID_TYPE) ((VF1_Type) fptr)(p1);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf =  ((FF1_Type) fptr)(p1);
#endif
	  else ret =  ((LF1_Type) fptr)(p1);
	  break;

	case 2:
	  if (type == VOID_TYPE)  ((VF2_Type) fptr)(p1, p2);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = ((FF2_Type) fptr)(p1, p2);
#endif
	  else ret = ((LF2_Type) fptr)(p1, p2);
	  break;

	case 3:
	  if (type == VOID_TYPE) ((VF3_Type) fptr)(p1, p2, p3);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = ((FF3_Type) fptr)(p1, p2, p3);
#endif
	  else ret = ((LF3_Type) fptr)(p1, p2, p3);
	  break;

	case 4:
	  if (type == VOID_TYPE) ((VF4_Type) fptr)(p1, p2, p3, p4);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = ((FF4_Type) fptr)(p1, p2, p3, p4);
#endif
	  else ret = ((LF4_Type) fptr)(p1, p2, p3, p4);
	  break;

	case 5:
	  if (type == VOID_TYPE) ((VF5_Type) fptr)(p1, p2, p3, p4, p5);
#ifdef FLOAT_TYPE
	  else if (type == FLOAT_TYPE) xf = ((FF5_Type) fptr)(p1, p2, p3, p4, p5);
#endif
	  else ret = ((LF5_Type) fptr)(p1, p2, p3, p4, p5);
	  break;

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

   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 == 1) FREE(p5);
   if (free_p4 == 1) FREE(p4);
   if (free_p3 == 1) FREE(p3);
   if (free_p2 == 1) FREE(p2);
   if (free_p1 == 1) FREE(p1);
}

void lang_do_loops(unsigned char type, long addr)
{
   register int i, ctrl = 0;
   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 == 0))
	    || ((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);
static SLang_Object_Type *Exit_Block_Ptr;

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;
   static char buf[96];
   int trace_max, j;
   static int trace = 0;
   SLang_Object_Type *exit_block_save;

   n_locals = (entry->obj.type) >> 8;

   exit_block_save = Exit_Block_Ptr;
   Exit_Block_Ptr = NULL;
   
   /* need loaded?  */
   if (n_locals == 255)
     {
	if (!SLang_load_file((char *) entry->obj.value)) goto the_return;
	n_locals = (entry->obj.type) >> 8;
	if (n_locals == 255)
	  {
	     SLang_doerror("Function did not autoload!");
             goto the_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!");
	goto the_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;
	
	trace_max = (trace > 50) ? 50 : trace - 1;
	if (trace)
	  {
	     for (j = 0; j < trace_max; j++) buf[j] = ' ';
	     sprintf(buf + trace_max, ">>%s\n", entry->name + 1);
	     (*SLang_Dump_Routine)(buf);
	     trace++;
	  }
	
	inner_interp((SLang_Object_Type *) val);
	Lang_Break_Condition = Lang_Return = Lang_Break = 0;
	if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
	
	if (trace) 
	  {
	     sprintf(buf + trace_max, "<<%s\n", entry->name + 1);
	     (*SLang_Dump_Routine)(buf);
	     trace--;
	     if (trace == 1) trace = 0;
	  }
     }
   else
     {
	inner_interp((SLang_Object_Type *) val);
	Lang_Break_Condition = Lang_Return = Lang_Break = 0;
	if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
     }
   

   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;
  
   the_return:
   Lang_Break_Condition = Lang_Return = Lang_Break = 0;
   Exit_Block_Ptr = exit_block_save;
}



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 *) &objp->value);
	  }
#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;
#ifdef USE_DOUBLE
   long extra;
#endif
#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;
#ifdef USE_DOUBLE
	     extra = ((SLang_Object_Type *) val) -> extra;
#endif	     
	     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;
#ifdef USE_DOUBLE
		  obj1.extra = extra;
#endif
		  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 (stype == EXIT_BLOCK)
	       Exit_Block_Ptr = (SLang_Object_Type *) addr->value;
	     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((double) 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:
	     if (stype == ARRAY_TYPE)
	       {
		  SLang_push ((SLang_Object_Type *) &((SLang_Name_Type *) val)->obj);
		  break;
	       }

	     switch(stype)
	       {
		case STRING_TYPE:
		  val = ((SLang_Name_Type *) val)->obj.value;
		  SLang_push_string((char *) val); break;
		case INT_TYPE: 
		  val = ((SLang_Name_Type *) val)->obj.value;
		  SLang_push_integer(*(int *) val); break;
#ifdef FLOAT_TYPE
		case FLOAT_TYPE: 
		  SLang_push_float(*(FLOAT *) ((SLang_Name_Type *) val)->obj.value);
		  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 int h = 0;
   while (*ss) h += (unsigned int) *ss++ + (h << 2);
   
   
   if (0 == (Hash = (unsigned char) h))
     {
	Hash = (unsigned char) (h >> 8);
	if (!Hash) Hash = *s;
     }
   
   return(Hash);
}

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;
     }
   ofs = SLang_Name_Table_Ofs [Hash];
   if (ofs == -1) ofs = SLang_Name_Table_Ofs [0];
   return SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, 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;
   int ofs, this_ofs;
   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)
     {
	/* 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;
	ofs = SLang_Name_Table_Ofs [Hash];
	this_ofs = (int) (entry - SLang_Name_Table);
	if (ofs == -1)		       /* unused */
	  {
	     SLang_Name_Table_Ofs [Hash] = this_ofs;
	     SLang_Name_Table_Ofs [0] = this_ofs;
	  }
     }

   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[SLANG_MAX_TOP_STACK];
   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);
}

/* Look for name ONLY in local or global slang tables */
static SLang_Name_Type *SLang_locate_slang_name (char *name)
{
   SLang_Name_Type *entry;
   int ofs;
   
   compute_hash ((unsigned char *) name);
   /* try local table first */
   entry = Lang_Local_Variable_Table;
   if (entry != NULL)
     {
	entry = SLang_locate_name_in_table(name, entry, entry, Local_Variable_Number);
     }
   if ((entry == NULL) || (*entry->name == 0))
     {
	ofs = SLang_Name_Table_Ofs [Hash];
	if (ofs == -1) ofs = SLang_Name_Table_Ofs [0];
	entry = SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, LANG_MAX_SYMBOLS);
     }
   return entry;
}

#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, int all)
{
   SLang_Name_Type *entry;
   short type;
   int ptr_type = 0;
   
   
   if (all && 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 (all) entry = SLang_locate_name(name);
	else entry = SLang_locate_slang_name (name);
	if ((entry == NULL) || (*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},
   {(char *) NULL, (int) 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);
     }
   else if (*flag && eqs(t, "EXIT_BLOCK"))
     {
	lop = Lang_Object_Ptr - 1;
	if (lop->type != LANG_BLOCK) SLang_doerror("Internal Error with exit_block!");
	else lop->type = LANG_BLOCK | (EXIT_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 = 0;
   unsigned char stype;
   long value = 0;
#ifdef FLOAT_TYPE
   FLOAT x;
#ifdef USE_DOUBLE
   long extra = 0;
#endif
#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;
#ifdef USE_DOUBLE
	extra = *(1 + (long *) &x);
#endif
     }
#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;
#ifdef USE_DOUBLE
   Lang_Object_Ptr->extra = extra;
#endif
   
   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 ((long) 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 int try_byte_compiled(register unsigned char *s)
{
   SLName_Table *nt;
   SLang_Name_Type *entry;
   register ofs;
   int n;
   
   if ((*s++ != '#') 
       || ((n = (int) (*s++ - '0')) < 0))
     {  
	SLang_doerror("Illegal name.");
	return 1;
     }
   if (n == 0)
     {
	try_directive ((char *) s, &n);	       /* note that n is a dummy now */
	return 1;
     }
   if (n == 1) 
     {
	lang_try_binary((char *) s);
	return 1;
     }
   if (n == 2)
     {
	/* global or local, try it. */
	if (Lang_Defining_Function == -1) return 0;
	return lang_exec ((char *) s, 0);
     }
   
   n -= 3;
   /* 3 digit base 26 number */
   ofs = (*s++ - 'A');
   ofs = 26 * ofs + (*s++ - 'A');
   ofs = 26 * ofs + (*s++ - 'A');
   
   nt = SLName_Table_Root;
   while (n--) 
     {
	nt = nt->next;	       /* find the correct table */
	if (nt == NULL)
	  {
	     SLang_doerror("Illegal name.");
	     return 1;
	  }
     }
   
   entry = &(nt->table[ofs]);
   
   /* table = Lang_Local_Variable_Table; */
   Lang_Object_Ptr->type = entry->obj.type;
   Lang_Object_Ptr->value = (long) entry;
   lang_try_now();
   return 1;
}
#endif

int SLPreprocess_Only = 0;

char *SLbyte_compile_name(char *name)
{
   static char code[36];
   SLang_Name_Type *t;
   SLName_Table *nt;
   int ofs, n;
   
   if (SLPreprocess_Only || (*name == 0)) return name;

   if (slang_eqs_name(name, Lang_Directives))
     {
	*code = '@'; code[1] = '#';  code[2] = '0';
	strcpy (code + 3, name);
	return code;
     }
   if (slang_eqs_name(name, Lang_Binaries))
     {
	*code = '@'; code[1] = '#';  code[2] = '1';
	strcpy (code + 3, name);
	return code;
     }
   
   (void) compute_hash((unsigned char *) name);

   /* see if it is in local table */
   t = Lang_Local_Variable_Table;
   if (t != NULL)
     {
	t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number);
     }
   
   if ((t == NULL) || (t->name == 0))
     {
	/* It must be global.  Check intrinsics first */
	nt = SLName_Table_Root;
	n = 3;
	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)) 
		    {
		       ofs = (int) (t - nt->table);
		       
		       *code = '@'; *(code + 1) = '#';
		       *(code + 2) = n + '0';
		       *(code + 5) = (ofs % 26) + 'A';
		       ofs = ofs / 26;
		       *(code + 4) = (ofs % 26) + 'A';
		       ofs = ofs / 26;
		       *(code + 3) = (ofs % 26) + 'A';
		       *(code + 6) = 0;
		       return code;
		    }
	       }
	     
	     nt = nt->next;
	     n++;
	  }
	
	/* Now try global */
	t = SLang_locate_slang_name (name);
	if ((t == NULL) || (*t->name == 0)) return name;
     }
	
   *code = '@';
   code [1] = '#';
   code [2] = '2';
   strcpy (code + 3, name);
   return code;
}


void SLcompile(char *t)
{
   static int flag = 0;
   int d = 0;
   char ch = *t;
   
   if (ch == 0) return;
   lang_check_space();                 /* make sure there is space for this */
   
   
   if (!SLang_Error
#ifdef SL_BYTE_COMPILING
       && (ch != '@')
#endif
       && (ch != '"'))
     {
	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 == '@') 
     {
	flag = 0; d = 0;
	if (0 == try_byte_compiled((unsigned char *) (t + 1)))
	  {
	     /* failure ONLY for slang functions/variables. */
	     t += 3;
	     ch = *t;
	  }
     }
#endif
   
   if ((ch == '@') || 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, 1));
   else 
     {
	SLang_Error = UNDEFINED_NAME;
     }
   

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






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






/* #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},
   {(char *) NULL, (int) 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;
}

void SLexpand_escaped_string (register char *s, register char *t, 
			      register char *tmax)
{
   char ch;
   
   while (t < tmax)
     {
	ch = *t++;
	if (ch == '\\')
	  {
	     t = SLexpand_escaped_char (t, &ch);
	  }
	*s++ = ch;
     }
   *s = 0;
}

   
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;  ch = '\'';
	       }
	     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;
   static init = 0;
   
   if (init == 0)
     {
	init = 1;
	for (i = 1; i < 256; i++) SLang_Name_Table_Ofs[i] = -1;
	SLang_Name_Table_Ofs[0] = 0;
     }
   
   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 *);
