/**********************************************************************
 
	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"



XL_SEXP * _xl_Lambda_Normal(XLISP_ENV *,XL_SEXP *);
XL_SEXP * _xl_Lambda_Applicative(XLISP_ENV *,XL_SEXP *);
XL_SEXP * xl_DefineDefault();

void
init_DefineDefault(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"DefineDefault"),
		get_func_prim(xl_DefineDefault,FO_NORMAL,0,2,4));
}

XL_SEXP *
_xl_DefineDefault(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * dat;
	dat = eval(env,get_el(s,1));
	if ( get_type(dat) == XLT_ERROR )
		return dat;
	set_default_env(env,dat);
	return 0;
}

XL_SEXP *
_xl_DefineDefault_Normal(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg2;
XL_SEXP * arg3;
	ret = 0;
	arg2 = get_el(s,1);
	arg3 = get_el(s,2);
	switch( get_type(arg2) ) {
	case XLT_ERROR:
		return arg2;
	case XLT_PAIR:
	case XLT_NULL:
	case XLT_SYMBOL:
		{
		XL_SEXP * dat;
			dat = _xl_Lambda_Normal(env,
				cons(	n_get_symbol("Lambda"),
					cdr(s)));
			if ( get_type(dat) == XLT_ERROR )
				return dat;
			return _xl_DefineDefault(env,
				cons(	n_get_symbol("Define"),
					cons(dat,
					0)));
		}
		break;
	default:
		return 0;
	}

	return ret;
}

XL_SEXP *
_xl_DefineDefault_Applicative(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg2;
XL_SEXP * arg3;
XL_SEXP * arg4;
	ret = 0;
	arg2 = get_el(s,1);
	arg3 = get_el(s,2);
	arg4 = get_el(s,3);
	switch( get_type(arg3) ) {
	case XLT_ERROR:
		return arg3;
	case XLT_PAIR:
	case XLT_NULL:
	case XLT_SYMBOL:
		{
		XL_SEXP * dat;
			dat = _xl_Lambda_Applicative(env,
				cons(	n_get_symbol("Lambda"),
					cdr(s)));
			if ( get_type(dat) == XLT_ERROR )
				return dat;
			return _xl_DefineDefault(env,
				cons(	n_get_symbol("Define"),
					cons(dat,0)));
		}
		break;
	default:
		return 0;
	}

	return 0;
}

#define _XL_DEFINE_APPLICATIVE	0
#define _XL_DEFINE_NORMAL	1

XL_SEXP *
xl_DefineDefault(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * args;
XL_SYM_FIELD * fld;
int ev;
int len;
	ret = 0;
	ev = _XL_DEFINE_APPLICATIVE;
	args = get_el(s,0);
	fld = args->symbol.field;
	if ( fld ) {
		if ( l_strcmp(fld->name, l_string(std_cm,"Order")) != 0 )
			goto formaterror1;

		if ( l_strcmp(fld->data, l_string(std_cm,"Applicative")) == 0 )
			ev = _XL_DEFINE_APPLICATIVE;
		else if ( l_strcmp(fld->data, l_string(std_cm,"Normal")) == 0 )
			ev = _XL_DEFINE_NORMAL;
		else
			goto formaterror2;
	}
	else {
		ev = _XL_DEFINE_APPLICATIVE;
	}

	if ( ev == _XL_DEFINE_NORMAL ) {
		ret = _xl_DefineDefault_Normal(env,s);
	}
	else {
		switch( get_type(get_el(s,1)) ) {
		case XLT_ENV:
		case XLT_NULL:
			break;
		default:
			goto type_missmatch;
		}
		ret = _xl_DefineDefault_Applicative(env,s);
	}

	return ret;	

formaterror1:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_INV_FORMAT,
		l_string(std_cm,"DefineDefault"),
		list(	n_get_string("format error: Order is required"),
			0));
formaterror2:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_INV_FORMAT,
		l_string(std_cm,"DefineDefault"),
		list(	n_get_string("format error: Order value"),
			0));
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"DefineDefault"),
		list(	n_get_string("type missmatch"),
			0));
}
