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

XL_SEXP * xl_V2H();
XL_SEXP * xl_h2v();

void
init_V2H(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"V2H"),
		get_func_prim(xl_V2H,FO_APPLICATIVE,0,3,4));
	set_env(env,l_string(std_cm,"h2v"),
		get_func_prim(xl_h2v,FO_APPLICATIVE,0,2,2));
}


XL_SEXP *
h2v(XL_SEXP * h)
{
XL_SEXP * _h;
	if ( get_type(h) == XLT_ERROR )
		return h;
	if ( get_type(cdr(h)) == XLT_PAIR ) {
		_h = h2v(cdr(h));
		if ( get_type(_h) == XLT_ERROR )
			return _h;
		return List(_h,car(h),-1);
	}
	return car(h);
}

XL_SEXP *
xl_h2v(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * h;
	h = get_el(s,1);
	if ( get_type(h) != XLT_PAIR )
		goto type_missmatch;
	return h2v(h);
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"h2v"),
		n_get_string("type missmatch"));
}

XL_SEXP *
_reverse_h_list(XL_SEXP * list)
{
	if ( get_type(list) != XLT_PAIR )
		return list;
	return reverse(cons(_reverse_h_list(car(list)),cdr(list)));
}


XL_SEXP *
reverse_h_list(XL_SEXP * list,int level)
{
	if ( level == 0 ) {
		return cons(_reverse_h_list(car(list)),
				cdr(list));
	}
	return cons(reverse_h_list(car(list),level-1),cdr(list));
}

XL_SEXP *
insert_h_list(XL_SEXP * list,XL_SEXP * target,int level)
{
	if ( level == 0 )
		return cons(target,list);
	return cons(insert_h_list(car(list),car(target),level-1),
			cdr(list));
}

XL_SEXP *
xl_V2H(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * cmp_func;
XL_SEXP * target, * next,* ins;
XL_SEXP * ret,* ev, * head;
XL_SEXP * cat;
XL_SEXP * preproc;
int i,cmp_result;
void gc_gb_sexp();
	target = get_el(s,1);
	cmp_func = get_el(s,2);
	if ( get_type(target) == XLT_NULL )
		return 0;
	if ( get_type(target) != XLT_PAIR )
		goto type_missmatch;
	if ( get_type(cmp_func) != XLT_FUNC )
		goto type_missmatch;
	if ( list_length(s) == 4 )
		preproc = get_el(s,3);
	else	preproc = 0;

	gc_push(0,0,"V2H2");
	gc_push(0,0,"V2H2");

	head = car(target);
	if ( preproc ) {
		gc_push(0,0,"V2H");
		ev = eval(env,
			List(preproc,car(target),-1));
		if ( get_type(ev) == XLT_ERROR ) {
			gc_pop(ev,gc_gb_sexp);
			gc_pop(ev,gc_gb_sexp);
			gc_pop(ev,gc_gb_sexp);
			return ev;
		}
		gc_pop(ev,gc_gb_sexp);
	}
	else	ev = car(target);
	ret = cons(ev,0);

	target = cdr(target);
	for ( ; get_type(target) == XLT_PAIR ; ) {
		ev = eval(env,
			List(cmp_func,
				head,
				car(target),
				-1));
		switch ( get_type(ev) ) {
		case XLT_ERROR:
			gc_pop(ev,gc_gb_sexp);
			gc_pop(ev,gc_gb_sexp);
			return ev;
		case XLT_INTEGER:
			break;
		default:
			gc_pop(0,0);
			gc_pop(0,0);
			goto func_type_missmatch;
		}
		cmp_result = ev->integer.data;
		gc_push(0,0,"V2H");
		ret = reverse_h_list(ret,cmp_result);
		if ( preproc ) {
			ev = eval(env,
				List(preproc,car(target),-1));
			if ( get_type(ev) == XLT_ERROR ) {
				gc_pop(ev,gc_gb_sexp);
				gc_pop(ev,gc_gb_sexp);
				gc_pop(ev,gc_gb_sexp);
				return ev;
			}
		}
		else	ev = car(target);
		ret = insert_h_list(ret,ev,cmp_result);
		gc_pop(ret,gc_gb_sexp);
		head = car(target);
		target = cdr(target);
	}
	gc_pop(ret,gc_gb_sexp);
	gc_push(ret,gc_gb_sexp,"V2H6");
	ret = reverse_h_list(ret,0);
	ret = reverse(ret);
	gc_pop(ret,gc_gb_sexp);
	gc_pop(ret,gc_gb_sexp);
	return ret;
type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"V2H"),
		n_get_string("type missmatch"));
func_type_missmatch:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"V2H"),
		n_get_string("type missmatch the return of cmp function"));
}


