#include "f2c.h"
#include "fio.h"

#ifndef KR_headers
#undef abs
#undef min
#undef max
#include "stdlib.h"
#include "string.h"
#endif

#include "fmt.h"
#include "fp.h"
#ifndef VAX
#include "ctype.h"
#endif

int
#ifdef KR_headers
wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
#else
wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
#endif
{
	char buf[FMAX+EXPMAXDIGS+4], *s, *se;
	int d1, delta, e1, i, sign, signspace;
	double dd;
#ifdef WANT_LEAD_0
	int insert0 = 0;
#endif
#ifndef VAX
	int e0 = e;
#endif

	if(e <= 0)
		e = 2;
	if(f__scale) {
		if(f__scale >= d + 2 || f__scale <= -d)
			goto nogood;
		}
	if(f__scale <= 0)
		--d;
	if (len == sizeof(real))
		dd = p->pf;
	else
		dd = p->pd;
	if (dd < 0.) {
		signspace = sign = 1;
		dd = -dd;
		}
	else {
		sign = 0;
		signspace = (int)f__cplus;
#ifndef VAX
		if (!dd)
			dd = 0.;	/* avoid -0 */
#endif
		}
	delta = w - (2 /* for the . and the d adjustment above */
			+ 2 /* for the E+ */ + signspace + d + e);
#ifdef WANT_LEAD_0
	if (f__scale <= 0 && delta > 0) {
		delta--;
		insert0 = 1;
		}
	else
#endif
	if (delta < 0) {
nogood:
		while(--w >= 0)
			PUT('*');
		return(0);
		}
	if (f__scale < 0)
		d += f__scale;
	if (d > FMAX) {
		d1 = d - FMAX;
		d = FMAX;
		}
	else
		d1 = 0;
	sprintf(buf,"%#.*E", d, dd);
#ifndef VAX
	/* check for NaN, Infinity */
	if (!isdigit((int)buf[0])) {
		switch(buf[0]) {
			case 'n':
			case 'N':
				signspace = 0;	/* no sign for NaNs */
			}
		delta = w - strlen(buf) - signspace;
		if (delta < 0)
			goto nogood;
		while(--delta >= 0)
			PUT(' ');
		if (signspace)
			PUT(sign ? '-' : '+');
		for(s = buf; *s; s++)
			PUT(*s);
		return 0;
		}
#endif
	se = buf + d + 3;
#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
	if (f__scale != 1 && dd)
		sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
#else
	if (dd)
		sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
	else
		strcpy(se, "+00");
#endif
	s = ++se;
	if (e < 2) {
		if (*s != '0')
			goto nogood;
		}
#ifndef VAX
	/* accommodate 3 significant digits in exponent */
	if (s[2]) {
#ifdef Pedantic
		if (!e0 && !s[3])
			for(s -= 2, e1 = 2; s[0] = s[1]; s++);

	/* Pedantic gives the behavior that Fortran 77 specifies,	*/
	/* i.e., requires that E be specified for exponent fields	*/
	/* of more than 3 digits.  With Pedantic undefined, we get	*/
	/* the behavior that Cray displays -- you get a bigger		*/
	/* exponent field if it fits.	*/
#else
		if (!e0) {
			for(s -= 2, e1 = 2; (s[0] = s[1]) != 0; s++)
#ifdef CRAY
				delta--;
			if ((delta += 4) < 0)
				goto nogood
#endif
				;
			}
#endif
		else if (e0 >= 0)
			goto shift;
		else
			e1 = e;
		}
	else
 shift:
#endif
		for(s += 2, e1 = 2; *s; ++e1, ++s)
			if (e1 >= e)
				goto nogood;
	while(--delta >= 0)
		PUT(' ');
	if (signspace)
		PUT(sign ? '-' : '+');
	s = buf;
	i = f__scale;
	if (f__scale <= 0) {
#ifdef WANT_LEAD_0
		if (insert0)
			PUT('0');
#endif
		PUT('.');
		for(; i < 0; ++i)
			PUT('0');
		PUT(*s);
		s += 2;
		}
	else if (f__scale > 1) {
		PUT(*s);
		s += 2;
		while(--i > 0)
			PUT(*s++);
		PUT('.');
		}
	if (d1) {
		se -= 2;
		while(s < se) PUT(*s++);
		se += 2;
		do PUT('0'); while(--d1 > 0);
		}
	while(s < se)
		PUT(*s++);
	if (e < 2)
		PUT(s[1]);
	else {
		while(++e1 <= e)
			PUT('0');
		while(*s)
			PUT(*s++);
		}
	return 0;
	}

int
#ifdef KR_headers
wrt_F(p,w,d,len) ufloat *p; ftnlen len;
#else
wrt_F(ufloat *p, int w, int d, ftnlen len)
#endif
{
	int d1, sign, n;
	double x;
	char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;

	x= (len==sizeof(real)?p->pf:p->pd);
	if (d < MAXFRACDIGS)
		d1 = 0;
	else {
		d1 = d - MAXFRACDIGS;
		d = MAXFRACDIGS;
		}
	if (x < 0.)
		{ x = -x; sign = 1; }
	else {
		sign = 0;
#ifndef VAX
		if (!x)
			x = 0.;
#endif
		}

	if ((n = f__scale) != 0) {
		if (n > 0) {
			do x *= 10.; while(--n > 0);
		} else {
			do x *= 0.1; while(++n < 0);
		}
	}
#ifdef USE_STRLEN
	sprintf(b = buf, "%#.*f", d, x);
	n = strlen(b) + d1;
#else
	n = sprintf(b = buf, "%#.*f", d, x) + d1;
#endif

#ifndef WANT_LEAD_0
	if (buf[0] == '0' && d)
		{ ++b; --n; }
#endif
	if (sign) {
		/* check for all zeros */
		for(s = b;;) {
			while(*s == '0') s++;
			switch(*s) {
				case '.':
					s++; continue;
				case 0:
					sign = 0;
				}
			break;
			}
		}
	if (sign || f__cplus)
		++n;
	if (n > w) {
#ifdef WANT_LEAD_0
		if (buf[0] == '0' && --n == w)
			++b;
		else
#endif
		{
			while(--w >= 0)
				PUT('*');
			return 0;
			}
		}
	for(w -= n; --w >= 0; )
		PUT(' ');
	if (sign)
		PUT('-');
	else if (f__cplus)
		PUT('+');
	while((n = *b++) != 0)
		PUT(n);
	while(--d1 >= 0)
		PUT('0');
	return 0;
	}

#ifdef ENABLE_QREAL

#ifndef Abs
#define Abs(x) ((x < 0) ? -x : x)
#endif /* Abs */

#define ROUND_F	0
#define ROUND_E	1

static void
getRoundStr(mVal, buf, expPtr, w, d, mode)
     mpf_t mVal;
     char *buf;
     mp_exp_t *expPtr;
     int w;
     int d;
     int mode;
{
    char *fBuf = NULL;
    int i = 0;
    mpf_t cmFive;
    mpf_t oVal;
    int len;
    int sgn = mpf_sgn(mVal);
    int doCmFive = 0;

    if (sgn == 0) {
	mpf_init_set(oVal, mVal);
	goto getStr;
    } else {
	fBuf = (char *)malloc(sizeof(char) * (w + 4));
	if (fBuf == NULL) {
	    sig_die("can't allocate a buffer for output rounding.", 1);
	    return;
	}
	if (sgn < 0) {
	    fBuf[i++] = '-';
	}
    }

    if (mode == ROUND_E) {
	mp_exp_t tExp;
	int iExp;
	char tmpBuf[1024];
	int dig;

	mpf_get_str(tmpBuf, &tExp, 10, 1022, mVal);
#if (OMNI_SIZEOF_QEXP_T > 4)
	iExp = (int)((_omInt64_t)tExp);
#else
	iExp = (int)tExp;
#endif /* (OMNI_SIZEOF_QEXP_T > 4) */
	iExp--;
	dig = iExp - d;
#if 0
	fprintf(stderr, "debug: mant '%s' exp %d, dig %d\n", tmpBuf, iExp, dig);
#endif

	if (dig == 0) {
	    sprintf(&(fBuf[i]), "5.0E0");
	} else {
	    sprintf(&(fBuf[i]), "5.0E%d", dig);
	}
    } else if (mode == ROUND_F) {
	sprintf(&(fBuf[i]), "5.0E%d", -d -1);
    }

    mpf_init_set_str(cmFive, fBuf, 10);
    doCmFive = 1;
    mpf_init_set(oVal, mVal);

    mpf_add(oVal, oVal, cmFive);

    getStr:
    mpf_set_prec(oVal, (unsigned long int)(precOutputInBits));
    mpf_get_str(buf, expPtr, 10, w, oVal);
#if 0
    fprintf(stderr, "debug: getRound: mant '%s'\n", buf);
#endif
    len = strlen(buf);
    if (len < (w + 1)) {
	memset(buf + len, '0', (w + 1 - len));
	buf[w + 1] = '\0';
    }

    mpf_clear(oVal);
    if (doCmFive == 1) {
	mpf_clear(cmFive);
    }
#if 0
    fprintf(stderr, "debug: round with '%s' -> '%s'\n", fBuf, buf);
#endif
    if (fBuf != NULL) {
	free(fBuf);
    }
}


int
#ifdef KR_headers
wrt_QF(qPtr, w, d, len) _omQReal_t *p; int w, d; ftnlen len;
#else
wrt_QF(_omQReal_t *qPtr, int w, int d, ftnlen len)
#endif
{
    mpf_t val;
    mp_exp_t exp;
    char *mntStr = NULL;
    char *mPtr = NULL;
    int iExp;
    int i;
    int iPart = w - d - 1;	/* -1 is for '.' */
    int isNeg = 0;

#if 0
    fprintf(stderr, "debug: w = %d, d = %d, len = %d\n",
	    w, d, (int)len);
#endif 

    if (QRNaN(qPtr) == 1) {
	/*
	 * NaN
	 */
	for (i = 0; i < w; i++) {
	    PUT('*');
	}
	return 0;
    }

    mpf_init(val);
    
    QR2mpf(qPtr, &val);
    
    mntStr = (char *)malloc(sizeof(char) * (w + 2)); /* sign + NUL */
    if (mntStr == NULL) {
	goto CantOut;
    }
    mPtr = mntStr;

    (void)getRoundStr(val, mntStr, &exp, w, d, ROUND_F);
#if (OMNI_SIZEOF_QEXP_T > 4)
    iExp = (int)((_omInt64_t)exp);
#else
    iExp = (int)exp;
#endif
    iExp--;
#if 0
    fprintf(stderr, "debug: exp %d, mant '%s'\n", iExp, mntStr);
#endif

    if (mPtr[0] == '-') {
	mPtr++;
	isNeg = 1;
	iPart--; /* for '-'. */
    }

    if (iExp == 0) {
	if (iPart <= 0) {
	    goto CantOut;
	}
	if (iPart > 1) {
	    iPart--;
	    for (i = 0; i < iPart; i++) {
		PUT(' ');
	    }
	}
	if (isNeg == 1) {
	    PUT('-');
	}
	PUT(*mPtr);
	mPtr++;
	PUT('.');
	for (i = 0; i < d; i++) {
	    PUT(*mPtr);
	    mPtr++;
	}
	goto Done;
    } else if (iExp > 0) {
	int putI = iExp + 1;
	if (iPart <= 0 ||
	    iPart < putI) {
	    goto CantOut;
	}
	if (iPart > putI) {
	    for (i = 0; i < (iPart - putI); i++) {
		PUT(' ');
	    }
	}
	if (isNeg == 1) {
	    PUT('-');
	}
	for (i = 0; i < putI; i++) {
	    PUT(*mPtr);
	    mPtr++;
	}
	PUT('.');
	for (i = 0; i < d; i++) {
	    PUT(*mPtr);
	    mPtr++;
	}
	goto Done;
    } else {
#ifdef WANT_LEAD_0
	int noLeadZero = 0;
#endif /* WANT_LEAD_0 */
	if (iPart <= 0) {
#ifdef WANT_LEAD_0
	    if (iPart == 0) {
		noLeadZero = 1;
		iPart = 1;
	    } else {
		goto CantOut;
	    }
#else
	    goto CantOut;
#endif /* WANT_LEAD_0 */
	}
	if (iPart > 1) {
	    iPart--;
	    for (i = 0; i < iPart; i++) {
		PUT(' ');
	    }
	}
	if (d < Abs(iExp)) {
	    if (isNeg == 1) {
		PUT(' '); /* out ' ' instead of '-'. */
	    }
#ifdef WANT_LEAD_0
	    PUT('0');
#endif /* WANT_LEAD_0 */
	    PUT('.');
	    for (i = 0; i < d; i++) {
		PUT('0');
	    }
	    goto Done;
	} else {
	    if (isNeg == 1) {
		PUT('-');
	    }
#ifdef WANT_LEAD_0
	    if (noLeadZero == 0) {
		PUT('0');
	    }
#endif /* WANT_LEAD_0 */
	    PUT('.');
	    for (i = 0; i < (Abs(iExp) - 1); i++) {
		PUT('0');
		d--;
	    }
	    for (i = 0; i < d; i++) {
		PUT(*mPtr);
		mPtr++;
	    }
	}
	goto Done;
    }
    CantOut:
    for (i = 0; i < w; i++) {
	PUT('*');
    }
    Done:
    if (mntStr != NULL) {
	(void)free(mntStr);
    }
    mpf_clear(val);
    return 0;
}


static int
getExpStr(exp, buf, max)
     int exp;
     char *buf;
     int max;	/*
		 * max length without "Q+".
		 * buf must have enuff room to keep max + 3 ("Q+" + nul).
		 */
{
    int digit = (exp != 0) ? (int)(log10((double)(Abs(exp))) + 1.0) : 1;

    if (digit <= 1 && digit != max) {
	digit = 2;
    }
    if (max < digit && max > 0) {
	return 0;
    } else {
	char fmt[32];
	if (max > digit) {
	    digit = max;
	}
	if (exp < 0) {
#if 0
	    sprintf(fmt, "Q-%%0%dd", digit);
#else
	    sprintf(fmt, "E-%%0%dd", digit);
#endif
	} else {
#if 0
	    sprintf(fmt, "Q+%%0%dd", digit);
#else
	    sprintf(fmt, "E+%%0%dd", digit);
#endif
	}
	sprintf(buf, fmt, Abs(exp));
	return digit;
    }
}


int
#ifdef KR_headers
wrt_QE(qPtr, w, d, e, len) _omQReal_t *p; int w, d, e; ftnlen len;
#else
wrt_QE(_omQReal_t *qPtr, int w, int d, int e, ftnlen len)
#endif
{
    mpf_t val;
    mp_exp_t exp;
    char *mntStr = NULL;
    char *mPtr = NULL;
    int iExp;
    int i;
    int iPart = w - d - 1;	/* -1 is for '.' */
    int isNeg = 0;
    char expStr[64];
    char *ePtr = expStr;
#ifdef WANT_LEAD_0
    int noLeadZero = 0;
#endif /* WANT_LEAD_0 */

#if 0
    fprintf(stderr, "debug: w = %d, d = %d, e = %d, len = %d\n",
	    w, d, e, (int)len);
#endif

    if (QRNaN(qPtr) == 1) {
	/*
	 * NaN
	 */
	for (i = 0; i < w; i++) {
	    PUT('*');
	}
	return 0;
    }

    mpf_init(val);
    
    QR2mpf(qPtr, &val);
    
    mntStr = (char *)malloc(sizeof(char) * (w + 2)); /* sign + NUL */
    if (mntStr == NULL) {
	goto CantOut;
    }
    mPtr = mntStr;

    (void)getRoundStr(val, mntStr, &exp, w, d, ROUND_E);
#if (OMNI_SIZEOF_QEXP_T > 4)
    iExp = (int)((_omInt64_t)exp);
#else
    iExp = (int)exp;
#endif
    iExp--;
#if 0
    fprintf(stderr, "debug: exp %d, mant '%s'\n", iExp, mntStr);
#endif

    if (getExpStr((iExp + 1), expStr, e) < 1) {
	goto CantOut;
    }
    iPart -= strlen(expStr);

    if (mPtr[0] == '-') {
	mPtr++;
	isNeg = 1;
	iPart--; /* for '-'. */
    }

#if 0
    fprintf(stderr, "debug: exp %d, mant '%s', expStr '%s'\n", iExp, mntStr, expStr);
#endif

    if (iPart <= 0) {
#ifdef WANT_LEAD_0
	if (iPart == 0) {
	    noLeadZero = 1;
	    iPart = 1;
	} else {
	    goto CantOut;
	}
#else
	goto CantOut;
#endif /* WANT_LEAD_0 */
    }

    if (iPart <= 0) {
	goto CantOut;
    }
    if (iPart > 1) {
	iPart--;
	for (i = 0; i < iPart; i++) {
	    PUT(' ');
	}
    }
    if (isNeg == 1) {
	PUT('-');
    }
#ifdef WANT_LEAD_0
    if (noLeadZero == 0) {
	PUT('0');
    }
#endif /* WANT_LEAD_0 */
    PUT('.');
    for (i = 0; i < d; i++) {
	PUT(*mPtr);
	mPtr++;
    }
    while (*ePtr != '\0') {
	PUT(*ePtr);
	ePtr++;
    }
    goto Done;

    CantOut:
    for (i = 0; i < w; i++) {
	PUT('*');
    }

    Done:
    mpf_clear(val);
    if (mntStr != NULL) {
	(void)free(mntStr);
    }
    return 0;
}

#endif /* ENABLE_QREAL */