/* infix to RPN parsing as well as file loading routines */
/*
   Copyright (C) 1993 John E. Davis (davis@amy.tch.harvard.edu)
   All rights reserved.

   This file is part of S-Lang.

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

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

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

#define NAME 256
#define ASSIGN 257
#define LEFT_P 258
#define RIGHT_P 259
#define END 260
#define COMMA 261
#define EOS 262
#define BRA 263
#define KET 264
#define EOS_BRA 265
#define EOS_KET 266
#define COLON 267
#define ASSIGN_M 268
#define ASSIGN_P 269

#define IF_TYPE 300
#define ELSE_TYPE 301
#define WHILE_TYPE 302
#define FOREVER_TYPE 303
#define FOR_TYPE 304
#define LOOP_TYPE 305
#define SWITCH_TYPE 306
#define F_TYPE 307
#define V_TYPE 308
#define INLINE_TOK 309
#define IF_NOT_TYPE 310
#define ERROR_B_TYPE 311
#define CFOR_TYPE 312
#define DO_WHILE 313
#define RETURN_TYPE 314

static int CTok;

static char *Token;
static char *Input;
static SLang_Load_Type *LLT;

static char Name_Stack[100][32];
static int Name_Stack_P = 0;

#define push_name() \
  if (*Token == '"') parse_error("Invalid Name", 0); else\
     strcpy(Name_Stack[Name_Stack_P++], Token)

#define pop_name()  (*SLcompile_ptr)(Name_Stack[--Name_Stack_P])

static int get_token(void);
static void expression(void);
static void term(void);
static void basic(void);
static void arguments(int);

static void pop_eqsname(int what)
{
   char work[80], *w = work;
   
   if (what == ASSIGN_M) *w++ = '-'; else if (what == ASSIGN_P) *w++ = '+';
   *w++ = '=';
   strcpy(w, Name_Stack[--Name_Stack_P]);
   (*SLcompile_ptr)(work);
}

#ifdef IF_TYPE
static void block(void);
static void directive(void);
static void block_internal(void);
static int if_fudge = 0;

void parse_error(char *str, int flag)
{
   char buf[132];
   if (str == NULL) str = Token;
   sprintf(buf, "Line %d: %s", LLT->n, str);
   if (flag && SLang_Error) *buf = 0;
   SLang_doerror(buf);
}


static void function_args(void)
{
   int n = 0;
   get_token();
   while ((CTok != END) && (CTok != RIGHT_P))
     {
	if (CTok == NAME)
	  {
	     n++;
	     push_name();
	     if (n == 1) (*SLcompile_ptr)("[");
	     (*SLcompile_ptr)(Token);
	  }
	else if (CTok != COMMA)
	  {
	     parse_error("Expecting comma.", 0);
	  }
	if (SLang_Error) return;
	get_token();
     }
   get_token();
   if (n)
     {
	(*SLcompile_ptr)("]");
	while(n--) pop_eqsname(ASSIGN);
     }
}


static void directive()
{
   int ctoks[3], t, i;
   
   switch (CTok)
     {
      case IF_TYPE: 
	get_token();
	if_fudge = 1;
	expression();
	if_fudge = 0;
	block();
	if (CTok == EOS) get_token();
	if (CTok == ELSE_TYPE)
	  {
	     directive();
	  }
	else (*SLcompile_ptr)("if");
	break;

	
      case RETURN_TYPE: 
	get_token();
	if (CTok == EOS) get_token(); else expression();
	(*SLcompile_ptr)("return");
	break;
	
      case ELSE_TYPE: 
	get_token();
	block();
	(*SLcompile_ptr)("else");
	break;

      case DO_WHILE: 
	get_token();
	block();
	if (CTok == EOS) get_token();
	if (CTok != WHILE_TYPE)
	  {
	     parse_error("Expecting while.", 0);
	     return;
	  }
	get_token();
	(*SLcompile_ptr)("{");
	expression();
	(*SLcompile_ptr)("}");
	(*SLcompile_ptr)("do_while");
	break;
	
      case WHILE_TYPE:
	get_token();
	(*SLcompile_ptr)("{");
	expression();
	(*SLcompile_ptr)("}");
	block();
	(*SLcompile_ptr)("while");
	break;
	
      case LOOP_TYPE:
      case FOR_TYPE:
      case IF_NOT_TYPE:
	push_name();
	get_token();
	expression();
	block();
	pop_name();
	break;
       
      case CFOR_TYPE: 
	push_name();
	get_token();
	if (CTok != LEFT_P) goto err;
	get_token();
	ctoks[0] = ctoks[1] = EOS, ctoks[2] = RIGHT_P;
	for (i = 0; i < 3; i++)
	  {
	     if (SLang_Error) return;
	     t = ctoks[i];
	     (*SLcompile_ptr)("{");
	     if (CTok != t) expression();
	     while (!SLang_Error && (CTok == COMMA)) 
	       {
		  get_token();
		  expression();
	       }
	     
	     if (CTok != t) goto err;
	     (*SLcompile_ptr)("}");
	     get_token();
	  }
	block();
	pop_name();
	break;
	
	
      case ERROR_B_TYPE: 
      case FOREVER_TYPE: 
	push_name();
	get_token();
	block();
	pop_name();
	break;
	
      case SWITCH_TYPE: 
	get_token();
	expression();
	while (!SLang_Error && (CTok == EOS_BRA)) block();
	(*SLcompile_ptr)("switch");
	break;
	
      case V_TYPE:		       /* variable declaration */
	get_token();
	(*SLcompile_ptr)("[");
	while (!SLang_Error && (CTok == NAME))
	  {
	     (*SLcompile_ptr)(Token);
	     get_token();
	     if (CTok == COMMA) get_token();
	     else
	       {
		  break;
	       }
	  }
	(*SLcompile_ptr)("]");
	if (CTok != EOS) parse_error("Expecting EOS.", 0);
	break;
	
      case F_TYPE:		       /* function declaration */
	get_token();
	if (CTok != NAME) 
	  {
	     parse_error("Expecting function name.", 0);
	     return;
	  }
	push_name();
	get_token();
	(*SLcompile_ptr)("(");
	if (CTok == LEFT_P) function_args();
	
	if (CTok == EOS_BRA) block_internal();
	else if (CTok != EOS)
	  {
	     parse_error("Expecting '{'", 0);
	     return;
	  }
	
	if (!SLang_Error) 
	  {
	     (*SLcompile_ptr)(")");
	     pop_name();
	  }
	break;
	
      case INLINE_TOK: 
	Input = SLang_rpn_interpret(Input + 1);
	if (!SLang_Error) 
	  {	
	     Input = NULL;
	     get_token();
	  }
	
	break;

      default: 
	expression();
     }
   return;
   err:
   parse_error("Syntax Error.", 1);
}


static void block_internal(void)
{
   if (CTok != EOS_BRA) expression();
   else 
     {
	get_token();
	while (!SLang_Error && (CTok != END) && (CTok != EOS_KET)) 
	  {
	     expression();
	     if (CTok == EOS) get_token();
	     /* if (CTok != EOS_KET)
	       {
		  SLang_Error = SYNTAX_ERROR;
		  return;
	       } */
	  }
	
	if (CTok == END) 
	  {
	     parse_error("Unexpected end of source.", 1);
	     return;
	  }
	get_token();
     }
}



static void block(void)
{
   (*SLcompile_ptr)("{");
   if (CTok != EOS) block_internal(); else get_token();
   if (!SLang_Error) (*SLcompile_ptr)("}");
}
#endif

static void expression(void)
{
   int anything_terminates = 0;
   
   /* if (CTok == END) return; */
#ifdef IF_TYPE
   if (CTok >= IF_TYPE)
     {
	directive();
	return;
     }
#endif

   if (CTok == COLON) 
     {
	(*SLcompile_ptr)(":");
	get_token();
     }
   
   if (CTok == LEFT_P) anything_terminates = 1;
   term();
   
   while (!SLang_Error)
     {
	switch (CTok)
	  {
	   case (LANG_PLUS): 
	   case (LANG_MINUS): 
	     push_name();
	     get_token();
	     term();
	     pop_name();
	     break;
	     
	   case (LANG_BOR): 
	   case (LANG_BXOR): 
	   case (LANG_OR): 
	   case (LANG_EQ): 
	   case (LANG_NE): 
	   case (LANG_GT): 
	   case (LANG_GE): 
	   case (LANG_LT): 
	   case (LANG_SHL): 
	   case (LANG_AND): 
	   case (LANG_BAND):
	   case (LANG_SHR):
	   case (LANG_LE):
	     push_name();
	     get_token();
	     expression();
	     pop_name();
	     break;

	   case EOS: case EOS_KET: case KET: case RIGHT_P:
	   case EOS_BRA: case COMMA:
	     return;
	     
	   case COLON: 
	     (*SLcompile_ptr)(":");
	     CTok = EOS;
	     return;
	     
	   case NAME: 
	     /* allow things like 'if (i == 2) i = 3;' and ':' */
	     if ((*Token == ':') && (Token[1] == 0))
	       {
		  CTok = COLON;
		  if_fudge = 1;
	       }
	     
	     if (if_fudge)
	       {
		  if_fudge = 0;
		  return;
	       }
	   default: 
	     if (anything_terminates) return;
	     parse_error("Expecting EOS", 0);
	     return;
	  }
     }
}

static void term(void)
{
   basic();
   while(!SLang_Error)
     {
	switch (CTok)
	  {
	   case (LANG_MOD): 
	   case (LANG_TIMES): 
	   case (LANG_DIVIDE): 
	     push_name();
	     get_token();
	     basic();
	     pop_name();
	     break;
	   default: return;
	  }
     }
}

static void basic(void)
{
   char *save, *save_again;
   int count, save_ctok;
   
   switch(CTok)
     {
      case NAME:
	if (*Token == '"')
	  {
	     (*SLcompile_ptr)(Token);
	     get_token();
	     break;
	  }
	
	push_name();
	get_token();
	switch(CTok)
	  {
	   case (ASSIGN_P): 
	   case (ASSIGN_M): 
	   case (ASSIGN):
	     save_ctok = CTok;
	     get_token();
	     expression();
	     pop_eqsname(save_ctok);
	     return;
	      
	   case (LEFT_P): 
	     get_token();
	     arguments(RIGHT_P);
	     break;
	
	   case BRA: 
	     /* find end of argument list */
	     save = Input;
	     count = 1;
	     while (count)
	       {
		  get_token();
		  if ((CTok == END) /* || (CTok == EOS) */
		      || (CTok == EOS_BRA) || (CTok == EOS_KET))
		    {
		       parse_error("Incomplete Statement.", 0);
		       return;
		    }
		  else if (CTok == BRA) count++;
		  else if (CTok == KET) count--;
	       }
	     
	     get_token();
	     if (CTok == ASSIGN)
	       {
		  get_token();
		  expression();
		  save_again = Input;  save_ctok = CTok;
		  Input = save;
		  get_token();
		  arguments(KET);
		  pop_name();
		  (*SLcompile_ptr)("aput");
		  Input = save_again;  CTok = save_ctok;
	       }
	     else
	       {
		  Input = save;
		  get_token();
		  arguments(KET);
		  pop_name();
		  (*SLcompile_ptr)("aget");
	       }
	     return;
	  }
	pop_name();		       /* this push at 'case NAME:' */
	break;
	
      case LANG_MINUS: 
	get_token();
	basic();
	(*SLcompile_ptr)("chs");
	break;
      case LEFT_P:
	
	while (!SLang_Error && (CTok != END) && (CTok != RIGHT_P))
	  {
	     get_token();
	     if (CTok != RIGHT_P) expression();
	  }
	if (!SLang_Error && (CTok != RIGHT_P)) SLang_doerror("Unbalanced parenthesis!");
	get_token();
	break;
	
      default: 
/*      case BRA:
	case
      case END:
      case EOS_BRA: 
      case EOS_KET: 
      case EOS: */
	parse_error("Syntax Error.", 0);
     }
}


static void arguments(int match)
{
   while (!SLang_Error)
     {
	if (CTok == match)
	  {
	     get_token();
	     return;
	  }
	else if (CTok == COMMA) get_token();  /* was EOS */
	else if ((CTok == END) || /* (CTok == EOS) || */
		 (CTok == EOS_BRA) || (CTok == EOS_KET))
	  {
	     parse_error("Incomplete list", 0);
	  }
	else expression();
     }
}

static char *(*Get_Token_Read_Fun)(SLang_Load_Type *);

/* interprets line-- returns offset of last part of line evaluated */
char *SLang_rpn_interpret(char *line)
{
   char token[256];
   char *ret;
   
   while(ret = line, extract_token(&line,token))
     {
	if (SLang_Error) break;
	if (*token == '%') break;
	(*SLcompile_ptr)(token);
	if (SLang_Error) break;
	/* puts(token); */
     }
   /* if (SLang_Error) SLang_doerror(NULL); */
   return(ret);
}


int slang_line_ok(char *buf, int *skip)
{
#ifdef pc_system
   char *sys = "IBMPC";
   char *sys1 = "NOT_UNIX";
   char *sys2 = "NOT_VMS";
#else
#ifdef VMS
   char *sys = "VMS";
   char *sys1 = "NOT_UNIX";
   char *sys2 = "NOT_IBMPC";
#endif
#ifdef unix
   char *sys = "UNIX";
   char *sys1 = "NOT_VMS";
   char *sys2 = "NOT_IBMPC";
#endif
#endif
   if (buf == NULL) return (1);
   if (*buf == '\n') return (0);
   if (*buf == '%') return (0);     /* since '%' is a comment */
	
   if (*buf == '#')
     {
	if (!strncmp(buf + 1, sys, 3) 
	    || !strncmp(buf + 1, sys1, 7)
	    || !strncmp(buf + 1, sys2, 7)
	    || !strncmp(buf + 1, "end", 3)) *skip = 0;
	else *skip = 1;
	return(0);
     }
   if (*skip) return(0);
   return(1);
}

#define STREQS(a,b) (*(a) == *(b)) && !strcmp(a,b)

static int get_token(void)
{
   int type;
   int skip = 0;
      
   if (SLang_Error) return (CTok = END);
   while ((Input == NULL) || (0 == extract_token(&Input, Token)) || (*Token == '%'))
     {
	do
	  {
	     LLT->n++;
	     if ((NULL == (Input = (*Get_Token_Read_Fun)(LLT))) 
		 || SLang_Error) return(CTok = END);
	     
	  }
	while (!slang_line_ok(Input, &skip));
	/* lines beginning with a '.' are RPN */
	if (*Input == '.') return(CTok = INLINE_TOK);
     }
   
   if (0 == Token[1])
     {
	switch (*Token)
	  {
	     case '(':  return(CTok = LEFT_P);
	     case ')':  return(CTok = RIGHT_P);
	     case ',':  return(CTok = COMMA);
	   case ';':    return(CTok = EOS);
	     case '=':  return(CTok = ASSIGN);
	     case '[':  return(CTok = BRA);
	     case ']':  return(CTok = KET);
	     case '{':  return(CTok = EOS_BRA);
	     case '}':  return(CTok = EOS_KET);
	  }
     }
   
   if (*Token == '"') return (CTok = NAME);
   else if (0 != (type = slang_eqs_name(Token, Lang_Binaries)))
     {
	return (CTok = abs(type));
     }

   if (STREQS("!if", Token)) return (CTok = IF_NOT_TYPE);
   if (STREQS("if", Token)) return (CTok = IF_TYPE);
   if (STREQS("else", Token)) return (CTok = ELSE_TYPE);
   if (STREQS("forever", Token)) return (CTok = FOREVER_TYPE);
   if (STREQS("while", Token)) return (CTok = WHILE_TYPE);
   if (STREQS("variable", Token)) return (CTok = V_TYPE);
   if (STREQS("define", Token)) return (CTok = F_TYPE);
   if (STREQS("for", Token)) return (CTok = CFOR_TYPE);
   if (STREQS("loop", Token)) return (CTok = LOOP_TYPE);
   if (STREQS("switch", Token)) return (CTok = SWITCH_TYPE);
   if (STREQS("return", Token)) return (CTok = RETURN_TYPE);
   if (STREQS("+=", Token)) return (CTok = ASSIGN_P);
   if (STREQS("-=", Token)) return (CTok = ASSIGN_M);
   if (STREQS("_for", Token)) return (CTok = FOR_TYPE);
   if (STREQS("do", Token)) return (CTok = DO_WHILE);
   if (STREQS("ERROR_BLOCK", Token)) return(CTok = ERROR_B_TYPE);
   if (*Token == '@')
     {
	parse_error("Illegal Name.", 1);
	return (CTok == END);
     }
   
   return (CTok = NAME);
}

/* Since these routines must be re-entrant, the context is saved and 
   later restored. */


void SLang_eval_object(SLang_Load_Type *x)
{
   char *(*last_read_fun)(SLang_Load_Type *) = Get_Token_Read_Fun;
   char *last_token = Token, *last_input = Input;
   SLang_Load_Type *last_llt = LLT;
   int last_ctok = CTok;
   
   x->n = 0;
   Get_Token_Read_Fun = x->read;
   Token = x->token;
   LLT = x;
   
   Input = NULL;
   
   /* Name_Stack_P = 0; */  /* This should be put in restart_slang */
   
   get_token();
   while (!SLang_Error && (CTok != END))
     {
	if (CTok == EOS) get_token();
	else if (CTok != END) directive();
     }
   /*   if (SLang_Error) parse_error(NULL, 0); */
   
   x->ptr = Input;
   
   Get_Token_Read_Fun = last_read_fun;
   Token = last_token;
   CTok = last_ctok;
   LLT = last_llt;
   Input = last_input;
}




int (*user_open_slang_object)(SLang_Load_Type *);
int (*user_close_slang_object)(SLang_Load_Type *);
char *SLang_User_Prompt;

char *slang_read_from_file (SLang_Load_Type *x)
{
   if ((x->handle == (LONG) stdin) && (SLang_User_Prompt != NULL))
     {
	fputs(SLang_User_Prompt, stdout);
	fflush(stdout);
     }
   
   return fgets((char *) x->buf, 511, (FILE *) x->handle);
}

char *slang_read_from_string (SLang_Load_Type *x)
{
   char *s, ch, *s1;
   
   if (x->handle == -1) return (NULL);
   else if (x->handle == 0)
     {
	x->handle = -1;
	return ";";
     }
   
   s1 = s = x->buf;
   while ((ch = *s++) != 0) if (ch == '\n') break;
   x->handle--;
   x->buf = s;
   return (s1);
}


int slang_close_object(SLang_Load_Type *x)
{
   int status;
   if ((user_close_slang_object != NULL)
       && ((status = (*user_close_slang_object)(x)) != SL_OBJ_UNKNOWN))
     {
	return(status);
     }
   
   switch (x->type)
     {
      case 'C':  /* File */
      case 'F':  /* File */
	
	if (x->handle != (LONG) stdin) fclose((FILE *) x->handle);
	FREE(x->buf);
	return (0);
	
      case 'S':  /* string */
	return (0);
	
      default: return SL_OBJ_UNKNOWN;
     }
}


/* returns 0 if successful */
int slang_open_object(SLang_Load_Type *x)
{
   int status, n;
   char *s, ch;

   if (user_open_slang_object != NULL)
     {
	status = (*user_open_slang_object)(x);
	if ((status == 0) || (status == SL_OBJ_NOPEN)) return(status);
	
	/* pass control to default */
     }
   
   switch (x->type)
     {
      case 'C': 
      case 'F':  /* File */
	
	x->read = slang_read_from_file;
	if ((x->name == 0) || (*(char *)(x->name) == 0))
	  {
	     x->name = (LONG) "<stdin>";
	     x->handle = (LONG) stdin;
	  }
	else if (0 == (x->handle = (LONG) fopen((char *) x->name, "r")))
	  {
	     return (SL_OBJ_NOPEN);
	  }
	
	if (NULL == (x->buf = (char *) MALLOC(512)))
	  {
	     SLang_Error = SL_MALLOC_ERROR;
	     if (x->handle != (LONG) stdin) fclose((FILE *) x->handle);
	     return(SL_OBJ_NOPEN);
	  }
	
	return (0);
	
      case 'S':  /* string */
	
	x->read = slang_read_from_string;
	s = (char *) x->name;
	x->buf = s;
	
	/* handle represents the number of lines in the string. */
	n = 1; while ((ch = *s++) != 0) if (ch == '\n') n++;
	x->handle = n;
	
	return (0);
	
      default: return SL_OBJ_UNKNOWN;
     }
}


int SLang_load_object(SLang_Load_Type *x)
{
   int status;
   
   status = slang_open_object(x);
   if (status != 0) return (status);
   SLang_eval_object(x);
   slang_close_object(x);
   if (SLang_Error) Name_Stack_P = 0;
   return SLang_Error;
}

   

   
/* Note that file could be freed from Slang during run of this routine
   so get it and store it !! (e.g., autoloading) */
      
int SLang_load_file(char *f)
{
   SLang_Load_Type x;
   char buf[300];
   char file[256]; 
   
   if (f != NULL) strcpy(file, f); else *file = 0;
   
   x.name = (LONG) file;
   x.type = 'F';
   if (SL_OBJ_NOPEN == SLang_load_object(&x))
     {
	sprintf(buf, "Error opening %s.", file);
	SLang_doerror(buf);
     }
   else if (SLang_Error) 
     {
	sprintf(buf, "S-Lang Error: line %d: file: %s", x.n, (char *) x.name);
	SLang_doerror(buf);
	return(0);
     }
   return(1);
}

char *SLang_load_string(char *string)
{
   SLang_Load_Type x;
   
   x.name = (LONG) string;
   x.type = 'S';
   SLang_load_object(&x);
   if (SLang_Error) 
     {
	SLang_doerror(NULL);
     } 
   return(x.ptr);
}
   

static FILE *byte_compile_fp;
static int Slang_Line_Len;
static int defining_variables;

void SLang_byte_compile(char *s)
{
   int n = Slang_Line_Len;
   int dn;
   
   if (SLang_Error) return;
   
   if (!defining_variables) s = SLbyte_compile_name(s);
   if (*s == '[') defining_variables = 1;
   else if (*s == ']') defining_variables = 0;
   
   dn = strlen(s) + 1;
   n += dn;
   if (n > 250)
     {
	fputs("\n.", byte_compile_fp);
	n = dn;
     }
   fputs(s, byte_compile_fp);
   putc(' ', byte_compile_fp);
   Slang_Line_Len = n;
}

void SLang_byte_compile_file(char *f)
{
   char file[256];
   SLang_Load_Type x;
   int status;
   char buf[290];
   
   sprintf(file, "%sc", f);
   if ((byte_compile_fp = fopen(file, "w")) == NULL)
     {
	SLang_doerror(file);
	SLang_doerror("Error opening .slc file for byte compiling");
	return;
     }
   
   x.name = (LONG) f;
   x.type = 'C';

   Slang_Line_Len = 1;
   putc('.', byte_compile_fp);
   SLcompile_ptr = SLang_byte_compile;
   status = SLang_load_object(&x);
   SLcompile_ptr = SLcompile;
      
   putc('\n', byte_compile_fp);
   fclose(byte_compile_fp);

   if (SL_OBJ_NOPEN == status)
     {
	sprintf(buf, "Error opening %s for byte compiling.", f);
	SLang_doerror(buf);
     }
   else if (SLang_Error) 
     {
	sprintf(buf, "S-Lang Error: line %d: file: %s", x.n, (char *) x.name);
	SLang_doerror(buf);
     }
}


