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

#define LEN_UNIT	10

XL_SEXP * xl_ListEval();


void
init_ListEval(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"ListEval"),
		get_func_prim(xl_ListEval,FO_APPLICATIVE,0,3,-1));
}

XL_SEXP *
search_and_eval(XLISP_ENV * env,XL_SEXP * d,L_CHAR * sym,char * flags)
{
int i;
XL_SEXP * r;
XL_SEXP * rr;

	i = 0;
	for ( ; get_type(d) ; d = cdr(d) , i ++ ) {
		r = car(d);
		switch ( get_type(r) ) {
		case XLT_SYMBOL:
			if ( l_strcmp(r->symbol.data,sym) == 0 )
				break;
			continue;
		case XLT_PAIR:
			rr = car(r);
			if ( get_type(rr) != XLT_SYMBOL )
				continue;
			if ( l_strcmp(rr->symbol.data,sym) == 0 )
				break;
			continue;
		default:
			continue;
		}
		flags[i] = 1;
		return eval(env,r);
	}
	return 0;
}

XL_SEXP *
get_omit_list(L_CHAR * str)
{
L_CHAR * buf;
L_CHAR *  p1,* p2;
int end_f;
XL_SEXP * ret;
	buf = ll_copy_str(str,1459);
	end_f = 0;
	ret = 0;
	for ( p1 = buf ; *p1 ; ) {
		for ( p2 = p1 ; *p2 && *p2 != ',' ; p2 ++ );
		if ( *p2 == 0 )
			end_f = 1;
		*p2 = 0;
		if ( *p1 )
			ret = cons(get_symbol(p1),ret);
		if ( end_f )
			break;
		p1 = p2 + 1;
	}
	d_f_ree(buf);
	return ret;
}

int
omit_check(L_CHAR * str,XL_SEXP * lst)
{
XL_SEXP * a;
	for ( ; lst ; lst = cdr(lst) ) {
		a = car(lst);
		if ( l_strcmp(str,a->symbol.data) == 0 )
			return 1;
	}
	return 0;
}

XL_SEXP *
xl_ListEval(XLISP_ENV * env,XL_SEXP * s,
	XLISP_ENV * a,
	XL_SYM_FIELD * sf)
{
XLISP_ENV * ee;
XL_SEXP * e;
XL_SEXP * d, * dd;
XL_SEXP * ret1, * ret2;
XL_SEXP * cmd;
char * flags;
int i,len,lp,_len;
XL_SEXP * r, * rr;
XL_SEXP * omit;

	omit = 0;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"omit")) == 0 )
			omit = get_omit_list(sf->data);
	}
	e = get_el(s,1);
	switch ( get_type(e) ) {
	case XLT_NULL:
		ee = env;
		break;
	case XLT_ENV:
		ee = e->env.data;
		break;
	default:
		goto type_missmatch;
	}
	d = get_el(s,2);
	switch ( get_type(d) ) {
	case XLT_NULL:
		return 0;
	case XLT_PAIR:
		break;
	default:
		goto type_missmatch;
	}
	flags = d_alloc(len = LEN_UNIT,23);
	for ( i = 0 ; i < len ; i ++ )
		flags[i] = 0;
	ret1 = 0;
	lp = 0;
	for ( cmd = cdr(cdr(cdr(s))) ; get_type(cmd) == XLT_PAIR ;
			cmd = cdr(cmd) ) {
		if ( lp >= len ) {
			_len = len + LEN_UNIT;
			flags = d_re_alloc(flags,_len);
			for ( i = len ; i < _len ; i ++ )
				flags[i] = 0;
			len = _len;
		}
		r = car(cmd);
		if ( get_type(r) == XLT_SYMBOL ) {
			dd = search_and_eval(ee,d,r->symbol.data,flags);
			if ( get_type(dd) == XLT_ERROR ) {
				d_f_ree(flags);
				return dd;
			}
			ret1 = cons(dd,ret1);
		}
		else {
			ret1 = cons(r,ret1);
		}
		lp ++;
	}
	i = 0;
	for ( ; get_type(d) ; d = cdr(d) , i ++ ) {
		if ( i < len && flags[i] )
			continue;
		cmd = car(car(d));
		if ( get_type(cmd) == XLT_SYMBOL )
			if ( omit_check(cmd->symbol.data,omit) )
				goto next;
		dd = eval(ee,car(d));
		if ( get_type(dd) == XLT_ERROR ) {
			d_f_ree(flags);
			return dd;
		}
		ret1 = cons(dd,ret1);
	next:
		;
	}
	ret2 = 0;
	for ( ; get_type(ret1) ; ret1 = cdr(ret1) )
		ret2 = cons(car(ret1),ret2);
	d_f_ree(flags);
	return ret2;
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"ListEval"),
		0);
}


