/**********************************************************************
 
	Copyright (C) 2003 Hirohisa MORI <joshua@nichibun.ac.jp>
 
	This program is free software; you can redistribute it 
	and/or modify it under the terms of the GLOBALBASE 
	Library General Public License (G-LGPL) as published by 

	http://www.globalbase.org/
 
	This program is distributed in the hope that it will be 
	useful, but WITHOUT ANY WARRANTY; without even the 
	implied warranty of MERCHANTABILITY or FITNESS FOR A 
	PARTICULAR PURPOSE.

**********************************************************************/


#include	"task.h"
#include	"memory_debug.h"
#include	"memory_routine.h"
#include	"xl.h"
#include	"xlerror.h"
#include	"mlong_char.h"

void gc_gb_sym_field();
void gc_gb_sexp();
extern SEM gb_env_lock;


ELEMENT *
search_env(XLISP_ENV * env,L_CHAR * sym)
{
ELEMENT * e;
unsigned int key;

int t;


	if ( env->type != GBET_ENV )
		er_panic("search_env(1)");
	key = hash_key(sym);
	for ( e = env->e.hash[key] ; e ; e = e->next )
		if ( l_strcmp(e->sym,sym) == 0 ) {
			return e;
		}
	return 0;
}

int
_eval_symbol(XL_SEXP ** ret,XLISP_ENV * env,L_CHAR * sym)
{
ELEMENT * e;
int er;

	e = 0;
	for ( ; env ; ) {
		switch ( env->type ) {
		case GBET_ENV:
			lock_task(gb_env_lock);
			if ( (e = search_env(env,sym)) ) {
				*ret = e->data;
				unlock_task(gb_env_lock,"_eval_symbol");
				return 0;
			}
			unlock_task(gb_env_lock,"_eval_symbol");
			env = env->e.parent;
			break;
		case GBET_PAIR:
			er = _eval_symbol(ret,env->p.env[0],sym);
			if ( er == 0 )
				return 0;
			env = env->p.env[1];
			break;
		default:
			er_panic("eval_symbol(1)");
		}
	}
	return -1;
}

XL_SEXP *
get_env_symbol(XLISP_ENV * env,L_CHAR * name)
{
int er;
XL_SEXP * ret;

	er = _eval_symbol(&ret,env,name);
	if ( er < 0 )
		return 0;
	return ret;
}

XL_SEXP *
eval_symbol(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;

	if ( _eval_symbol(&ret,env,s->symbol.data) < 0 ) {
		return get_error(
			s->h.file,
			s->h.line,
			XLE_SEMANTICS_UNDEF_SYMBOL,
			l_string(std_cm,"eval(symbol)"),
			List(	n_get_string("eval:undefined symbol"),
				get_integer(s->h.type,0),
				s,
				-1));
	}
	return ret;
}


int
_eval_default_symbol(XL_SEXP ** ret,XLISP_ENV * env)
{
ELEMENT * e;
int er;
	e = 0;
	for ( ; env ; ) {
		switch ( env->type ) {
		case GBET_ENV:
			if ( env->e.default_sym ) {
				*ret = env->e.default_sym->data;
				return 0;
			}
			env = env->e.parent;
			break;
		case GBET_PAIR:
			er = _eval_default_symbol(ret,env->p.env[0]);
			if ( er == 0 )
				return 0;
			env = env->p.env[1];
			break;
		default:
			er_panic("eval_default_symbol(1)");
		}
	}
	return -1;
}

XL_SEXP *
get_sym_field(XL_SYM_FIELD ** sfp,XLISP_ENV * env,XL_SEXP * s)
{
XL_SYM_FIELD * sf,* sf1;
XL_SEXP * a, *data;
char * buf;
	*sfp = 0;
	for ( sf = s->symbol.field ; sf ; sf = sf->next ) {
		sf1 = mmalloc(sizeof(*sf1),gc_gb_sym_field);
		sf1->name = sf->name;
		if ( sf->data[0] == '^' ) {
			if ( sf->data[1] == '^' ) {
				sf1->data = ll_copy_mstr(&sf->data[1]);
			}
			else {
				if ( _eval_symbol(&data,env,
						&sf->data[1]) < 0 ) {
					return get_error(
						s->h.file,
						s->h.line,
						XLE_SEMANTICS_UNDEF_SYMBOL,
						l_string(std_cm,
						 "eval(attribute symbol)"),
						List(	n_get_string(
						   "eval:undefined symbol"),
							s,
							-1));
				}
				switch ( get_type(data) ) {
				case XLT_ERROR:
					return data;
				case XLT_STRING:
					sf1->data = data->string.data;
					break;
				case XLT_INTEGER:
					buf = d_alloc(20,141);
					if ( data->integer.unit )
						sprintf(buf,"%i%s",
							data->integer.data,
							n_string(std_cm,
							  data->integer.unit));
					else	sprintf(buf,"%i",
							data->integer.data);
					sf1->data = nl_copy_mstr(std_cm,buf);
					d_f_ree(buf);
					break;
				case XLT_FLOAT:
					buf = d_alloc(200,141);
					if ( data->floating.unit )
						sprintf(buf,"%lf%s",
							data->floating.data,
							n_string(std_cm,
							 data->floating.unit));
					else	sprintf(buf,"%lf",
							data->floating.data);
					sf1->data = nl_copy_mstr(std_cm,buf);
					d_f_ree(buf);
					break;
				default:
					return get_error(
						s->h.file,
						s->h.line,
						XLE_SEMANTICS_TYPE_MISSMATCH,
						l_string(std_cm,
						 "eval(attribute symbol)"),
						List(	n_get_string(
						   "eval:undefined symbol"),
							s,
							-1));
				}
			}
		}
		else	sf1->data = sf->data;
		sf1->next = 0;
		*sfp = sf1;
		sfp = &sf1->next;
	}
	return 0;
}


XL_SEXP *
eval_pair(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ee, * ret;
int len,len2;
XLISP_ENV * nenv;
XL_SEXP * a,* b,* c, * d;
XL_SYM_FIELD * sf, * sf1;
int f;
int tp;


	a = car(s);
	if ( get_type(a) == XLT_SYMBOL ) {
		sf1 = a->symbol.field;
		f = 0;
		for ( ; sf1 ; sf1 = sf1->next )
			if ( sf1->data[0] == '^' )
				f = 1;
		if ( f ) {
			b = get_sym_field(&sf,env,a);
			if ( get_type(b) == XLT_ERROR )
				return b;
		}
		else	sf = a->symbol.field;
	}
	else	sf = 0;

	gc_push(0,0,"eval_p1"); /* section 1 */
	ee = eval(env,a);
	gc_pop(ee,gc_gb_sexp); /* section 2 */
retry:

	if ( get_type(ee) != XLT_FUNC ) {
		if ( get_type(ee) == XLT_ENV ) {
			tp = 0;
			sf1 = sf;
			for ( ; sf ; sf = sf->next ) {
				if ( l_strcmp(sf->name,
					l_string(std_cm,"type")) == 0 ) {
					if ( l_strcmp(sf->data,
						l_string(std_cm,"raw")) == 0 )
							{
						tp = 1;
					}
				}
			}
			gc_push(0,0,"eval env 1");
			if ( tp ) {
				nenv = ee->env.data;
			}
			else {
				nenv = new_env(ee->env.data);
				set_env(nenv,l_string(std_cm,"Local"),
					get_env(env));
			}
			for ( ; sf1 ; sf1 = sf1->next )
				set_env(nenv,sf1->name,
					get_string(sf1->data));
			a = 0;
			for ( s = cdr(s) ; get_type(s) ; s = cdr(s) ) {
				if ( get_type(s) == XLT_ERROR ) {
					gc_pop(0,0);
					return s;
				}
				b = car(s);
				if ( get_type(b) == XLT_ERROR ) {
					gc_pop(s,gc_gb_sexp);
					return b;
				}
				gc_push(b,gc_gb_sexp,"eval env");
				a = eval(nenv,b);
				gc_pop(a,gc_gb_sexp);
				if ( get_type(a) == XLT_ERROR )
					break;
			}
			gc_pop(a,gc_gb_sexp);
			return a;
		}
		else if ( get_type(ee) == XLT_ERROR ) {
			if ( ee->err.code != 
					XLE_SEMANTICS_UNDEF_SYMBOL )
				return ee;
			if ( get_type(a) != XLT_SYMBOL )
				return ee;
			if ( _eval_default_symbol(&ret,env) < 0 )
				return ee;
			ee = ret;
			goto retry;
		}
		return get_error(
			car(s)->h.file,
			car(s)->h.line,
			XLE_SEMANTICS_EXEC_NO_FUNC,
			l_string(std_cm,"eval"),
			list(	n_get_string("execute no function"),
				s,
				0));
	}

	gc_push(0,0,"eval_p2");	/* section 2 */
	if ( ee->func.max != -1 || ee->func.order == FO_APPLICATIVE ) {
		len = list_length(s);
		if ( len < 0 ) {
			a = list_error(s);
			gc_pop(a,gc_gb_sexp); /* section 2 */
			return a;
		}
		if ( len < ee->func.min ||
				ee->func.max != -1 && 
				len > ee->func.max ) {

			gc_pop(0,0); /* section 2 */
			return get_error(
				s->h.file,
				s->h.line,
				XLE_SEMANTICS_INV_PARAM_LENGTH,
				l_string(std_cm,"eval"),
				list(
			n_get_string("invalid parameters length"),
					n_get_string("minimum"),
					get_integer(ee->func.min,0),
					n_get_string("maximum"),
					get_integer(ee->func.max,0),
					s,
					0));
		}
	}
	else {
	int len;
	XL_SEXP * a;
		len = 1; 
		for ( a = s ; get_type(a) == XLT_PAIR ; a = cdr(a) , len ++ ) {
			if ( len >= ee->func.min )
				goto ok;
		}
		len = list_length(s);
		if ( len < 0 ) {
			gc_pop(0,0); // section 2
			return list_error(s);
		}
		gc_pop(0,0); // section 2
		return get_error(
			s->h.file,
			s->h.line,
			XLE_SEMANTICS_INV_PARAM_LENGTH,
			l_string(std_cm,"eval"),
			list(
		n_get_string("invalid parameters length(2)"),
				n_get_string("minimum"),
				get_integer(ee->func.min,0),
				n_get_string("maximum"),
				get_integer(ee->func.max,0),
				s,
				0));
		
	ok:
		{}
	}
	if ( ee->func.order == FO_APPLICATIVE ) {
	XL_SEXP ** arg_buf;
	XL_FILE ** arg_file;
	int * arg_flags;
	int * arg_line;
	int aptr;
		if ( ee->func.args_env )
			nenv = new_env_pair(ee->func.args_env,env);
		else	nenv = env;
		arg_buf = d_alloc(sizeof(XL_SEXP*)*len,30);
		arg_file = d_alloc(sizeof(XL_FILE *)*len,31);
		arg_line = d_alloc(sizeof(int *)*len,32);
		arg_flags = d_alloc(sizeof(int *)*len,33);
		aptr = 0;

		arg_buf[aptr] = a = car(s);
		arg_file[aptr] = a->h.file;
		arg_line[aptr] = a->h.line;
		arg_flags[aptr] = a->h.flags;
		s = cdr(s);
		aptr++;
		for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
			b = eval(nenv,car(s));
			if ( get_type(b) == XLT_ERROR ) {
				gc_pop(b,gc_gb_sexp); /* section 2 */
				d_f_ree(arg_buf);
				d_f_ree(arg_file);
				d_f_ree(arg_line);
				d_f_ree(arg_flags);
				return b;
			}
			arg_buf[aptr] = b;
			arg_file[aptr] = s->h.file;
			arg_line[aptr] = s->h.line;
			arg_flags[aptr] = s->h.flags;
			aptr ++;
		}
		if ( get_type(s) == XLT_ERROR ) {
			gc_pop(s,gc_gb_sexp);
			return s;
		}
		b = 0;
		aptr --;
		for ( ; aptr >= 0 ; aptr --  ) {
			b = cons_inh_2(arg_buf[aptr],b);
			b->h.file = arg_file[aptr];
			b->h.line = arg_line[aptr];
			b->h.flags = arg_flags[aptr];
		}
		s = b;
		d_f_ree(arg_buf);
		d_f_ree(arg_line);
		d_f_ree(arg_file);
		d_f_ree(arg_flags);
	}
	if ( ee->func.type == FT_PRIM ) {

		ret = (*ee->func.prim)(env,s,ee->func.args_env,sf,
				       ee->func.sp_env);
		gc_pop(ret,gc_gb_sexp); /* section 2 */

		return ret;
	}
	else if ( ee->func.type == FT_LAMBDA ) {
		nenv = new_env(env);
		if ( ee->func.args_env )
			set_env(nenv,l_string(std_cm,"__args_env"),
				get_env(ee->func.args_env));
		else	set_env(nenv,l_string(std_cm,"__args_env"),0);
		for ( ; sf ; sf = sf->next )
			set_env(nenv,sf->name,get_string(sf->data));
		switch ( get_type(ee->func.l_params) ) {
		case XLT_NULL:
		case XLT_PAIR:
			for ( a = cdr(s), b = ee->func.l_params;
					get_type(b);
					a = cdr(a), b = cdr(b) ) {
				d = car(b);
				set_env(nenv,d->symbol.data,car(a));
			}
			break;
		default:
			set_env(nenv,ee->func.l_params->symbol.data,s);
		}
		b = 0;
		for ( a = ee->func.l_body ; get_type(a) ; a = cdr(a) ) {
			if ( get_type(a) != XLT_PAIR ) {
				ret = eval(nenv,a);

				gc_pop(ret,gc_gb_sexp); /* section 2 */
				return ret;
			}
			b = eval(nenv,car(a));
			if ( get_type(b) == XLT_ERROR ) {

				gc_pop(b,gc_gb_sexp); /* section 2 */

				return b;
			}
		}

		gc_pop(b,gc_gb_sexp); /* section 2 */

		return b;
	}
	else {

		gc_pop(0,0); /* section 2 */
		return get_error(
			s->h.file,
			s->h.line,
			XLE_SEMANTICS_UNSUPPORT_FUNC,
			l_string(std_cm,"eval"),
			list(	n_get_string("eval:unsupport lambda"),
				s,
				0));
	}
}


XL_SEXP *
eval(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * r;
ELEMENT * e;
int len;

	if ( break_check ) {
		r = (*break_check)(s);
		if ( get_type(r) == XLT_ERROR )
			return r;
	} 
	switch ( get_type(s) ) {
	case XLT_PAIR:
		return eval_pair(env,s);
	case XLT_SYMBOL:
		return eval_symbol(env,s);
	default:
		return s;
	}
}
