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