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 / common / dconsole.c < prev    next >
C/C++ Source or Header  |  1996-03-22  |  21KB  |  916 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. novalue 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. /*
  147.  * initalloc - initialization routine to allocate memory regions
  148.  */
  149.  
  150. novalue initalloc(codesize)
  151. word codesize;
  152.    {
  153.    static char dummy[1];    /* dummy static region */
  154.  
  155.    StrLoc(kywd_prog) = "wicont";
  156.    StrLen(kywd_prog) = strlen(StrLoc(kywd_prog));
  157.    /*
  158.     * Set up allocated memory.    The regions are:
  159.     *    Allocated string region
  160.     *    Allocate block region
  161.     */
  162.    curstring = (struct region *)malloc(sizeof(struct region));
  163.    curblock = (struct region *)malloc(sizeof(struct region));
  164.    curstring->size = 2000;
  165.    curblock->size = 2000;
  166.    curstring->next = curstring->prev = NULL;
  167.    curstring->Gnext = curstring->Gprev = NULL;
  168.    curblock->next = curblock->prev = NULL;
  169.    curblock->Gnext = curblock->Gprev = NULL;
  170.  
  171.    if ((strfree = strbase = (char *)AllocReg(ssize)) == NULL)
  172.       tfatal("insufficient memory for string region", NULL);
  173.    strend = strbase + ssize;
  174.    if ((blkfree = blkbase = (char *)AllocReg(abrsize)) == NULL)
  175.       tfatal("insufficient memory for block region", NULL);
  176.    blkend = blkbase + abrsize;
  177.    }
  178.  
  179.  
  180. novalue err_msg(n, v)
  181. int n;
  182. dptr v;
  183. {
  184. fprintf(stderr, "err_msg %d\n", n);
  185. c_exit(1);
  186. }
  187.  
  188. /*
  189.  * qsearch(key,base,nel,width,compar) - binary search
  190.  *
  191.  *  A binary search routine with arguments similar to qsort(3).
  192.  *  Returns a pointer to the item matching "key", or NULL if none.
  193.  *  Based on Bentley, CACM 28,7 (July, 1985), p. 676.
  194.  */
  195.  
  196. char * qsearch (key, base, nel, width, compar)
  197. char * key;
  198. char * base;
  199. int nel, width;
  200. int (*compar)();
  201. {
  202.     int l, u, m, r;
  203.     char * a;
  204.  
  205.     l = 0;
  206.     u = nel - 1;
  207.     while (l <= u) {
  208.     m = (l + u) / 2;
  209.     a = (char *) ((char *) base + width * m);
  210.     r = compar (a, key);
  211.     if (r < 0)
  212.         l = m + 1;
  213.     else if (r > 0)
  214.         u = m - 1;
  215.     else
  216.         return a;
  217.     }
  218.     return 0;
  219. }
  220. /*
  221.  * c_get - convenient C-level access to the get function
  222.  *  returns 0 on failure, otherwise fills in res
  223.  */
  224. int c_get(hp,res)
  225. struct b_list *hp;
  226. struct descrip *res;
  227. {
  228.    register word i;
  229.    register struct b_lelem *bp;
  230.  
  231.    /*
  232.     * Fail if the list is empty.
  233.     */
  234.    if (hp->size <= 0)
  235.       return 0;
  236.  
  237.    /*
  238.     * Point bp at the first list block.  If the first block has no
  239.     *  elements in use, point bp at the next list block.
  240.     */
  241.    bp = (struct b_lelem *) hp->listhead;
  242.    if (bp->nused <= 0) {
  243.       bp = (struct b_lelem *) bp->listnext;
  244.       hp->listhead = (union block *) bp;
  245.       bp->listprev = NULL;
  246.       }
  247.  
  248.    /*
  249.     * Locate first element and assign it to result for return.
  250.     */
  251.    i = bp->first;
  252.    *res = bp->lslots[i];
  253.  
  254.    /*
  255.     * Set bp->first to new first element, or 0 if the block is now
  256.     *  empty.  Decrement the usage count for the block and the size
  257.     *  of the list.
  258.     */
  259.    if (++i >= bp->nslots)
  260.       i = 0;
  261.    bp->first = i;
  262.    bp->nused--;
  263.    hp->size--;
  264.  
  265.    return 1;
  266. }
  267. /*
  268.  * c_put - C-level, nontending list put function
  269.  */
  270. void c_put(l,val)
  271. struct descrip *l;
  272. struct descrip *val;
  273. {
  274.    register word i;
  275.    register struct b_lelem *bp;  /* does not need to be tended */
  276.    static two = 2;        /* some compilers generate bad code for
  277.                    division by a constant that's a power of 2*/
  278.  
  279.    /*
  280.     * Point hp at the list-header block and bp at the last
  281.     *  list-element block.
  282.     */
  283.    bp = (struct b_lelem *) BlkLoc(*l)->list.listtail;
  284.    
  285. #ifdef EventMon     /* initialize i so it's 0 if last list-element */
  286.    i = 0;            /* block isn't full */
  287. #endif                /* EventMon */
  288.  
  289.    /*
  290.     * If the last list-element block is full, allocate a new
  291.     *  list-element block, make it the last list-element block,
  292.     *  and make it the next block of the former last list-element
  293.     *  block.
  294.     */
  295.    if (bp->nused >= bp->nslots) {
  296.       /*
  297.        * Set i to the size of block to allocate.
  298.        */
  299.       i = ((struct b_list *)BlkLoc(*l))->size / two;
  300.       if (i < MinListSlots)
  301.          i = MinListSlots;
  302. #ifdef MaxListSlots
  303.       if (i > MaxListSlots)
  304.          i = MaxListSlots;
  305. #endif                    /* MaxListSlots */
  306.  
  307.       /*
  308.        * Allocate a new list element block.  If the block can't
  309.        *  be allocated, try smaller blocks.
  310.        */
  311.       while ((bp = alclstb(i, (word)0, (word)0)) == NULL) {
  312.          i /= 4;
  313.          if (i < MinListSlots)
  314.             fatalerr(0,NULL);
  315.          }
  316.  
  317.       ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext =
  318.     (union block *) bp;
  319.       bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail;
  320.       ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp;
  321.       }
  322.  
  323.    /*
  324.     * Set i to position of new last element and assign val to
  325.     *  that element.
  326.     */
  327.    i = bp->first + bp->nused;
  328.    if (i >= bp->nslots)
  329.       i -= bp->nslots;
  330.    bp->lslots[i] = *val;
  331.  
  332.    /*
  333.     * Adjust block usage count and current list size.
  334.     */
  335.    bp->nused++;
  336.    ((struct b_list *)BlkLoc(*l))->size++;
  337. }
  338.  
  339. /*
  340.  * cnv_c_str - cnv:C_string(*s, *d), convert a value into a C (and Icon) string
  341.  */
  342. int cnv_c_str(s, d)
  343. dptr s;
  344. dptr d;
  345.    {
  346.    /*
  347.     * Get the string to the end of the string region and append a '\0'.
  348.     */
  349.  
  350.    if (!Qual(*s)) {
  351.       /* if (!cnv_str(s, d)) { */
  352.          return 0;
  353.          /*}*/
  354.       }
  355.    else {
  356.       *d = *s;
  357.       }
  358.    {
  359.       register word slen = StrLen(*d);
  360.       register char *sp, *dp;
  361.  
  362.       dp = malloc(slen+1);
  363.       if (dp == NULL)
  364.          fatalerr(0,NULL);
  365.  
  366.       StrLen(*d) = StrLen(*d)+1;
  367.       sp = StrLoc(*d);
  368.       StrLoc(*d) = dp;
  369.       while (slen-- > 0)
  370.          *dp++ = *sp++;
  371.       *dp = '\0';
  372.       }
  373.    return 1;
  374.    }
  375.  
  376. /*
  377.  * itos - convert the integer num into a string using s as a buffer and
  378.  *  making q a descriptor for the resulting string.
  379.  */
  380.  
  381. static novalue itos(num, dp, s)
  382. C_integer num;
  383. dptr dp;
  384. char *s;
  385.    {
  386.    register char *p;
  387.    long ival;
  388.    static char *maxneg = MaxNegInt;
  389.  
  390.    p = s + MaxCvtLen - 1;
  391.    ival = num;
  392.  
  393.    *p = '\0';
  394.    if (num >= 0L)
  395.       do {
  396.      *--p = ival % 10L + '0';
  397.      ival /= 10L;
  398.      } while (ival != 0L);
  399.    else {
  400.       if (ival == -ival) {      /* max negative value */
  401.      p -= strlen (maxneg);
  402.      sprintf (p, "%s", maxneg);
  403.          }
  404.       else {
  405.     ival = -ival;
  406.     do {
  407.        *--p = '0' + (ival % 10L);
  408.        ival /= 10L;
  409.        } while (ival != 0L);
  410.     *--p = '-';
  411.     }
  412.       }
  413.  
  414.    StrLen(*dp) = s + MaxCvtLen - 1 - p;
  415.    StrLoc(*dp) = p;
  416.    }
  417. /*
  418.  * tmp_str - Convert to temporary string.
  419.  */
  420. int tmp_str(sbuf, s, d)
  421. char *sbuf;
  422. dptr s;
  423. dptr d;
  424.    {
  425.    if (Qual(*s))
  426.       *d = *s;
  427.    else switch (Type(*s)) {
  428.    case T_Integer: {
  429.          itos(IntVal(*s), d, sbuf);
  430.      break;
  431.      }
  432.    case T_Real: {
  433.          double res;
  434.          GetReal(s, res);
  435.          rtos(res, d, sbuf);
  436.      break;
  437.          }
  438. /*
  439.    case T_Cset:
  440.          cstos(BlkLoc(*s)->cset.bits, d, sbuf);
  441.      break;
  442. */
  443.    default:
  444.          return 0;
  445.       }
  446.    return 1;
  447.    }
  448.  
  449. /*
  450.  * radix - convert string s in radix r into an integer in *result.  sign
  451.  *  will be either '+' or '-'.
  452.  */
  453. int radix(sign, r, s, end_s, result)
  454. int sign;
  455. register int r;
  456. register char *s;
  457. register char *end_s;
  458. union numeric *result;
  459.    {
  460.    register int c;
  461.    long num;
  462.  
  463.    if (r < 2 || r > 36)
  464.       return CvtFail;
  465.    c = (s < end_s) ? *s++ : ' ';
  466.    num = 0L;
  467.    while (isalnum(c)) {
  468. #if !EBCDIC
  469. #define tonum(c)    (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a'))
  470. #endif
  471.       c = tonum(c);
  472.       if (c >= r)
  473.      return CvtFail;
  474.       num = num * r + c;
  475.       c = (s < end_s) ? *s++ : ' ';
  476.       }
  477.  
  478.    /*
  479.     * Skip trailing white space and make sure there is nothing else left
  480.     *  in the string. Note, if we have already reached end-of-string,
  481.     *  c has been set to a space.
  482.     */
  483.    while (isspace(c) && s < end_s)
  484.       c = *s++;
  485.    if (!isspace(c))
  486.       return CvtFail;
  487.  
  488.    result->integer = (sign == '+' ? num : -num);
  489.  
  490.    return T_Integer;
  491.    }
  492.  
  493. /*
  494.  * rtos - convert the real number n into a string using s as a buffer and
  495.  *  making a descriptor for the resulting string.
  496.  */
  497. novalue rtos(n, dp, s)
  498. double n;
  499. dptr dp;
  500. char *s;
  501.    {
  502.  
  503.    s++;             /* leave room for leading zero */
  504. /*
  505.  * The following code is operating-system dependent [@rconv.01]. Convert real
  506.  *  number to string.
  507.  *
  508.  * If IconGcvt is defined, icon_gcvt() is actually called, due to a #define
  509.  *  in config.h.
  510.  */
  511. #undef gcvt
  512.  
  513. #if PORT
  514.    gcvt(n, Precision, s);
  515. Deliberate Syntax Error
  516. #endif                    /* PORT */
  517.  
  518. #if HIGHC_386
  519.    sprintf(s,"%.*g", Precision, n);
  520. #else                    /* HIGHC_386 */
  521. #if AMIGA || ARM || ATARI_ST || MSDOS || OS2 || UNIX || VMS
  522.    gcvt(n, Precision, s);
  523. #endif                                  /* AMIGA || ARM || ATARI_ST || ... */
  524. #endif                    /* HIGHC_386 */
  525.  
  526. #if MACINTOSH
  527.    sprintf(s,"%.20g",n);
  528. #endif                    /* MACINTOSH */
  529.  
  530. #if VM || MVS
  531.    sprintf(s,"%.*g", Precision, n);
  532.    {
  533.      char *ep = strstr(s, "e+");
  534.      if (ep) memmove(ep+1, ep+2, strlen(ep+2)+1);
  535.    }
  536. #endif                    /* VM || MVS */
  537.  
  538. /*
  539.  * End of operating-system specific code.
  540.  */
  541.    
  542.    /*
  543.     * Now clean up possible messes.
  544.     */
  545.    while (*s == ' ')            /* delete leading blanks */
  546.       s++;
  547.    if (*s == '.') {            /* prefix 0 to initial period */
  548.       s--;
  549.       *s = '0';
  550.       }
  551.    else if (strcmp(s, "-0.0") == 0)    /* negative zero */
  552.       s++;
  553.    else if (!index(s, '.') && !index(s,'e') && !index(s,'E'))
  554.          strcat(s, ".0");        /* if no decimal point or exp. */
  555.    if (s[strlen(s) - 1] == '.')        /* if decimal point is at end ... */
  556.       strcat(s, "0");
  557.    StrLen(*dp) = strlen(s);
  558.    StrLoc(*dp) = s;
  559.    }
  560. /*
  561.  * ston - convert a string to a numeric quantity if possible.
  562.  * Returns a typecode or CvtFail.  Its answer is in the dptr,
  563.  * unless its a double, in which case its in the union numeric
  564.  * (we do this to avoid allocating a block for a real
  565.  * that will later be used directly as a C_double).
  566.  */
  567. static int ston(sp, result)
  568. dptr sp;
  569. union numeric *result;
  570.    {
  571.    register char *s = StrLoc(*sp), *end_s;
  572.    register int c;
  573.    int realflag = 0;    /* indicates a real number */
  574.    char msign = '+';    /* sign of mantissa */
  575.    char esign = '+';    /* sign of exponent */
  576.    double mantissa = 0; /* scaled mantissa with no fractional part */
  577.    long lresult = 0;    /* integer result */
  578.    int scale = 0;    /* number of decimal places to shift mantissa */
  579.    int digits = 0;    /* total number of digits seen */
  580.    int sdigits = 0;    /* number of significant digits seen */
  581.    int exponent = 0;    /* exponent part of real number */
  582.    double fiveto;    /* holds 5^scale */
  583.    double power;    /* holds successive squares of 5 to compute fiveto */
  584.    int err_no;
  585.    char *ssave;         /* holds original ptr for bigradix */
  586.  
  587.    if (StrLen(*sp) == 0)
  588.       return CvtFail;
  589.    end_s = s + StrLen(*sp);
  590.    c = *s++;
  591.  
  592.    /*
  593.     * Skip leading white space.
  594.     */
  595.    while (isspace(c))
  596.       if (s < end_s)
  597.          c = *s++;
  598.       else
  599.          return CvtFail;
  600.  
  601.    /*
  602.     * Check for sign.
  603.     */
  604.    if (c == '+' || c == '-') {
  605.       msign = c;
  606.       c = (s < end_s) ? *s++ : ' ';
  607.       }
  608.  
  609.    ssave = s - 1;   /* set pointer to beginning of digits in case it's needed */
  610.  
  611.    /*
  612.     * Get integer part of mantissa.
  613.     */
  614.    while (isdigit(c)) {
  615.       digits++;
  616.       if (mantissa < Big) {
  617.      mantissa = mantissa * 10 + (c - '0');
  618.          lresult = lresult * 10 + (c - '0');
  619.      if (mantissa > 0.0)
  620.         sdigits++;
  621.      }
  622.       else
  623.      scale++;
  624.       c = (s < end_s) ? *s++ : ' ';
  625.       }
  626.  
  627.    /*
  628.     * Check for based integer.
  629.     */
  630.    if (c == 'r' || c == 'R') {
  631.       int rv;
  632.       rv = radix((int)msign, (int)mantissa, s, end_s, result);
  633.       return rv;
  634.       }
  635.  
  636.    /*
  637.     * Get fractional part of mantissa.
  638.     */
  639.    if (c == '.') {
  640.       realflag++;
  641.       c = (s < end_s) ? *s++ : ' ';
  642.       while (isdigit(c)) {
  643.      digits++;
  644.      if (mantissa < Big) {
  645.         mantissa = mantissa * 10 + (c - '0');
  646.         lresult = lresult * 10 + (c - '0');
  647.         scale--;
  648.         if (mantissa > 0.0)
  649.            sdigits++;
  650.         }
  651.          c = (s < end_s) ? *s++ : ' ';
  652.      }
  653.       }
  654.  
  655.    /*
  656.     * Check that at least one digit has been seen so far.
  657.     */
  658.    if (digits == 0)
  659.       return CvtFail;
  660.  
  661.    /*
  662.     * Get exponent part.
  663.     */
  664.    if (c == 'e' || c == 'E') {
  665.       realflag++;
  666.       c = (s < end_s) ? *s++ : ' ';
  667.       if (c == '+' || c == '-') {
  668.      esign = c;
  669.          c = (s < end_s) ? *s++ : ' ';
  670.      }
  671.       if (!isdigit(c))
  672.      return CvtFail;
  673.       while (isdigit(c)) {
  674.      exponent = exponent * 10 + (c - '0');
  675.          c = (s < end_s) ? *s++ : ' ';
  676.      }
  677.       scale += (esign == '+') ? exponent : -exponent;
  678.       }
  679.  
  680.    /*
  681.     * Skip trailing white space and make sure there is nothing else left
  682.     *  in the string. Note, if we have already reached end-of-string,
  683.     *  c has been set to a space.
  684.     */
  685.    while (isspace(c) && s < end_s)
  686.       c = *s++;
  687.    if (!isspace(c))
  688.       return CvtFail;
  689.  
  690.    /*
  691.     * Test for integer.
  692.     */
  693.    if (!realflag && !scale && mantissa >= MinLong && mantissa <= MaxLong) {
  694.       result->integer = (msign == '+' ? lresult : -lresult);
  695.       return T_Integer;
  696.       }
  697.  
  698.    if (!realflag)
  699.       return CvtFail;        /* don't promote to real if integer format */
  700.  
  701.    /*
  702.     * Rough tests for overflow and underflow.
  703.     */
  704.    if (sdigits + scale > LogHuge)
  705.       return CvtFail;
  706.  
  707.    if (sdigits + scale < -LogHuge) {
  708.       result->real = 0.0;
  709.       return T_Real;
  710.       }
  711.  
  712.    /*
  713.     * Put the number together by multiplying the mantissa by 5^scale and
  714.     *  then using ldexp() to multiply by 2^scale.
  715.     */
  716.  
  717.    exponent = (scale > 0)? scale : -scale;
  718.    fiveto = 1.0;
  719.    power = 5.0;
  720.    for (;;) {
  721.       if (exponent & 01)
  722.      fiveto *= power;
  723.       exponent >>= 1;
  724.       if (exponent == 0)
  725.      break;
  726.       power *= power;
  727.       }
  728.    if (scale > 0)
  729.       mantissa *= fiveto;
  730.    else
  731.       mantissa /= fiveto;
  732.  
  733.    err_no = 0;
  734.    mantissa = ldexp(mantissa, scale);
  735.    if (err_no > 0 && mantissa > 0)
  736.       /*
  737.        * ldexp caused overflow.
  738.        */
  739.       return CvtFail;
  740.  
  741.    if (msign == '-')
  742.       mantissa = -mantissa;
  743.    result->real = mantissa;
  744.    return T_Real;
  745.    }
  746.  
  747. /*
  748.  * cnv_c_dbl - cnv:C_double(*s, *d), convert a value directly into a C double
  749.  */
  750. int cnv_c_dbl(s, d)
  751. dptr s;
  752. double *d;
  753.    {
  754.      struct descrip result, cnvstr;
  755.      char sbuf[MaxCvtLen];
  756.  
  757.    union numeric numrc;
  758.  
  759.    if (!Qual(*s)) {
  760.       if (Type(*s) == T_Integer) {
  761.          *d = IntVal(*s);
  762.          return 1;
  763.          }
  764.       else if (Type(*s) == T_Cset) {
  765.         tmp_str(sbuf, s, &cnvstr);
  766.         s = &cnvstr;
  767.         }
  768.       else {
  769.         return 0;
  770.         }
  771.       }
  772.  
  773.    /*
  774.     * s is now an string.
  775.     */
  776.    switch( ston(s, &numrc) ) {
  777.       case T_Integer:
  778.          *d = numrc.integer;
  779.          return 1;
  780.       case T_Real:
  781.          *d = numrc.real;
  782.          return 1;
  783.       default:
  784.          return 0;
  785.       }
  786.   }
  787.  
  788. /*
  789.  * cnv_c_int - cnv:C_integer(*s, *d), convert a value directly into a C_integer
  790.  */
  791. int cnv_c_int(s, d)
  792. dptr s;
  793. C_integer *d;
  794.    {
  795.    struct descrip cnvstr, result;            /* not tended */
  796.    union numeric numrc;
  797.    char sbuf[MaxCvtLen];
  798.  
  799.    if (!Qual(*s)) {
  800.       if (Type(*s) == T_Integer) {
  801.          *d = IntVal(*s);
  802.          return 1;
  803.          }
  804.       else if (Type(*s) == T_Real) {
  805.          double dbl;
  806.          GetReal(s,dbl);
  807.          if (dbl > MaxLong || dbl < MinLong) {
  808.             return 0;
  809.             }
  810.          *d = dbl;
  811.          return 1;
  812.          }
  813.       else if (Type(*s) == T_Cset) {
  814.         tmp_str(sbuf, s, &cnvstr);
  815.         s = &cnvstr;
  816.         }
  817.       else {
  818.          return 0;
  819.          }
  820.       }
  821.  
  822.    /*
  823.     * s is now a string.
  824.     */
  825.    switch( ston(s, &numrc) ) {
  826.       case T_Integer: {
  827.          *d = numrc.integer;
  828.          return 1;
  829.      }
  830.       case T_Real: {
  831.          double dbl = numrc.real;
  832.          if (dbl > MaxLong || dbl < MinLong) {
  833.             return 0;
  834.             }
  835.          *d = dbl;
  836.          return 1;
  837.          }
  838.       default:
  839.          return 0;
  840.       }
  841.    }
  842.  
  843.  
  844. /*
  845.  * def_c_dbl - def:C_double(*s, df, *d), convert to C double with a
  846.  *  default value. Default is of type C double; if used, just copy to
  847.  *  destination.
  848.  */
  849.  
  850. int def_c_dbl(s,df,d)
  851. dptr s;
  852. double df;
  853. double *d;
  854.    {
  855.    if (Type(*s) == T_Null) {
  856.       *d = df;
  857.       return 1;
  858.       }
  859.    else
  860.       return cnv_c_dbl(s,d); /* I really mean cnv:type */
  861.    }
  862.  
  863.  
  864. int def_c_int(s,df,d)
  865. dptr s;
  866. C_integer df;
  867. C_integer *d;
  868.    {
  869.    if (Type(*s) == T_Null) {
  870.       *d = df;
  871.       return 1;
  872.       }
  873.    else
  874.       return cnv_c_int(s,d); /* I really mean cnv:type */
  875.    }
  876.  
  877.  
  878. /*
  879.  * the global buffer used as work space for printing string, etc 
  880.  */
  881. char ConsoleStringBuf[512 * 48];
  882. char *ConsoleStringBufPtr = ConsoleStringBuf;
  883. unsigned long ConsoleFlags = 0;             /* Console flags */
  884. extern int ConsolePause;
  885. /*
  886.  * c_exit(i) - flush all buffers and exit with status i.
  887.  */
  888. novalue c_exit(i)
  889. int i;
  890. {
  891.    char *msg = "Strike any key to close console...";
  892.  
  893.    /*
  894.     * if the console was used for anything, pause it
  895.     */
  896.    if (ConsoleBinding && ConsolePause) {
  897.       char label[256], tossanswer[256];
  898.  
  899.       wputstr((wbp)ConsoleBinding, msg, strlen(msg));
  900.  
  901.       strcpy(tossanswer, "label=wicont - execution terminated");
  902.       wattr(ConsoleBinding, tossanswer, strlen(tossanswer));
  903.       waitkey(ConsoleBinding);
  904.       }
  905.    if (wstates != NULL) {
  906.       PostQuitMessage(i);
  907.       pollevent();
  908.       }
  909.  
  910. #if !MACINTOSH
  911. #undef exit
  912. #endif                    /* MACINTOSH */
  913.    exit(i);
  914. }
  915. #endif                    /* ConsoleWindow */
  916.