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 / oarith.r < prev    next >
Text File  |  1996-03-22  |  8KB  |  431 lines
  1. /*
  2.  * File: oarith.r
  3.  *  Contents: arithmetic operators + - * / % ^.  Auxiliary routines
  4.  *   iipow, ripow.
  5.  *
  6.  * The arithmetic operators all follow a canonical conversion
  7.  * protocol encapsulated in the macro ArithOp.
  8.  */
  9.  
  10. int over_flow = 0;
  11.  
  12. #begdef ArithOp(icon_op, func_name, c_int_op, c_real_op)
  13.  
  14.    operator{1} icon_op func_name(x, y)
  15.       declare {
  16. #ifdef LargeInts
  17.          tended struct descrip lx, ly;
  18. #endif                    /* LargeInts */
  19.      C_integer irslt;
  20.          }
  21.       arith_case (x, y) of {
  22.          C_integer: {
  23.             abstract {
  24.                return integer
  25.                }
  26.             inline {
  27.                extern int over_flow;
  28.                c_int_op(x,y);
  29.                }
  30.             }
  31.          integer: { /* large integers only */
  32.             abstract {
  33.                return integer
  34.                }
  35.             inline {
  36.                big_ ## c_int_op(x,y);
  37.                }
  38.             }
  39.          C_double: {
  40.             abstract {
  41.                return real
  42.                }
  43.             inline {
  44.                c_real_op(x, y);
  45.                }
  46.             }
  47.          }
  48. end
  49.  
  50. #enddef
  51.  
  52. /*
  53.  * x / y
  54.  */
  55.  
  56. #begdef big_Divide(x,y)
  57. {
  58.   bigdiv(&x,&y,&result);
  59.   return result;
  60. }
  61. #enddef
  62. #define Divide(x,y) return C_integer (x / y);
  63. #begdef RealDivide(x,y)
  64. {
  65.    double z;
  66. #ifdef ZERODIVIDE
  67.    if (y == 0.0)
  68.       runerr(204);
  69. #endif                        /* ZERODIVIDE */
  70.    z = x / y;
  71. #ifdef SUN
  72.    if (z >= HUGE || z <= -HUGE) {
  73.       kill(getpid(), SIGFPE);
  74.    }
  75. #endif
  76.    return C_double z;
  77. }
  78. #enddef
  79.  
  80.  
  81. ArithOp( / , divide , Divide , RealDivide )
  82.  
  83. /*
  84.  * x - y
  85.  */
  86.  
  87. #begdef big_Sub(x,y)
  88. {
  89.    if (bigsub(&x,&y,&result) == Error) /* alcbignum failed */
  90.       runerr(0);
  91.    return result;
  92. }
  93. #enddef
  94.  
  95. #begdef Sub(x,y)
  96.    irslt = sub(x,y);
  97.    if (over_flow) {
  98. #ifdef LargeInts
  99.       MakeInt(x,&lx);
  100.       MakeInt(y,&ly);
  101.       if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */
  102.          runerr(0);
  103.       return result;
  104. #else                    /* LargeInts */
  105.       runerr(203);
  106. #endif                    /* LargeInts */
  107.       }
  108.    else return C_integer irslt;
  109. #enddef
  110.  
  111. #define RealSub(x,y) return C_double (x - y);
  112.  
  113. ArithOp( - , minus , Sub , RealSub )
  114.  
  115.  
  116. /*
  117.  * x % y
  118.  */
  119.  
  120. #define Abs(x) ((x) > 0 ? (x) : -(x))
  121. /*
  122.  * The sign of modulo's result must match that of x.
  123.  */
  124. #begdef MatchSignToX(x,y,theResult,zero)
  125.    if (x < zero) {
  126.       if (theResult > zero) {
  127.          theResult -= Abs(y);
  128.          }
  129.       }
  130.    else if (theResult < zero) {
  131.       theResult += Abs(y);
  132.       }
  133. #enddef
  134.  
  135. #begdef big_IntMod(x,y)
  136. {
  137.    if (bigmod(&x,&y,&result) == Error)
  138.       runerr(0);
  139.    return result;
  140. }
  141. #enddef
  142.  
  143. #begdef IntMod(x,y)
  144. {
  145.    if (y == 0) {
  146.       irunerr(202,y);
  147.       errorfail;
  148.       }
  149.    irslt = x % y;
  150.    MatchSignToX(x,y,irslt,0);
  151.    return C_integer irslt;
  152. }
  153. #enddef
  154.  
  155. #begdef RealMod(x,y)
  156. {
  157.    double d;
  158.    d = fmod(x, y);
  159.    MatchSignToX(x,y,d,0.0);
  160.    return C_double d;
  161. }
  162. #enddef
  163.  
  164. ArithOp( % , mod , IntMod , RealMod )
  165.  
  166. /*
  167.  * x * y
  168.  */
  169.  
  170. #begdef big_Mpy(x,y)
  171. {
  172.    if (bigmul(&x,&y,&result) == Error)
  173.       runerr(0);
  174.    return result;
  175. }
  176. #enddef
  177.  
  178. #begdef Mpy(x,y)
  179.    irslt = mul(x,y);
  180.    if (over_flow) {
  181. #ifdef LargeInts
  182.       MakeInt(x,&lx);
  183.       MakeInt(y,&ly);
  184.       if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */
  185.          runerr(0);
  186.       return result;
  187. #else                    /* LargeInts */
  188.       runerr(203);
  189. #endif                    /* LargeInts */
  190.       }
  191.    else return C_integer irslt;
  192. #enddef
  193.  
  194.  
  195. #define RealMpy(x,y) return C_double (x * y);
  196.  
  197. ArithOp( * , mult , Mpy , RealMpy )
  198.  
  199.  
  200. "-x - negate x."
  201.  
  202. operator{1} - neg(x)
  203.    if cnv:(exact)C_integer(x) then {
  204.       abstract {
  205.          return integer
  206.          }
  207.       inline {
  208.         C_integer i;
  209.         extern int over_flow;
  210.  
  211.         i = neg(x);
  212.         if (over_flow) {
  213. #ifdef LargeInts
  214.            struct descrip tmp;
  215.            MakeInt(x,&tmp);
  216.            if (bigneg(&tmp, &result) == Error)  /* alcbignum failed */
  217.               runerr(0);
  218.                return result;
  219. #else                    /* LargeInts */
  220.            irunerr(203,x);
  221.                errorfail;
  222. #endif                    /* LargeInts */
  223.                }
  224.          return C_integer i;
  225.          }
  226.       }
  227. #ifdef LargeInts
  228.    else if cnv:(exact) integer(x) then {
  229.       abstract {
  230.          return integer
  231.          }
  232.       inline {
  233.      if (cpbignum(&x, &result) == Error)  /* alcbignum failed */
  234.         runerr(0);
  235.      BlkLoc(result)->bignumblk.sign ^= 1;
  236.      return result;
  237.          }
  238.       }
  239. #endif                    /* LargeInts */
  240.    else {
  241.       if !cnv:C_double(x) then
  242.          runerr(102, x)
  243.       abstract {
  244.          return real
  245.          }
  246.       inline {
  247.          double drslt;
  248.      drslt = -x;
  249.          return C_double drslt;
  250.          }
  251.       }
  252. end
  253.  
  254.  
  255. "+x - convert x to a number."
  256. /*
  257.  *  Operational definition: generate runerr if x is not numeric.
  258.  */
  259. operator{1} + number(x)
  260.    if cnv:(exact)C_integer(x) then {
  261.        abstract {
  262.           return integer
  263.           }
  264.        inline {
  265.           return C_integer x;
  266.           }
  267.       }
  268. #ifdef LargeInts
  269.    else if cnv:(exact) integer(x) then {
  270.        abstract {
  271.           return integer
  272.           }
  273.        inline {
  274.           return x;
  275.           }
  276.       }
  277. #endif                    /* LargeInts */
  278.    else if cnv:C_double(x) then {
  279.        abstract {
  280.           return real
  281.           }
  282.        inline {
  283.           return C_double x;
  284.           }
  285.       }
  286.    else
  287.       runerr(102, x)
  288. end
  289.  
  290. /*
  291.  * x + y
  292.  */
  293.  
  294. #begdef big_Add(x,y)
  295. {
  296.    if (bigadd(&x,&y,&result) == Error)
  297.       runerr(0);
  298.    return result;
  299. }
  300. #enddef
  301.  
  302. #begdef Add(x,y)
  303.    irslt = add(x,y);
  304.    if (over_flow) {
  305. #ifdef LargeInts
  306.       MakeInt(x,&lx);
  307.       MakeInt(y,&ly);
  308.       if (bigadd(&lx, &ly, &result) == Error)  /* alcbignum failed */
  309.      runerr(0);
  310.       return result;
  311. #else                    /* LargeInts */
  312.       runerr(203);
  313. #endif                    /* LargeInts */
  314.       }
  315.    else return C_integer irslt;
  316. #enddef
  317.  
  318. #define RealAdd(x,y) return C_double (x + y);
  319.  
  320. ArithOp( + , plus , Add , RealAdd )
  321.  
  322.  
  323. "x ^ y - raise x to the y power."
  324.  
  325. operator{1} ^ powr(x, y)
  326.    if cnv:(exact)integer(y) then {
  327.       if cnv:(exact)integer(x) then {
  328.          abstract {
  329.             return integer
  330.             }
  331.          inline {
  332.         extern int over_flow;
  333. #ifdef LargeInts
  334.             if (bigpow(&x, &y, &result) == Error)  /* alcbignum failed */
  335.                runerr(0);
  336.             return result;
  337. #else
  338.             C_integer r = iipow(IntVal(x), IntVal(y));
  339.             if (over_flow)
  340.                runerr(203);
  341.             return C_integer r;
  342. #endif
  343.            }
  344.          }
  345.       else {
  346.          if !cnv:C_double(x) then
  347.             runerr(102, x)
  348.          abstract {
  349.             return real
  350.             }
  351.          inline {
  352.             if (ripow(x,IntVal(y), &result) ==  Error)
  353.                 runerr(0);
  354.             return result;
  355.             }
  356.          }
  357.       }
  358.    else {
  359.       if !cnv:C_double(x) then
  360.          runerr(102, x)
  361.       if !cnv:C_double(y) then
  362.          runerr(102, y)
  363.       abstract {
  364.          return real
  365.          }
  366.       inline {
  367.          if (x == 0.0 && y < 0.0)
  368.              runerr(204);
  369.          if (x < 0.0)
  370.             runerr(206);
  371.          return C_double pow(x,y);
  372.          }
  373.       }
  374. end
  375.  
  376. #if COMPILER || !(defined LargeInts)
  377. /*
  378.  * iipow - raise an integer to an integral power. 
  379.  */
  380. C_integer iipow(n1, n2)
  381. C_integer n1, n2;
  382.    {
  383.    C_integer result;
  384.  
  385.    if (n1 == 0 && n2 <= 0) {
  386.       over_flow = 1;
  387.       return 0;
  388.       }
  389.    if (n2 < 0)
  390.       return 0;
  391.    result = 1L;
  392.    while (n2 > 0) {
  393.       if (n2 & 01L)
  394.          result *= n1;
  395.       n1 *= n1;
  396.       n2 >>= 1;
  397.       }
  398.    over_flow = 0;
  399.    return result;
  400.    }
  401. #endif                    /* COMPILER || !(defined LargeInts) */
  402.  
  403.  
  404. /*
  405.  * ripow - raise a real number to an integral power.
  406.  */
  407. int ripow(r, n, drslt)
  408. double r;
  409. C_integer n;
  410. dptr drslt;
  411.    {
  412.    double retval;
  413.  
  414.    if (r == 0.0 && n <= 0) 
  415.       ReturnErrNum(204, Error);
  416.    if (n < 0) {
  417.       n = -n;
  418.       r = 1.0 / r;
  419.       }
  420.    retval = 1.0;
  421.    while (n > 0) {
  422.       if (n & 01L)
  423.          retval *= r;
  424.       r *= r;
  425.       n >>= 1;
  426.       }
  427.    Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return Error);
  428.    drslt->dword = D_Real;
  429.    return Succeeded;
  430.    }
  431.