/**********************************************************************
 
	Copyright (C) 2005- 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	"machine/include.h"
#include	"memory_debug.h"
#include	"pri_level.h"
#include	"lock_level.h"
#include	"utils.h"
#include	"task.h"
#include	"matrix.h"
#include	"xl.h"
#include	"xlerror.h"


void mem_test();
void gc_tick_notin_tick();


XL_SEXP *
xl_mxCH(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a,XL_SYM_FIELD * sf);

void
init_mxCH(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"mxCH"),
		get_func_prim(xl_mxCH,FO_APPLICATIVE,0,1,3));
}


XL_SEXP *
xl_mxCH(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a,XL_SYM_FIELD * sf)
{
XL_SEXP * c;
MATRIX_TOKEN * t;
L_CHAR * _type;
INTEGER64 * dim_code;
MATRIX_NODE * n;
int err;
int _ch;
XL_SEXP * ch;
MATRIX * m;
XL_SEXP * ret;
L_CHAR * _neturl;
L_CHAR * _filename;
L_CHAR * _key;
XL_SEXP * d_ret;
XL_SEXP * info;
char  * err_msg;
MX_DIM_CODE_LIST * lst, * lst2;
	info = 0;
	err = 0;
	lst = 0;
	err_msg = 0;

	ret = 0;
	gc_push(0,0,"XXX");

	t = get_env_work(env);
	if ( t == 0 ) {
		ret = 0;
		goto end;
	}
	_type = get_sf_attribute(sf,l_string(std_cm,"type"));
	dim_code = copy_dim_code(t->process_node->matrix,t->process_node->dim_code);
	m = t->process_node->matrix;
	if ( _type == 0 )
		goto me;
	if ( l_strcmp(_type,l_string(std_cm,"me")) == 0 ) {
	me:
		n = t->process_node;
		ch = get_el(s,1);
		if ( get_type(ch) != XLT_INTEGER )
			goto type_missmatch;
		_ch = ch->integer.data;
	}
	else if ( l_strcmp(_type,l_string(std_cm,"parent")) == 0 ) {
		dim_code[0] ++;
		if ( dim_code[0] >= t->process_node->matrix->total_levels ) {
			d_f_ree(dim_code);
			dim_code = 0;
			n = 0;
			ret = 0;
			goto end;
		}
		else {
			gc_push(0,0,"");
			n = get_matrix_node(&err,m,dim_code,GN_ERROR_NORETRY,t);
			info = List(
				n_get_string("parent"),
				get_integer(err,0),
				get_sexp_from_dim_code(m,dim_code),
				-1);
			if ( n == 0 ) {
				d_f_ree(dim_code);
				gc_pop(0,0);
				err_msg = "parent";
				goto no_obj;
			}
			if ( err != 0 ) {
				d_f_ree(dim_code);
				ret = matrix_error("mxCH",s,AME_TRAP,info);
				gc_pop(ret,gc_gb_sexp);
				goto end;
			}
			gc_pop(0,0);
		}
		ch = get_el(s,1);
		if ( get_type(ch) != XLT_INTEGER )
			goto type_missmatch;
		_ch = ch->integer.data;
	}
	else if ( l_strcmp(_type,l_string(std_cm,"children")) == 0 ) {
		ch = get_el(s,1);
		if ( get_type(ch) != XLT_INTEGER )
			goto type_missmatch;
		_ch = ch->integer.data;
		n = t->process_node;
		err = 0;
		lst = lst2 = get_children_list(&err,n->matrix,
				dim_code,GN_ERROR_NORETRY,0,t);
		d_f_ree(dim_code);
		dim_code = 0;
		info = 0;
		if ( err == ME_ERR_NODE ) {
			err_msg = "children-loading";
			goto no_obj;
		}
		if ( err ) {
			ret = matrix_error("mxCH",
				s,AME_TRAP,info);
			goto end;
		}
		ret = 0;
		for ( ; lst2 ; lst2 = lst2->next ) {

			err = 0;
			n = get_matrix_node(&err,m,lst2->dc,
					GN_ERROR_NORETRY,t);
			info = List(
				get_integer(err,0),
				get_sexp_from_dim_code(m,lst2->dc),
				-1);
			if ( err == ME_ERR_NODE || n == 0 ) {
				err_msg = "children loading(2)";
				goto no_obj;
			}
			if ( err != 0 ) {
				ret = matrix_error("mxCH",
					s,AME_TRAP,info);
				goto end;
			}
			if ( n->channel == 0 ) {
				err_msg = "children loading(3)";
				goto no_obj;
			}
			d_ret = get_channel_data(n,_ch,s);
			if ( get_type(d_ret) == XLT_ERROR ) {
				ret = d_ret;
				goto end;
			}
			ret = cons(
				List(n_get_symbol("data"),
					get_sexp_from_dim_code
						(m,lst2->dc),
					d_ret,
					-1),
				ret);
		}
		free_mx_dim_code_list(lst);
		lst = 0;
		ret = cons(n_get_symbol("Children"),ret);
		goto end;
	}
	else if ( l_strcmp(_type,l_string(std_cm,"matrix")) == 0 ) {
		_neturl = get_sf_attribute(sf,l_string(std_cm,"neturl"));
		_filename = get_sf_attribute(sf,
					l_string(std_cm,"filename"));
		_key = get_sf_attribute(sf,l_string(std_cm,"key"));
	retry:
		m = search_matrix(&err,_neturl,_filename,_key,t);
		switch ( err ) {
		case ME_PROC_NODE:
			ret = matrix_error("mxCH",s,AME_TRAP,0);
			goto end;
		case ME_NO_NODE:
			open_matrix(_neturl,_filename,_key,
				t->process_node->matrix->p.open_method,0);
			goto retry;
		case ME_ERROR:
			goto matrix_err;
		default:
			er_panic("mxCH");
		}
		c = get_el(s,1);
		if ( get_type(c) != XLT_PAIR )
			goto type_missmatch;
		d_f_ree(dim_code);
		dim_code = get_dim_code_from_sexp(c);
		n = get_matrix_node(&err,m,dim_code,GN_ERROR_NORETRY,t);
		info = get_sexp_from_dim_code(m,dim_code);
		if ( n == 0 ) {
			d_f_ree(dim_code);
			dim_code = 0;
			err_msg = "matrix";
			goto no_obj;
		}
		if ( err != 0 ) {
			d_f_ree(dim_code);
			ret = matrix_error("mxCH",s,AME_TRAP,info);
			goto end;
		}
		ch = get_el(s,2);
		if ( get_type(ch) != XLT_INTEGER )
			goto type_missmatch;
		_ch = ch->integer.data;
	}
	else {
		c = get_el(s,1);
		if ( get_type(c) != XLT_PAIR )
			goto type_missmatch;
		dim_code = get_dim_code_from_sexp(c);
		n = get_matrix_node(&err,m,dim_code,GN_ERROR_NORETRY,t);
		info = List(
			get_integer(err,0),
			get_sexp_from_dim_code(m,dim_code),
			-1);
		if ( n == 0 ) {
			d_f_ree(dim_code);
			err_msg = "others";
			goto no_obj;
		}
		if ( err != 0 ) {
			d_f_ree(dim_code);
			ret = matrix_error("mxCH",s,AME_TRAP,info);
			goto end;
		}
		ch = get_el(s,2);
		if ( get_type(ch) != XLT_INTEGER )
			goto type_missmatch;
		_ch = ch->integer.data;
	}
	gc_push(0,0,"");
	if ( _ch < 0 || _ch >= m->p.channel_nos ) {
		d_f_ree(dim_code);
		gc_pop(0,0);
		goto inv_param;
	}
	if ( n->channel == 0 ) {
		d_f_ree(dim_code);
		err_msg = "others(2)";
		gc_pop(0,0);
		goto no_obj;
	}
	gc_push(0,0,"");
	d_ret = get_channel_data(n,_ch,s);
	if ( get_type(d_ret) == XLT_ERROR ) {
		ret = d_ret;
		gc_pop(0,0);
		gc_pop(0,0);
		goto end;
	}
	ret = List(n_get_symbol("data"),
			get_sexp_from_dim_code(m,dim_code),
			d_ret,
			-1);
	gc_pop(ret,gc_gb_sexp);
	d_f_ree(dim_code);
	gc_pop(ret,gc_gb_sexp);
	goto end;

type_missmatch:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"mxCH"),
		0);
	goto end;
inv_param:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"mxCH"),
		n_get_string("invalid parameter in mxCH"));
	goto end;
no_obj:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_OBJECT,
		l_string(std_cm,"mxCH"),
		List(n_get_string("invalid object in channel of NODE"),
			n_get_string(err_msg),
			info,-1));
matrix_err:
	ret = get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_OBJECT,
		l_string(std_cm,"mxCH"),
		n_get_string("invalid matrix loading"));
	goto end;
end:
	if ( lst )
		free_mx_dim_code_list(lst);
	gc_pop(ret,(void(*)())gc_gb_sexp);
	return ret;
}





