/* libshoe.c
 *
 * COPYRIGHT (c) 1998 by Fredrik Noring.
 *
 * This is the entire Shoe interpreter and runtime system.
 */

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

#include "libshoe.h"

#define BALANCE(c)       ((((c) == '(')?1:0)-(((c) == ')')?1:0))
#define ERRP(x)          ((x)[0] == '#' && (x)[1] == 'E')

Byte *symbols[MAX_SYMBOLS][2];
Byte *heap_pointer, *stack_pointer, *heap, errormsg[1024];
Int online = 0, trace = 0, symbol_counter, bounded_counter;

void bootstrap(void);
void notify(Byte *symbol, Byte *args);

Int spacep(Byte c)
{
	return c == '\0' || c == ' ' || c == '\t' || c == '\n' || c == '\r';
}

Byte *panic(Byte *msg)
{
	sprintf(errormsg, "#Panic. %s", msg);
	notify("panic", errormsg);
	return msg;
}

Byte *exterr(Byte *msg, Byte *context)
{
	sprintf(errormsg, "#Exception. %s%s\n", msg,
	        context?context:"#no-context?");
	notify("error", errormsg);
	return ERR;
}

void check_symbol_space(void)
{
	if(symbol_counter >= MAX_SYMBOLS)
		panic("Symbol table full.");
}

Byte* call_bif(Byte *address, Byte *args)
{
	if(!address)
		return 0;
	if(address[0] != '#' || !DIGITP(address[1]))
		return exterr("Cannot call: ", address);
#pragma warn -pro
	return (*((Byte*(*)())atol(address+1)))(args);
#pragma warn .pro
}

Byte* fetch_symbol(Byte *symbol)
{
	Int i;
  
	for(i = bounded_counter; i--; )
		if(MATCH(symbol, symbols[i][0])) {
			if(trace)
				printf("#-> value: [%s = %s]\n", symbol, symbols[i][1]);
			return symbols[i][1];
		}
	return 0;
}

Byte *mem(Int amount)
{
	if(heap_pointer+amount > stack_pointer)
		panic("Out of memory.");
	return (heap_pointer += amount) - amount;
}

Byte *memdup(Byte *s)
{
	return strcpy(mem(strlen(s)+1), s);
}

Byte *push_stack(Byte *s)
{
	return strcpy(stack_pointer -= strlen(s)+1, s);
}

Byte *pop_n_elems(Int n)
{
	Byte *old;
	
	old = stack_pointer;
	while(n--)
		stack_pointer += strlen(stack_pointer)+1;
	return old;
}

void notify(Byte *symbol, Byte *args)
{
	call_bif(fetch_symbol(symbol), args);
}

Byte *gc(void)
{
	Byte *chunk, *minimum;
	Int s_j = 0, s_k = 0, i, j, k;

	notify("notify-gc", "#t");
	minimum = heap;
	for(i = 0; i < 2*symbol_counter; i++) {
		chunk = heap+HEAP_SIZE;
		for(j = 0; j < symbol_counter; j++)
			for(k = 0; k < 2; k++)
		if(symbols[j][k] <= chunk && minimum <= symbols[j][k])
			chunk = symbols[s_j=j][s_k=k];
		symbols[s_j][s_k] = minimum;
		while(*chunk)
			*minimum++ = *chunk++;
		*minimum++ = '\0';
	}
	heap_pointer = minimum;
	notify("notify-gc", "#f");
	return T;
}

Byte *trim(Byte *s)
{
	while(spacep(*s))
		s++;
	return s;
}

Byte *suf(Byte *a, Byte *b)
{
	Byte *s;
  
	sprintf(s = mem(strlen(a)+strlen(b)+1), "%s%s", a, b);
	return s;
}

Int statement_size(Byte* s)
{
	Byte *source;
	Int nbalance = 0;
  
	source = s = trim(s);
	while(nbalance | 
			!((spacep(*s) | (*s == ')')) || (*s == '(' && s-source))) {
		nbalance += BALANCE(*s);
		s++;
	}
	return s-source;
}

Byte *car(Byte* s)
{
	Int size;
  
	if(!LISTP(s)) return exterr("Cannot car: ", s);
	if(NILP(s)) return s;
	size = statement_size(++s);
	s = strncpy(mem(size+1), s, size);
	s[size] = '\0';
	return s;
}

Byte *cdr(Byte *s)
{
	if(!LISTP(s)) return exterr("Cannot cdr: ", s);
	s = trim(s+statement_size(++s));
	s = strcpy(mem(strlen(s)+2)+1, s)-1;
	s[0] = '(';
	return s;
}

Byte *bind_symbol(Byte *symbol, Byte *value)
{
	Int old_definition, ok = 0;

	for(old_definition = bounded_counter; old_definition--; )
		if(MATCH(symbol, symbols[old_definition][0])) {
			ok = 1;
			break;
		}

	if(!ok) {
		check_symbol_space();
		bounded_counter++;
	}
	symbols[ok?old_definition:symbol_counter][1] = value;
	return symbols[ok?old_definition:symbol_counter++][0] = symbol;
}

Byte *bif_cons(Byte *s)
{
	DUAL_EVAL(s, (NILP(b)?sprintf(s = mem(strlen(a)+3), "(%s)", a):
		LISTP(b)?sprintf(s = mem(strlen(a)+strlen(b)+3), "(%s %s", a, b+1):
		sprintf(s = mem(strlen(a)+strlen(b)+4), "(%s %s)", a, b)));
}

Byte *bif_lambda(Byte *s)
{
	return suf("#lambda ", s);
}

Byte *bif_macro(Byte *s)
{
	return suf("#macro ", s);
}

Byte *bif_car(Byte *s)
{
	return car(EVAL(s));
}

Byte *bif_cdr(Byte *s)
{
	return cdr(EVAL(s));
}

Byte *bif_if(Byte *s)
{
	s = EVALARG(FP(EVAL(s = push_stack(s)))?cdr(s):s);
	pop_n_elems(1);
	return s;
}

Byte *bif_equal(Byte *s)
{
	DUAL_EVAL(s, s = MATCH(a, b)?T:F);
}

Byte *bif_function(Byte* s)
{
	return EVAL(s);
}

Byte *bif_eval(Byte* s)
{
	return eval(EVAL(s));
}

Byte *bif_trace(Byte *s)
{
	return ((trace=TP(EVAL(s)))!=0)?T:F;
}

Byte *bif_define(Byte *s)
{
	return (bind_symbol(car(s), NILP(cdr(cdr(s)))?
				eval(car(cdr(s))):suf("#lambda ", cdr(s))));
}

Byte *bif_memory(Byte *s)
{
	sprintf(s = mem(128), "((heap %lu) (stack %lu) (available %lu) (total %lu))",
		(unsigned long) (heap_pointer-heap),
		(unsigned long) (heap+HEAP_SIZE-stack_pointer),
		(unsigned long) (stack_pointer-heap_pointer),
		(unsigned long) (HEAP_SIZE));
	return s;
}

Byte *eval(Byte *s)
{
	Byte macro, *args, *vars, *body;
	Int rest = 0, old_symbol_counter, old_bounded_counter;

	if(!s) exit(0);
	if(!online) bootstrap();
	if(trace) printf("#eval: [%s]\n", s);
	s = trim(s);
	if(strlen(s) == 0 || s[0] == '#' || DIGITP(*s) || NILP(s))
		return s;
	if((body = fetch_symbol(s)) != 0)
		return body;

	s = push_stack(s);
	if(stack_pointer-heap_pointer < GC_MINIMUM)
		gc();
	body = push_stack(EVAL(s));
	args = push_stack(cdr(s));
	if(body[0] == '#' && (body[1] == 'l' || body[1] == 'm')) {
		macro = body[1]=='m';
		body += (macro?7:8);
		old_symbol_counter = symbol_counter;
		old_bounded_counter = bounded_counter;
		vars = push_stack(car(body));
		while(!ERRP(vars) && !ERRP(args) && 
				(!NILP(args) || !NILP(vars))) {
			s = memdup(macro?car(args):EVAL(args));
			if(rest) {
				Byte *t;
				t = symbols[rest][1];
				t[strlen(t)-1] = '\0';
				symbols[rest][1] = suf(suf(suf(t, " "), s), ")");
			} else {
				if(MATCH(car(vars), "#rest")) {
					s = NILP(args)?memdup("()"):suf(suf("(", s), ")");
					vars = cdr(vars);
					rest = symbol_counter;
				}
				check_symbol_space();
				symbols[symbol_counter][1] = s;
				symbols[symbol_counter++][0] = memdup(car(vars));
			}
			vars = cdr(vars);
			args = cdr(args);
			pop_n_elems(2);
			vars = push_stack(vars);
			args = push_stack(args);
		}
		bounded_counter = symbol_counter;
		s = EVALARG(body);
		pop_n_elems(4);
		symbol_counter = old_symbol_counter;
		bounded_counter = old_bounded_counter;
		return macro?eval(s):s;
	}
	s = ERRP(body)?memdup(body):call_bif(body, args);
	pop_n_elems(3);
	return s;
}

void bif(Byte *symbol, void *f)
{
	if(!online) bootstrap();
  
	bounded_counter++;
	check_symbol_space();
	sprintf(symbols[symbol_counter][0] = mem(strlen(symbol)+1), "%s", symbol);
	sprintf(symbols[symbol_counter++][1] = mem(17), "#%lu", (unsigned long) f);
}

Byte *decode_string(Byte *s)
{
	Byte *o, *d;

	if(!s)
		return 0;
	o = d = s = memdup(s);
	while(*s)
		if(*s == '%') {
			switch(*++s) {
				case '_':
					*d++ = ' ';
					break;
				case '[':
					*d++ = '(';
					break;
				case ']':
					*d++ = ')';
					break;
				default:
					*d++ = *s;
					break;
			}
			s++;
		} else
			*d++ = *s++;
	*d = '\0';
	return o;
}

Byte *bif_string(Byte *s)
{
	return decode_string(car(s));
}

static Int nbalance = 0;
Int inquire_balance(void)
{
	return nbalance;
}

#define PARSE_RESET() { state = 0; nbalance = 0; src = src_start = 0; }

Byte *parse_eval(Byte *input)
{
	static int state = 0;
	static Byte *src_stack = 0, last = '\0';
	Byte *src = 0, *src_start = 0, *result = 0, *eos;

	if(!online) bootstrap();
	
	if(src_stack) {
		src = src_start = memdup(src_stack);
		src += strlen(src);
		pop_n_elems(1);
		src_stack = 0;
	}

	if(MATCH(input, ".")) { /* Interrupt current input. */
		PARSE_RESET();
		return 0;
	}
	
	eos = input+strlen(input);
	while(input <= eos) {
		if(!src)
			src = src_start = mem(1);
	
		switch(state) {
		case 0:   /* Read whitespace. */
			if(*input == ';')
				state = 3;
			else if(*input == '{')
				state = 4;
			else if(spacep(*input))
				input++;
			else
				state = 1;
			break;
		case 1:   /* Read non whitespace characters. */
			if((spacep(*input) || *input == ';' || *input == '{') &&
			   nbalance == 0) {
				state = 2;
			} else if(*input == '"') {
/*
				mem(7);
				*src++ = '('; *src++ = 'q'; *src++ = 'u'; *src++ = 'o';
				*src++ = 't'; *src++ = 'e'; *src++ = ' ';
*/
				mem(8);
				*src++ = '('; *src++ = 's'; *src++ = 't'; *src++ = 'r';
				*src++ = 'i'; *src++ = 'n'; *src++ = 'g'; *src++ = ' ';
				state = 5;
				input++;
			} else {
				if(spacep(*input) || *input == ';' || *input == '{') {
					state = 0;
					if(last == '(')
						break;
				}
				if(*input == ')' && spacep(last))
					src--;
				nbalance += BALANCE(*input);
				last = *input;
				*src++ = spacep(*input)?' ':*input++;
				mem(1);
			}
			break;
		case 2:   /* Evaluate. */
			*src = '\0';
			result = eval(src_start);
			PARSE_RESET();
			break;
		case 3:   /* Skip ; comments. */
			if(*input == '\n' || *input == '\r' || *input == '\0')
				state = 0;
			input++;
			break;
		case 4:   /* Skip { } comments. */
			if(*input == '}')
				state = 0;
			input++;
			break;
		case 5:   /* Read string. */
			if(*input == '"') {
				*src++ = ')';
				mem(1);
				state = 1;
			} else {
				if(spacep(*input)) {
					*src++ = '%';
					*src++ = '_';
					mem(1);
				} else if(*input == '%') {
					*src++ = '%';
					*src++ = '%';
					mem(1);
				} else if(*input == '(') {
					*src++ = '%';
					*src++ = '[';
					mem(1);
				} else if(*input == ')') {
					*src++ = '%';
					*src++ = ']';
					mem(1);
				} else
					*src++ = *input;
				mem(1);
			}
			last = *input++;
		}
	}

	if(nbalance < 0) {
		PARSE_RESET();
		return "mismatched )";
	}

	if(src) {
		*src = '\0';
		src_stack = push_stack(src_start);
	}
	return result;
/*	return decode_string(result); */
}

/*
 * Built-in functions, outside the Shoe kernel itself.
 */

#define NUMERICAL(op, ix, fu)                           \
	Byte* fu(Byte* args)                                 \
	{                                                    \
	Int x = ix;                                          \
	Byte *tail, *result;                                 \
	                                                     \
	if(!NILP(args)) {                                    \
		tail = push_stack(cdr(args));                     \
			x = atol(EVAL(args));                          \
		op;                                               \
		pop_n_elems(1);                                   \
	}                                                    \
	return sprintf(result = mem(16), "%ld", x), result;  \
	}

NUMERICAL(x = x + atol(bif_plus(tail)),                  0, bif_plus);
NUMERICAL(x = NILP(tail)?-x:x - atol(bif_plus(tail)),    0, bif_minus);
NUMERICAL(x = x * atol(bif_multiply(tail)),              1, bif_multiply);
NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)
            return memdup("#DIV."); x = x / tx; },       1, bif_divide);
NUMERICAL({ Int tx; if(NILP(tail) || (tx=atol(bif_multiply(tail))) == 0)
            return memdup("#MOD."); x = x % tx; },       0, bif_modulo);

Int numberp(Byte *s)
{
	while(*s)
		if(DIGITP(*s))
			s++;
		else
			return 0;
	return 1;
}

Byte *bif_numberp(Byte* s)
{
	return numberp(EVAL(s))?T:F;
}

Byte *bif_listp(Byte* s)
{
	return LISTP(EVAL(s))?T:F;
}

Int less_thanp(Byte *a, Byte *b)
{
	return numberp(a)&&numberp(b)?atol(a)<atol(b):strcmp(a,b)<0;
}

Byte *bif_less_than(Byte *s)
{
	DUAL_EVAL(s, s=less_thanp(a,b)?T:F);
}

Byte *bif_symbol_to_string(Byte *args)
{
	Byte *result, buf[4];
	
	if(NILP(args))
		return memdup("()");
	args = decode_string(EVAL(args));
	result = mem(2);
	result[0] = '(';
	result[1] = '\0';
	while(*args) {
		sprintf(buf, "%d ", (int) *args++);
		mem(strlen(buf));
		strcat(result, buf);
	}
	result[strlen(result)-1] = ')';
	return result;
}

/*
 * Optimizations. These functions are already easily expressable in Shoe.
 * However, they are too damn slow too. Therefore their equivalents are
 * available here, written in C.
 */

Byte *bif_sort(Byte *args)
{
	Int length, nargs, i, j;
	Byte *result, *s, *r, *selected, *current;

	args = EVAL(args);
	length = strlen(args);
	args[length-1] = '\0';
	args++;
	result = mem(length+1);
	
	nargs = NILP(args)?0:1;
	for(s = args; *s; s++)
		if(*s == ' ') {
			*s = '\0';
			nargs++;
		}

	r = result;
	*r++ = '(';
	for(i = 0; i < nargs; i++) {
		selected = current = args;
		for(j = 0; j < nargs; j++) {
			if((*selected == ' ' || less_thanp(current, selected)) &&
			    *current != ' ')
				selected = current;
			current += strlen(current)+1;
		}
		s = selected;
		while(*s)
			*r++ = *s++;
		*selected = ' ';
		if(i != nargs-1)
			*r++ = ' ';
	}
	*r++ = ')';
	*r++ = '\0';
	return result;
}

Byte *bif_append(Byte *args)
{
	Byte *arg, *result;
	Int nargs = 0, length, total_length = 0;

	args = push_stack(args);
	while(LISTP(args) && !NILP(args)) {
		arg = EVAL(args);
		args = cdr(args);
		pop_n_elems(1);
		if(!NILP(arg)) {
			push_stack(arg);
			length = strlen(arg);
			total_length += length;
			nargs++;
		}
		args = push_stack(args);
	}
	pop_n_elems(1);
	
	result = mem(total_length+3)+total_length;
	*result-- = '\0';
	*result = ')';
	while(nargs--) {
		arg = pop_n_elems(1);
		length = strlen(arg)-2;
		result -= length;
		strncpy(result, arg+1, length);
		if(nargs > 0)
			*--result = ' ';
	}
	*--result = '(';
	return result;
}

/*
 * Bootstrap for initializing the Shoe kernel.
 */

void bootstrap(void)
{
	heap = malloc(HEAP_SIZE);
	if(!heap) {
		fprintf(stderr, "No memory for heap!\n");
		exit(1);
	}

	online = 1;
	heap_pointer = heap;
	stack_pointer = heap+HEAP_SIZE;
	symbol_counter = bounded_counter = 0;
  
	/* Kernel functions. */
	bif("eval",     bif_eval);
	bif("function", bif_function);
	bif("quote",    car);
	bif("string",   bif_string);
	bif("lambda",   bif_lambda);
	bif("macro",    bif_macro);
	bif("define",   bif_define);
	bif("if",       bif_if);
	bif("equal",    bif_equal);
	bif("car",      bif_car);
	bif("cdr",      bif_cdr);
	bif("cons",     bif_cons);
	bif("memory",   bif_memory);
	bif("trace",    bif_trace);
	bif("gc",       gc);
	
	/* General functions. */
	bif("<",        bif_less_than);
	 
	/* Numerical functions. */
	bif("+",        bif_plus);
	bif("-",        bif_minus);
	bif("*",        bif_multiply);
	bif("/",        bif_divide);
	bif("%",        bif_modulo);
	  
	/* Predicates. */
	bif("number?",  bif_numberp);
	bif("list?",    bif_listp);
	 
	/* Optimizations. */
	bif("append",    bif_append);
	bif("sort",      bif_sort);
	  
	/* Strings. */
	bif("symbol-to-string", bif_symbol_to_string);
}