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

XL_SEXP * xl_Cast();


char type_table[XLT_MAX][12] = {
	"null",
	"error",
	"list",
	"symbol",
	"string",
	"integer",
	"floating",
	"function",
	"delay",
	"pointer",
	"raw",
	"environment",
};


void
init_Cast(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Cast"),
		get_func_prim(xl_Cast,FO_APPLICATIVE,0,2,2));
}

XL_SEXP *
cast_symbol2string(XL_SEXP * s)
{
L_CHAR * buf, * ptr;
int len;
XL_SYM_FIELD * sf;
XL_SEXP * ret;
	if ( s->symbol.field ) {
		len = l_strlen(s->symbol.data)+1;
		for ( sf = s->symbol.field ; sf ; sf = sf->next ) {
			len += l_strlen(sf->name) +
				l_strlen(sf->data) + 4;
		}
		len += 2;
		buf = d_alloc(len*sizeof(L_CHAR));
		buf[0] = '[';
		ptr = &buf[1];
		l_strcpy(ptr,s->symbol.data);
		ptr += l_strlen(ptr);
		for ( sf = s->symbol.field ; sf ; sf = sf->next ) {
			*ptr++ = ' ';
			l_strcpy(ptr,sf->name);
			ptr += l_strlen(ptr);
			*ptr++ = '=';
			*ptr++ = '\"';
			l_strcpy(ptr,sf->data);
			ptr += l_strlen(ptr);
			*ptr++ = '\"';
		}
		*ptr ++ = ']';
		*ptr = 0;
		ret = get_string(buf);
		d_f_ree(buf);
		return ret;
	}
	else {
		return get_string(s->symbol.data);
	}
}

XL_SEXP *
cast_integer2string(XL_SEXP * s,L_CHAR * opt)
{
char * buf;
XL_SEXP * ret;
L_CHAR * retstring;
void gc_text();
	if ( opt && l_strcmp(opt,l_string(std_cm,"char")) == 0 ) {
		retstring = mmalloc(sizeof(L_CHAR)*2,gc_text);
		retstring[0] = s->integer.data;
		retstring[1] = 0;
		ret = n_get_string("");
		ret->string.data = retstring;
		return ret;
	}
	if ( s->integer.unit ) {
		buf = d_alloc(l_strlen(s->integer.unit)*sizeof(L_CHAR) + 50);
		sprintf(buf,"%i%s",s->integer.data,
			n_string(std_cm,s->integer.unit));
		ret = n_get_string(buf);
		d_f_ree(buf);
		return ret;
	}
	else {
		buf = d_alloc(50);
		sprintf(buf,"%i",s->integer.data);
		ret = n_get_string(buf);
		return ret;
	}
}

XL_SEXP *
cast_floating2string(XL_SEXP * s)
{
char * buf;
XL_SEXP * ret;
	if ( s->floating.unit ) {
		buf = d_alloc(l_strlen(s->floating.unit)*sizeof(L_CHAR) + 100);
		sprintf(buf,"%lf%s",s->floating.data,
			n_string(std_cm,s->floating.unit));
		ret = n_get_string(buf);
		d_f_ree(buf);
		return ret;
	}
	else {
		buf = d_alloc(100);
		sprintf(buf,"%lf",s->floating.data);
		ret = n_get_string(buf);
		return ret;
	}
}

L_CHAR * 
discard_space(L_CHAR * str)
{
L_CHAR * ret;
int len;
L_CHAR * p1, * p2;
	len = l_strlen(str);
	ret = d_alloc((len+1)*sizeof(L_CHAR));
	p1 = ret;
	p2 = str;
	for ( ; *p2 ; p2 ++ ) {
		switch ( *p2 ) {
		case ' ':
		case '\t':
		case '\n':
		case '\r':
			break;
		default:
			*p1 = *p2;
			p1 ++;
		}
	}
	*p1 = 0;
	return ret;
}

XL_SEXP *
cast_string2integer(XL_SEXP * s)
{
char buf[16];
int i;
L_CHAR * ptr, * bptr;
int d;
int hex_oct_dec;
XL_SEXP * ret;
	i = 0;
	bptr = discard_space(s->string.data);
	ptr = bptr;
	if ( bptr[0] == '0' ) {
		buf[0] = '0';
		if ( bptr[1] == 'x' ||
				bptr[1] == 'X' ) {
			hex_oct_dec = 0;
			buf[1] = 'x';
			ptr = &bptr[2];
			i = 2;
		}
		else	hex_oct_dec = 1;
	}
	else {
		hex_oct_dec = 2;
	}
	for ( ; *ptr ; ptr ++ ) {
		if ( '0' <= *ptr && *ptr <= '7' )
			goto ok;
		if ( hex_oct_dec == 1 )
			break;
		if ( '8' <= *ptr && *ptr <= '9' )
			goto ok;
		if ( hex_oct_dec == 2 )
			break;
		if ( 'A' <= *ptr && *ptr <= 'F' )
			goto ok;
		if ( 'a' <= *ptr && *ptr <= 'f' )
			goto ok;
		break;
	ok:
		buf[i++] = *ptr;
		if ( i >= 15 )
			break;
	}
	buf[i] = 0;
	sscanf(buf,"%i",&d);
	if ( *ptr == 0 )
		ptr = 0;
	ret = get_integer(d,ptr);
	d_f_ree(bptr);
	return ret;
}
XL_SEXP *
cast_string2floating(XL_SEXP * s)
{
L_CHAR * p;
L_CHAR * u;
L_CHAR * ptr;
float frt;
XL_SEXP * ret;
	ptr = discard_space(s->string.data);
	p = ptr;
	switch ( *p ) {
	case '+':
		p ++;
	case '-':
		p ++;
	default:
		break;
	}
under_point:
	for ( ; p ; p ++ ) {
		if ( *p < '0' )
			break;
		if ( *p > '9' )
			break;
	}
	switch ( *p ) {
	case 0:
		goto end;
	case '.':
		p ++;
		goto under_point;
	case 'e':
	case 'E':
		p ++;
		goto exp;
	default:
		goto end;
	}
exp:
	switch ( *p ) {
	case '+':
		p ++;
		break;
	case '-':
		p ++;
		break;
	default:
		break;
	}
	for ( ; p ; p ++ ) {
		if ( *p < '0' )
			break;
		if ( *p > '9' )
			break;
	}
end:
	u = ll_copy_str(p);
	*p = 0;
	sscanf(n_string(std_cm,ptr),"%f",&frt);
	ret = get_floating(frt,u);
	d_f_ree(u);
	d_f_ree(ptr);
	return ret;
}

XL_SEXP *
cast_string2string(XL_SEXP * from,L_CHAR * opt)
{
L_CHAR * ret, * pp;
XL_SEXP * _ret;
	if ( opt == 0 )
		return from;
	ret = ll_copy_str(from->string.data);
	if ( l_strcmp(opt,l_string(std_cm,"small")) == 0 ) {
		pp = ret;
		for ( ; *pp ; pp ++ )
			if ( 'A' <= *pp && *pp <= 'Z' )
				*pp = *pp + 'a' - 'A';
	}
	else if ( l_strcmp(opt,l_string(std_cm,"capital")) == 0 ) {
		pp = ret;
		for ( ; *pp ; pp ++ )
			if ( 'a' <= *pp && *pp <= 'z' )
				*pp = *pp + 'A' - 'a';
	}
	_ret = get_string(ret);
	d_f_ree(ret);
	return _ret;
}

XL_SEXP *
xl_Cast(XLISP_ENV * env,XL_SEXP * s,XLISP_ENV * a_e,XL_SYM_FIELD * sf)
{
int to;
XL_SEXP * from;
char * str;
XL_SEXP * ret;
L_CHAR * opt;
	to = -1;
	opt = 0;
	for ( ; sf ; sf = sf->next ) {
		if ( l_strcmp(sf->name,l_string(std_cm,"type")) == 0 ) {
			str = n_string(std_cm,sf->data);
			for ( to = 0 ; to < XLT_MAX ; to ++ ) {
				if ( type_table[to][0] == 0 )
					er_panic("xl_Cast");
				if ( strcmp(type_table[to],str) == 0 )
					break;
			}
		}
		else if ( l_strcmp(sf->name,l_string(std_cm,"option")) == 0 ) {
			opt = sf->data;
		}
	}
	if ( to == XLT_MAX || to == -1 )
		goto invalid_param;
	from = get_el(s,1);
	switch ( get_type(from) ) {
	case XLT_NULL:
		switch ( to ) {
		case XLT_NULL:
			return from;
		case XLT_ERROR:
			goto convert_error;
		case XLT_PAIR:
			return from;
		}
		break;
	case XLT_ERROR:
		return from;
	case XLT_PAIR:
		switch ( to ) {
		case XLT_PAIR:
			return from;
		}
		break;
	case XLT_SYMBOL:
		switch ( to ) {
		case XLT_SYMBOL:
			return from;
		case XLT_STRING:
			return cast_symbol2string(from);
		}
		break;
	case XLT_STRING:
		switch ( to ) {
		case XLT_SYMBOL:
			return get_symbol(from->string.data);
		case XLT_STRING:
			return cast_string2string(from,opt);
		case XLT_INTEGER:
			return cast_string2integer(from);
		case XLT_FLOAT:
			return cast_string2floating(from);
		}
		break;
	case XLT_INTEGER:
		switch ( to ) {
		case XLT_STRING:
			return cast_integer2string(from,opt);
		case XLT_INTEGER:
			return from;
		case XLT_FLOAT:
			return get_floating(from->integer.data,
					from->integer.unit);
		}
		break;
	case XLT_FLOAT:
		switch ( to ) {
		case XLT_STRING:
			return cast_floating2string(from);
		case XLT_INTEGER:
			return get_integer(from->floating.data,
				from->integer.unit);
		case XLT_FLOAT:
			return from;
		}
		break;
	case XLT_FUNC:
		switch ( to ) {
		case XLT_FUNC:
			return from;
		}
		break;
	case XLT_DELAY:
		er_panic("xl_Cast(2)");
	case XLT_PTR:
		switch ( to ) {
		case XLT_PTR:
			return from;
		}
		break;
	case XLT_RAW:
		switch ( to ) {
		case XLT_RAW:
			return from;
		}
		break;
	case XLT_ENV:
		switch ( to ) {
		case XLT_ENV:
			return from;
		}
		break;
	default:
		er_panic("xl_Cast(1)");
	}
	goto convert_error;
convert_error:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_SEMANTICS_TYPE_MISSMATCH,
		l_string(std_cm,"Cast"),
		0);
invalid_param:
	return get_error(
		s->h.file,
		s->h.line,
		XLE_PROTO_INV_PARAM,
		l_string(std_cm,"Cast"),
		n_get_string("invalid type name"));
}


