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


XL_SEXP * xl_Print();

void
init_Print(XLISP_ENV * env)
{
	set_env(env,l_string(std_cm,"Print"),
		get_func_prim(xl_Print,FO_APPLICATIVE,0,2,2));
}

L_CHAR *
_xl_l_strcat(L_CHAR * str1, L_CHAR * str2)
{
L_CHAR * ret;
L_CHAR * p;
int l1, l2;
	if ( str1 == 0 )
		l1 = 0;
	else
		l1 = l_strlen(str1);
	l2 = l_strlen(str2);
	ret = (L_CHAR *)d_alloc(sizeof(L_CHAR)*(l1+l2+1),163);
	p = ret + l1;
	if ( str1 != 0 )
		l_strcpy(ret,str1);
	l_strcpy(p,str2);
	if ( str1 != 0 )
		d_f_ree(str1);
	return ret;
}

L_CHAR *
_xl_Print_sexp(XL_SEXP * s,L_CHAR * str,XL_SEXP **ee)
{
int t;
int n;
char * cp;
XL_SEXP * rr;
        switch ( get_type(s) ) {
	case 0:
		str = _xl_l_strcat(str,l_string(std_cm,"()"));
		break;
	case XLT_ERROR:
		*ee = s;
		return 0;
	case XLT_PAIR:
		str = _xl_l_strcat(str,l_string(std_cm,"("));
		for ( ; (t = get_type(s)) == XLT_PAIR ; ) {
			str = _xl_Print_sexp(car(s),str,ee);
			s = cdr(s);
			if ( get_type(s) )
				str = _xl_l_strcat(str,l_string(std_cm," "));
		}
		if ( t == 0 ) {
			str = _xl_l_strcat(str,l_string(std_cm,")"));
		}
		else {
			str = _xl_l_strcat(str,l_string(std_cm,"."));
			str = _xl_Print_sexp(s,str,ee);
			str = _xl_l_strcat(str,l_string(std_cm,")"));
		}
		break;
        case XLT_SYMBOL:
		if ( s->symbol.field ) {
			char c[256];
			XL_SYM_FIELD * sf;
			str = _xl_l_strcat(str,l_string(std_cm,"["));
			str = _xl_l_strcat(str,s->symbol.data);
			for ( sf = s->symbol.field ; sf ; sf = sf->next ) {
				sprintf(c," %s=\"%s\"",
                                        n_string(std_cm,sf->name),
                                        n_string(std_cm,sf->data));
				str = _xl_l_strcat(str,l_string(std_cm,c));
			}
			str = _xl_l_strcat(str,l_string(std_cm,"]"));
		}
		else {
			str = _xl_l_strcat(str,s->symbol.data);
		}
                break;
	case XLT_STRING:
		{
		L_CHAR * p1;
		L_CHAR * buf;
		int len;
			p1 = s->string.data;
			str = _xl_l_strcat(str,l_string(std_cm,"\""));
			buf = d_alloc(10,164);
			for ( ; ; ) {
				for ( len = 0 ; p1[len] != '\n' &&
					p1[len] != '\r' &&
					p1[len] != 0;
					len ++ ) ;
				buf = d_re_alloc(buf,(len+1)*sizeof(L_CHAR));
				memcpy(buf,p1,len*sizeof(L_CHAR));
				buf[len] = 0;
				if ( p1[len] == 0 ) {
					str = _xl_l_strcat(str,buf);
					str = _xl_l_strcat(str,l_string(std_cm,"\""));
					break;
				}
				else {
					str = _xl_l_strcat(str,buf);
					str = _xl_l_strcat(str,l_string(std_cm,"\\n"));
				}
				p1 = &p1[len+1];
			}
			d_f_ree(buf);
		}
		break;
	case XLT_INTEGER:
		{
	/*
		t = s->integer.data;
		d = (double)t;
		n = (int)floor(log10(d));
		cp = (char *)d_alloc(n*2,165);
		sprintf(cp,"%i",t);
		str = _xl_l_strcat(str,l_string(std_cm,cp));
		d_f_ree(cp);
	*/
		char c[256];
		sprintf(c,"%i",s->integer.data);
		str = _xl_l_strcat(str,l_string(std_cm,c));
		}
		if ( s->integer.unit )
			str = _xl_l_strcat(str,s->integer.unit);
		break;
	case XLT_FLOAT:
		{
		char c[256];
		sprintf(c,"%lf",s->floating.data);
		str = _xl_l_strcat(str,l_string(std_cm,c));
		if ( s->floating.unit )
			str = _xl_l_strcat(str,s->floating.unit);
		}
		break;
	case XLT_FUNC:
		switch ( s->func.type ) {
			char c[256];
		case FT_PRIM:
			sprintf(c,"[prim:0x%x]",s->func.prim);
			str = _xl_l_strcat(str,l_string(std_cm,c));
			break;
		case FT_LAMBDA:
			sprintf(c,"[lambda:0x%x]",s->func.l_body);
			str = _xl_l_strcat(str,l_string(std_cm,c));
			break;
		default:
			sprintf(c,"[%i]",s->func.type);
			str = _xl_l_strcat(str,l_string(std_cm,c));
			break;
		}
		break;
	case XLT_RAW:
		{
		char c[256];
		sprintf(c,"#%x#]",s->raw.size);
		str = _xl_l_strcat(str,l_string(std_cm,c));
		}
		break;
	default:
		er_panic("xl_Print(_xl_Print_sexp(1)");
	}
	return str;
}

XL_SEXP *
xl_Print(XLISP_ENV * env,XL_SEXP * s)
{
XL_SEXP * ss;
XL_SEXP * ret;
XL_SEXP * eret;
L_CHAR * str;
	ss = get_el(s,1);
	str = 0;
	str = _xl_Print_sexp(ss,str,&eret);
	if ( str == 0 ) {
		return eret;
	}
	ret = get_string(str);
	d_f_ree(str);
	return ret;
}

