home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / src / runtime / fconv.r < prev    next >
Text File  |  2002-01-18  |  5KB  |  261 lines
  1. /*
  2.  * fconv.r -- abs, cset, integer, numeric, proc, real, string.
  3.  */
  4.  
  5. "abs(N) - produces the absolute value of N."
  6.  
  7. function{1} abs(n)
  8.    /*
  9.     * If n is convertible to a (large or small) integer or real,
  10.     * this code returns -n if n is negative
  11.     */
  12.    if cnv:(exact)C_integer(n) then {
  13.       abstract {
  14.          return integer
  15.          }
  16.       inline {
  17.      C_integer i;
  18.      extern int over_flow;
  19.  
  20.      if (n >= 0)
  21.         i = n;
  22.      else {
  23.         i = neg(n);
  24.         if (over_flow) {
  25. #ifdef LargeInts
  26.            struct descrip tmp;
  27.            MakeInt(n,&tmp);
  28.            if (bigneg(&tmp, &result) == Error)  /* alcbignum failed */
  29.               runerr(0);
  30.                return result;
  31. #else                    /* LargeInts */
  32.            irunerr(203,n);
  33.                errorfail;
  34. #endif                    /* LargeInts */
  35.            }
  36.         }
  37.          return C_integer i;
  38.          }
  39.       }
  40.  
  41.  
  42. #ifdef LargeInts
  43.    else if cnv:(exact)integer(n) then {
  44.       abstract {
  45.          return integer
  46.          }
  47.       inline {
  48.      if (BlkLoc(n)->bignumblk.sign == 0)
  49.         result = n;
  50.      else {
  51.         if (bigneg(&n, &result) == Error)  /* alcbignum failed */
  52.            runerr(0);
  53.         }
  54.          return result;
  55.          }
  56.       }
  57. #endif                    /* LargeInts */
  58.  
  59.    else if cnv:C_double(n) then {
  60.       abstract {
  61.          return real
  62.          }
  63.       inline {
  64.          return C_double Abs(n);
  65.          }
  66.       }
  67.    else
  68.       runerr(102,n)
  69. end
  70.  
  71.  
  72. /*
  73.  * The convertible types cset, integer, real, and string are identical
  74.  *  enough to be expansions of a single macro, parameterized by type.
  75.  */
  76. #begdef ReturnYourselfAs(t)
  77. #t "(x) - produces a value of type " #t " resulting from the conversion of x, "
  78.    "but fails if the conversion is not possible."
  79. function{0,1} t(x)
  80.  
  81.    if cnv:t(x) then {
  82.       abstract {
  83.          return t
  84.          }
  85.       inline {
  86.          return x;
  87.          }
  88.       }
  89.    else {
  90.       abstract {
  91.          return empty_type
  92.          }
  93.       inline {
  94.          fail;
  95.          }
  96.       }
  97. end
  98.  
  99. #enddef
  100.  
  101. ReturnYourselfAs(cset)     /* cset(x) - convert to cset or fail */
  102. ReturnYourselfAs(integer)  /* integer(x) - convert to integer or fail */
  103. ReturnYourselfAs(real)     /* real(x) - convert to real or fail */
  104. ReturnYourselfAs(string)   /* string(x) - convert to string or fail */
  105.  
  106.  
  107.  
  108. "numeric(x) - produces an integer or real number resulting from the "
  109. "type conversion of x, but fails if the conversion is not possible."
  110.  
  111. function{0,1} numeric(n)
  112.  
  113.    if cnv:(exact)integer(n) then {
  114.       abstract {
  115.          return integer
  116.          }
  117.       inline {
  118.          return n;
  119.          }
  120.       }
  121.    else if cnv:real(n) then {
  122.       abstract {
  123.          return real
  124.          }
  125.       inline {
  126.          return n;
  127.          }
  128.       }
  129.    else {
  130.       abstract {
  131.          return empty_type
  132.          }
  133.       inline {
  134.          fail;
  135.          }
  136.       }
  137. end
  138.  
  139.  
  140. "proc(x,i) - convert x to a procedure if possible; use i to resolve "
  141. "ambiguous string names."
  142.  
  143. #ifdef MultiThread
  144. function{0,1} proc(x,i,c)
  145. #else                    /* MultiThread */
  146. function{0,1} proc(x,i)
  147. #endif                    /* MultiThread */
  148.  
  149. #ifdef MultiThread
  150.    if is:coexpr(x) then {
  151.       abstract {
  152.          return proc
  153.          }
  154.       inline {
  155.      struct b_coexpr *ce = NULL;
  156.      struct b_proc *bp = NULL;
  157.      struct pf_marker *fp;
  158.      dptr dp=NULL;
  159.      if (BlkLoc(x) != BlkLoc(k_current)) {
  160.         ce = (struct b_coexpr *)BlkLoc(x);
  161.         dp = ce->es_argp;
  162.         if (dp == NULL) fail;
  163.         bp = (struct b_proc *)BlkLoc(*(dp));
  164.         }
  165.      else
  166.         bp = (struct b_proc *)BlkLoc(*(glbl_argp));
  167.      return proc(bp);
  168.      }
  169.       }
  170. #endif                    /* MultiThread */
  171.  
  172.    if is:proc(x) then {
  173.       abstract {
  174.          return proc
  175.          }
  176.       inline {
  177.  
  178. #ifdef MultiThread
  179.      if (!is:null(c)) {
  180.         struct progstate *p;
  181.         if (!is:coexpr(c)) runerr(118,c);
  182.         /*
  183.          * Test to see whether a given procedure belongs to a given
  184.          * program.  Currently this is a sleazy pointer arithmetic check.
  185.          */
  186.         p = BlkLoc(c)->coexpr.program;
  187.         if (! InRange(p, BlkLoc(x)->proc.entryp.icode,
  188.               (char *)p + p->hsize))
  189.            fail;
  190.         }
  191. #endif                    /* MultiThread */
  192.          return x;
  193.          }
  194.       }
  195.  
  196.    else if cnv:tmp_string(x) then {
  197.       /*
  198.        * i must be 0, 1, 2, or 3; it defaults to 1.
  199.        */
  200.       if !def:C_integer(i, 1) then
  201.          runerr(101, i)
  202.       inline {
  203.          if (i < 0 || i > 3) {
  204.             irunerr(205, i);
  205.             errorfail;
  206.             }
  207.          }
  208.  
  209.       abstract {
  210.          return proc
  211.          }
  212.       inline {
  213.          struct b_proc *prc;
  214.  
  215. #ifdef MultiThread
  216.      struct progstate *prog, *savedprog;
  217.  
  218.      savedprog = curpstate;
  219.      if (is:null(c)) {
  220.         prog = curpstate;
  221.         }
  222.      else if (is:coexpr(c)) {
  223.         prog = BlkLoc(c)->coexpr.program;
  224.         }
  225.      else {
  226.         runerr(118,c);
  227.         }
  228.  
  229.      ENTERPSTATE(prog);
  230. #endif                        /* MultiThread */
  231.  
  232.          /*
  233.           * Attempt to convert Arg0 to a procedure descriptor using i to
  234.           *  discriminate between procedures with the same names.  If i
  235.           *  is zero, only check builtins and ignore user procedures.
  236.           *  Fail if the conversion isn't successful.
  237.           */
  238.      if (i == 0)
  239.             prc = bi_strprc(&x, 0);
  240.      else
  241.          prc = strprc(&x, i);
  242.  
  243. #ifdef MultiThread
  244.      ENTERPSTATE(savedprog);
  245. #endif                        /* MultiThread */
  246.          if (prc == NULL)
  247.             fail;
  248.          else
  249.             return proc(prc);
  250.          }
  251.       }
  252.    else {
  253.       abstract {
  254.          return empty_type
  255.          }
  256.       inline {
  257.          fail;
  258.          }
  259.       }
  260. end
  261.