home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / runtime / cnv.r next >
Text File  |  2002-01-18  |  25KB  |  1,183 lines
  1. /*
  2.  * cnv.r -- Conversion routines:
  3.  *
  4.  * cnv_c_dbl, cnv_c_int, cnv_c_str, cnv_cset, cnv_ec_int,
  5.  * cnv_eint, cnv_int, cnv_real, cnv_str, cnv_tcset, cnv_tstr, deref,
  6.  * getdbl, strprc, bi_strprc
  7.  *
  8.  * Service routines: itos, ston, radix, cvpos
  9.  *
  10.  * Philosophy: certain redundancy is present which could be avoided,
  11.  * and nested conversion calls are avoided due to the importance of
  12.  * minimizing these routines' costs.
  13.  *
  14.  * Assumed: the C compiler must handle assignments of C integers to
  15.  * C double variables and vice-versa.  Hopefully production C compilers
  16.  * have managed to eliminate bugs related to these assignments.
  17.  *
  18.  * Note: calls beginning with EV are empty macros unless EventMon
  19.  * is defined.
  20.  */
  21.  
  22. #define tonum(c)    (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
  23.  
  24. /*
  25.  * Prototypes for static functions.
  26.  */
  27. static void cstos (unsigned int *cs, dptr dp, char *s);
  28. static void itos (C_integer num, dptr dp, char *s);
  29. static int ston (dptr sp, union numeric *result);
  30. static int tmp_str (char *sbuf, dptr s, dptr d);
  31.  
  32. /*
  33.  * cnv_c_dbl - cnv:C_double(*s, *d), convert a value directly into a C double
  34.  */
  35. int cnv_c_dbl(s, d)
  36. dptr s;
  37. double *d;
  38.    {
  39.  
  40. #ifdef LargeInts
  41.    tended    /* need to be tended if ston allocates largeint blocks */
  42. #endif                    /* LargeInts */
  43.  
  44.    struct descrip result, cnvstr;
  45.    char sbuf[MaxCvtLen];
  46.  
  47.    union numeric numrc;
  48.  
  49.    type_case *s of {
  50.       real: {
  51.          GetReal(s, *d);
  52.          return 1;
  53.          }
  54.       integer: {
  55.  
  56. #ifdef LargeInts
  57.          if (Type(*s) == T_Lrgint)
  58.             *d = bigtoreal(s);
  59.          else
  60. #endif                    /* LargeInts */
  61.  
  62.             *d = IntVal(*s);
  63.  
  64.          return 1;
  65.          }
  66.       string: {
  67.          /* fall through */
  68.          }
  69.       cset: {
  70.         tmp_str(sbuf, s, &cnvstr);
  71.         s = &cnvstr;
  72.         }
  73.       default: {
  74.         return 0;
  75.         }
  76.       }
  77.  
  78.    /*
  79.     * s is now an string.
  80.     */
  81.    switch( ston(s, &numrc) ) {
  82.       case T_Integer:
  83.          *d = numrc.integer;
  84.          return 1;
  85.  
  86. #ifdef LargeInts
  87.       case T_Lrgint:
  88.          result.dword = D_Lrgint;
  89.      BlkLoc(result) = (union block *)numrc.big;
  90.          *d = bigtoreal(&result);
  91.          return 1;
  92. #endif                    /* LargeInts */
  93.  
  94.       case T_Real:
  95.          *d = numrc.real;
  96.          return 1;
  97.       default:
  98.          return 0;
  99.       }
  100.   }
  101.  
  102. /*
  103.  * cnv_c_int - cnv:C_integer(*s, *d), convert a value directly into a C_integer
  104.  */
  105. int cnv_c_int(s, d)
  106. dptr s;
  107. C_integer *d;
  108.    {
  109.  
  110. #ifdef LargeInts
  111.    tended  /* tended since ston now allocates blocks */
  112. #endif                        /* LargeInts */
  113.  
  114.    struct descrip cnvstr, result;            /* not tended */
  115.    union numeric numrc;
  116.    char sbuf[MaxCvtLen];
  117.  
  118.    type_case *s of {
  119.       integer: {
  120.  
  121. #ifdef LargeInts
  122.          if (Type(*s) == T_Lrgint) {
  123.             return 0;
  124.             }
  125. #endif                    /* LargeInts */
  126.  
  127.          *d = IntVal(*s);
  128.          return 1;
  129.          }
  130.       real: {
  131.          double dbl;
  132.          GetReal(s,dbl);
  133.          if (dbl > MaxLong || dbl < MinLong) {
  134.             return 0;
  135.             }
  136.          *d = dbl;
  137.          return 1;
  138.          }
  139.       string: {
  140.          /* fall through */
  141.          }
  142.       cset: {
  143.         tmp_str(sbuf, s, &cnvstr);
  144.         s = &cnvstr;
  145.         }
  146.       default: {
  147.          return 0;
  148.          }
  149.       }
  150.  
  151.    /*
  152.     * s is now a string.
  153.     */
  154.    switch( ston(s, &numrc) ) {
  155.       case T_Integer: {
  156.          *d = numrc.integer;
  157.          return 1;
  158.      }
  159.       case T_Real: {
  160.          double dbl = numrc.real;
  161.          if (dbl > MaxLong || dbl < MinLong) {
  162.             return 0;
  163.             }
  164.          *d = dbl;
  165.          return 1;
  166.          }
  167.       default:
  168.          return 0;
  169.       }
  170.    }
  171.  
  172. /*
  173.  * cnv_c_str - cnv:C_string(*s, *d), convert a value into a C (and Icon) string
  174.  */
  175. int cnv_c_str(s, d)
  176. dptr s;
  177. dptr d;
  178.    {
  179.    /*
  180.     * Get the string to the end of the string region and append a '\0'.
  181.     */
  182.  
  183.    if (!is:string(*s)) {
  184.       if (!cnv_str(s, d)) {
  185.          return 0;
  186.          }
  187.       }
  188.    else {
  189.       *d = *s;
  190.       }
  191.  
  192.    /*
  193.     * See if the end of d is already at the end of the string region
  194.     * and there is room for one more byte.
  195.     */
  196.    if ((StrLoc(*d) + StrLen(*d) == strfree) && (strfree != strend)) {
  197.       Protect(alcstr("\0", 1), fatalerr(0,NULL));
  198.       ++StrLen(*d);
  199.       }
  200.    else {
  201.       register word slen = StrLen(*d);
  202.       register char *sp, *dp;
  203.       Protect(dp = alcstr(NULL,slen+1), fatalerr(0,NULL));
  204.       StrLen(*d) = StrLen(*d)+1;
  205.       sp = StrLoc(*d);
  206.       StrLoc(*d) = dp;
  207.       while (slen-- > 0)
  208.          *dp++ = *sp++;
  209.       *dp = '\0';
  210.       }
  211.  
  212.    return 1;
  213.    }
  214.  
  215. /*
  216.  * cnv_cset - cnv:cset(*s, *d), convert to a cset
  217.  */
  218. int cnv_cset(s, d)
  219. dptr s, d;
  220.    {
  221.    tended struct descrip str;
  222.    char sbuf[MaxCvtLen];
  223.    register C_integer l;
  224.    register char *s1;        /* does not need to be tended */
  225.  
  226.    EVValD(s, E_Aconv);
  227.    EVValD(&csetdesc, E_Tconv);
  228.  
  229.    if (is:cset(*s)) {
  230.       *d = *s;
  231.       EVValD(s, E_Nconv);
  232.       return 1;
  233.       }
  234.    /*
  235.     * convert to a string and then add its contents to the cset
  236.     */
  237.    if (tmp_str(sbuf, s, &str)) {
  238.       Protect(BlkLoc(*d) = (union block *)alccset(), fatalerr(0,NULL));
  239.       d->dword = D_Cset;
  240.       s1 = StrLoc(str);
  241.       l = StrLen(str);
  242.       while(l--) {
  243.          Setb(*s1, *d);
  244.      s1++;
  245.          }
  246.       EVValD(d, E_Sconv);
  247.       return 1;
  248.       }
  249.    else {
  250.       EVValD(s, E_Fconv);
  251.       return 0;
  252.       }
  253.   }
  254.  
  255. /*
  256.  * cnv_ec_int - cnv:(exact)C_integer(*s, *d), convert to an exact C integer
  257.  */
  258. int cnv_ec_int(s, d)
  259. dptr s;
  260. C_integer *d;
  261.    {
  262.  
  263. #ifdef LargeInts
  264.    tended  /* tended since ston now allocates blocks */
  265. #endif                        /* LargeInts */
  266.  
  267.    struct descrip cnvstr;            /* not tended */
  268.    union numeric numrc;
  269.    char sbuf[MaxCvtLen];
  270.  
  271.    type_case *s of {
  272.       integer: {
  273.  
  274. #ifdef LargeInts
  275.          if (Type(*s) == T_Lrgint) {
  276.             return 0;
  277.             }
  278. #endif                    /* LargeInts */
  279.          *d = IntVal(*s);
  280.          return 1;
  281.          }
  282.       string: {
  283.          /* fall through */
  284.          }
  285.       cset: {
  286.         tmp_str(sbuf, s, &cnvstr);
  287.         s = &cnvstr;
  288.         }
  289.       default: {
  290.          return 0;
  291.          }
  292.       }
  293.  
  294.    /*
  295.     * s is now a string.
  296.     */
  297.    if (ston(s, &numrc) == T_Integer) {
  298.       *d = numrc.integer;
  299.       return 1;
  300.       }
  301.    else {
  302.       return 0;
  303.       }
  304.    }
  305.  
  306. /*
  307.  * cnv_eint - cnv:(exact)integer(*s, *d), convert to an exact integer
  308.  */
  309. int cnv_eint(s, d)
  310. dptr s, d;
  311.    {
  312.  
  313. #ifdef LargeInts
  314.    tended  /* tended since ston now allocates blocks */
  315. #endif                        /* LargeInts */
  316.  
  317.    struct descrip cnvstr;            /* not tended */
  318.    char sbuf[MaxCvtLen];
  319.    union numeric numrc;
  320.  
  321.    type_case *s of {
  322.       integer: {
  323.          *d = *s;
  324.          return 1;
  325.          }
  326.       string: {
  327.          /* fall through */
  328.          }
  329.       cset: {
  330.         tmp_str(sbuf, s, &cnvstr);
  331.         s = &cnvstr;
  332.         }
  333.       default: {
  334.         return 0;
  335.         }
  336.       }
  337.  
  338.    /*
  339.     * s is now a string.
  340.     */
  341.    switch (ston(s, &numrc)) {
  342.       case T_Integer:
  343.          MakeInt(numrc.integer, d);
  344.      return 1;
  345.  
  346. #ifdef LargeInts
  347.       case T_Lrgint:
  348.          d->dword = D_Lrgint;
  349.      BlkLoc(*d) = (union block *)numrc.big;
  350.          return 1;
  351. #endif                /* LargeInts */
  352.  
  353.       default:
  354.          return 0;
  355.       }
  356.    }
  357.  
  358. /*
  359.  * cnv_int - cnv:integer(*s, *d), convert to integer
  360.  */
  361. int cnv_int(s, d)
  362. dptr s, d;
  363.    {
  364.  
  365. #ifdef LargeInts
  366.    tended   /* tended since ston now allocates blocks */
  367. #endif                        /* LargeInts */
  368.  
  369.    struct descrip cnvstr;            /* not tended */
  370.    char sbuf[MaxCvtLen];
  371.    union numeric numrc;
  372.  
  373.    EVValD(s, E_Aconv);
  374.    EVValD(&zerodesc, E_Tconv);
  375.  
  376.    type_case *s of {
  377.       integer: {
  378.          *d = *s;
  379.          EVValD(s, E_Nconv);
  380.          return 1;
  381.          }
  382.       real: {
  383.          double dbl;
  384.          GetReal(s,dbl);
  385.          if (dbl > MaxLong || dbl < MinLong) {
  386.  
  387. #ifdef LargeInts
  388.             if (realtobig(s, d) == Succeeded) {
  389.                EVValD(d, E_Sconv);
  390.                return 1;
  391.                }
  392.             else {
  393.                EVValD(s, E_Fconv);
  394.                return 0;
  395.                }
  396. #else                    /* LargeInts */
  397.             EVValD(s, E_Fconv);
  398.             return 0;
  399. #endif                    /* LargeInts */
  400.         }
  401.          MakeInt((word)dbl,d);
  402.          EVValD(d, E_Sconv);
  403.          return 1;
  404.          }
  405.       string: {
  406.          /* fall through */
  407.          }
  408.       cset: {
  409.         tmp_str(sbuf, s, &cnvstr);
  410.         s = &cnvstr;
  411.         }
  412.       default: {
  413.          EVValD(s, E_Fconv);
  414.          return 0;
  415.          }
  416.       }
  417.  
  418.    /*
  419.     * s is now a string.
  420.     */
  421.    switch( ston(s, &numrc) ) {
  422.  
  423. #ifdef LargeInts
  424.       case T_Lrgint:
  425.          d->dword = D_Lrgint;
  426.      BlkLoc(*d) = (union block *)numrc.big;
  427.          EVValD(d, E_Sconv);
  428.      return 1;
  429. #endif                    /* LargeInts */
  430.  
  431.       case T_Integer:
  432.          MakeInt(numrc.integer,d);
  433.          EVValD(d, E_Sconv);
  434.          return 1;
  435.       case T_Real: {
  436.          double dbl = numrc.real;
  437.          if (dbl > MaxLong || dbl < MinLong) {
  438.  
  439. #ifdef LargeInts
  440.             if (realtobig(s, d) == Succeeded) {
  441.                EVValD(d, E_Sconv);
  442.                return 1;
  443.                }
  444.             else {
  445.                EVValD(s, E_Fconv);
  446.                return 0;
  447.                }
  448. #else                    /* LargeInts */
  449.             EVValD(s, E_Fconv);
  450.             return 0;
  451. #endif                    /* LargeInts */
  452.         }
  453.          MakeInt((word)dbl,d);
  454.          EVValD(d, E_Sconv);
  455.          return 1;
  456.          }
  457.       default:
  458.          EVValD(s, E_Fconv);
  459.          return 0;
  460.       }
  461.    }
  462.  
  463. /*
  464.  * cnv_real - cnv:real(*s, *d), convert to real
  465.  */
  466. int cnv_real(s, d)
  467. dptr s, d;
  468.    {
  469.    double dbl;
  470.  
  471.    EVValD(s, E_Aconv);
  472.    EVValD(&rzerodesc, E_Tconv);
  473.  
  474.    if (cnv_c_dbl(s, &dbl)) {
  475.       Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL));
  476.       d->dword = D_Real;
  477.       EVValD(d, E_Sconv);
  478.       return 1;
  479.       }
  480.    else
  481.       EVValD(s, E_Fconv);
  482.       return 0;
  483.    }
  484.  
  485. /*
  486.  * cnv_str - cnv:string(*s, *d), convert to a string
  487.  */
  488. int cnv_str(s, d)
  489. dptr s, d;
  490.    {
  491.    char sbuf[MaxCvtLen];
  492.  
  493.    EVValD(s, E_Aconv);
  494.    EVValD(&emptystr, E_Tconv);
  495.  
  496.    type_case *s of {
  497.       string: {
  498.          *d = *s;
  499.          EVValD(s, E_Nconv);
  500.          return 1;
  501.          }
  502.       integer: {
  503.  
  504. #ifdef LargeInts
  505.          if (Type(*s) == T_Lrgint) {
  506.             word slen;
  507.             word dlen;
  508.  
  509.             slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1);
  510.             dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  511.         bigtos(s,d);
  512.         }
  513.          else
  514. #endif                    /* LargeInts */
  515.  
  516.          itos(IntVal(*s), d, sbuf);
  517.      }
  518.       real: {
  519.          double res;
  520.          GetReal(s, res);
  521.          rtos(res, d, sbuf);
  522.          }
  523.       cset:
  524.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  525.       default: {
  526.          EVValD(s, E_Fconv);
  527.          return 0;
  528.          }
  529.       }
  530.    Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL));
  531.    EVValD(d, E_Sconv);
  532.    return 1;
  533.    }
  534.  
  535. /*
  536.  * cnv_tcset - cnv:tmp_cset(*s, *d), convert to a temporary cset
  537.  */
  538. int cnv_tcset(cbuf, s, d)
  539. struct b_cset *cbuf;
  540. dptr s, d;
  541.    {
  542.    struct descrip tmpstr;
  543.    char sbuf[MaxCvtLen];
  544.    register char *s1;
  545.    C_integer l;
  546.  
  547.    EVValD(s, E_Aconv);
  548.    EVValD(&csetdesc, E_Tconv);
  549.  
  550.    if (is:cset(*s)) {
  551.       *d = *s;
  552.       EVValD(s, E_Nconv);
  553.       return 1;
  554.       }
  555.    if (tmp_str(sbuf, s, &tmpstr)) {
  556.       for (l = 0; l < CsetSize; l++)
  557.           cbuf->bits[l] = 0;
  558.       d->dword = D_Cset;
  559.       BlkLoc(*d) = (union block *)cbuf;
  560.       s1 = StrLoc(tmpstr);
  561.       l = StrLen(tmpstr);
  562.       while(l--) {
  563.          Setb(*s1, *d);
  564.      s1++;
  565.          }
  566.       EVValD(d, E_Sconv);
  567.       return 1;
  568.       }
  569.    else {
  570.       EVValD(s, E_Fconv);
  571.       return 0;
  572.       }
  573.    }
  574.  
  575. /*
  576.  * cnv_tstr - cnv:tmp_string(*s, *d), convert to a temporary string
  577.  */
  578. int cnv_tstr(sbuf, s, d)
  579. char *sbuf;
  580. dptr s;
  581. dptr d;
  582.    {
  583.    EVValD(s, E_Aconv);
  584.    EVValD(&emptystr, E_Tconv);
  585.  
  586.    if (is:string(*s)) {
  587.       *d = *s;
  588.       EVValD(s, E_Nconv);
  589.       return 1;
  590.       }
  591.    else if (tmp_str(sbuf, s, d)) {
  592.       EVValD(d, E_Sconv);
  593.       return 1;
  594.       }
  595.    else {
  596.       EVValD(s, E_Fconv);
  597.       return 0;
  598.       }
  599.    }
  600.  
  601. /*
  602.  * deref - dereference a descriptor.
  603.  */
  604. void deref(s, d)
  605. dptr s, d;
  606.    {
  607.    /*
  608.     * no allocation is done, so nothing need be tended.
  609.     */
  610.    register union block *bp;
  611.    struct descrip v;
  612.    register union block **ep;
  613.    int res;
  614.  
  615.    if (!is:variable(*s)) {
  616.       *d = *s;
  617.       }
  618.    else type_case *s of {
  619.       tvsubs: {
  620.          /*
  621.           * A substring trapped variable is being dereferenced.
  622.           *  Point bp to the trapped variable block and v to
  623.           *  the string.
  624.           */
  625.          bp = BlkLoc(*s);
  626.          deref(&bp->tvsubs.ssvar, &v);
  627.          if (!is:string(v))
  628.             fatalerr(103, &v);
  629.          if (bp->tvsubs.sspos + bp->tvsubs.sslen - 1 > StrLen(v))
  630.             fatalerr(205, NULL);
  631.          /*
  632.           * Make a descriptor for the substring by getting the
  633.           *  length and pointing into the string.
  634.           */
  635.          StrLen(*d) = bp->tvsubs.sslen;
  636.          StrLoc(*d) = StrLoc(v) + bp->tvsubs.sspos - 1;
  637.         }
  638.  
  639.       tvtbl: {
  640.          /*
  641.           * Look up the element in the table.
  642.           */
  643.          bp = BlkLoc(*s);
  644.          ep = memb(bp->tvtbl.clink,&bp->tvtbl.tref,bp->tvtbl.hashnum,&res);
  645.          if (res == 1)
  646.             *d = (*ep)->telem.tval;            /* found; use value */
  647.          else
  648.             *d = bp->tvtbl.clink->table.defvalue;    /* nope; use default */
  649.          }
  650.  
  651.       kywdint:
  652.       kywdpos:
  653.       kywdsubj:
  654.       kywdevent:
  655.       kywdwin:
  656.       kywdstr:
  657.          *d = *VarLoc(*s);
  658.  
  659.       default:
  660.          /*
  661.           * An ordinary variable is being dereferenced.
  662.           */
  663.          *d = *(dptr)((word *)VarLoc(*s) + Offset(*s));
  664.       }
  665.    }
  666.  
  667. /*
  668.  * getdbl - return as a double the value inside a real block.
  669.  */
  670. double getdbl(dp)
  671. dptr dp;
  672.    {
  673.    double d;
  674.    GetReal(dp, d);
  675.    return d;
  676.    }
  677.  
  678. /*
  679.  * tmp_str - Convert to temporary string.
  680.  */
  681. static int tmp_str(sbuf, s, d)
  682. char *sbuf;
  683. dptr s;
  684. dptr d;
  685.    {
  686.    type_case *s of {
  687.       string:
  688.          *d = *s;
  689.       integer: {
  690.  
  691. #ifdef LargeInts
  692.          if (Type(*s) == T_Lrgint) {
  693.             word slen;
  694.             word dlen;
  695.  
  696.             slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1);
  697.             dlen = slen * NB * 0.3010299956639812;    /* 1 / log2(10) */
  698.         bigtos(s,d);
  699.         }
  700.          else
  701. #endif                    /* LargeInts */
  702.  
  703.          itos(IntVal(*s), d, sbuf);
  704.      }
  705.       real: {
  706.          double res;
  707.          GetReal(s, res);
  708.          rtos(res, d, sbuf);
  709.          }
  710.       cset:
  711.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  712.       default:
  713.          return 0;
  714.       }
  715.    return 1;
  716.    }
  717.  
  718. /*
  719.  * dp_pnmcmp - do a string comparison of a descriptor to the procedure
  720.  *   name in a pstrnm struct; used in call to qsearch().
  721.  */
  722. int dp_pnmcmp(pne,dp)
  723. struct pstrnm *pne;
  724. struct descrip *dp;
  725. {
  726.    struct descrip d;
  727.    StrLen(d) = strlen(pne->pstrep);
  728.    StrLoc(d) = pne->pstrep;
  729.    return lexcmp(&d,dp);
  730. }
  731.  
  732. /*
  733.  * bi_strprc - convert a string to a (built-in) function or operator.
  734.  */
  735. struct b_proc *bi_strprc(s, arity)
  736. dptr s;
  737. C_integer arity;
  738.    {
  739.    C_integer i;
  740.    struct pstrnm *pp;
  741.  
  742.    if (!StrLen(*s))
  743.       return NULL;
  744.  
  745.    /*
  746.     * See if the string represents an operator. In this case the arity
  747.     *  of the operator must match the one given.
  748.     */
  749.    if (!isalpha(*StrLoc(*s))) {
  750.       for (i = 0; i < op_tbl_sz; ++i)
  751.      if (eq(s, &op_tbl[i].pname) && (arity == op_tbl[i].nparam ||
  752.                      op_tbl[i].nparam == -1))
  753.         return &op_tbl[i];
  754.       return NULL;
  755.       }
  756.  
  757.    /*
  758.     * See if the string represents a built-in function.
  759.     */
  760. #if COMPILER
  761.    for (i = 0; i < n_globals; ++i)
  762.       if (eq(s, &gnames[i]))
  763.      return builtins[i];  /* may be null */
  764. #else                    /* COMPILER */
  765.    pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize,
  766.                  sizeof(struct pstrnm),dp_pnmcmp);
  767.    if (pp!=NULL)
  768.       return (struct b_proc *)pp->pblock;
  769. #endif                    /* !COMPILER */
  770.  
  771.    return NULL;
  772.    }
  773.  
  774. /*
  775.  * strprc - convert a string to a procedure.
  776.  */
  777. struct b_proc *strprc(s, arity)
  778. dptr s;
  779. C_integer arity;
  780.    {
  781.    C_integer i;
  782.  
  783.    /*
  784.     * See if the string is the name of a global variable.
  785.     */
  786.    for (i = 0; i < n_globals; ++i)
  787.       if (eq(s, &gnames[i]))
  788.          if (is:proc(globals[i]))
  789.             return (struct b_proc *)BlkLoc(globals[i]);
  790.          else
  791.             return NULL;
  792.  
  793.    return bi_strprc(s,arity);
  794.    }
  795.  
  796. /*
  797.  * Service routines
  798.  */
  799.  
  800. /*
  801.  * itos - convert the integer num into a string using s as a buffer and
  802.  *  making q a descriptor for the resulting string.
  803.  */
  804.  
  805. static void itos(num, dp, s)
  806. C_integer num;
  807. dptr dp;
  808. char *s;
  809.    {
  810.    register char *p;
  811.    long ival;
  812.    static char *maxneg = MaxNegInt;
  813.  
  814.    p = s + MaxCvtLen - 1;
  815.    ival = num;
  816.  
  817.    *p = '\0';
  818.    if (num >= 0L)
  819.       do {
  820.      *--p = ival % 10L + '0';
  821.      ival /= 10L;
  822.      } while (ival != 0L);
  823.    else {
  824.       if (ival == -ival) {      /* max negative value */
  825.      p -= strlen (maxneg);
  826.      sprintf (p, "%s", maxneg);
  827.          }
  828.       else {
  829.     ival = -ival;
  830.     do {
  831.        *--p = '0' + (ival % 10L);
  832.        ival /= 10L;
  833.        } while (ival != 0L);
  834.     *--p = '-';
  835.     }
  836.       }
  837.  
  838.    StrLen(*dp) = s + MaxCvtLen - 1 - p;
  839.    StrLoc(*dp) = p;
  840.    }
  841.  
  842.  
  843. /*
  844.  * ston - convert a string to a numeric quantity if possible.
  845.  * Returns a typecode or CvtFail.  Its answer is in the dptr,
  846.  * unless its a double, in which case its in the union numeric
  847.  * (we do this to avoid allocating a block for a real
  848.  * that will later be used directly as a C_double).
  849.  */
  850. static int ston(sp, result)
  851. dptr sp;
  852. union numeric *result;
  853.    {
  854.    register char *s = StrLoc(*sp), *end_s;
  855.    register int c;
  856.    int realflag = 0;    /* indicates a real number */
  857.    char msign = '+';    /* sign of mantissa */
  858.    char esign = '+';    /* sign of exponent */
  859.    double mantissa = 0; /* scaled mantissa with no fractional part */
  860.    long lresult = 0;    /* integer result */
  861.    int scale = 0;    /* number of decimal places to shift mantissa */
  862.    int digits = 0;    /* total number of digits seen */
  863.    int sdigits = 0;    /* number of significant digits seen */
  864.    int exponent = 0;    /* exponent part of real number */
  865.    double fiveto;    /* holds 5^scale */
  866.    double power;    /* holds successive squares of 5 to compute fiveto */
  867.    int err_no;
  868.    char *ssave;         /* holds original ptr for bigradix */
  869.  
  870.    if (StrLen(*sp) == 0)
  871.       return CvtFail;
  872.    end_s = s + StrLen(*sp);
  873.    c = *s++;
  874.  
  875.    /*
  876.     * Skip leading white space.
  877.     */
  878.    while (isspace(c))
  879.       if (s < end_s)
  880.          c = *s++;
  881.       else
  882.          return CvtFail;
  883.  
  884.    /*
  885.     * Check for sign.
  886.     */
  887.    if (c == '+' || c == '-') {
  888.       msign = c;
  889.       c = (s < end_s) ? *s++ : ' ';
  890.       }
  891.  
  892.    ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */
  893.  
  894.    /*
  895.     * Get integer part of mantissa.
  896.     */
  897.    while (isdigit(c)) {
  898.       digits++;
  899.       if (mantissa < Big) {
  900.      mantissa = mantissa * 10 + (c - '0');
  901.          lresult = lresult * 10 + (c - '0');
  902.      if (mantissa > 0.0)
  903.         sdigits++;
  904.      }
  905.       else
  906.      scale++;
  907.       c = (s < end_s) ? *s++ : ' ';
  908.       }
  909.  
  910.    /*
  911.     * Check for based integer.
  912.     */
  913.    if (c == 'r' || c == 'R') {
  914.       int rv;
  915. #ifdef LargeInts
  916.       rv = bigradix((int)msign, (int)mantissa, s, end_s, result);
  917.       if (rv == Error)
  918.          fatalerr(0, NULL);
  919. #else                    /* LargeInts */
  920.       rv = radix((int)msign, (int)mantissa, s, end_s, result);
  921. #endif                    /* LargeInts */
  922.       return rv;
  923.       }
  924.  
  925.    /*
  926.     * Get fractional part of mantissa.
  927.     */
  928.    if (c == '.') {
  929.       realflag++;
  930.       c = (s < end_s) ? *s++ : ' ';
  931.       while (isdigit(c)) {
  932.      digits++;
  933.      if (mantissa < Big) {
  934.         mantissa = mantissa * 10 + (c - '0');
  935.         lresult = lresult * 10 + (c - '0');
  936.         scale--;
  937.         if (mantissa > 0.0)
  938.            sdigits++;
  939.         }
  940.          c = (s < end_s) ? *s++ : ' ';
  941.      }
  942.       }
  943.  
  944.    /*
  945.     * Check that at least one digit has been seen so far.
  946.     */
  947.    if (digits == 0)
  948.       return CvtFail;
  949.  
  950.    /*
  951.     * Get exponent part.
  952.     */
  953.    if (c == 'e' || c == 'E') {
  954.       realflag++;
  955.       c = (s < end_s) ? *s++ : ' ';
  956.       if (c == '+' || c == '-') {
  957.      esign = c;
  958.          c = (s < end_s) ? *s++ : ' ';
  959.      }
  960.       if (!isdigit(c))
  961.      return CvtFail;
  962.       while (isdigit(c)) {
  963.      exponent = exponent * 10 + (c - '0');
  964.          c = (s < end_s) ? *s++ : ' ';
  965.      }
  966.       scale += (esign == '+') ? exponent : -exponent;
  967.       }
  968.  
  969.    /*
  970.     * Skip trailing white space and make sure there is nothing else left
  971.     *  in the string. Note, if we have already reached end-of-string,
  972.     *  c has been set to a space.
  973.     */
  974.    while (isspace(c) && s < end_s)
  975.       c = *s++;
  976.    if (!isspace(c))
  977.       return CvtFail;
  978.  
  979.    /*
  980.     * Test for integer.
  981.     */
  982.    if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
  983.       result->integer = (msign == '+' ? lresult : -lresult);
  984.       return T_Integer;
  985.       }
  986.  
  987. #ifdef LargeInts
  988.    /*
  989.     * Test for bignum.
  990.     */
  991. #if COMPILER
  992.    if (largeints)
  993. #endif                    /* COMPILER */
  994.       if (!realflag) {
  995.          int rv;
  996.          rv = bigradix((int)msign, 10, ssave, end_s, result);
  997.          if (rv == Error)
  998.             fatalerr(0, NULL);
  999.          return rv;
  1000.          }
  1001. #endif                    /* LargeInts */
  1002.  
  1003.    if (!realflag)
  1004.       return CvtFail;        /* don't promote to real if integer format */
  1005.  
  1006.    /*
  1007.     * Rough tests for overflow and underflow.
  1008.     */
  1009.    if (sdigits + scale > LogHuge)
  1010.       return CvtFail;
  1011.  
  1012.    if (sdigits + scale < -LogHuge) {
  1013.       result->real = 0.0;
  1014.       return T_Real;
  1015.       }
  1016.  
  1017.    /*
  1018.     * Put the number together by multiplying the mantissa by 5^scale and
  1019.     *  then using ldexp() to multiply by 2^scale.
  1020.     */
  1021.  
  1022.    exponent = (scale > 0)? scale : -scale;
  1023.    fiveto = 1.0;
  1024.    power = 5.0;
  1025.    for (;;) {
  1026.       if (exponent & 01)
  1027.      fiveto *= power;
  1028.       exponent >>= 1;
  1029.       if (exponent == 0)
  1030.      break;
  1031.       power *= power;
  1032.       }
  1033.    if (scale > 0)
  1034.       mantissa *= fiveto;
  1035.    else
  1036.       mantissa /= fiveto;
  1037.  
  1038.    err_no = 0;
  1039.    mantissa = ldexp(mantissa, scale);
  1040.    if (err_no > 0 && mantissa > 0)
  1041.       /*
  1042.        * ldexp caused overflow.
  1043.        */
  1044.       return CvtFail;
  1045.  
  1046.    if (msign == '-')
  1047.       mantissa = -mantissa;
  1048.    result->real = mantissa;
  1049.    return T_Real;
  1050.    }
  1051.  
  1052. #if COMPILER || !(defined LargeInts)
  1053. /*
  1054.  * radix - convert string s in radix r into an integer in *result.  sign
  1055.  *  will be either '+' or '-'.
  1056.  */
  1057. int radix(sign, r, s, end_s, result)
  1058. int sign;
  1059. register int r;
  1060. register char *s;
  1061. register char *end_s;
  1062. union numeric *result;
  1063.    {
  1064.    register int c;
  1065.    long num;
  1066.  
  1067.    if (r < 2 || r > 36)
  1068.       return CvtFail;
  1069.    c = (s < end_s) ? *s++ : ' ';
  1070.    num = 0L;
  1071.    while (isalnum(c)) {
  1072.       c = tonum(c);
  1073.       if (c >= r)
  1074.      return CvtFail;
  1075.       num = num * r + c;
  1076.       c = (s < end_s) ? *s++ : ' ';
  1077.       }
  1078.  
  1079.    /*
  1080.     * Skip trailing white space and make sure there is nothing else left
  1081.     *  in the string. Note, if we have already reached end-of-string,
  1082.     *  c has been set to a space.
  1083.     */
  1084.    while (isspace(c) && s < end_s)
  1085.       c = *s++;
  1086.    if (!isspace(c))
  1087.       return CvtFail;
  1088.  
  1089.    result->integer = (sign == '+' ? num : -num);
  1090.  
  1091.    return T_Integer;
  1092.    }
  1093. #endif                    /* COMPILER || !(defined LargeInts) */
  1094.  
  1095.  
  1096. /*
  1097.  * cvpos - convert position to strictly positive position
  1098.  *  given length.
  1099.  */
  1100.  
  1101. word cvpos(pos, len)
  1102. long pos;
  1103. register long len;
  1104.    {
  1105.    register word p;
  1106.  
  1107.    /*
  1108.     * Make sure the position is in the range of an int. (?)
  1109.     */
  1110.    if ((long)(p = pos) != pos)
  1111.       return CvtFail;
  1112.    /*
  1113.     * Make sure the position is within range.
  1114.     */
  1115.    if (p < -len || p > len + 1)
  1116.       return CvtFail;
  1117.    /*
  1118.     * If the position is greater than zero, just return it.  Otherwise,
  1119.     *  convert the zero/negative position.
  1120.     */
  1121.    if (pos > 0)
  1122.       return p;
  1123.    return (len + p + 1);
  1124.    }
  1125.  
  1126. double dblZero = 0.0;
  1127.  
  1128. /*
  1129.  * rtos - convert the real number n into a string using s as a buffer and
  1130.  *  making a descriptor for the resulting string.
  1131.  */
  1132. void rtos(n, dp, s)
  1133. double n;
  1134. dptr dp;
  1135. char *s;
  1136.    {
  1137.    s++;                    /* leave room for leading zero */
  1138.    sprintf(s, "%.*g", Precision, n + dblZero);   /* format, avoiding -0 */
  1139.  
  1140.    /*
  1141.     * Now clean up possible messes.
  1142.     */
  1143.    while (*s == ' ')            /* delete leading blanks */
  1144.       s++;
  1145.    if (*s == '.') {            /* prefix 0 to initial period */
  1146.       s--;
  1147.       *s = '0';
  1148.       }
  1149.    else if (!strchr(s, '.') && !strchr(s,'e') && !strchr(s,'E'))
  1150.          strcat(s, ".0");        /* if no decimal point or exp. */
  1151.    if (s[strlen(s) - 1] == '.')        /* if decimal point is at end ... */
  1152.       strcat(s, "0");
  1153.    StrLen(*dp) = strlen(s);
  1154.    StrLoc(*dp) = s;
  1155.    }
  1156.  
  1157. /*
  1158.  * cstos - convert the cset bit array pointed at by cs into a string using
  1159.  *  s as a buffer and making a descriptor for the resulting string.
  1160.  */
  1161.  
  1162. static void cstos(cs, dp, s)
  1163. unsigned int *cs;
  1164. dptr dp;
  1165. char *s;
  1166.    {
  1167.    register unsigned int w;
  1168.    register int j, i;
  1169.    register char *p;
  1170.  
  1171.    p = s;
  1172.    for (i = 0; i < CsetSize; i++) {
  1173.       if (cs[i])
  1174.      for (j=i*IntBits, w=cs[i]; w; j++, w >>= 1)
  1175.         if (w & 01)
  1176.            *p++ = (char)j;
  1177.       }
  1178.    *p = '\0';
  1179.  
  1180.    StrLen(*dp) = p - s;
  1181.    StrLoc(*dp) = s;
  1182.    }
  1183.