/**********************************************************************
 
	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	"xl.h"
#include	"xlerror.h"

XL_SEXP * xl_EE();
XL_SEXP * sort_list();
XL_SEXP * get_join_option();
XL_SEXP * njoin_cmp_s();
XL_SEXP * xl_GetElement();
void gc_gb_sexp();

int
njoin_cmp_field_list(XL_SEXP ** retp,XL_SEXP * flist,
	XL_SEXP * s1,XL_SEXP * s2);

void
init_EE(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"EE"),
		get_func_prim(xl_EE,FO_NORMAL,0,1,-1));
}


XL_SEXP *
get_rmt(L_CHAR * str)
{
XL_SEXP * ret, * ret2;
L_CHAR * buf;
L_CHAR * p1,*p2;
L_CHAR ch;
	buf = ll_copy_str(str,1457);
	ret = 0;
	p1 = buf;
	ch = buf[0];
	for ( ; ch ; ) {
		p2 = p1;
		for ( ; *p1 && *p1 != ',' ; p1 ++ );
		ch = *p1;
		*p1 = 0;
		ret = cons(
			get_symbol(p2),
				ret);
		p1 ++;
	}
	ret2 = 0;
	for ( ; ret ; ret = cdr(ret) )
		ret2 = cons(car(ret),ret2);
	return ret2;
}

int
check_rmt(XL_SEXP * rmt,XL_SEXP * sym)
{
	for ( ; get_type(rmt) ; rmt = cdr(rmt) ) {
		if ( l_strcmp(car(rmt)->symbol.data,sym->symbol.data) == 0 )
			return 0;
	}
	return -1;
}


XL_SEXP *
_EE(XLISP_ENV * env,XL_SEXP * cmd,XL_SEXP * target,XL_SEXP * rmt)
{
XLISP_ENV * e;
XL_SEXP * s,* sym;
int len;
	gc_push(0,0,"_EE1");
	e = new_env(env);
	s = car(target);
	if ( get_type(s) == XLT_SYMBOL )
		set_env(e,l_string(std_cm,"tag"),s);
	else	set_env(e,l_string(std_cm,"tag"),0);
	for ( ; get_type(target) == XLT_PAIR ; target = cdr(target) ) {
		s = car(target);
		switch ( get_type(s) ) {
		case XLT_ERROR:
			gc_pop(s,gc_gb_sexp);
			return s;
		case XLT_PAIR:
			break;
		default:
			continue;
		}
		sym = car(s);
		switch ( get_type(sym) ) {
		case XLT_ERROR:
			gc_pop(sym,gc_gb_sexp);
			return sym;
		case XLT_SYMBOL:
			break;
		default:
			continue;
		}
		len = list_length(s);
		if ( len < 0 ) {
			gc_pop(s,gc_gb_sexp);
			return list_error(s);
		}
		if ( len == 2 && check_rmt(rmt,sym) )
			set_env(e,sym->symbol.data,get_el(s,1));
		else	set_env(e,sym->symbol.data,cdr(s));
	}
	s = 0;
	for ( ; get_type(cmd) == XLT_PAIR ; cmd = cdr(cmd) ) {
		gc_push(0,0,"_EE");
		s = eval(e,car(cmd));
		if ( get_type(s) == XLT_ERROR ) {
			gc_pop(s,gc_gb_sexp);
			gc_pop(s,gc_gb_sexp);
			return s;
		}
		gc_pop(s,gc_gb_sexp);
	}

	gc_pop(s,gc_gb_sexp);
	return s;
}


XL_SEXP *
EE_normal(XLISP_ENV * env,XL_SEXP * cmd,XL_SEXP * target,XL_SEXP * rmt)
{
	return _EE(env,cmd,target,rmt);
}

XL_SEXP *
EE_list(XLISP_ENV * env,XL_SEXP * cmd,XL_SEXP * target,XL_SEXP * rmt)
{
XL_SEXP * ret1,* ret2;
XL_SEXP * s, * sym;
XL_SEXP * ret;
XL_SEXP * t;
	ret1 = 0;
	t = target;
	for ( ; get_type(target) == XLT_PAIR  ; target = cdr(target) ) {
		s = car(target);
		switch ( get_type(s) ) {
		case XLT_ERROR:
			return s;
		case XLT_PAIR:
			break;
		default:
			continue;
		}
		ret = _EE(env,cmd,s,rmt);
		if ( get_type(ret) == XLT_ERROR )
			return ret;
		ret1 = cons(ret,ret1);
	}
	ret2 = 0;
	for ( ; ret1 ; ret1 = cdr(ret1) )
		ret2 = cons(car(ret1),ret2);
	return ret2;
}

XL_SEXP *
xl_EE(XLISP_ENV * env,XL_SEXP * s,
	      XLISP_ENV * a,XL_SYM_FIELD * sf)
{
int mode;
L_CHAR * target;
XL_SEXP * _target;
XL_SEXP * rmt;
	mode = 0;
	rmt = 0;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"mode")) == 0 ) {
			if ( l_strcmp(sf->data,
					l_string(std_cm,"list")) == 0 ) {
				mode = 1;
			}
			else {
				mode = 0;
			}
		}
		else if ( l_strcmp(sf->name,l_string(std_cm,"raw.mode.tag"))
				 == 0 ) {
			rmt = get_rmt(sf->data);
		}
		else if ( l_strcmp(sf->name,l_string(std_cm,"target")) == 0 ) {				target = sf->data;
		}
	}
	if ( target[0] == '^' )
		target ++;
	_target = eval(env,get_symbol(target));
	switch ( get_type(_target) ) {
	case XLT_ERROR:
		return _target;
	case XLT_PAIR:
		break;
	default:
		goto type_missmatch;
	}
	switch ( mode ) {
	case 1:
		return EE_list(env,s,_target,rmt);
	}
	return EE_normal(env,s,_target,rmt);
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"EE"),
		0);
}
