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

void gc_gb_sexp();
XL_SEXP * xl_While();
XLISP_ENV * loop_env;

void
init_While(XLISP_ENV * env)
{
	loop_env = new_env(0);
	init_Break(loop_env);
	init_Continue(loop_env);
	set_env(env,l_string(std_cm,"While"),
		get_func_prim(xl_While,FO_NORMAL,loop_env,3,3));
}

XL_SEXP *
xl_While(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * cond;
int _cond;
XL_SEXP * ret;
	env = new_env_pair(loop_env,env);
	for ( ; ; ) {
		gc_push(0,0,"While1");
		ret = eval(env,get_el(s,2));
		if ( get_type(ret) == XLT_ERROR ) {
			switch ( ret->err.code ) {
			case XLE_SYSTEM_LOOP_BREAK:
				ret = ret->err.data;
				gc_pop(ret,gc_gb_sexp);
				return ret;
			case XLE_SYSTEM_LOOP_CONTINUE:
				ret = ret->err.data;
				gc_pop(0,0);
				continue;
			default:
				gc_pop(ret,gc_gb_sexp);
				return ret;
			}
		}
		gc_pop(ret,gc_gb_sexp);
		gc_push(0,0,"While2");
		cond = eval(env,get_el(s,1));
		switch ( get_type(cond) ) {
		case XLT_ERROR:
			gc_pop(cond,gc_gb_sexp);
			return cond;
		case XLT_INTEGER:
			if ( cond->integer.data == 0 )
				_cond = 0;
			else	_cond = 1;
			break;
		case XLT_FLOAT:
			if ( cond->floating.data == 0 )
				_cond = 0;
			else	_cond = 1;
			break;
		default:
			goto type_missmatch;
		}
		if ( _cond == 0 ) {
			gc_pop(0,0);
			return ret;
		}
		gc_pop(0,0);
	}
type_missmatch:
	gc_pop(0,0);
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"While"),
		n_get_string("condition type missmatch"));
}

