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 / oarith.r < prev    next >
Text File  |  2002-01-18  |  9KB  |  503 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.    if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) )
  59.       runerr(201);  /* Divide fix */
  60.  
  61.    if (bigdiv(&x,&y,&result) == Error) /* alcbignum failed */
  62.       runerr(0);
  63.    return result;
  64. }
  65. #enddef
  66. #begdef Divide(x,y)
  67. {
  68.    if ( y == 0 )
  69.       runerr(201);  /* divide fix */
  70.  
  71.    irslt = div3(x,y);
  72.    if (over_flow) {
  73. #ifdef LargeInts
  74.       MakeInt(x,&lx);
  75.       MakeInt(y,&ly);
  76.       if (bigdiv(&lx,&ly,&result) == Error) /* alcbignum failed */
  77.      runerr(0);
  78.       return result;
  79. #else                                   /* LargeInts */
  80.       runerr(203);
  81. #endif                                  /* LargeInts */
  82.       }
  83.    else return C_integer irslt;
  84. }
  85. #enddef
  86. #begdef RealDivide(x,y)
  87. {
  88.    double z;
  89.  
  90.    if (y == 0.0)
  91.       runerr(204);
  92.    z = x / y;
  93.    return C_double z;
  94. }
  95. #enddef
  96.  
  97.  
  98. ArithOp( / , divide , Divide , RealDivide)
  99.  
  100. /*
  101.  * x - y
  102.  */
  103.  
  104. #begdef big_Sub(x,y)
  105. {
  106.    if (bigsub(&x,&y,&result) == Error) /* alcbignum failed */
  107.       runerr(0);
  108.    return result;
  109. }
  110. #enddef
  111.  
  112. #begdef Sub(x,y)
  113.    irslt = sub(x,y);
  114.    if (over_flow) {
  115. #ifdef LargeInts
  116.       MakeInt(x,&lx);
  117.       MakeInt(y,&ly);
  118.       if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */
  119.          runerr(0);
  120.       return result;
  121. #else                    /* LargeInts */
  122.       runerr(203);
  123. #endif                    /* LargeInts */
  124.       }
  125.    else return C_integer irslt;
  126. #enddef
  127.  
  128. #define RealSub(x,y) return C_double (x - y);
  129.  
  130. ArithOp( - , minus , Sub , RealSub)
  131.  
  132.  
  133. /*
  134.  * x % y
  135.  */
  136. #define Abs(x) ((x) > 0 ? (x) : -(x))
  137.  
  138. #begdef big_IntMod(x,y)
  139. {
  140.    if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) ) {
  141.       irunerr(202,0);
  142.       errorfail;
  143.       }
  144.    if (bigmod(&x,&y,&result) == Error)
  145.       runerr(0);
  146.    return result;
  147. }
  148. #enddef
  149.  
  150. #begdef IntMod(x,y)
  151. {
  152.    irslt = mod3(x,y);
  153.    if (over_flow) {
  154.       irunerr(202,y);
  155.       errorfail;
  156.       }
  157.    return C_integer irslt;
  158. }
  159. #enddef
  160.  
  161. #begdef RealMod(x,y)
  162. {
  163.    double d;
  164.  
  165.    if (y == 0.0)
  166.       runerr(204);
  167.  
  168.    d = fmod(x, y);
  169.    /* d must have the same sign as x */
  170.    if (x < 0.0) {
  171.       if (d > 0.0) {
  172.          d -= Abs(y);
  173.          }
  174.       }
  175.    else if (d < 0.0) {
  176.       d += Abs(y);
  177.       }
  178.    return C_double d;
  179. }
  180. #enddef
  181.  
  182. ArithOp( % , mod , IntMod , RealMod)
  183.  
  184. /*
  185.  * x * y
  186.  */
  187.  
  188. #begdef big_Mpy(x,y)
  189. {
  190.    if (bigmul(&x,&y,&result) == Error)
  191.       runerr(0);
  192.    return result;
  193. }
  194. #enddef
  195.  
  196. #begdef Mpy(x,y)
  197.    irslt = mul(x,y);
  198.    if (over_flow) {
  199. #ifdef LargeInts
  200.       MakeInt(x,&lx);
  201.       MakeInt(y,&ly);
  202.       if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */
  203.          runerr(0);
  204.       return result;
  205. #else                    /* LargeInts */
  206.       runerr(203);
  207. #endif                    /* LargeInts */
  208.       }
  209.    else return C_integer irslt;
  210. #enddef
  211.  
  212.  
  213. #define RealMpy(x,y) return C_double (x * y);
  214.  
  215. ArithOp( * , mult , Mpy , RealMpy)
  216.  
  217.  
  218. "-x - negate x."
  219.  
  220. operator{1} - neg(x)
  221.    if cnv:(exact)C_integer(x) then {
  222.       abstract {
  223.          return integer
  224.          }
  225.       inline {
  226.         C_integer i;
  227.         extern int over_flow;
  228.  
  229.         i = neg(x);
  230.         if (over_flow) {
  231. #ifdef LargeInts
  232.            struct descrip tmp;
  233.            MakeInt(x,&tmp);
  234.            if (bigneg(&tmp, &result) == Error)  /* alcbignum failed */
  235.               runerr(0);
  236.                return result;
  237. #else                    /* LargeInts */
  238.            irunerr(203,x);
  239.                errorfail;
  240. #endif                    /* LargeInts */
  241.                }
  242.          return C_integer i;
  243.          }
  244.       }
  245. #ifdef LargeInts
  246.    else if cnv:(exact) integer(x) then {
  247.       abstract {
  248.          return integer
  249.          }
  250.       inline {
  251.      if (bigneg(&x, &result) == Error)  /* alcbignum failed */
  252.         runerr(0);
  253.      return result;
  254.          }
  255.       }
  256. #endif                    /* LargeInts */
  257.    else {
  258.       if !cnv:C_double(x) then
  259.          runerr(102, x)
  260.       abstract {
  261.          return real
  262.          }
  263.       inline {
  264.          double drslt;
  265.      drslt = -x;
  266.          return C_double drslt;
  267.          }
  268.       }
  269. end
  270.  
  271.  
  272. "+x - convert x to a number."
  273. /*
  274.  *  Operational definition: generate runerr if x is not numeric.
  275.  */
  276. operator{1} + number(x)
  277.    if cnv:(exact)C_integer(x) then {
  278.        abstract {
  279.           return integer
  280.           }
  281.        inline {
  282.           return C_integer x;
  283.           }
  284.       }
  285. #ifdef LargeInts
  286.    else if cnv:(exact) integer(x) then {
  287.        abstract {
  288.           return integer
  289.           }
  290.        inline {
  291.           return x;
  292.           }
  293.       }
  294. #endif                    /* LargeInts */
  295.    else if cnv:C_double(x) then {
  296.        abstract {
  297.           return real
  298.           }
  299.        inline {
  300.           return C_double x;
  301.           }
  302.       }
  303.    else
  304.       runerr(102, x)
  305. end
  306.  
  307. /*
  308.  * x + y
  309.  */
  310.  
  311. #begdef big_Add(x,y)
  312. {
  313.    if (bigadd(&x,&y,&result) == Error)
  314.       runerr(0);
  315.    return result;
  316. }
  317. #enddef
  318.  
  319. #begdef Add(x,y)
  320.    irslt = add(x,y);
  321.    if (over_flow) {
  322. #ifdef LargeInts
  323.       MakeInt(x,&lx);
  324.       MakeInt(y,&ly);
  325.       if (bigadd(&lx, &ly, &result) == Error)  /* alcbignum failed */
  326.      runerr(0);
  327.       return result;
  328. #else                    /* LargeInts */
  329.       runerr(203);
  330. #endif                    /* LargeInts */
  331.       }
  332.    else return C_integer irslt;
  333. #enddef
  334.  
  335. #define RealAdd(x,y) return C_double (x + y);
  336.  
  337. ArithOp( + , plus , Add , RealAdd)
  338.  
  339.  
  340. "x ^ y - raise x to the y power."
  341.  
  342. operator{1} ^ powr(x, y)
  343.    if cnv:(exact)C_integer(y) then {
  344.       if cnv:(exact)integer(x) then {
  345.      abstract {
  346.         return integer
  347.         }
  348.      inline {
  349. #ifdef LargeInts
  350.         tended struct descrip ly;
  351.         MakeInt ( y, &ly );
  352.         if (bigpow(&x, &ly, &result) == Error)  /* alcbignum failed */
  353.            runerr(0);
  354.         return result;
  355. #else
  356.         extern int over_flow;
  357.         C_integer r = iipow(IntVal(x), y);
  358.         if (over_flow)
  359.            runerr(203);
  360.         return C_integer r;
  361. #endif
  362.        }
  363.      }
  364.       else {
  365.      if !cnv:C_double(x) then
  366.         runerr(102, x)
  367.      abstract {
  368.         return real
  369.         }
  370.      inline {
  371.         if (ripow( x, y, &result) ==  Error)
  372.            runerr(0);
  373.         return result;
  374.         }
  375.      }
  376.       }
  377. #ifdef LargeInts
  378.    else if cnv:(exact)integer(y) then {
  379.       if cnv:(exact)integer(x) then {
  380.      abstract {
  381.         return integer
  382.         }
  383.      inline {
  384.         if (bigpow(&x, &y, &result) == Error)  /* alcbignum failed */
  385.            runerr(0);
  386.         return result;
  387.         }
  388.      }
  389.       else {
  390.      if !cnv:C_double(x) then
  391.         runerr(102, x)
  392.      abstract {
  393.         return real
  394.         }
  395.      inline {
  396.         if ( bigpowri ( x, &y, &result ) == Error )
  397.            runerr(0);
  398.         return result;
  399.         }
  400.      }
  401.       }
  402. #endif                    /* LargeInts */
  403.    else {
  404.       if !cnv:C_double(x) then
  405.      runerr(102, x)
  406.       if !cnv:C_double(y) then
  407.      runerr(102, y)
  408.       abstract {
  409.      return real
  410.      }
  411.       inline {
  412.      if (x == 0.0 && y < 0.0)
  413.          runerr(204);
  414.      if (x < 0.0)
  415.         runerr(206);
  416.      return C_double pow(x,y);
  417.      }
  418.       }
  419. end
  420.  
  421. #if COMPILER || !(defined LargeInts)
  422. /*
  423.  * iipow - raise an integer to an integral power.
  424.  */
  425. C_integer iipow(n1, n2)
  426. C_integer n1, n2;
  427.    {
  428.    C_integer result;
  429.  
  430.    /* Handle some special cases first */
  431.    over_flow = 0;
  432.    switch ( n1 ) {
  433.       case 1:
  434.      return 1;
  435.       case -1:
  436.      /* Result depends on whether n2 is even or odd */
  437.      return ( n2 & 01 ) ? -1 : 1;
  438.       case 0:
  439.      if ( n2 <= 0 )
  440.         over_flow = 1;
  441.      return 0;
  442.       default:
  443.      if (n2 < 0)
  444.         return 0;
  445.       }
  446.  
  447.    result = 1L;
  448.    for ( ; ; ) {
  449.       if (n2 & 01L)
  450.      {
  451.      result = mul(result, n1);
  452.      if (over_flow)
  453.         return 0;
  454.      }
  455.  
  456.       if ( ( n2 >>= 1 ) == 0 ) break;
  457.       n1 = mul(n1, n1);
  458.       if (over_flow)
  459.      return 0;
  460.       }
  461.    over_flow = 0;
  462.    return result;
  463.    }
  464. #endif                    /* COMPILER || !(defined LargeInts) */
  465.  
  466.  
  467. /*
  468.  * ripow - raise a real number to an integral power.
  469.  */
  470. int ripow(r, n, drslt)
  471. double r;
  472. C_integer n;
  473. dptr drslt;
  474.    {
  475.    double retval;
  476.  
  477.    if (r == 0.0 && n <= 0)
  478.       ReturnErrNum(204, Error);
  479.    if (n < 0) {
  480.       /*
  481.        * r ^ n = ( 1/r ) * ( ( 1/r ) ^ ( -1 - n ) )
  482.        *
  483.        * (-1) - n never overflows, even when n == MinLong.
  484.        */
  485.       n = (-1) - n;
  486.       r = 1.0 / r;
  487.       retval = r;
  488.       }
  489.    else
  490.       retval = 1.0;
  491.  
  492.    /* multiply retval by r ^ n */
  493.    while (n > 0) {
  494.       if (n & 01L)
  495.      retval *= r;
  496.       r *= r;
  497.       n >>= 1;
  498.       }
  499.    Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return Error);
  500.    drslt->dword = D_Real;
  501.    return Succeeded;
  502.    }
  503.