home *** CD-ROM | disk | FTP | other *** search
/ APDL Public Domain 1 / APDL_PD1A.iso / program / language / icon / Source / Iconx / C / Rconv < prev    next >
Encoding:
Text File  |  1990-07-19  |  15.8 KB  |  760 lines
  1. /*
  2.  * File: rconv.c
  3.  *  Contents: cvcset, cvint, cvnum, cvpos, cvreal, cvstr, mkint,
  4.  *    makereal, mksubs, strprc
  5.  */
  6.  
  7. #include <math.h>
  8. #include "../h/config.h"
  9. #include "../h/rt.h"
  10. #include "rproto.h"
  11.  
  12. /*
  13.  * Prototypes.
  14.  */
  15.  
  16. hidden int    cstos    Params((int *cs,dptr dp,char *s));
  17. hidden int    itos    Params((long num,dptr dp,char *s));
  18. hidden int    ston    Params((char *s,dptr dp));
  19.  
  20. #ifndef LargeInts
  21. hidden int    radix    Params((int sign,int r,char *s,dptr dp));
  22. #endif                    /* LargeInts */
  23.  
  24. #ifdef StrInvoke
  25. extern struct pstrnm pntab[];
  26. #endif                    /* StrInvoke */
  27.  
  28. #include <ctype.h>
  29.  
  30. #if !EBCDIC
  31. #define tonum(c)    (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
  32. #endif                    /* !EBCDIC */
  33.  
  34. /*
  35.  * cvcset(dp, cs, csbuf) - convert dp to a cset and
  36.  *  make cs point to it, using csbuf as a buffer if necessary.
  37.  */
  38.  
  39. int cvcset(dp, cs, csbuf)
  40. register dptr dp;
  41. int **cs, *csbuf;
  42.    {
  43.    register char *s;
  44.    register word l;
  45.    char sbuf[MaxCvtLen];
  46.  
  47.    if (dp->dword == D_Cset) {
  48.       *cs = BlkLoc(*dp)->cset.bits;
  49.       return T_Cset;
  50.       }
  51.  
  52.    if (cvstr(dp, sbuf) == CvtFail)
  53.       return CvtFail;
  54.  
  55.    for (l = 0; l < CsetSize; l++)
  56.       csbuf[l] = 0;
  57.  
  58.    s = StrLoc(*dp);
  59.    l = StrLen(*dp);
  60.    while (l--) {
  61.       Setb(ToAscii(*s), csbuf);
  62.       s++;
  63.       }
  64.    *cs = csbuf;
  65.    return T_Cset;
  66.    }
  67.  
  68. /*
  69.  * cvint - convert the value represented by dp into an integer and write
  70.  *  the value into the location referenced by i.  cvint returns the type or
  71.  *  CvtFail depending on the outcome of the conversion.
  72.  */
  73.  
  74. int cvint(dp)
  75. register dptr dp;
  76.    {
  77.    /*
  78.     * Use cvnum to attempt the conversion into "result".
  79.     */
  80.    switch (cvnum(dp)) {
  81.  
  82.       case T_Integer:
  83.      return T_Integer;
  84.  
  85. #ifdef LargeInts
  86.       case T_Bignum:
  87.      /*
  88.       * Bignum, not in the range of an integer.  Fail as we do 
  89.       *  for large reals.
  90.       */
  91.      return CvtFail;
  92. #endif                    /* LargeInts */
  93.  
  94.       case T_Real:
  95.      /*
  96.       * The value converted into a real number.  If it's not in the
  97.       *  range of an integer, fail, otherwise convert the real value
  98.       *  into an integer.
  99.       */
  100.      if (BlkLoc(*dp)->realblk.realval > MaxLong || 
  101.          BlkLoc(*dp)->realblk.realval < MinLong)
  102.         return CvtFail;
  103.      dp->dword = D_Integer;
  104.      IntVal(*dp) = (long)BlkLoc(*dp)->realblk.realval;
  105.      return T_Integer;
  106.  
  107.       default:
  108.      return CvtFail;
  109.       }
  110.    }
  111.  
  112. /*
  113.  * cvnum - convert the value represented by d into a numeric quantity
  114.  *  in place. The value returned is the type or CvtFail.
  115.  */
  116.  
  117. int cvnum(dp)
  118. register dptr dp;
  119.    {
  120.    static char sbuf[MaxCvtLen];
  121.    struct descrip cstring;
  122.  
  123.    cstring = *dp;  /* placed outside "if" to avoid Lattice 3.21 code gen bug */
  124.    if (Qual(*dp)) {
  125.       qtos(&cstring, sbuf);
  126.       return ston(StrLoc(cstring), dp);
  127.       }
  128.  
  129.    switch (Type(*dp)) {
  130.  
  131.       case T_Integer:
  132.  
  133. #ifdef LargeInts
  134.       case T_Bignum:
  135. #endif                    /* LargeInts */
  136.  
  137.       case T_Real:
  138.      return Type(*dp);
  139.  
  140.       default:
  141.      /*
  142.       * Try to convert the value to a string and
  143.       *  then try to convert the string to an integer.
  144.       */
  145.      if (cvstr(dp, sbuf) == CvtFail)
  146.         return CvtFail;
  147.      return ston(StrLoc(*dp), dp);
  148.       }
  149.    }
  150.  
  151. /*
  152.  * ston - convert a string to a numeric quantity if possible.
  153.  */
  154. static int ston(s, dp)
  155. register char *s;
  156. dptr dp;
  157.    {
  158.    register int c;
  159.    int realflag = 0;    /* indicates a real number */
  160.    char msign = '+';    /* sign of mantissa */
  161.    char esign = '+';    /* sign of exponent */
  162.    double mantissa = 0; /* scaled mantissa with no fractional part */
  163.    long lresult = 0;    /* integer result */
  164.    int scale = 0;    /* number of decimal places to shift mantissa */
  165.    int digits = 0;    /* total number of digits seen */
  166.    int sdigits = 0;    /* number of significant digits seen */
  167.    int exponent = 0;    /* exponent part of real number */
  168.    double fiveto;    /* holds 5^scale */
  169.    double power;    /* holds successive squares of 5 to compute fiveto */
  170.    int err_no;
  171.    char *ssave;         /* holds original ptr for bigradix */
  172.  
  173.    c = *s++;
  174.  
  175.    /*
  176.     * Skip leading white space.
  177.     */
  178.    while (isspace(c))
  179.       c = *s++;
  180.  
  181.    /*
  182.     * Check for sign.
  183.     */
  184.    if (c == '+' || c == '-') {
  185.       msign = c;
  186.       c = *s++;
  187.       }
  188.  
  189.    ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */
  190.  
  191.    /*
  192.     * Get integer part of mantissa.
  193.     */
  194.    while (isdigit(c)) {
  195.       digits++;
  196.       if (mantissa < Big) {
  197.      mantissa = mantissa * 10 + (c - '0');
  198.          lresult = lresult * 10 + (c - '0');
  199.      if (mantissa > 0.0)
  200.         sdigits++;
  201.      }
  202.       else
  203.      scale++;
  204.       c = *s++;
  205.       }
  206.  
  207.    /*
  208.     * Check for based integer.
  209.     */
  210.    if (c == 'r' || c == 'R')
  211.  
  212. #ifdef LargeInts
  213.       return bigradix(msign, (int)mantissa, s, dp);
  214. #else                    /* LargeInts */
  215.       return radix(msign, (int)mantissa, s, dp);
  216. #endif                    /* LargeInts */
  217.  
  218.    /*
  219.     * Get fractional part of mantissa.
  220.     */
  221.    if (c == '.') {
  222.       realflag++;
  223.       c = *s++;
  224.       while (isdigit(c)) {
  225.      digits++;
  226.      if (mantissa < Big) {
  227.         mantissa = mantissa * 10 + (c - '0');
  228.         lresult = lresult * 10 + (c - '0');
  229.         scale--;
  230.         if (mantissa > 0.0)
  231.            sdigits++;
  232.         }
  233.      c = *s++;
  234.      }
  235.       }
  236.  
  237.    /*
  238.     * Check that at least one digit has been seen so far.
  239.     */
  240.    if (digits == 0)
  241.       return CvtFail;
  242.  
  243.    /*
  244.     * Get exponent part.
  245.     */
  246.    if (c == 'e' || c == 'E') {
  247.       realflag++;
  248.       c = *s++;
  249.       if (c == '+' || c == '-') {
  250.      esign = c;
  251.      c = *s++;
  252.      }
  253.       if (!isdigit(c))
  254.      return CvtFail;
  255.       while (isdigit(c)) {
  256.      exponent = exponent * 10 + (c - '0');
  257.      c = *s++;
  258.      }
  259.       scale += (esign == '+') ? exponent : -exponent;
  260.       }
  261.  
  262.    /*
  263.     * Skip trailing white space.
  264.     */
  265.    while (isspace(c))
  266.       c = *s++;
  267.  
  268.    /*
  269.     * Check that entire string has been consumed.
  270.     */
  271.    if (c != '\0')
  272.       return CvtFail;
  273.  
  274.    /*
  275.     * Test for integer.
  276.     */
  277.    if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
  278.       dp->dword = D_Integer;
  279.       IntVal(*dp) = (msign == '+' ? lresult : -lresult);
  280.       return T_Integer;
  281.       }
  282.  
  283. #ifdef LargeInts
  284.    /*
  285.     * Test for bignum.
  286.     */
  287.    if (!realflag)
  288.       return bigradix(msign, 10, ssave, dp);
  289. #endif                    /* LargeInts */
  290.  
  291.    if (!realflag)
  292.       return CvtFail;        /* don't promote to real if integer format */
  293.  
  294.    /*
  295.     * Rough tests for overflow and underflow.
  296.     */
  297.    if (sdigits + scale > LogHuge)
  298.       return CvtFail;
  299.  
  300.    if (sdigits + scale < -LogHuge) {
  301.       makereal(0.0, dp);
  302.       return T_Real;
  303.       }
  304.  
  305.    /*
  306.     * Put the number together by multiplying the mantissa by 5^scale and
  307.     *  then using ldexp() to multiply by 2^scale.
  308.     */
  309.  
  310.    exponent = (scale > 0)? scale : -scale;
  311.    fiveto = 1.0;
  312.    power = 5.0;
  313.    for (;;) {
  314.       if (exponent & 01)
  315.      fiveto *= power;
  316.       exponent >>= 1;
  317.       if (exponent == 0)
  318.      break;
  319.       power *= power;
  320.       }
  321.    if (scale > 0)
  322.       mantissa *= fiveto;
  323.    else
  324.       mantissa /= fiveto;
  325.  
  326.    err_no = 0;
  327.    mantissa = ldexp(mantissa, scale);
  328.    if (err_no > 0 && mantissa > 0)
  329.       /*
  330.        * ldexp caused overflow.
  331.        */
  332.       return CvtFail;
  333.  
  334.    if (msign == '-')
  335.       mantissa = -mantissa;
  336.    makereal(mantissa, dp);
  337.    return T_Real;
  338.    }
  339.  
  340. #ifndef LargeInts
  341. /*
  342.  * radix - convert string s in radix r into an integer in *dp.  sign
  343.  *  will be either '+' or '-'.
  344.  */
  345. static int radix(sign, r, s, dp)
  346. int sign;
  347. register int r;
  348. register char *s;
  349. dptr dp;
  350.    {
  351.    register int c;
  352.    long num;
  353.  
  354.    if (r < 2 || r > 36)
  355.       return CvtFail;
  356.    c = *s++;
  357.    num = 0L;
  358.    while (isalnum(c)) {
  359.       c = tonum(c);
  360.       if (c >= r)
  361.      return CvtFail;
  362.       num = num * r + c;
  363.       c = *s++;
  364.       }
  365.  
  366.    while (isspace(c))
  367.       c = *s++;
  368.  
  369.    if (c != '\0')
  370.       return CvtFail;
  371.  
  372.    dp->dword = D_Integer;
  373.    dp->vword.integr = (sign == '+' ? num : -num);
  374.  
  375.    return T_Integer;
  376.    }
  377. #endif                    /* LargeInts */
  378.  
  379. /*
  380.  * cvpos - convert position to strictly positive position
  381.  *  given length.
  382.  */
  383.  
  384. word cvpos(pos, len)
  385. long pos;
  386. register long len;
  387.    {
  388.    register word p;
  389.  
  390.    /*
  391.     * Make sure the position is in the range of an int. (?)
  392.     */
  393.    if ((long)(p = pos) != pos)
  394.       return CvtFail;
  395.    /*
  396.     * Make sure the position is within range.
  397.     */
  398.    if (p < -len || p > len + 1)
  399.       return CvtFail;
  400.    /*
  401.     * If the position is greater than zero, just return it.  Otherwise,
  402.     *  convert the zero/negative position.
  403.     */
  404.    if (pos > 0)
  405.       return p;
  406.    return (len + p + 1);
  407.    }
  408.  
  409. /*
  410.  * cvreal - convert to real in place.
  411.  */
  412.  
  413. int cvreal(dp)
  414. register dptr dp;
  415.    {
  416.    /*
  417.     * Use cvnum to classify the value.    Cast integers into reals and
  418.     *  fail if the value is non-numeric.
  419.     */
  420.    switch (cvnum(dp)) {
  421.  
  422.       case T_Integer:
  423.      makereal((double)IntVal(*dp), dp);
  424.      return T_Real;
  425.  
  426. #ifdef LargeInts
  427.       case T_Bignum:
  428.      makereal(bigtoreal(dp), dp);
  429.      return T_Real;
  430. #endif                    /* LargeInts */
  431.  
  432.       case T_Real:
  433.      return T_Real;
  434.  
  435.       default:
  436.      return CvtFail;
  437.       }
  438.    }
  439.  
  440. /*
  441.  * cvstr(dp,s) - convert dp (in place) into a string, using s as buffer
  442.  *  if necessary.  cvstr returns CvtFail if the conversion fails, Cvt if dp
  443.  *  wasn't a string but was converted into one, and NoCvt if dp was already
  444.  *  a string.  When a string conversion takes place, sbuf gets the
  445.  *  resulting string.
  446.  */
  447.  
  448. int cvstr(dp, sbuf)
  449. register dptr dp;
  450. char *sbuf;
  451.    {
  452.    double rres;
  453.  
  454.    if (Qual(*dp))
  455.       return NoCvt;            /* It is already a string */
  456.  
  457.    switch (Type(*dp)) {
  458.       /*
  459.        * For types that can be converted into strings, call the
  460.        *  appropriate conversion routine and return its result.
  461.        *  Note that the conversion routines change the descriptor
  462.        *  pointed to by dp.
  463.        */
  464.       case T_Integer:
  465.      return itos((long)IntVal(*dp), dp, sbuf);
  466.  
  467. #ifdef LargeInts
  468.       case T_Bignum:
  469.      return bigtos(dp, dp);
  470. #endif                    /* LargeInts */
  471.  
  472.       case T_Real:
  473.      GetReal(dp,rres);
  474.      return rtos(rres, dp, sbuf);
  475.  
  476.       case T_Cset:
  477.      return cstos(BlkLoc(*dp)->cset.bits, dp, sbuf);
  478.  
  479.       default:
  480.      /*
  481.       * The value cannot be converted to a string.
  482.       */
  483.      return CvtFail;
  484.       }
  485.    }
  486.  
  487. /*
  488.  * itos - convert the integer num into a string using s as a buffer and
  489.  *  making q a descriptor for the resulting string.
  490.  */
  491.  
  492. static int itos(num, dp, s)
  493. long num;
  494. dptr dp;
  495. char *s;
  496.    {
  497.    register char *p;
  498.    long ival;
  499.    static char *maxneg = MaxNegInt;
  500.  
  501.    p = s + MaxCvtLen - 1;
  502.    ival = num;
  503.  
  504.    *p = '\0';
  505.    if (num >= 0L)
  506.       do {
  507.      *--p = ival % 10L + '0';
  508.      ival /= 10L;
  509.      } while (ival != 0L);
  510.    else {
  511.       if (ival == -ival) {      /* max negative value */
  512.      p -= strlen (maxneg);
  513.      sprintf (p, "%s", maxneg);
  514.          }
  515.       else {
  516.     ival = -ival;
  517.     do {
  518.        *--p = '0' + (ival % 10L);
  519.        ival /= 10L;
  520.        } while (ival != 0L);
  521.     *--p = '-';
  522.     }
  523.       }
  524.  
  525.    StrLen(*dp) = s + MaxCvtLen - 1 - p;
  526.    StrLoc(*dp) = p;
  527.    return Cvt;
  528.    }
  529.  
  530. /*
  531.  * rtos - convert the real number n into a string using s as a buffer and
  532.  *  making a descriptor for the resulting string.
  533.  */
  534. int rtos(n, dp, s)
  535. double n;
  536. dptr dp;
  537. char *s;
  538.    {
  539.  
  540.    s++;             /* leave room for leading zero */
  541. /*
  542.  * The following code is operating-system dependent [@rconv.01]. Convert real
  543.  *  number to string.
  544.  *
  545.  * If IconGcvt is defined, icon_gcvt() is actually called, due to a #define
  546.  *  in config.h.
  547.  */
  548.  
  549. #if PORT
  550.    gcvt(n, Precision, s);
  551. Deliberate Syntax Error
  552. #endif                    /* PORT */
  553.  
  554. #if AMIGA || ARM || ATARI_ST || MSDOS || UNIX || VMS
  555.    gcvt(n, Precision, s);
  556. #endif                                  /* AMIGA || ATARI_ST || ... */
  557.  
  558. #if VM || MVS
  559. #if SASC
  560.    sprintf(s,"%.*g", Precision, n);
  561.    {
  562.      char *ep = strstr(s, "e+");
  563.      if (ep) memmove(ep+1, ep+2, strlen(ep+2)+1);
  564.    }
  565. #else                    /* SASC */
  566.    gcvt(n, Precision, s);
  567. #endif                    /* SASC */
  568. #endif                                  /* MVS || VM */
  569.  
  570.  
  571. #if HIGHC_386
  572.    sprintf(s,"%.*g", Precision, n);
  573. #endif                    /* HIGHC_386 */
  574.  
  575. #if MACINTOSH
  576.    sprintf(s,"%20g",n);
  577. #endif                    /* MACINTOSH */
  578.  
  579. /*
  580.  * End of operating-system specific code.
  581.  */
  582.    
  583.    /*
  584.     * Now clean up possible messes.
  585.     */
  586.    while (*s == ' ')            /* delete leading blanks */
  587.       s++;
  588.    if (*s == '.') {            /* prefix 0 t0 to initial period */
  589.       s--;
  590.       *s = '0';
  591.       }
  592.    else if (strcmp(s, "-0.0") == 0)    /* negative zero */
  593.       s++;
  594.    else if (!index(s, '.') && !index(s,'e') && !index(s,'E'))
  595.          strcat(s, ".0");        /* if no decimal point or exp. */
  596.    if (s[strlen(s) - 1] == '.')        /* if decimal point is at the end ... */
  597.       strcat(s, "0");
  598.    StrLen(*dp) = strlen(s);
  599.    StrLoc(*dp) = s;
  600.    return Cvt;
  601.    }
  602.  
  603. /*
  604.  * cstos - convert the cset bit array pointed at by cs into a string using
  605.  *  s as a buffer and making a descriptor for the resulting string.
  606.  */
  607.  
  608. static int cstos(cs, dp, s)
  609. int *cs;
  610. dptr dp;
  611. char *s;
  612.    {
  613.    register unsigned int w;
  614.    register int j, i;
  615.    register char *p;
  616.  
  617.    p = s;
  618.    for (i = 0; i < CsetSize; i++) {
  619.       if (cs[i])
  620.      for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1)
  621.         if (w & 01)
  622.            *p++ = FromAscii((char)j);
  623.       }
  624.    *p = '\0';
  625.  
  626.    StrLen(*dp) = p - s;
  627.    StrLoc(*dp) = s;
  628.    return Cvt;
  629.    }
  630.  
  631. /*
  632.  * makereal(r, dp) - make a real number descriptor and associated block
  633.  *  for r and place it in *dp.
  634.  */
  635.  
  636. int makereal(r, dp)
  637. double r;
  638. register dptr dp;
  639.    {
  640.  
  641.    if (blkreq((uword)sizeof(struct b_real)) == Error)
  642.       return Error;
  643.    dp->dword = D_Real;
  644.    BlkLoc(*dp) = (union block *)alcreal(r);
  645.    return Success;
  646.    }
  647.  
  648. /*
  649.  * mksubs - form a substring.  var is a descriptor for the string from
  650.  *  which the substring is to be formed.  var may be a variable.  val
  651.  *  is a dereferenced version of var.  The descriptor for the resulting
  652.  *  substring is placed in *result.  The substring starts at position
  653.  *  i and extends for j characters.
  654.  */
  655.  
  656. novalue mksubs(var, val, i, j, result)
  657. register dptr var, val, result;
  658. word i, j;
  659.    {
  660.  
  661.    if (!Var(*var)) {
  662.       /*
  663.        * var isn't a variable, just form a descriptor that points into
  664.        *  the string named by val.
  665.        */
  666.       StrLen(*result) = j;
  667.       StrLoc(*result) = StrLoc(*val) + i - 1;
  668.       return;
  669.       }
  670.  
  671.    if ((var)->dword == D_Tvsubs) {
  672.       /*
  673.        * If var is a substring trapped variable,
  674.        *  adjust the position and make var the substrung string.
  675.        */
  676.      i += BlkLoc(*var)->tvsubs.sspos - 1;
  677.      var = &BlkLoc(*var)->tvsubs.ssvar;
  678.      }
  679.  
  680.    /*
  681.     * Make a substring trapped variable by passing the buck to alcsubs.
  682.     */
  683.    result->dword = D_Tvsubs;
  684.    BlkLoc(*result) = (union block *) alcsubs(j, i, var);
  685.    return;
  686.    }
  687.  
  688. /*
  689.  * strprc - Convert the qualified string named by *dp into a procedure
  690.  *  descriptor if possible.  n is the number of arguments that the desired
  691.  *  procedure has.  n is only used when the name of the procedure is
  692.  *  non-alphabetic (hence, an operator).
  693.  *
  694.  */
  695. int strprc(dp, n)
  696. dptr dp;
  697. word n;
  698.    {
  699.  
  700. #ifndef StrInvoke
  701.    return CvtFail;
  702. #else                    /* StrInvoke */
  703.  
  704.    dptr np, gp;
  705.    struct pstrnm *p;
  706.    char *s;
  707.    int i;
  708.    word ns;
  709.  
  710.    /*
  711.     * Look in global name list first.
  712.     */
  713.    np = gnames; gp = globals;
  714.    while (gp < eglobals) {
  715.       if (!lexcmp(np++,dp))
  716.          if (BlkLoc(*gp)->proc.title == T_Proc) {
  717.         StrLen(*dp) = D_Proc; /* really type field */
  718.         BlkLoc(*dp) = BlkLoc(*gp);
  719.         return T_Proc;
  720.         }
  721.       gp++;
  722.    }
  723.  
  724. /*
  725.  * The name is not a global, see if it is a function or an operator.
  726.  */
  727.    s = StrLoc(*dp);
  728.    if (StrLen(*dp) > MaxCvtLen)        /* can't be that big */
  729.       return CvtFail;
  730.    i = (int)StrLen(*dp);
  731.    for (p = pntab; p->pstrep; p++)
  732.       /*
  733.        * Compare the desired name with each standard procedure/operator
  734.        *  name.
  735.        */
  736.       if (strlen(p->pstrep) == i && strncmp(s,p->pstrep,i) == 0) {
  737.      if (isalpha(*s)) {
  738.         /*
  739.          * The names are the same and s starts with an alphabetic,
  740.          *  so it's the one being looked for; return it.
  741.          */
  742.          StrLen(*dp) = D_Proc;
  743.          BlkLoc(*dp) = (union block *) p->pblock;
  744.          return T_Proc;
  745.          }
  746.       if ((ns = p->pblock->nstatic) < 0)
  747.          ns = -ns;
  748.       else
  749.          ns = abs((int)p->pblock->nparam);
  750.       if (n == ns) {
  751.          StrLen(*dp) = D_Proc;    /* really type field */
  752.          BlkLoc(*dp) = (union block *)p->pblock;
  753.          return T_Proc;
  754.          }
  755.      }
  756.    return CvtFail;
  757. #endif                    /* StrInvoke */
  758.  
  759.    }
  760.