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


void
init_Categorize(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Categorize"),
		get_func_prim(xl_Categorize,FO_APPLICATIVE,0,3,3));
}

XL_SEXP *
xl_Categorize(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * cmp_func;
XL_SEXP * target, * next;
XL_SEXP * ret,* ev;
XL_SEXP * cat;
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;
	ret = 0;
	cat = 0;
	gc_push(0,0,"Categorize2");
	gc_push(0,0,"Categorize2");
	for ( ; get_type(target) == XLT_PAIR ; ) {
		cat = cons(car(target),cat);
		gc_pop(cat,gc_gb_sexp);
		gc_push(cat,gc_gb_sexp,"Catgorize3");
		next = cdr(target);
		if ( get_type(next) != XLT_PAIR ) {
			if ( cat ) {
				ret = cons(reverse(cat),ret);
				cat = 0;
				gc_pop(ret,gc_gb_sexp);
				gc_push(ret,gc_gb_sexp,"Categorize4");
			}
			break;
		}
		gc_push(0,0,"Categorize1");
		ev = eval(env,
			List(cmp_func,
				car(target),
				car(next),
				-1));
		gc_pop(ev,gc_gb_sexp);
		if ( get_type(ev) == XLT_ERROR ) {
			gc_pop(ev,gc_gb_sexp);
			gc_pop(ev,gc_gb_sexp);
			return ev;
		}
		if ( get_type(ev) != XLT_INTEGER )
			goto func_type_missmatch;
		if ( ev->integer.data == 0 ) {
			ret = cons(reverse(cat),ret);
			cat = 0;
			gc_pop(ret,gc_gb_sexp);
			gc_push(ret,gc_gb_sexp,"Categorize5");
		}
		target = next;
	}
	if ( cat )
		ret = cons(reverse(cat),ret);
	gc_pop(ret,gc_gb_sexp);
	gc_push(ret,gc_gb_sexp,"Categorize6");
	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,"Categorize"),
		n_get_string("type missmatch"));
func_type_missmatch:
	gc_pop(0,0);
	gc_pop(0,0);
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"Categorize"),
		n_get_string("type missmatch the return of cmp function"));
}


