/*
 * File: rconv.c
 *  Contents: cvcset, cvint, cvnum, cvpos, cvreal, cvstr, mkint,
 *    makereal, mksubs, strprc
 */

#include <math.h>
#include "..\h\config.h"
#include "..\h\rt.h"
#include "rproto.h"

/*
 * Prototypes.
 */

hidden int	cstos	Params((int *cs,dptr dp,char *s));
hidden int	itos	Params((long num,dptr dp,char *s));
hidden int	ston	Params((char *s,dptr dp));

#ifndef LargeInts
hidden int	radix	Params((int sign,int r,char *s,dptr dp));
#endif					/* LargeInts */

#ifdef StrInvoke
extern struct pstrnm pntab[];
#endif					/* StrInvoke */

#include <ctype.h>

#if !EBCDIC
#define tonum(c)	(isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
#endif					/* !EBCDIC */

/*
 * cvcset(dp, cs, csbuf) - convert dp to a cset and
 *  make cs point to it, using csbuf as a buffer if necessary.
 */

int cvcset(dp, cs, csbuf)
register dptr dp;
int **cs, *csbuf;
   {
   register char *s;
   register word l;
   char sbuf[MaxCvtLen];

   if (dp->dword == D_Cset) {
      *cs = BlkLoc(*dp)->cset.bits;
      return T_Cset;
      }

   if (cvstr(dp, sbuf) == CvtFail)
      return CvtFail;

   for (l = 0; l < CsetSize; l++)
      csbuf[l] = 0;

   s = StrLoc(*dp);
   l = StrLen(*dp);
   while (l--) {
      Setb(ToAscii(*s), csbuf);
      s++;
      }
   *cs = csbuf;
   return T_Cset;
   }

/*
 * cvint - convert the value represented by dp into an integer and write
 *  the value into the location referenced by i.  cvint returns the type or
 *  CvtFail depending on the outcome of the conversion.
 */

int cvint(dp)
register dptr dp;
   {
   /*
    * Use cvnum to attempt the conversion into "result".
    */
   switch (cvnum(dp)) {

      case T_Integer:
	 return T_Integer;

#ifdef LargeInts
      case T_Bignum:
	 /*
	  * Bignum, not in the range of an integer.  Fail as we do 
	  *  for large reals.
	  */
	 return CvtFail;
#endif					/* LargeInts */

      case T_Real:
	 /*
	  * The value converted into a real number.  If it's not in the
	  *  range of an integer, fail, otherwise convert the real value
	  *  into an integer.
	  */
	 if (BlkLoc(*dp)->realblk.realval > MaxLong || 
	     BlkLoc(*dp)->realblk.realval < MinLong)
	    return CvtFail;
	 dp->dword = D_Integer;
	 IntVal(*dp) = (long)BlkLoc(*dp)->realblk.realval;
	 return T_Integer;

      default:
	 return CvtFail;
      }
   }

/*
 * cvnum - convert the value represented by d into a numeric quantity
 *  in place. The value returned is the type or CvtFail.
 */

int cvnum(dp)
register dptr dp;
   {
   static char sbuf[MaxCvtLen];
   struct descrip cstring;

   cstring = *dp;  /* placed outside "if" to avoid Lattice 3.21 code gen bug */
   if (Qual(*dp)) {
      qtos(&cstring, sbuf);
      return ston(StrLoc(cstring), dp);
      }

   switch (Type(*dp)) {

      case T_Integer:

#ifdef LargeInts
      case T_Bignum:
#endif					/* LargeInts */

      case T_Real:
	 return Type(*dp);

      default:
	 /*
	  * Try to convert the value to a string and
	  *  then try to convert the string to an integer.
	  */
	 if (cvstr(dp, sbuf) == CvtFail)
	    return CvtFail;
	 return ston(StrLoc(*dp), dp);
      }
   }

/*
 * ston - convert a string to a numeric quantity if possible.
 */
static int ston(s, dp)
register char *s;
dptr dp;
   {
   register int c;
   int realflag = 0;	/* indicates a real number */
   char msign = '+';    /* sign of mantissa */
   char esign = '+';    /* sign of exponent */
   double mantissa = 0; /* scaled mantissa with no fractional part */
   long lresult = 0;	/* integer result */
   int scale = 0;	/* number of decimal places to shift mantissa */
   int digits = 0;	/* total number of digits seen */
   int sdigits = 0;	/* number of significant digits seen */
   int exponent = 0;	/* exponent part of real number */
   double fiveto;	/* holds 5^scale */
   double power;	/* holds successive squares of 5 to compute fiveto */
   int err_no;
   char *ssave;         /* holds original ptr for bigradix */

   c = *s++;

   /*
    * Skip leading white space.
    */
   while (isspace(c))
      c = *s++;

   /*
    * Check for sign.
    */
   if (c == '+' || c == '-') {
      msign = c;
      c = *s++;
      }

   ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */

   /*
    * Get integer part of mantissa.
    */
   while (isdigit(c)) {
      digits++;
      if (mantissa < Big) {
	 mantissa = mantissa * 10 + (c - '0');
         lresult = lresult * 10 + (c - '0');
	 if (mantissa > 0.0)
	    sdigits++;
	 }
      else
	 scale++;
      c = *s++;
      }

   /*
    * Check for based integer.
    */
   if (c == 'r' || c == 'R')

#ifdef LargeInts
      return bigradix(msign, (int)mantissa, s, dp);
#else					/* LargeInts */
      return radix(msign, (int)mantissa, s, dp);
#endif					/* LargeInts */

   /*
    * Get fractional part of mantissa.
    */
   if (c == '.') {
      realflag++;
      c = *s++;
      while (isdigit(c)) {
	 digits++;
	 if (mantissa < Big) {
	    mantissa = mantissa * 10 + (c - '0');
	    lresult = lresult * 10 + (c - '0');
	    scale--;
	    if (mantissa > 0.0)
	       sdigits++;
	    }
	 c = *s++;
	 }
      }

   /*
    * Check that at least one digit has been seen so far.
    */
   if (digits == 0)
      return CvtFail;

   /*
    * Get exponent part.
    */
   if (c == 'e' || c == 'E') {
      realflag++;
      c = *s++;
      if (c == '+' || c == '-') {
	 esign = c;
	 c = *s++;
	 }
      if (!isdigit(c))
	 return CvtFail;
      while (isdigit(c)) {
	 exponent = exponent * 10 + (c - '0');
	 c = *s++;
	 }
      scale += (esign == '+') ? exponent : -exponent;
      }

   /*
    * Skip trailing white space.
    */
   while (isspace(c))
      c = *s++;

   /*
    * Check that entire string has been consumed.
    */
   if (c != '\0')
      return CvtFail;

   /*
    * Test for integer.
    */
   if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
      dp->dword = D_Integer;
      IntVal(*dp) = (msign == '+' ? lresult : -lresult);
      return T_Integer;
      }

#ifdef LargeInts
   /*
    * Test for bignum.
    */
   if (!realflag)
      return bigradix(msign, 10, ssave, dp);
#endif					/* LargeInts */

   if (!realflag)
      return CvtFail;		/* don't promote to real if integer format */

   /*
    * Rough tests for overflow and underflow.
    */
   if (sdigits + scale > LogHuge)
      return CvtFail;

   if (sdigits + scale < -LogHuge) {
      makereal(0.0, dp);
      return T_Real;
      }

   /*
    * Put the number together by multiplying the mantissa by 5^scale and
    *  then using ldexp() to multiply by 2^scale.
    */

   exponent = (scale > 0)? scale : -scale;
   fiveto = 1.0;
   power = 5.0;
   for (;;) {
      if (exponent & 01)
	 fiveto *= power;
      exponent >>= 1;
      if (exponent == 0)
	 break;
      power *= power;
      }
   if (scale > 0)
      mantissa *= fiveto;
   else
      mantissa /= fiveto;

   err_no = 0;
   mantissa = ldexp(mantissa, scale);
   if (err_no > 0 && mantissa > 0)
      /*
       * ldexp caused overflow.
       */
      return CvtFail;

   if (msign == '-')
      mantissa = -mantissa;
   makereal(mantissa, dp);
   return T_Real;
   }

#ifndef LargeInts
/*
 * radix - convert string s in radix r into an integer in *dp.  sign
 *  will be either '+' or '-'.
 */
static int radix(sign, r, s, dp)
int sign;
register int r;
register char *s;
dptr dp;
   {
   register int c;
   long num;

   if (r < 2 || r > 36)
      return CvtFail;
   c = *s++;
   num = 0L;
   while (isalnum(c)) {
      c = tonum(c);
      if (c >= r)
	 return CvtFail;
      num = num * r + c;
      c = *s++;
      }

   while (isspace(c))
      c = *s++;

   if (c != '\0')
      return CvtFail;

   dp->dword = D_Integer;
   dp->vword.integr = (sign == '+' ? num : -num);

   return T_Integer;
   }
#endif					/* LargeInts */

/*
 * cvpos - convert position to strictly positive position
 *  given length.
 */

word cvpos(pos, len)
long pos;
register long len;
   {
   register word p;

   /*
    * Make sure the position is in the range of an int. (?)
    */
   if ((long)(p = pos) != pos)
      return CvtFail;
   /*
    * Make sure the position is within range.
    */
   if (p < -len || p > len + 1)
      return CvtFail;
   /*
    * If the position is greater than zero, just return it.  Otherwise,
    *  convert the zero/negative position.
    */
   if (pos > 0)
      return p;
   return (len + p + 1);
   }

/*
 * cvreal - convert to real in place.
 */

int cvreal(dp)
register dptr dp;
   {
   /*
    * Use cvnum to classify the value.	Cast integers into reals and
    *  fail if the value is non-numeric.
    */
   switch (cvnum(dp)) {

      case T_Integer:
	 makereal((double)IntVal(*dp), dp);
	 return T_Real;

#ifdef LargeInts
      case T_Bignum:
	 makereal(bigtoreal(dp), dp);
	 return T_Real;
#endif					/* LargeInts */

      case T_Real:
	 return T_Real;

      default:
	 return CvtFail;
      }
   }

/*
 * cvstr(dp,s) - convert dp (in place) into a string, using s as buffer
 *  if necessary.  cvstr returns CvtFail if the conversion fails, Cvt if dp
 *  wasn't a string but was converted into one, and NoCvt if dp was already
 *  a string.  When a string conversion takes place, sbuf gets the
 *  resulting string.
 */

int cvstr(dp, sbuf)
register dptr dp;
char *sbuf;
   {
   double rres;

   if (Qual(*dp))
      return NoCvt;			/* It is already a string */

   switch (Type(*dp)) {
      /*
       * For types that can be converted into strings, call the
       *  appropriate conversion routine and return its result.
       *  Note that the conversion routines change the descriptor
       *  pointed to by dp.
       */
      case T_Integer:
	 return itos((long)IntVal(*dp), dp, sbuf);

#ifdef LargeInts
      case T_Bignum:
	 return bigtos(dp, dp);
#endif					/* LargeInts */

      case T_Real:
	 GetReal(dp,rres);
	 return rtos(rres, dp, sbuf);

      case T_Cset:
	 return cstos(BlkLoc(*dp)->cset.bits, dp, sbuf);

      default:
	 /*
	  * The value cannot be converted to a string.
	  */
	 return CvtFail;
      }
   }

/*
 * itos - convert the integer num into a string using s as a buffer and
 *  making q a descriptor for the resulting string.
 */

static int itos(num, dp, s)
long num;
dptr dp;
char *s;
   {
   register char *p;
   long ival;
   static char *maxneg = MaxNegInt;

   p = s + MaxCvtLen - 1;
   ival = num;

   *p = '\0';
   if (num >= 0L)
      do {
	 *--p = ival % 10L + '0';
	 ival /= 10L;
	 } while (ival != 0L);
   else {
      if (ival == -ival) {      /* max negative value */
	 p -= strlen (maxneg);
	 sprintf (p, "%s", maxneg);
         }
      else {
	ival = -ival;
	do {
	   *--p = '0' + (ival % 10L);
	   ival /= 10L;
	   } while (ival != 0L);
	*--p = '-';
	}
      }

   StrLen(*dp) = s + MaxCvtLen - 1 - p;
   StrLoc(*dp) = p;
   return Cvt;
   }

/*
 * rtos - convert the real number n into a string using s as a buffer and
 *  making a descriptor for the resulting string.
 */
int rtos(n, dp, s)
double n;
dptr dp;
char *s;
   {

   s++; 			/* leave room for leading zero */
/*
 * The following code is operating-system dependent [@rconv.01]. Convert real
 *  number to string.
 *
 * If IconGcvt is defined, icon_gcvt() is actually called, due to a #define
 *  in config.h.
 */

#if PORT
   gcvt(n, Precision, s);
Deliberate Syntax Error
#endif					/* PORT */

#if AMIGA || ATARI_ST || MSDOS || UNIX || VMS
   gcvt(n, Precision, s);
#endif                                  /* AMIGA  || ATARI_ST || ... */

#if VM || MVS
#if SASC
   sprintf(s,"%.*g", Precision, n);
   {
     char *ep = strstr(s, "e+");
     if (ep) memmove(ep+1, ep+2, strlen(ep+2)+1);
   }
#else					/* SASC */
   gcvt(n, Precision, s);
#endif					/* SASC */
#endif                                  /* MVS || VM */


#if HIGHC_386
   sprintf(s,"%.*g", Precision, n);
#endif					/* HIGHC_386 */

#if MACINTOSH
   sprintf(s,"%20g",n);
#endif					/* MACINTOSH */

/*
 * End of operating-system specific code.
 */
   
   /*
    * Now clean up possible messes.
    */
   while (*s == ' ')			/* delete leading blanks */
      s++;
   if (*s == '.') {			/* prefix 0 t0 to initial period */
      s--;
      *s = '0';
      }
   else if (strcmp(s, "-0.0") == 0)	/* negative zero */
      s++;
   else if (!index(s, '.') && !index(s,'e') && !index(s,'E'))
         strcat(s, ".0");		/* if no decimal point or exp. */
   if (s[strlen(s) - 1] == '.')		/* if decimal point is at the end ... */
      strcat(s, "0");
   StrLen(*dp) = strlen(s);
   StrLoc(*dp) = s;
   return Cvt;
   }

/*
 * cstos - convert the cset bit array pointed at by cs into a string using
 *  s as a buffer and making a descriptor for the resulting string.
 */

static int cstos(cs, dp, s)
int *cs;
dptr dp;
char *s;
   {
   register unsigned int w;
   register int j, i;
   register char *p;

   p = s;
   for (i = 0; i < CsetSize; i++) {
      if (cs[i])
	 for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1)
	    if (w & 01)
	       *p++ = FromAscii((char)j);
      }
   *p = '\0';

   StrLen(*dp) = p - s;
   StrLoc(*dp) = s;
   return Cvt;
   }

/*
 * makereal(r, dp) - make a real number descriptor and associated block
 *  for r and place it in *dp.
 */

int makereal(r, dp)
double r;
register dptr dp;
   {

   if (blkreq((uword)sizeof(struct b_real)) == Error)
      return Error;
   dp->dword = D_Real;
   BlkLoc(*dp) = (union block *)alcreal(r);
   return Success;
   }

/*
 * mksubs - form a substring.  var is a descriptor for the string from
 *  which the substring is to be formed.  var may be a variable.  val
 *  is a dereferenced version of var.  The descriptor for the resulting
 *  substring is placed in *result.  The substring starts at position
 *  i and extends for j characters.
 */

novalue mksubs(var, val, i, j, result)
register dptr var, val, result;
word i, j;
   {

   if (!Var(*var)) {
      /*
       * var isn't a variable, just form a descriptor that points into
       *  the string named by val.
       */
      StrLen(*result) = j;
      StrLoc(*result) = StrLoc(*val) + i - 1;
      return;
      }

   if ((var)->dword == D_Tvsubs) {
      /*
       * If var is a substring trapped variable,
       *  adjust the position and make var the substrung string.
       */
	 i += BlkLoc(*var)->tvsubs.sspos - 1;
	 var = &BlkLoc(*var)->tvsubs.ssvar;
	 }

   /*
    * Make a substring trapped variable by passing the buck to alcsubs.
    */
   result->dword = D_Tvsubs;
   BlkLoc(*result) = (union block *) alcsubs(j, i, var);
   return;
   }

/*
 * strprc - Convert the qualified string named by *dp into a procedure
 *  descriptor if possible.  n is the number of arguments that the desired
 *  procedure has.  n is only used when the name of the procedure is
 *  non-alphabetic (hence, an operator).
 *
 */
int strprc(dp, n)
dptr dp;
word n;
   {

#ifndef StrInvoke
   return CvtFail;
#else					/* StrInvoke */

   dptr np, gp;
   struct pstrnm *p;
   char *s;
   int i;
   word ns;

   /*
    * Look in global name list first.
    */
   np = gnames; gp = globals;
   while (gp < eglobals) {
      if (!lexcmp(np++,dp))
         if (BlkLoc(*gp)->proc.title == T_Proc) {
   	 StrLen(*dp) = D_Proc; /* really type field */
   	 BlkLoc(*dp) = BlkLoc(*gp);
   	 return T_Proc;
   	 }
      gp++;
   }

/*
 * The name is not a global, see if it is a function or an operator.
 */
   s = StrLoc(*dp);
   if (StrLen(*dp) > MaxCvtLen)		/* can't be that big */
      return CvtFail;
   i = (int)StrLen(*dp);
   for (p = pntab; p->pstrep; p++)
      /*
       * Compare the desired name with each standard procedure/operator
       *  name.
       */
      if (strlen(p->pstrep) == i && strncmp(s,p->pstrep,i) == 0) {
	 if (isalpha(*s)) {
	    /*
	     * The names are the same and s starts with an alphabetic,
	     *  so it's the one being looked for; return it.
	     */
	     StrLen(*dp) = D_Proc;
	     BlkLoc(*dp) = (union block *) p->pblock;
	     return T_Proc;
	     }
	  if ((ns = p->pblock->nstatic) < 0)
	     ns = -ns;
	  else
	     ns = abs((int)p->pblock->nparam);
	  if (n == ns) {
	     StrLen(*dp) = D_Proc;	/* really type field */
	     BlkLoc(*dp) = (union block *)p->pblock;
	     return T_Proc;
	     }
	 }
   return CvtFail;
#endif					/* StrInvoke */

   }