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

void
init_Lambda(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Lambda"),
		get_func_prim(xl_Lambda,FO_NORMAL,0,3,4));
}

XL_SEXP *
_xl_Lambda_Normal(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg1;
XL_SEXP * arg2;
	ret = 0;
	arg1 = get_el(s,1);
	arg2 = get_el(s,2);
	switch( get_type(arg1) ) {
	case XLT_ERROR:
		return arg1;
	case XLT_PAIR:
	case XLT_NULL:
		{
		XL_SEXP * a;
		XL_SEXP * arg;
			for ( a = arg1 ; get_type(a) ; a = cdr(a) ) {
				if ( get_type(a) != XLT_PAIR )
					return 0;
				arg = car(a);
				switch ( get_type(arg) ) {
				case XLT_ERROR:
					return arg;
				case XLT_SYMBOL:
					break;
				default:
					return 0;
				}
			}
			ret = get_sexp(s->h.file,XLT_FUNC);
			ret->func.type = FT_LAMBDA;
			ret->func.order = FO_NORMAL;
			ret->func.args_env = 0;
			ret->func.max = list_length(arg1);
			ret->func.min = list_length(arg1);
			ret->func.prim = 0;
			if ( get_type(arg1) == XLT_NULL )
				ret->func.l_params = 0;
			else	ret->func.l_params = cdr(arg1);
			ret->func.l_body = cdr(cdr(s));
		}
		break;
	case XLT_SYMBOL:
		{
			ret = get_sexp(s->h.file,XLT_FUNC);
			ret->func.type = FT_LAMBDA;
			ret->func.order = FO_NORMAL;
			ret->func.args_env = 0;
			ret->func.max = -1;
			ret->func.min = 1;
			ret->func.prim = 0;
			ret->func.l_params = arg1;
			ret->func.l_body = cdr(cdr(s));
		}
		break;
	default:
		return 0;
	}

	return ret;
}

XL_SEXP *
_xl_Lambda_Applicative(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * arg1;
XL_SEXP * arg2;
XLISP_ENV * e;

	ret = 0;
	arg1 = eval(env,get_el(s,1));
	arg2 = get_el(s,2);
	switch( get_type(arg1) ) {
	case XLT_ENV:
		e = arg1->env.data;
		break;
	case XLT_NULL:
		e = 0;
		break;
	default:
		return 0;
	}
	switch( get_type(arg2) ) {
	case XLT_ERROR:
		return arg2;
	case XLT_PAIR:
	case XLT_NULL:
		{
		XL_SEXP * a;
		XL_SEXP * arg;
			ret = get_sexp(s->h.file,XLT_FUNC);
			ret->func.type = FT_LAMBDA;
			ret->func.order = FO_APPLICATIVE;
			ret->func.args_env = e;
			ret->func.max = list_length(arg2);
			ret->func.min = list_length(arg2);
			ret->func.prim = 0;
			if ( get_type(arg2) == XLT_NULL )
				ret->func.l_params = 0;
			else	ret->func.l_params = cdr(arg2);
			ret->func.l_body = cdr(cdr(cdr(s)));
		}
		break;
	case XLT_SYMBOL:
		{
			ret = get_sexp(s->h.file,XLT_FUNC);
			ret->func.type = FT_LAMBDA;
			ret->func.order = FO_APPLICATIVE;
			ret->func.args_env = e;
			ret->func.max = -1;
			ret->func.min = 1;
			ret->func.prim = 0;
			ret->func.l_params = arg2;
			ret->func.l_body = cdr(cdr(cdr(s)));
		}
		break;
	default:
		return 0;
	}

	return ret;
}

#define _XL_LAMBDA_APPLICATIVE	0
#define _XL_LAMBDA_NORMAL	1

XL_SEXP *
xl_Lambda(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ret;
XL_SEXP * args;
XL_SYM_FIELD * fld;
int ev;
	ret = 0;
	ev = _XL_LAMBDA_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_LAMBDA_APPLICATIVE;
		else if ( l_strcmp(fld->data, l_string(std_cm,"Normal")) == 0 )
			ev = _XL_LAMBDA_NORMAL;
		else
			goto formaterror;
	}

	if ( ev == _XL_LAMBDA_NORMAL ) {
		ret = _xl_Lambda_Normal(env,s);
	}
	else {
		switch( get_type(get_el(s,1)) ) {
		case XLT_ENV:
		case XLT_NULL:
			break;
		default:
			goto formaterror;
		}
		ret = _xl_Lambda_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,"lambda"),
		list(	n_get_string("format error in lambda argment"),
			get_integer(s->h.type,0),
			s,
			0));
}
