/**********************************************************************
 
	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_For();
extern XLISP_ENV * loop_env;

void
init_For(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"For"),
		get_func_prim(xl_For,FO_NORMAL,loop_env,2,-1));
}

XL_SEXP *
_xl_For(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * cond;
int _cond;
XL_SEXP * ret;
XL_SEXP * seq;
	env = new_env_pair(loop_env,env);
	_cond = 1;
	ret = get_integer(0,0);
	for ( ; _cond ; ) {
		gc_push(ret,gc_gb_sexp,"For");
		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(ret,gc_gb_sexp);
			return ret;
		}
		seq = cdr(cdr(s));
		for ( ; get_type(seq) == XLT_PAIR ; seq = cdr(seq) ) {
			gc_push(0,0,"ForExec");
			ret = eval(env,car(seq));
			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);
					gc_pop(ret,gc_gb_sexp);
					return ret;
				case XLE_SYSTEM_LOOP_CONTINUE:
					ret = ret->err.data;
					gc_pop(ret,gc_gb_sexp);
					goto cont;
				default:
					gc_pop(ret,gc_gb_sexp);
					gc_pop(ret,gc_gb_sexp);
					return ret;
				}
			}
			gc_pop(ret,gc_gb_sexp);
		}
	cont:
		gc_pop(ret,gc_gb_sexp);
	}
	return ret;
type_missmatch:
	gc_pop(0,0);
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"For"),
		n_get_string("condition type missmatch"));
}


XL_SEXP *
_xl_For_cnt(XLISP_ENV * env,XL_SEXP * s,L_CHAR * dec)
{
XL_SEXP * cond;
int _cond;
XL_SEXP * ret;
XL_SEXP * seq;
int type;
XL_SEXP * dec_sym;
	dec_sym = get_symbol(dec);
	env = new_env_pair(loop_env,env);
	_cond = 1;
	ret = get_integer(0,0);
	for ( ; _cond ; ) {
		gc_push(ret,gc_gb_sexp,"For");
		cond = eval(env,dec_sym);
		switch ( type = 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;
		case XLT_PAIR:
			break;
		case XLT_NULL:
			gc_pop(ret,gc_gb_sexp);
			return ret;
		default:
			goto type_missmatch;
		}
		if ( _cond == 0 ) {
			gc_pop(ret,gc_gb_sexp);
			return ret;
		}
		seq = cdr(s);
		for ( ; get_type(seq) == XLT_PAIR ; seq = cdr(seq) ) {
			gc_push(0,0,"ForExec");
			ret = eval(env,car(seq));
			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);
					gc_pop(ret,gc_gb_sexp);
					return ret;
				case XLE_SYSTEM_LOOP_CONTINUE:
					ret = ret->err.data;
					gc_pop(ret,gc_gb_sexp);
					goto cont;
				default:
					gc_pop(ret,gc_gb_sexp);
					gc_pop(ret,gc_gb_sexp);
					return ret;
				}
			}
			gc_pop(ret,gc_gb_sexp);
		}
	cont:
		switch ( type ) {
		case XLT_INTEGER:
			cond = get_integer(
				cond->integer.data - 1,
				cond->integer.unit);
			break;
		case XLT_FLOAT:
			cond = get_floating(
				cond->floating.data - 1,
				cond->floating.unit);
			break;
		case XLT_PAIR:
			cond = cdr(cond);
			break;
		}
		set_op(env,dec_sym,cond);
		gc_pop(ret,gc_gb_sexp);
	}
	return ret;
type_missmatch:
	gc_pop(0,0);
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"For"),
		n_get_string("condition type missmatch"));
}



XL_SEXP *
xl_For(XLISP_ENV * env,XL_SEXP * s,XL_ENV * a,XL_SYM_FIELD * sf)
{
L_CHAR * dec;
	dec = get_sf_attribute(sf,l_string(std_cm,"dec"));
	if ( dec ) {
		if ( dec[0] == '^' )
			dec ++;
		return _xl_For_cnt(env,s,dec);
	}
	else	return _xl_For(env,s);
}
