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 / common / dconsole.c < prev    next >
C/C++ Source or Header  |  2002-01-18  |  22KB  |  952 lines
  1. /*
  2.  * dconsole.c - versions of run-time support for console windows for
  3.  *  applications that do not include the entire Icon runtime system
  4.  *  (namely, icont and rtt).
  5.  */
  6. #include "../h/rt.h"
  7.  
  8. #ifdef ConsoleWindow
  9.  
  10. FILE *ConsoleBinding = NULL;
  11. struct region *curstring, *curblock;
  12.  
  13. #define AlcBlk(var, struct_nm, t_code, nbytes) \
  14. var = (struct struct_nm *)calloc(1, nbytes); \
  15. if (!var) return NULL; \
  16. var->title = t_code;
  17.  
  18. #define AlcFixBlk(var, struct_nm, t_code)\
  19.    AlcBlk(var, struct_nm, t_code, sizeof(struct struct_nm))
  20. /*
  21.  * AlcVarBlk - allocate a variable-length block.
  22.  */
  23. #define AlcVarBlk(var, struct_nm, t_code, n_desc) \
  24.    { \
  25.    register uword size; \
  26.    size = sizeof(struct struct_nm) + (n_desc - 1) * sizeof(struct descrip);\
  27.    AlcBlk(var, struct_nm, t_code, size)\
  28.    var->blksize = size;\
  29.    }
  30.  
  31. struct descrip nulldesc = {D_Null};    /* null value */
  32. struct descrip nullptr =
  33.    {F_Ptr | F_Nqual};                    /* descriptor with null block pointer */
  34. struct descrip emptystr;        /* zero-length empty string */
  35. struct descrip kywd_prog;        /* &progname */
  36. struct descrip kywd_err = {D_Integer};  /* &error */
  37.  
  38. int t_errornumber = 0;            /* tentative k_errornumber value */
  39. int t_have_val = 0;            /* tentative have_errval flag */
  40. struct descrip t_errorvalue;        /* tentative k_errorvalue value */
  41. static int list_ser;
  42. struct tend_desc *tend;
  43.  
  44. #ifdef MSWindows
  45.    char *getenv(char *s)
  46.    {
  47.    static char tmp[1537];
  48.    DWORD rv;
  49.    rv = GetEnvironmentVariable(s, tmp, 1536);
  50.    if (rv > 0) return tmp;
  51.       return NULL;
  52.    }
  53. #endif                        /* MSWindows */
  54.  
  55. /*
  56.  * An array of all characters for use in making one-character strings.
  57.  */
  58.  
  59. unsigned char allchars[256] = {
  60.      0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14, 15,
  61.     16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,
  62.     32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47,
  63.     48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63,
  64.     64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79,
  65.     80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95,
  66.     96, 97, 98, 99,100,101,102,103,104,105,106,107,108,109,110,111,
  67.    112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,
  68.    128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,
  69.    144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,
  70.    160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,
  71.    176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,
  72.    192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,
  73.    208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,
  74.    224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,
  75.    240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,
  76. };
  77. /*
  78.  * fatalerr - disable error conversion and call run-time error routine.
  79.  */
  80. void fatalerr(n, v)
  81. int n;
  82. dptr v;
  83.    {
  84.    IntVal(kywd_err) = 0;
  85.    err_msg(n, v);
  86.    }
  87.  
  88. struct b_list *alclist(size)
  89. uword size;
  90.    {
  91.    register struct b_list *blk;
  92.    AlcFixBlk(blk, b_list, T_List)
  93.    blk->size = size;
  94.    blk->id = list_ser++;
  95.    blk->listhead = NULL;
  96.    blk->listtail = NULL;
  97.    return blk;
  98.    }
  99. /*
  100.  * alclstb - allocate a list element block in the block region.
  101.  */
  102.  
  103. struct b_lelem *alclstb(nslots, first, nused)
  104. uword nslots, first, nused;
  105.    {
  106.    register struct b_lelem *blk;
  107.    register word i, size;
  108.  
  109.    AlcVarBlk(blk, b_lelem, T_Lelem, nslots)
  110.    blk->nslots = nslots;
  111.    blk->first = first;
  112.    blk->nused = nused;
  113.    blk->listprev = NULL;
  114.    blk->listnext = NULL;
  115.    /*
  116.     * Set all elements to &null.
  117.     */
  118.    for (i = 0; i < nslots; i++)
  119.       blk->lslots[i] = nulldesc;
  120.    return blk;
  121.    }
  122.  
  123.  
  124. struct b_real *alcreal(val)
  125. double val;
  126.    {
  127.    register struct b_real *blk;
  128.  
  129.    AlcFixBlk(blk, b_real, T_Real)
  130.  
  131. #ifdef Double
  132.    /* access real values one word at a time */
  133.    { int *rp, *rq;
  134.      rp = (int *) &(blk->realval);
  135.      rq = (int *) &val;
  136.      *rp++ = *rq++;
  137.      *rp   = *rq;
  138.    }
  139. #else                                   /* Double */
  140.    blk->realval = val;
  141. #endif                                  /* Double */
  142.  
  143.    return blk;
  144.    }
  145.  
  146. char *alcstr(char *s, int len)
  147. {
  148.    register char *s1;
  149.  
  150.    s1 = (char *)alloc(len + 1);
  151.    return strncpy(s1, s, len);
  152. }
  153.  
  154. /*
  155.  * initalloc - initialization routine to allocate memory regions
  156.  */
  157.  
  158. void initalloc(codesize)
  159. word codesize;
  160.    {
  161.    static char dummy[1];    /* dummy static region */
  162.  
  163.    StrLoc(kywd_prog) = "wicont";
  164.    StrLen(kywd_prog) = strlen(StrLoc(kywd_prog));
  165.    /*
  166.     * Set up allocated memory.    The regions are:
  167.     *    Allocated string region
  168.     *    Allocate block region
  169.     */
  170.    curstring = (struct region *)malloc(sizeof(struct region));
  171.    curblock = (struct region *)malloc(sizeof(struct region));
  172.    curstring->size = 2000;
  173.    curblock->size = 2000;
  174.    curstring->next = curstring->prev = NULL;
  175.    curstring->Gnext = curstring->Gprev = NULL;
  176.    curblock->next = curblock->prev = NULL;
  177.    curblock->Gnext = curblock->Gprev = NULL;
  178.  
  179.    if ((strfree = strbase = (char *)AllocReg(ssize)) == NULL)
  180.       tfatal("insufficient memory for string region", NULL);
  181.    strend = strbase + ssize;
  182.    if ((blkfree = blkbase = (char *)AllocReg(abrsize)) == NULL)
  183.       tfatal("insufficient memory for block region", NULL);
  184.    blkend = blkbase + abrsize;
  185.    }
  186.  
  187.  
  188. void err_msg(n, v)
  189. int n;
  190. dptr v;
  191. {
  192. fprintf(stderr, "err_msg %d\n", n);
  193. c_exit(1);
  194. }
  195.  
  196. /*
  197.  * qsearch(key,base,nel,width,compar) - binary search
  198.  *
  199.  *  A binary search routine with arguments similar to qsort(3).
  200.  *  Returns a pointer to the item matching "key", or NULL if none.
  201.  *  Based on Bentley, CACM 28,7 (July, 1985), p. 676.
  202.  */
  203.  
  204. char * qsearch (key, base, nel, width, compar)
  205. char * key;
  206. char * base;
  207. int nel, width;
  208. int (*compar)();
  209. {
  210.     int l, u, m, r;
  211.     char * a;
  212.  
  213.     l = 0;
  214.     u = nel - 1;
  215.     while (l <= u) {
  216.     m = (l + u) / 2;
  217.     a = (char *) ((char *) base + width * m);
  218.     r = compar (a, key);
  219.     if (r < 0)
  220.         l = m + 1;
  221.     else if (r > 0)
  222.         u = m - 1;
  223.     else
  224.         return a;
  225.     }
  226.     return 0;
  227. }
  228. /*
  229.  * c_get - convenient C-level access to the get function
  230.  *  returns 0 on failure, otherwise fills in res
  231.  */
  232. int c_get(hp,res)
  233. struct b_list *hp;
  234. struct descrip *res;
  235. {
  236.    register word i;
  237.    register struct b_lelem *bp;
  238.  
  239.    /*
  240.     * Fail if the list is empty.
  241.     */
  242.    if (hp->size <= 0)
  243.       return 0;
  244.  
  245.    /*
  246.     * Point bp at the first list block.  If the first block has no
  247.     *  elements in use, point bp at the next list block.
  248.     */
  249.    bp = (struct b_lelem *) hp->listhead;
  250.    if (bp->nused <= 0) {
  251.       bp = (struct b_lelem *) bp->listnext;
  252.       hp->listhead = (union block *) bp;
  253.       bp->listprev = NULL;
  254.       }
  255.  
  256.    /*
  257.     * Locate first element and assign it to result for return.
  258.     */
  259.    i = bp->first;
  260.    *res = bp->lslots[i];
  261.  
  262.    /*
  263.     * Set bp->first to new first element, or 0 if the block is now
  264.     *  empty.  Decrement the usage count for the block and the size
  265.     *  of the list.
  266.     */
  267.    if (++i >= bp->nslots)
  268.       i = 0;
  269.    bp->first = i;
  270.    bp->nused--;
  271.    hp->size--;
  272.  
  273.    return 1;
  274. }
  275. /*
  276.  * c_put - C-level, nontending list put function
  277.  */
  278. void c_put(l,val)
  279. struct descrip *l;
  280. struct descrip *val;
  281. {
  282.    register word i;
  283.    register struct b_lelem *bp;  /* does not need to be tended */
  284.    static two = 2;        /* some compilers generate bad code for
  285.                    division by a constant that's a power of 2*/
  286.  
  287.    /*
  288.     * Point hp at the list-header block and bp at the last
  289.     *  list-element block.
  290.     */
  291.    bp = (struct b_lelem *) BlkLoc(*l)->list.listtail;
  292.  
  293. #ifdef EventMon        /* initialize i so it's 0 if last list-element */
  294.    i = 0;            /* block isn't full */
  295. #endif                /* EventMon */
  296.  
  297.    /*
  298.     * If the last list-element block is full, allocate a new
  299.     *  list-element block, make it the last list-element block,
  300.     *  and make it the next block of the former last list-element
  301.     *  block.
  302.     */
  303.    if (bp->nused >= bp->nslots) {
  304.       /*
  305.        * Set i to the size of block to allocate.
  306.        */
  307.       i = ((struct b_list *)BlkLoc(*l))->size / two;
  308.       if (i < MinListSlots)
  309.          i = MinListSlots;
  310. #ifdef MaxListSlots
  311.       if (i > MaxListSlots)
  312.          i = MaxListSlots;
  313. #endif                    /* MaxListSlots */
  314.  
  315.       /*
  316.        * Allocate a new list element block.  If the block can't
  317.        *  be allocated, try smaller blocks.
  318.        */
  319.       while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  320.          i /= 4;
  321.          if (i < MinListSlots)
  322.             fatalerr(0,NULL);
  323.          }
  324.  
  325.       ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext =
  326.     (union block *) bp;
  327.       bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail;
  328.       ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp;
  329.       }
  330.  
  331.    /*
  332.     * Set i to position of new last element and assign val to
  333.     *  that element.
  334.     */
  335.    i = bp->first + bp->nused;
  336.    if (i >= bp->nslots)
  337.       i -= bp->nslots;
  338.    bp->lslots[i] = *val;
  339.  
  340.    /*
  341.     * Adjust block usage count and current list size.
  342.     */
  343.    bp->nused++;
  344.    ((struct b_list *)BlkLoc(*l))->size++;
  345. }
  346.  
  347. /*
  348.  * cnv_c_str - cnv:C_string(*s, *d), convert a value into a C (and Icon) string
  349.  */
  350. int cnv_c_str(s, d)
  351. dptr s;
  352. dptr d;
  353.    {
  354.    /*
  355.     * Get the string to the end of the string region and append a '\0'.
  356.     */
  357.  
  358.    if (!Qual(*s)) {
  359.       /* if (!cnv_str(s, d)) { */
  360.          return 0;
  361.          /*}*/
  362.       }
  363.    else {
  364.       *d = *s;
  365.       }
  366.    {
  367.       register word slen = StrLen(*d);
  368.       register char *sp, *dp;
  369.  
  370.       dp = malloc(slen+1);
  371.       if (dp == NULL)
  372.          fatalerr(0,NULL);
  373.  
  374.       StrLen(*d) = StrLen(*d)+1;
  375.       sp = StrLoc(*d);
  376.       StrLoc(*d) = dp;
  377.       while (slen-- > 0)
  378.          *dp++ = *sp++;
  379.       *dp = '\0';
  380.       }
  381.    return 1;
  382.    }
  383.  
  384. /*
  385.  * itos - convert the integer num into a string using s as a buffer and
  386.  *  making q a descriptor for the resulting string.
  387.  */
  388.  
  389. static void itos(num, dp, s)
  390. C_integer num;
  391. dptr dp;
  392. char *s;
  393.    {
  394.    register char *p;
  395.    long ival;
  396.    static char *maxneg = MaxNegInt;
  397.  
  398.    p = s + MaxCvtLen - 1;
  399.    ival = num;
  400.  
  401.    *p = '\0';
  402.    if (num >= 0L)
  403.       do {
  404.      *--p = ival % 10L + '0';
  405.      ival /= 10L;
  406.      } while (ival != 0L);
  407.    else {
  408.       if (ival == -ival) {      /* max negative value */
  409.      p -= strlen (maxneg);
  410.      sprintf (p, "%s", maxneg);
  411.          }
  412.       else {
  413.     ival = -ival;
  414.     do {
  415.        *--p = '0' + (ival % 10L);
  416.        ival /= 10L;
  417.        } while (ival != 0L);
  418.     *--p = '-';
  419.     }
  420.       }
  421.  
  422.    StrLen(*dp) = s + MaxCvtLen - 1 - p;
  423.    StrLoc(*dp) = p;
  424.    }
  425. /*
  426.  * tmp_str - Convert to temporary string.
  427.  */
  428. int tmp_str(sbuf, s, d)
  429. char *sbuf;
  430. dptr s;
  431. dptr d;
  432.    {
  433.    if (Qual(*s))
  434.       *d = *s;
  435.    else switch (Type(*s)) {
  436.    case T_Integer: {
  437.          itos(IntVal(*s), d, sbuf);
  438.      break;
  439.      }
  440.    case T_Real: {
  441.          double res;
  442.          GetReal(s, res);
  443.          rtos(res, d, sbuf);
  444.      break;
  445.          }
  446. /*
  447.    case T_Cset:
  448.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  449.      break;
  450. */
  451.    default:
  452.          return 0;
  453.       }
  454.    return 1;
  455.    }
  456.  
  457. /*
  458.  * radix - convert string s in radix r into an integer in *result.  sign
  459.  *  will be either '+' or '-'.
  460.  */
  461. int radix(sign, r, s, end_s, result)
  462. int sign;
  463. register int r;
  464. register char *s;
  465. register char *end_s;
  466. union numeric *result;
  467.    {
  468.    register int c;
  469.    long num;
  470.  
  471.    if (r < 2 || r > 36)
  472.       return CvtFail;
  473.    c = (s < end_s) ? *s++ : ' ';
  474.    num = 0L;
  475.    while (isalnum(c)) {
  476.       #define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
  477.       c = tonum(c);
  478.       if (c >= r)
  479.      return CvtFail;
  480.       num = num * r + c;
  481.       c = (s < end_s) ? *s++ : ' ';
  482.       }
  483.  
  484.    /*
  485.     * Skip trailing white space and make sure there is nothing else left
  486.     *  in the string. Note, if we have already reached end-of-string,
  487.     *  c has been set to a space.
  488.     */
  489.    while (isspace(c) && s < end_s)
  490.       c = *s++;
  491.    if (!isspace(c))
  492.       return CvtFail;
  493.  
  494.    result->integer = (sign == '+' ? num : -num);
  495.  
  496.    return T_Integer;
  497.    }
  498.  
  499. /*
  500.  * rtos - convert the real number n into a string using s as a buffer and
  501.  *  making a descriptor for the resulting string.
  502.  */
  503. void rtos(n, dp, s)
  504. double n;
  505. dptr dp;
  506. char *s;
  507.    {
  508.    s++;                    /* leave room for leading zero */
  509.    sprintf(s, "%.*g", Precision, n + 0.0);  /* format string; +0.0 avoids -0 */
  510.  
  511.    /*
  512.     * Now clean up possible messes.
  513.     */
  514.    while (*s == ' ')            /* delete leading blanks */
  515.       s++;
  516.    if (*s == '.') {            /* prefix 0 to initial period */
  517.       s--;
  518.       *s = '0';
  519.       }
  520.    else if (strcmp(s, "-0.0") == 0)    /* negative zero */
  521.       s++;
  522.    else if (!strchr(s, '.') && !strchr(s,'e') && !strchr(s,'E'))
  523.          strcat(s, ".0");        /* if no decimal point or exp. */
  524.    if (s[strlen(s) - 1] == '.')        /* if decimal point is at end ... */
  525.       strcat(s, "0");
  526.    StrLen(*dp) = strlen(s);
  527.    StrLoc(*dp) = s;
  528.    }
  529. /*
  530.  * ston - convert a string to a numeric quantity if possible.
  531.  * Returns a typecode or CvtFail.  Its answer is in the dptr,
  532.  * unless its a double, in which case its in the union numeric
  533.  * (we do this to avoid allocating a block for a real
  534.  * that will later be used directly as a C_double).
  535.  */
  536. static int ston(sp, result)
  537. dptr sp;
  538. union numeric *result;
  539.    {
  540.    register char *s = StrLoc(*sp), *end_s;
  541.    register int c;
  542.    int realflag = 0;    /* indicates a real number */
  543.    char msign = '+';    /* sign of mantissa */
  544.    char esign = '+';    /* sign of exponent */
  545.    double mantissa = 0; /* scaled mantissa with no fractional part */
  546.    long lresult = 0;    /* integer result */
  547.    int scale = 0;    /* number of decimal places to shift mantissa */
  548.    int digits = 0;    /* total number of digits seen */
  549.    int sdigits = 0;    /* number of significant digits seen */
  550.    int exponent = 0;    /* exponent part of real number */
  551.    double fiveto;    /* holds 5^scale */
  552.    double power;    /* holds successive squares of 5 to compute fiveto */
  553.    int err_no;
  554.    char *ssave;         /* holds original ptr for bigradix */
  555.  
  556.    if (StrLen(*sp) == 0)
  557.       return CvtFail;
  558.    end_s = s + StrLen(*sp);
  559.    c = *s++;
  560.  
  561.    /*
  562.     * Skip leading white space.
  563.     */
  564.    while (isspace(c))
  565.       if (s < end_s)
  566.          c = *s++;
  567.       else
  568.          return CvtFail;
  569.  
  570.    /*
  571.     * Check for sign.
  572.     */
  573.    if (c == '+' || c == '-') {
  574.       msign = c;
  575.       c = (s < end_s) ? *s++ : ' ';
  576.       }
  577.  
  578.    ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */
  579.  
  580.    /*
  581.     * Get integer part of mantissa.
  582.     */
  583.    while (isdigit(c)) {
  584.       digits++;
  585.       if (mantissa < Big) {
  586.      mantissa = mantissa * 10 + (c - '0');
  587.          lresult = lresult * 10 + (c - '0');
  588.      if (mantissa > 0.0)
  589.         sdigits++;
  590.      }
  591.       else
  592.      scale++;
  593.       c = (s < end_s) ? *s++ : ' ';
  594.       }
  595.  
  596.    /*
  597.     * Check for based integer.
  598.     */
  599.    if (c == 'r' || c == 'R') {
  600.       int rv;
  601.       rv = radix((int)msign, (int)mantissa, s, end_s, result);
  602.       return rv;
  603.       }
  604.  
  605.    /*
  606.     * Get fractional part of mantissa.
  607.     */
  608.    if (c == '.') {
  609.       realflag++;
  610.       c = (s < end_s) ? *s++ : ' ';
  611.       while (isdigit(c)) {
  612.      digits++;
  613.      if (mantissa < Big) {
  614.         mantissa = mantissa * 10 + (c - '0');
  615.         lresult = lresult * 10 + (c - '0');
  616.         scale--;
  617.         if (mantissa > 0.0)
  618.            sdigits++;
  619.         }
  620.          c = (s < end_s) ? *s++ : ' ';
  621.      }
  622.       }
  623.  
  624.    /*
  625.     * Check that at least one digit has been seen so far.
  626.     */
  627.    if (digits == 0)
  628.       return CvtFail;
  629.  
  630.    /*
  631.     * Get exponent part.
  632.     */
  633.    if (c == 'e' || c == 'E') {
  634.       realflag++;
  635.       c = (s < end_s) ? *s++ : ' ';
  636.       if (c == '+' || c == '-') {
  637.      esign = c;
  638.          c = (s < end_s) ? *s++ : ' ';
  639.      }
  640.       if (!isdigit(c))
  641.      return CvtFail;
  642.       while (isdigit(c)) {
  643.      exponent = exponent * 10 + (c - '0');
  644.          c = (s < end_s) ? *s++ : ' ';
  645.      }
  646.       scale += (esign == '+') ? exponent : -exponent;
  647.       }
  648.  
  649.    /*
  650.     * Skip trailing white space and make sure there is nothing else left
  651.     *  in the string. Note, if we have already reached end-of-string,
  652.     *  c has been set to a space.
  653.     */
  654.    while (isspace(c) && s < end_s)
  655.       c = *s++;
  656.    if (!isspace(c))
  657.       return CvtFail;
  658.  
  659.    /*
  660.     * Test for integer.
  661.     */
  662.    if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
  663.       result->integer = (msign == '+' ? lresult : -lresult);
  664.       return T_Integer;
  665.       }
  666.  
  667.    if (!realflag)
  668.       return CvtFail;        /* don't promote to real if integer format */
  669.  
  670.    /*
  671.     * Rough tests for overflow and underflow.
  672.     */
  673.    if (sdigits + scale > LogHuge)
  674.       return CvtFail;
  675.  
  676.    if (sdigits + scale < -LogHuge) {
  677.       result->real = 0.0;
  678.       return T_Real;
  679.       }
  680.  
  681.    /*
  682.     * Put the number together by multiplying the mantissa by 5^scale and
  683.     *  then using ldexp() to multiply by 2^scale.
  684.     */
  685.  
  686.    exponent = (scale > 0)? scale : -scale;
  687.    fiveto = 1.0;
  688.    power = 5.0;
  689.    for (;;) {
  690.       if (exponent & 01)
  691.      fiveto *= power;
  692.       exponent >>= 1;
  693.       if (exponent == 0)
  694.      break;
  695.       power *= power;
  696.       }
  697.    if (scale > 0)
  698.       mantissa *= fiveto;
  699.    else
  700.       mantissa /= fiveto;
  701.  
  702.    err_no = 0;
  703.    mantissa = ldexp(mantissa, scale);
  704.    if (err_no > 0 && mantissa > 0)
  705.       /*
  706.        * ldexp caused overflow.
  707.        */
  708.       return CvtFail;
  709.  
  710.    if (msign == '-')
  711.       mantissa = -mantissa;
  712.    result->real = mantissa;
  713.    return T_Real;
  714.    }
  715.  
  716. /*
  717.  * cnv_c_dbl - cnv:C_double(*s, *d), convert a value directly into a C double
  718.  */
  719. int cnv_c_dbl(s, d)
  720. dptr s;
  721. double *d;
  722.    {
  723.      struct descrip result, cnvstr;
  724.      char sbuf[MaxCvtLen];
  725.  
  726.    union numeric numrc;
  727.  
  728.    if (!Qual(*s)) {
  729.       if (Type(*s) == T_Integer) {
  730.          *d = IntVal(*s);
  731.          return 1;
  732.          }
  733.       else if (Type(*s) == T_Cset) {
  734.         tmp_str(sbuf, s, &cnvstr);
  735.         s = &cnvstr;
  736.         }
  737.       else {
  738.         return 0;
  739.         }
  740.       }
  741.  
  742.    /*
  743.     * s is now an string.
  744.     */
  745.    switch( ston(s, &numrc) ) {
  746.       case T_Integer:
  747.          *d = numrc.integer;
  748.          return 1;
  749.       case T_Real:
  750.          *d = numrc.real;
  751.          return 1;
  752.       default:
  753.          return 0;
  754.       }
  755.   }
  756.  
  757. /*
  758.  * cnv_c_int - cnv:C_integer(*s, *d), convert a value directly into a C_integer
  759.  */
  760. int cnv_c_int(s, d)
  761. dptr s;
  762. C_integer *d;
  763.    {
  764.    struct descrip cnvstr, result;            /* not tended */
  765.    union numeric numrc;
  766.    char sbuf[MaxCvtLen];
  767.  
  768.    if (!Qual(*s)) {
  769.       if (Type(*s) == T_Integer) {
  770.          *d = IntVal(*s);
  771.          return 1;
  772.          }
  773.       else if (Type(*s) == T_Real) {
  774.          double dbl;
  775.          GetReal(s,dbl);
  776.          if (dbl > MaxLong || dbl < MinLong) {
  777.             return 0;
  778.             }
  779.          *d = dbl;
  780.          return 1;
  781.          }
  782.       else if (Type(*s) == T_Cset) {
  783.         tmp_str(sbuf, s, &cnvstr);
  784.         s = &cnvstr;
  785.         }
  786.       else {
  787.          return 0;
  788.          }
  789.       }
  790.  
  791.    /*
  792.     * s is now a string.
  793.     */
  794.    switch( ston(s, &numrc) ) {
  795.       case T_Integer: {
  796.          *d = numrc.integer;
  797.          return 1;
  798.      }
  799.       case T_Real: {
  800.          double dbl = numrc.real;
  801.          if (dbl > MaxLong || dbl < MinLong) {
  802.             return 0;
  803.             }
  804.          *d = dbl;
  805.          return 1;
  806.          }
  807.       default:
  808.          return 0;
  809.       }
  810.    }
  811.  
  812.  
  813. /*
  814.  * def_c_dbl - def:C_double(*s, df, *d), convert to C double with a
  815.  *  default value. Default is of type C double; if used, just copy to
  816.  *  destination.
  817.  */
  818.  
  819. int def_c_dbl(s,df,d)
  820. dptr s;
  821. double df;
  822. double *d;
  823.    {
  824.    if (Type(*s) == T_Null) {
  825.       *d = df;
  826.       return 1;
  827.       }
  828.    else
  829.       return cnv_c_dbl(s,d); /* I really mean cnv:type */
  830.    }
  831.  
  832.  
  833. int def_c_int(s,df,d)
  834. dptr s;
  835. C_integer df;
  836. C_integer *d;
  837.    {
  838.    if (Type(*s) == T_Null) {
  839.       *d = df;
  840.       return 1;
  841.       }
  842.    else
  843.       return cnv_c_int(s,d); /* I really mean cnv:type */
  844.    }
  845.  
  846.  
  847. /*
  848.  * the global buffer used as work space for printing string, etc
  849.  */
  850. char ConsoleStringBuf[512 * 48];
  851. char *ConsoleStringBufPtr = ConsoleStringBuf;
  852. unsigned long ConsoleFlags = 0;             /* Console flags */
  853. extern int ConsolePause;
  854. extern FILE *flog;
  855.  
  856.  
  857. void closelogfile()
  858. {
  859.    if (flog) {
  860.       extern char *lognam;
  861.       extern char tmplognam[];
  862.       FILE *flog2;
  863.       int i;
  864.       fclose(flog);
  865.  
  866.       /*
  867.        * copy to the permanent file name
  868.        */
  869.       if ((flog = fopen(tmplognam, "r")) &&
  870.       (flog2 = fopen(lognam, "w"))) {
  871.      while ((i = getc(flog)) != EOF)
  872.         putc(i, flog2);
  873.      fclose(flog);
  874.      fclose(flog2);
  875.      remove(tmplognam);
  876.      }
  877.  
  878.       free(lognam);
  879.       flog = NULL;
  880.       }
  881. }
  882.  
  883.  
  884. /*
  885.  * c_exit(i) - flush all buffers and exit with status i.
  886.  */
  887. void c_exit(i)
  888. int i;
  889. {
  890.    char *msg = "Strike any key to close console...";
  891.  
  892.    /*
  893.     * if the console was used for anything, pause it
  894.     */
  895.    if (ConsoleBinding && ConsolePause) {
  896.       char label[256], tossanswer[256];
  897.  
  898.       wputstr((wbp)ConsoleBinding, msg, strlen(msg));
  899.  
  900.       strcpy(tossanswer, "label=wicont - execution terminated");
  901.       wattr(ConsoleBinding, tossanswer, strlen(tossanswer));
  902.       waitkey(ConsoleBinding);
  903.       }
  904.    if (flog) {
  905.       extern char *lognam;
  906.       extern char tmplognam[];
  907.       FILE *flog2;
  908.       int i;
  909.       fclose(flog);
  910.  
  911.       /*
  912.        * try to rename, then try to copy to the permanent file name
  913.        */
  914.       i = rename(tmplognam, lognam);
  915.       if (i != 0) {
  916.          if ((flog = fopen(tmplognam, "r")) &&
  917.          (flog2 = fopen(lognam, "w"))) {
  918.         while ((i = getc(flog)) != EOF)
  919.            putc(i, flog2);
  920.         fclose(flog);
  921.         fclose(flog2);
  922.         remove(tmplognam);
  923.         }
  924.          }
  925.  
  926.       free(lognam);
  927.       }
  928.    if (wstates != NULL) {
  929.       PostQuitMessage(i);
  930.       pollevent();
  931.       }
  932.  
  933. #if !MACINTOSH
  934.    #undef exit
  935. #endif                    /* MACINTOSH */
  936.    exit(i);
  937. }
  938.  
  939.  
  940. int strncasecmp(char *s1, char *s2, int n)
  941. {
  942.    int i, j;
  943.    for(i=0;i<n;i++) {
  944.       j = tolower(s1[i]) - tolower(s2[i]);
  945.       if (j) return j;
  946.       if (s1[i] == '\0') return 0; /* terminate if both at end-of-string */
  947.       }
  948.    return 0;
  949. }
  950.  
  951. #endif                    /* ConsoleWindow */
  952.