/**********************************************************************
 
	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_Let(XLISP_ENV * env,XL_SEXP * s);

XL_SEXP *
xl_Let(XLISP_ENV * env,XL_SEXP * s)
{
char * pos;
XL_SEXP * sub, * sym;
XL_SEXP * ev,* sb, * dd;
XLISP_ENV * e;
XL_SEXP * ret;
int f;
/*
	f = 0 : no operation for env
	f = 1 : top env is pair
	f = 2 : top env is real env.
*/

	f = 0;
	e = env;
	s = cdr(s);
	for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
		sub = car(s);
		if ( get_type(sub) != XLT_PAIR )
			break;
		sym = car(sub);
		if ( get_type(sym) != XLT_SYMBOL ) {
			pos = "symbol is required";
			s = sym;
			goto syntax;
		}
		if ( l_strcmp(sym->symbol.data,l_string(std_cm,"Env"))
					== 0 ) {
			sub = cdr(sub);
			for ( ; get_type(sub) == XLT_PAIR ; sub = cdr(sub) ) {
				ev = eval(env,car(sub));
				switch ( get_type(ev) ) {
				case XLT_ERROR:
					return ev;
				case XLT_ENV:
					break;
				default:
					pos = "environment type is required";
					s = ev;
					goto syntax;
				}
				e = new_env_pair(e,ev->env.data);
				f = 1;
			}
			if ( get_type(sub) == XLT_ERROR )
				return sub;
		}
		else if ( l_strcmp(sym->symbol.data,
				l_string(std_cm,"Sub")) == 0 ) {
			sub = cdr(sub);
			e = new_env(e);
			f = 2;
			for ( ; get_type(sub) == XLT_PAIR ; sub = cdr(sub) ) {
				sb = car(sub);
				switch ( get_type(sb) ) {
				case XLT_ERROR:
					return sb;
				case XLT_PAIR:
					break;
				default:
					pos = "substitution pair is required";
					s = sb;
					goto syntax;
				}
				sym = car(sb);
				if ( get_type(sym) != XLT_SYMBOL ) {
					pos = "symbol is required";
					s = sym;
					goto syntax;
				}
				dd = eval(e,get_el(sb,1));
				if ( get_type(dd) == XLT_ERROR )
					return dd;
				set_env(e,sym->symbol.data,dd);
			}
		}
		else {
			break;
		}
	}
	if ( f == 0 || f == 1 )
		e = new_env(e);
	for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
		ret = eval(e,car(s));
		if ( get_type(ret) == XLT_ERROR )
			break;
	}
	return ret;
syntax:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_INV_FORMAT,
		l_string(std_cm,"Let"),
		list(	n_get_string("format error"),
			n_get_string(pos),
			s,
			0));
}



void
init_Let(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Let"),
		get_func_prim(xl_Let,FO_NORMAL,0,1,-1));
}



