static char rcsid[] = "$Id: F-qreal.c,v 1.15 2001/02/05 03:27:45 m-hirano Exp $";
/* 
 * $RWC_Release: Omni-1.6 $
 * $RWC_Copyright:
 *  Omni Compiler Software Version 1.5-1.6
 *  Copyright (C) 2002 PC Cluster Consortium
 *  
 *  This software is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License version
 *  2.1 published by the Free Software Foundation.
 *  
 *  Omni Compiler Software Version 1.0-1.4
 *  Copyright (C) 1999, 2000, 2001.
 *   Tsukuba Research Center, Real World Computing Partnership, Japan.
 *  
 *  Please check the Copyright and License information in the files named
 *  COPYRIGHT and LICENSE under the top  directory of the Omni Compiler
 *  Software release kit.
 *  
 *  
 *  $
 */

#ifdef ENABLE_QREAL

#include "F-front.h"


static expv	expv_qreal_const_assign_direct _ANSI_ARGS_((expv src, expv dst));


void
QRinit(qPtr)
     _omQReal_t *qPtr;
{
    qPtr->_mp_prec = gmpLimbSize - 1;
    qPtr->_mp_size = 0;
    qPtr->_mp_exp = 0;
    qPtr->_mp_d = (mp_limb_t *)malloc(OMNI_SIZEOF_QLIM_T * gmpLimbSize);
    if (qPtr->_mp_d == NULL) {
	fatal("can't allocate _omQReal_t.");
	return;
    }
    memset((char *)(qPtr->_mp_d), 0, OMNI_SIZEOF_QLIM_T * gmpLimbSize);
}


void
QRclean(qPtr)
     _omQReal_t *qPtr;
{
    if (qPtr->_mp_d != NULL) {
	(void)free((char *)qPtr->_mp_d);
	qPtr->_mp_d = NULL;
    }
}


void
mpf2QR(src, dst)
     mpf_t *src;
     _omQReal_t *dst;
{
    __mpf_struct *sPtr = (__mpf_struct *)src;
    
    dst->_mp_prec = sPtr->_mp_prec;
    dst->_mp_size = sPtr->_mp_size;
    dst->_mp_exp = sPtr->_mp_exp;
    memcpy((char *)(dst->_mp_d), (char *)(sPtr->_mp_d),
	   OMNI_SIZEOF_QLIM_T * gmpLimbSize);
}


void
QR2mpf(src, dst)
     _omQReal_t *src;
     mpf_t *dst;
{
    __mpf_struct *dPtr = (__mpf_struct *)dst;

    dPtr->_mp_prec = src->_mp_prec;
    dPtr->_mp_size = src->_mp_size;
    dPtr->_mp_exp = src->_mp_exp;
    memcpy((char *)(dPtr->_mp_d), (char *)(src->_mp_d),
	   OMNI_SIZEOF_QLIM_T * gmpLimbSize);
}

     
void
str2QR(str, dst)
     char *str;
     _omQReal_t *dst;
{
    mpf_t nVal;

    mpf_init_set_str(nVal, str, 10);
    mpf2QR(&nVal, dst);
    mpf_clear(nVal);
}


#define QLIM_BIT (OMNI_SIZEOF_QLIM_T * CHAR_BIT)
#define EXTRA_OUTPUT_PREC (QLIM_BIT * 2)

char *
mpf2str(val)
     mpf_t val;
{
    mp_exp_t exp;
    char *buf = NULL;
    int len;
    char *vStr;
    char *ret = NULL;
    mpf_t hpVal;

    mpf_init_set(hpVal, val);
    mpf_set_prec(hpVal, (unsigned long int)(qRealPrec + EXTRA_OUTPUT_PREC));
    vStr = mpf_get_str(NULL, &exp, 10, 0, hpVal);
    len = strlen(vStr);
    buf = (char *)malloc(sizeof(char) * (len + 1024));
    if (buf == NULL) {
	fatal("can't allocate a buffer for quad/multiple precision conversion.");
	return NULL;
    }

    if (vStr[0] == '-') {
	sprintf(buf, "-0.%s0000E%d", vStr + 1, (int)exp);
    } else {
	sprintf(buf, "0.%s0000E%d", vStr, (int)exp);
    }
    
    (void)free(vStr);
    mpf_clear(hpVal);

    ret = strdup(buf);
    (void)free(buf);

    return ret;
}


static int	qr_pow_qi _ANSI_ARGS_((mpf_t a, mpf_t q0, signed long int n));

static int
qr_pow_qi(a, q0, n)
     mpf_t a;
     mpf_t q0;
     signed long int n;
{
    signed long int i;
    mpf_t q0V, aV;
    int ret = FALSE;

    mpf_init_set(q0V, q0);
    mpf_init_set_str(aV, "1.0", 10);

    if (n == 0) {
	goto done;
    } else if (n < 0) {
	if (mpf_sgn(q0V) == 0) {
	    error("zero raised to negative power, divide by zero");
	    goto errDone;
	}
	n = -n;
	mpf_div(q0V, aV, q0V);
    }
    for (i = 0; i < n; i++) {
	mpf_mul(aV, aV, q0V);
    }

    done:
    ret = TRUE;
    mpf_set(a, aV);
    errDone:
    mpf_clear(q0V);
    mpf_clear(aV);
    return ret;
}


expv
expv_qreal_const_to_qreal(qV)
     expv qV;
{
    TYPE_DESC tp = EXPV_TYPE(qV);
    expv retV = NULL;

    if (TYPE_BASIC_TYPE(tp) != TYPE_QREAL) {
	fatal("expv_qreal_const_to_qreal: not a quad-real.");
	return NULL;
    }
    if (EXPR_CODE(qV) != QREAL_CONSTANT) {
	return qV;
    }

    retV = allocate_temp(type_QREAL);
    output_expr_statement(expv_call_runtime("_str2QR", NULL,
					    list2(LIST,
						  EXPV_QREAL_CONST(qV),
						  expv_get_address(retV))));
    return retV;
}


expv
expv_qreal_const_assign_direct(qV, qDst)
     expv qV;
     expv qDst;
{
    TYPE_DESC tp = EXPV_TYPE(qV);

    if (TYPE_BASIC_TYPE(tp) != TYPE_QREAL) {
	fatal("expv_qreal_const_assign_direct: not a quad-real.");
	return NULL;
    }
    if (EXPR_CODE(qV) != QREAL_CONSTANT) {
	fatal("expv_qreal_const_assign_direct: right is not a quad-real constant.");
	return NULL;
    }

    return expv_call_runtime("_str2QR", NULL,
			     list2(LIST,
				   EXPV_QREAL_CONST(qV),
				   expv_get_address(qDst)));
}


expv
expv_qreal_const_type_conversion(tp, v)
     TYPE_DESC tp;
     expv v;
{
    TYPE_DESC vt = EXPV_TYPE(v);
    char *str = NULL;

    if (TYPE_BASIC_TYPE(vt) != TYPE_QREAL) {
	fatal("expv_qreal_const_type_conversion: not a quad-real.");
	return NULL;
    }
    if (EXPV_CODE(v) != QREAL_CONSTANT) {
	fatal("expv_qreal_const_type_conversion: not a quad-real constant.");
	return NULL;
    }

    str = EXPV_STR(((expv)EXPV_QREAL_CONST(v)));
    switch (TYPE_BASIC_TYPE(tp)) {

	case TYPE_QREAL: {
	    return expv_qreal_const_to_qreal(v);
	}

	case TYPE_REAL:
	case TYPE_DREAL: {
	    return expv_float_term(FLOAT_CONSTANT, tp, atof(str));
	}

	case TYPE_SHORT:
	case TYPE_INT:
	case TYPE_LOGICAL: {
	    double d = atof(str);
	    int i = (int)d;
	    return expv_int_term(INT_CONSTANT, tp, i);
	}

#ifdef HAS_INT64
	case TYPE_LONGLONG: {
	    double d = atof(str);
	    _omInt64_t i64 = (_omInt64_t)d;
	    expv ret = expv_longlong_term(LONGLONG_CONSTANT, tp, 0, 0);
	    expr_int64_save(ret, i64);
	    return ret;
	}
#endif /* HAS_INT64 */
	
	case TYPE_COMPLEX: {
	    float d = (float)atof(str);
	    return expv_c_cons(expv_float_term(FLOAT_CONSTANT, type_REAL, d),
			       expv_float_0,
			       FALSE);
	}

	case TYPE_DCOMPLEX: {
	    double d = atof(str);
	    return expv_z_cons(expv_float_term(FLOAT_CONSTANT, type_DREAL, d),
			       expv_double_0,
			       FALSE);
	}

	default: {
	    error("expv_qreal_const_type_consversion: not a numeric type.");
	    return NULL;
	}
    }

    return NULL;
}


expv
expv_qreal_type_conversion(tp, v)
     TYPE_DESC tp;
     expv v;
{
    TYPE_DESC vt = EXPV_TYPE(v);

    if (TYPE_BASIC_TYPE(vt) == TYPE_BASIC_TYPE(tp) &&
	TYPE_BASIC_TYPE(tp) == TYPE_QREAL) {
	if (EXPV_CODE(v) == QREAL_CONSTANT) {
	    return expv_qreal_const_type_conversion(tp, v);
	} else {
	    return v;
	}
    } else if (TYPE_BASIC_TYPE(vt) == TYPE_QREAL) {
	/* From qreal to other. */
	if (EXPV_CODE(v) == QREAL_CONSTANT) {
	    return expv_qreal_const_type_conversion(tp, v);
	} else {
	    expv dV = allocate_temp(type_DREAL);
	    expv callArgs = list2(LIST, expv_get_address(v), expv_get_address(dV));
	    output_expr_statement(expv_call_runtime("_QR2double", NULL, callArgs));
	    /* cast to desired type */
	    return expv_cons(CAST_EXPR, tp, dV, NULL);
	}
    } else if (TYPE_BASIC_TYPE(tp) == TYPE_QREAL) {
	/* From other to qreal. */
	char *runtime = NULL;
	expv newV = NULL;
	expv callArgs = NULL;
	expv retV = allocate_temp(type_QREAL);

	switch (TYPE_BASIC_TYPE(vt)) {
#ifdef HAS_INT64
	    case TYPE_LONGLONG: {
#if (SIZEOF_UNSIGNED_LONG > 4)
		/*
		 * sizeof(long long int) == sizeof(long int) == 8.
		 */
		newV = v;
#else
		/*
		 * sizeof(long long int) != sizeof(long int) == 4.
		 */
		newV = expv_type_conversion(type_INT, v);
#endif /* SIZEOF_UNSIGNED_LONG ... */
		runtime = "_long2QR";
		break;
	    }
#endif /* HAS_INT64 */
	    case TYPE_SHORT:
	    case TYPE_INT: {
#if (SIZEOF_UNSIGNED_LONG > 4)
		newV = expv_type_conversion(type_LONGLONG, v);
#else
		newV = v;
#endif /* SIZEOF_UNSIGNED_LONG ... */
		runtime = "_long2QR";
		break;
	    }
	    case TYPE_REAL:
	    case TYPE_DREAL: {
		if (TYPE_BASIC_TYPE(vt) == TYPE_REAL) {
		    newV = expv_type_conversion(type_DREAL, v);
		} else {
		    newV = v;
		}
		runtime = "_double2QR";
		break;
	    }
	    case TYPE_COMPLEX:
	    case TYPE_DCOMPLEX: {
		newV = expv_complex_real(type_DREAL, v);
		runtime = "_double2QR";
		break;
	    }
	    default: {
		fatal("expv_qreal_tyoe_conversion: not a numeric type.");
		return NULL;
	    }
	}
	callArgs = list2(LIST, expv_get_address(newV), expv_get_address(retV));
	output_expr_statement(expv_call_runtime(runtime, NULL, callArgs));
	return retV;
    }
    return NULL;
}


expv
expv_qreal_assignment(vL, vR)
     expv vL;
     expv vR;
{
    TYPE_DESC lt, rt;
    expv retV = NULL;

    lt = EXPV_TYPE(vL);
    rt = EXPV_TYPE(vR);

    if (TYPE_BASIC_TYPE(lt) == TYPE_BASIC_TYPE(rt) &&
	TYPE_BASIC_TYPE(lt) == TYPE_QREAL) {
	if (EXPR_CODE(vR) == QREAL_CONSTANT) {
	    if (doQCZFolding == TRUE) {
		retV = expv_cons(ASSIGN_EXPR, NULL,
				 vL,
				 expv_qreal_const_DATA_initialize(vR));
	    } else {
		retV = expv_qreal_const_assign_direct(vR, vL);
	    }
	} else {
	    /* Just copy. */
	    retV = expv_cons(ASSIGN_EXPR, NULL, vL, vR);
	}
    } else {
	retV = expv_cons(ASSIGN_EXPR, lt,
			 vL,
			 expv_qreal_type_conversion(lt, vR));
    }

    return retV;
}


int
expv_const_convert_to_mpf(v, mpV)
     expv v;
     mpf_t mpV;
{
    if (!(IS_NUMERIC_CONST_V(v))) {
	fatal("expv_const_convert_to_mpf: tried to convert non numeric to quad real.");
	return FALSE;
    }

    if (EXPV_TYPE(v) == NULL) {
	fatal("expv_const_convert_to_mpf: numeric constant without type??.");
	return FALSE;
    }

    switch (TYPE_BASIC_TYPE(EXPV_TYPE(v))) {
#ifdef HAS_INT64
	case TYPE_LONGLONG: {
#if (SIZEOF_UNSIGNED_LONG > 4)
	    /*
	     * sizeof(long long int) == sizeof(long int) == 8.
	     */
	    _omInt64_t i64 = (_omInt64_t)EXPV_INT64_VALUE(v);
	    mpf_set_si(mpV, (long int)i64);
#else
	    /*
	     * sizeof(long long int) != sizeof(long int) == 4.
	     */
	    _omInt64_t i64 = (_omInt64_t)EXPV_INT64_VALUE(v);
	    int i32 = (int)((_omAddrInt_t)i64);
	    mpf_set_si(mpV, (long int)i32);
#endif /* SIZEOF_UNSIGNED_LONG ... */
	    break;
	}
#endif /* HAS_INT64 */
	case TYPE_LOGICAL:
	case TYPE_CHAR:
	case TYPE_SHORT:
	case TYPE_INT: {
#if (SIZEOF_UNSIGNED_LONG > 4)
	    _omInt64_t i64 = (_omInt64_t)EXPV_INT_VALUE(v);
	    mpf_set_si(mpV, (long int)i64);
#else
	    int i32 = (int)EXPV_INT_VALUE(v);
	    mpf_set_si(mpV, (long int)i32);
#endif /* SIZEOF_UNSIGNED_LONG ... */
	    break;
	}
	case TYPE_REAL:
	case TYPE_DREAL: {
	    double d = EXPV_FLOAT_VALUE(v);
	    mpf_set_d(mpV, d);
	    break;
	}

	case TYPE_QREAL: {
	    char *str = EXPV_STR(((expv)EXPV_QREAL_CONST(v)));
	    mpf_set_str(mpV, str, 10);
	    break;
	}

	case TYPE_COMPLEX:
	case TYPE_DCOMPLEX: {
	    expv re = expv_complex_real(type_DREAL, v);
	    double d = EXPV_FLOAT_VALUE(re);
	    mpf_set_d(mpV, d);
	    break;
	}
	default: {
	    fatal("expv_const_convert_to_mpf: not a numeric constant.");
	    return FALSE;
	}
    }
    return TRUE;
}


int
expv_const_convert_to_qreal(v, valPtr)
     expv v;
     _omQReal_t *valPtr;
{
    mpf_t mpV;
    int ret;

    mpf_init(mpV);

    ret = expv_const_convert_to_mpf(v, mpV);
    if (ret == TRUE) {
	mpf2QR(&mpV, valPtr);
    }
    
    mpf_clear(mpV);
    return ret;
}    


/* stack struct for quad real folding */
typedef struct _qrStackRec {
    mpf_t qr;
    struct _qrStackRec *next;
} qrStack;


static qrStack *	initQrStack _ANSI_ARGS_((void));
static mpf_t *		getQrStack _ANSI_ARGS_((qrStack *qPtr));
static void		freeQrStack _ANSI_ARGS_((qrStack *qPtr));

/* head allocater */
static qrStack *
initQrStack()
{
    qrStack *ret = (qrStack *)malloc(sizeof(qrStack));
    mpf_init(ret->qr);
    ret->next = NULL;

    return ret;
}

static mpf_t *
getQrStack(qPtr)
     qrStack *qPtr;
{
    while (qPtr->next != NULL) {
	qPtr = qPtr->next;
    }
    qPtr->next = (qrStack *)malloc(sizeof(qrStack));
    qPtr->next->next = NULL;
    mpf_init(qPtr->next->qr);
    return &(qPtr->next->qr);
}


static void
freeQrStack(qPtr)
     qrStack *qPtr;
{
    if (qPtr->next != NULL) {
	freeQrStack(qPtr->next);
    }
    mpf_clear(qPtr->qr);
    free(qPtr);
}


static mpf_t *
qrealConstFolding(v, qPtr)
     expv v;
     qrStack *qPtr;
{
    mpf_t *tVal;

    if (EXPV_CODE(v) == COMPLEX_CONSTANT ||
	EXPV_CODE(v) == COMPLEX_NODE) {
	fatal("qrealConstFolding: not here. must be treat as complex constant.");
	return NULL;
    }

    /* terminal */
    if (EXPR_CODE_IS_TERMINAL_OR_CONST(EXPV_CODE(v))) {
	tVal = getQrStack(qPtr);
	v = compile_terminal_node(v);
	if (expv_const_convert_to_mpf(v, *tVal) == FALSE) {
	    return NULL;
	} else {
	    goto Done;
	}
    }

    tVal = getQrStack(qPtr);
    switch (EXPV_CODE(v)) {

	case F_UNARY_MINUS_EXPR:
	case UNARY_MINUS_EXPR: {
	    mpf_t *t1 = qrealConstFolding(EXPR_ARG1(v), qPtr);
	    if (t1 == NULL) {
		return NULL;
	    }
	    mpf_neg(*tVal, *t1);
	    break;
	}

	case F_PLUS_EXPR:
	case PLUS_EXPR: {
	    mpf_t *t1 = qrealConstFolding(EXPR_ARG1(v), qPtr); 
	    mpf_t *t2 = qrealConstFolding(EXPR_ARG2(v), qPtr);
	    if (t1 == NULL || t2 == NULL) {
		return NULL;
	    }
	    mpf_add(*tVal, *t1, *t2);
	    break;
	}

	case F_MINUS_EXPR:
	case MINUS_EXPR: {
	    mpf_t *t1 = qrealConstFolding(EXPR_ARG1(v), qPtr); 
	    mpf_t *t2 = qrealConstFolding(EXPR_ARG2(v), qPtr);
	    if (t1 == NULL || t2 == NULL) {
		return NULL;
	    }
	    mpf_sub(*tVal, *t1, *t2);
	    break;
	}

	case F_MUL_EXPR:
	case MUL_EXPR: {
	    mpf_t *t1 = qrealConstFolding(EXPR_ARG1(v), qPtr); 
	    mpf_t *t2 = qrealConstFolding(EXPR_ARG2(v), qPtr);
	    if (t1 == NULL || t2 == NULL) {
		return NULL;
	    }
	    mpf_mul(*tVal, *t1, *t2);
	    break;
	}

	case F_DIV_EXPR:
	case DIV_EXPR: {
	    mpf_t *t1 = qrealConstFolding(EXPR_ARG1(v), qPtr); 
	    mpf_t *t2 = qrealConstFolding(EXPR_ARG2(v), qPtr);
	    if (t1 == NULL || t2 == NULL) {
		return NULL;
	    }
	    mpf_div(*tVal, *t1, *t2);
	    break;
	}

	case F_POWER_EXPR: {
	    expv v1 = EXPR_ARG1(v);
	    expv v2 = EXPR_ARG2(v);
	    if (expr_is_constant(v1) == FALSE) {
		return NULL;
	    } else {
		v1 = expr_constant_value(v1, FALSE);
	    }
	    if (expr_is_constant(v2) == FALSE) {
		return NULL;
	    } else {
		v2 = expr_constant_value(v2, FALSE);
	    }
	    if (!(IS_NUMERIC_CONST_V(v1)) ||
		!(IS_NUMERIC_CONST_V(v2))) {
		return NULL;
	    }
	    if (IS_INT_CONST_V(v2)) {
		mpf_t *qV1 = qrealConstFolding(v1, qPtr);
		signed long int n;
#if (SIZEOF_UNSIGNED_LONG >= 8)
		n = (signed long)EXPV_INT64_VALUE(v2);
#else
		n = (signed long)EXPV_INT_VALUE(v2);
#endif /* (SIZEOF_UNSIGNED_LONG >= 8) */
		if (qr_pow_qi(*tVal, *qV1, n) != TRUE) {
		    return NULL;
		}
	    } else {
		error("power of quad-real is not supported yet.");
		return NULL;
	    }
	    break;
	}

	default: {
	    error("unknown opcode to reduce.");
	    return NULL;
	}
    }

    Done:
    return tVal;
}


expv
expv_qreal_const_reduce(v)
     expv v;
{
    expv ret = NULL; /* will be created as quad-real constant. */
    qrStack *top = initQrStack();
    mpf_t *val = qrealConstFolding(v, top);
    char *str = NULL;

    if (val == NULL) {
	freeQrStack(top);
	return NULL;
    }

    str = mpf2str(*val);
    ret = expv_qreal_term(QREAL_CONSTANT, type_QREAL,
			  expv_str_term(STRING_CONSTANT,
					type_char(strlen(str)),
					str));
    
    freeQrStack(top);
    return ret;
}


expv
expv_qreal_const_DATA_initialize(v)
     expv v;
{
    ID vId = NULL;
    expv dataVar;
    SYMBOL vSym;
    expr qx;

    if (TYPE_BASIC_TYPE(EXPV_TYPE(v)) != TYPE_QREAL &&
	EXPV_CODE(v) != QREAL_CONSTANT) {
	return NULL;
    }

    dataVar = allocate_temp2(EXPV_TYPE(v), &vId);
    vSym = ID_SYM(vId);
    qx = make_qreal_enode(F_QREAL_CONSTANT,
			  EXPV_STR(((expv)EXPV_QREAL_CONST(v))));

    compile_DATA_decl(list1(LIST,
			    list2(LIST,
				  list1(LIST, make_enode(IDENT, (void *)vSym)),
				  list1(LIST, qx))));

    return dataVar;
}

#else
static int __qReal_not_supported = 1;
#endif /* ENABLE_QREAL */