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

XL_SEXP * xl_UnitSystem();


void
init_UnitSystem(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"UnitSystem"),
		get_func_prim(xl_UnitSystem,FO_NORMAL,0,1,-1));
}


XL_SEXP *
us_system(UNIT_ENV * ue,XLISP_ENV * env,XL_SEXP * rec,XL_SEXP * sym)
{
XL_SEXP * shi,* bo;
double _shi,_bo;
L_CHAR * name;
L_CHAR * dim;
int _dim;

	if ( list_length(rec) != 3 )
		goto inv_param_length;

	name = get_sf_attribute(sym->symbol.field,l_string(std_cm,"name"));
	if ( name == 0 )
		goto inval_attr;
	dim = get_sf_attribute(sym->symbol.field,l_string(std_cm,"dim"));
	if ( dim == 0 )
		goto inval_attr;
	if ( l_strcmp(dim,l_string(std_cm,"l")) == 0 )
		_dim = D_L;
	else if ( l_strcmp(dim,l_string(std_cm,"t")) == 0 )
		_dim = D_T;
	else if ( l_strcmp(dim,l_string(std_cm,"w")) == 0 )
		_dim = D_W;
	else	goto type_missmatch;

	shi = eval(env,get_el(rec,1));
	switch ( get_type(shi) ) {
	case XLT_ERROR:
		return shi;
	case XLT_INTEGER:
		_shi = shi->integer.data;
		break;
	case XLT_FLOAT:
		_shi = shi->floating.data;
		break;
	default:
		goto type_missmatch;
	}
	bo = eval(env,get_el(rec,2));
	switch ( get_type(bo) ) {
	case XLT_ERROR:
		return bo;
	case XLT_INTEGER:
		_bo = bo->integer.data;
		break;
	case XLT_FLOAT:
		_bo = bo->floating.data;
		break;
	default:
		goto type_missmatch;
	}
	new_su(ue,_dim,name,_bo,_shi);
	return 0;
inv_param_length:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_SEMANTICS_INV_PARAM_LENGTH,
		l_string(std_cm,"UnitSystem/System"),
		n_get_string("invalid param length"));
inval_attr:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"UnitSystem/System"),
		n_get_string("invalid attribute parameter"));
type_missmatch:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"UnitSystem/System"),
		List(n_get_string("type missmatch"),
			-1)
		);
}

XL_SEXP *
us_alias(UNIT_ENV * ue,XLISP_ENV * env,XL_SEXP * rec,XL_SEXP * sym)
{
XL_SEXP * shi,* bo;
double _shi,_bo;
L_CHAR * name;
L_CHAR * dim;
L_CHAR * new;
L_CHAR * rate;
double _rate;
DIMENSION _dim[DIM];

	if ( list_length(rec) != 1 )
		goto inv_param_length;

	name = get_sf_attribute(sym->symbol.field,l_string(std_cm,"name"));
	if ( name == 0 )
		goto inval_attr;
	dim = get_sf_attribute(sym->symbol.field,l_string(std_cm,"dim"));
	if ( dim == 0 )
		goto inval_attr;
	rate = get_sf_attribute(sym->symbol.field,l_string(std_cm,"rate"));
	if ( rate == 0 )
		_rate = 1;
	else {
		sscanf(n_string(std_cm,rate),"%lf",&_rate);
	}
	name2dim(ue,_dim,dim);
	new_ua(ue,_dim,name);
	return 0;
inv_param_length:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_SEMANTICS_INV_PARAM_LENGTH,
		l_string(std_cm,"UnitSystem/System"),
		n_get_string("invalid param length"));
inval_attr:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"UnitSystem/System"),
		n_get_string("invalid attribute parameter"));
type_missmatch:
	return get_error(
		rec->h.file,
		rec->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"UnitSystem/System"),
		List(n_get_string("type missmatch"),
			-1)
		);
}

XL_SEXP *
xl_UnitSystem(XLISP_ENV * env,XL_SEXP * s,
	XLISP_ENV * a,
	XL_SYM_FIELD * sf)
{
L_CHAR * name, * inherit;
UNIT_ENV * org_ue;
UNIT_ENV * new_ue;
XL_SEXP * rec,* sym;
XL_SEXP * ret;
int f;
	inherit = get_sf_attribute(sf,l_string(std_cm,"inherit"));
	name = get_sf_attribute(sf,l_string(std_cm,"name"));
	if ( inherit ) {
		if ( l_strcmp(inherit,l_string(std_cm,"new")) == 0 )
			org_ue = 0;
		else {
			org_ue = search_uenv_name(inherit);
			if ( org_ue == 0 )
				goto undef_obj;
		}
	}
	else {
		org_ue = get_uenv(env);
		if ( org_ue == 0 )
			org_ue = new_uenv();
	}
	if ( list_length(s) == 1 ) {
		set_uenv(env,org_ue);
		return 0;
	}
	if ( org_ue )
		new_ue = copy_uenv1(org_ue);
	else	new_ue = new_uenv();
	s = cdr(s);
	f = 0;
	ret = 0;
	for ( ; get_type(s) == XLT_PAIR ; s = cdr(s) ) {
		rec = car(s);
		if ( get_type(rec) != XLT_PAIR )
			goto type_missmatch_inval;
		sym = car(rec);
		if ( get_type(sym) != XLT_SYMBOL )
			goto type_missmatch_inval;
		if ( l_strcmp(sym->symbol.data,
				l_string(std_cm,"System"))
				== 0 ) {
			if ( f == 1 )
				goto system_after_alias;
			ret = us_system(new_ue,env,rec,sym);
		}
		else if ( l_strcmp(sym->symbol.data,
				l_string(std_cm,"Alias"))
				== 0 ) {
			if ( f == 0 ) {
				system_unit_alias(new_ue);
				if ( org_ue )
					copy_uenv2(new_ue,org_ue);
			}
			f = 1;
			ret = us_alias(new_ue,env,rec,sym);
		}
		else	goto type_missmatch_inval;
		if ( get_type(ret) == XLT_ERROR )
			return ret;
	}
	if ( f == 0 ) {
		system_unit_alias(new_ue);
		if ( org_ue )
			copy_uenv2(new_ue,org_ue);
	}
	if ( name ) {
		del_uenv_name(name);
		set_uenv_name(new_ue,name);
	}
	set_uenv(env,new_ue);
	return 0;
type_missmatch_inval:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"UnitSystem"),
		List(n_get_string("invalid tag in UnitSystem element"),
			-1)
		);
undef_obj:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_OBJECT,
		l_string(std_cm,"UnitSystem"),
		List(n_get_string("undefined unit environment"),
			-1)
		);
system_after_alias:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"UnitSystem"),
		List(n_get_string("System tag after Alias tags"),
			-1)
		);
}


