/**********************************************************************
 
	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_Define();

void
init_Define(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Define"),
		get_func_prim(xl_Define,FO_NORMAL,0,3,5));
}

XL_SEXP *
_xl_Define(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * dat;

	ret = get_el(s,1);
	if ( get_type(ret) != XLT_SYMBOL )
		return 0;
	dat = eval(env,get_el(s,2));
	if ( get_type(dat) == XLT_ERROR )
		return dat;
	set_env(env,ret->symbol.data,dat);
	return ret;
}

XL_SEXP *
_xl_Define_Normal(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg1;
XL_SEXP * arg2;
XL_SEXP * arg3;
	ret = 0;
	arg1 = get_el(s,1);
	arg2 = get_el(s,2);
	arg3 = get_el(s,3);
	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(cdr(s))));
			if ( get_type(dat) == XLT_ERROR )
				return dat;
			return _xl_Define(env,
				cons(	n_get_symbol("Define"),
					cons(arg1,
					cons(dat,
					0))));
		}
		break;
	default:
		return 0;
	}

	return ret;
}

XL_SEXP *
_xl_Define_Applicative(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg1;
XL_SEXP * arg2;
XL_SEXP * arg3;
XL_SEXP * arg4;

	ret = 0;
	arg1 = get_el(s,1);
	arg2 = get_el(s,2);
	arg3 = get_el(s,3);
	arg4 = get_el(s,4);
	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,
				List(	n_get_symbol("lambda"),
					arg2,
					arg3,
					arg4,
					-1));
			if ( get_type(dat) == XLT_ERROR )
				return dat;
			return _xl_Define(env,
				List(	n_get_symbol("define"),
					arg1,
					dat,
					-1));
		}
		break;
	default:
		return 0;
	}

	return 0;
}

#define _XL_DEFINE_APPLICATIVE	0
#define _XL_DEFINE_NORMAL	1

XL_SEXP *
xl_Define(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * args;
XL_SYM_FIELD * fld;
int ev;

	ret = 0;
	if ( list_length(s) == 3 ) {
		ret = _xl_Define(env,s);
		if ( ret == 0 )
			goto formaterror;
		return ret;
	}
	else {
		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 formaterror;

			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 formaterror;
		}
	}

	if ( ev == _XL_DEFINE_NORMAL ) {
		ret = _xl_Define_Normal(env,s);
	}
	else {
		ret = _xl_Define_Applicative(env,s);
	}

	if ( ret == 0 )
		goto formaterror;

	return ret;	

formaterror:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_INV_FORMAT,
		l_string(std_cm,"Define"),
		list(	n_get_string("format error in Define argment"),
			0));
}
