home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / artutl.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  12KB  |  495 lines
  1. /* -*-C-*-
  2.  
  3. $Id: artutl.c,v 1.16 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Arithmetic Utilities */
  23.  
  24. #include "scheme.h"
  25. #include <math.h>
  26. #include "limits.h"
  27.  
  28. /* Conversions between Scheme types and C types. */
  29.  
  30. long
  31. DEFUN (fixnum_to_long, (fixnum), SCHEME_OBJECT fixnum)
  32. {
  33.   return (FIXNUM_TO_LONG (fixnum));
  34. }
  35.  
  36. SCHEME_OBJECT
  37. DEFUN (double_to_fixnum, (value), double value)
  38. {
  39. #ifdef HAVE_DOUBLE_TO_LONG_BUG
  40.   fast long temp = ((long) value);
  41.   return (LONG_TO_FIXNUM (temp));
  42. #else
  43.   return (LONG_TO_FIXNUM ((long) value));
  44. #endif
  45. }
  46.  
  47. Boolean
  48. DEFUN (integer_to_long_p, (n), fast SCHEME_OBJECT n)
  49. {
  50.   return ((FIXNUM_P (n)) || (BIGNUM_TO_LONG_P (n)));
  51. }
  52.  
  53. long
  54. DEFUN (integer_to_long,
  55.        (n),
  56.        fast SCHEME_OBJECT n)
  57. {
  58.   return ((FIXNUM_P (n)) ? (FIXNUM_TO_LONG (n)) : (bignum_to_long (n)));
  59. }
  60.  
  61. SCHEME_OBJECT
  62. DEFUN (long_to_integer, (number), long number)
  63. {
  64.   return
  65.     ((LONG_TO_FIXNUM_P (number))
  66.      ? (LONG_TO_FIXNUM (number))
  67.      : (long_to_bignum (number)));
  68. }
  69.  
  70. Boolean
  71. DEFUN (integer_to_ulong_p, (n), fast SCHEME_OBJECT n)
  72. {
  73.   return ((FIXNUM_P (n)) || (BIGNUM_TO_ULONG_P (n)));
  74. }
  75.  
  76. unsigned long
  77. DEFUN (integer_to_ulong,
  78.        (n),
  79.        fast SCHEME_OBJECT n)
  80. {
  81.   return ((FIXNUM_P (n))
  82.       ? ((unsigned long) (FIXNUM_TO_LONG (n)))
  83.       : (bignum_to_ulong (n)));
  84. }
  85.  
  86. SCHEME_OBJECT
  87. DEFUN (ulong_to_integer, (number), unsigned long number)
  88. {
  89.   long s_number = ((long) number);
  90.   if (s_number >= 0)
  91.     return
  92.       ((LONG_TO_FIXNUM_P (s_number))
  93.        ? (LONG_TO_FIXNUM (s_number))
  94.        : (long_to_bignum (s_number)));
  95.   else
  96.     return (ulong_to_bignum (number));
  97. }
  98.  
  99. Boolean
  100. DEFUN (integer_to_double_p, (n), fast SCHEME_OBJECT n)
  101. {
  102.   return ((FIXNUM_P (n)) || (BIGNUM_TO_DOUBLE_P (n)));
  103. }
  104.  
  105. double
  106. DEFUN (integer_to_double, (n), fast SCHEME_OBJECT n)
  107. {
  108.   return ((FIXNUM_P (n)) ? (FIXNUM_TO_DOUBLE (n)) : (bignum_to_double (n)));
  109. }
  110.  
  111. SCHEME_OBJECT
  112. DEFUN (double_to_integer, (x), fast double x)
  113. {
  114.   return
  115.     ((DOUBLE_TO_FIXNUM_P (x))
  116.      ? (DOUBLE_TO_FIXNUM (x))
  117.      : (double_to_bignum (x)));
  118. }
  119.  
  120. double
  121. DEFUN (double_truncate, (x), fast double x)
  122. {
  123.   double iptr;
  124.   (void) modf (x, (&iptr));
  125.   return (iptr);
  126. }
  127.  
  128. /* Conversions between Scheme types and Scheme types. */
  129.  
  130. SCHEME_OBJECT
  131. DEFUN (bignum_to_fixnum, (bignum), fast SCHEME_OBJECT bignum)
  132. {
  133.   return
  134.     ((BIGNUM_TO_FIXNUM_P (bignum))
  135.      ? (BIGNUM_TO_FIXNUM (bignum))
  136.      : SHARP_F);
  137. }
  138.  
  139. SCHEME_OBJECT
  140. DEFUN (bignum_to_integer, (bignum), fast SCHEME_OBJECT bignum)
  141. {
  142.   return
  143.     ((BIGNUM_TO_FIXNUM_P (bignum))
  144.      ? (BIGNUM_TO_FIXNUM (bignum))
  145.      : bignum);
  146. }
  147.  
  148. SCHEME_OBJECT
  149. DEFUN (bignum_to_flonum, (bignum), fast SCHEME_OBJECT bignum)
  150. {
  151.   return
  152.     ((BIGNUM_TO_FLONUM_P (bignum))
  153.      ? (BIGNUM_TO_FLONUM (bignum))
  154.      : SHARP_F);
  155. }
  156.  
  157. Boolean
  158. DEFUN (flonum_integer_p, (x), SCHEME_OBJECT x)
  159. {
  160.   extern double EXFUN (modf, (double, double *));
  161.   double iptr;
  162.   return ((modf ((FLONUM_TO_DOUBLE (x)), (&iptr))) == 0);
  163. }
  164.  
  165. SCHEME_OBJECT
  166. DEFUN (flonum_floor, (x), SCHEME_OBJECT x)
  167. {
  168.   extern double EXFUN (floor, (double));
  169.   return (double_to_flonum (floor (FLONUM_TO_DOUBLE (x))));
  170. }
  171.  
  172. SCHEME_OBJECT
  173. DEFUN (flonum_ceiling, (x), SCHEME_OBJECT x)
  174. {
  175.   extern double EXFUN (ceil, (double));
  176.   return (double_to_flonum (ceil (FLONUM_TO_DOUBLE (x))));
  177. }
  178.  
  179. SCHEME_OBJECT
  180. DEFUN (flonum_round,
  181.        (x),
  182.        SCHEME_OBJECT x)
  183. {
  184.   fast double dx = (FLONUM_TO_DOUBLE (x));
  185.   return
  186.     (double_to_flonum (double_truncate ((dx < 0) ? (dx - 0.5) : (dx + 0.5))));
  187. }
  188.  
  189. SCHEME_OBJECT
  190. DEFUN (flonum_normalize, (x), SCHEME_OBJECT x)
  191. {
  192.   extern double EXFUN (frexp, (double, int *));
  193.   int exponent;
  194.   double significand = (frexp ((FLONUM_TO_DOUBLE (x)), (&exponent)));
  195.   return (cons ((double_to_flonum (significand)),
  196.         (long_to_integer ((long) exponent))));
  197. }
  198.  
  199. SCHEME_OBJECT
  200. DEFUN (flonum_denormalize, (x, e), SCHEME_OBJECT x AND SCHEME_OBJECT e)
  201. {
  202.   extern double EXFUN (ldexp, (double, int));
  203.   return (double_to_flonum (ldexp ((FLONUM_TO_DOUBLE (x)),
  204.                    ((int) (integer_to_long (e))))));
  205. }
  206.  
  207. /* Generic Integer Operations */
  208.  
  209. Boolean
  210. DEFUN (integer_zero_p, (n), SCHEME_OBJECT n)
  211. {
  212.   return ((FIXNUM_P (n)) ? (FIXNUM_ZERO_P (n)) : (BIGNUM_ZERO_P (n)));
  213. }
  214.  
  215. Boolean
  216. DEFUN (integer_negative_p, (n), SCHEME_OBJECT n)
  217. {
  218.   return ((FIXNUM_P (n)) ? (FIXNUM_NEGATIVE_P (n)) : (BIGNUM_NEGATIVE_P (n)));
  219. }
  220.  
  221. Boolean
  222. DEFUN (integer_positive_p, (n), SCHEME_OBJECT n)
  223. {
  224.   return ((FIXNUM_P (n)) ? (FIXNUM_POSITIVE_P (n)) : (BIGNUM_POSITIVE_P (n)));
  225. }
  226.  
  227. Boolean
  228. DEFUN (integer_equal_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  229. {
  230.   return
  231.     ((FIXNUM_P (n))
  232.      ? ((FIXNUM_P (m))
  233.     ? (FIXNUM_EQUAL_P (n, m))
  234.     : (bignum_equal_p ((FIXNUM_TO_BIGNUM (n)), m)))
  235.      : (bignum_equal_p (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
  236. }
  237.  
  238. Boolean
  239. DEFUN (integer_less_p, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  240. {
  241.   return
  242.     ((FIXNUM_P (n))
  243.      ? ((FIXNUM_P (m))
  244.     ? (FIXNUM_LESS_P (n, m))
  245.     : (BIGNUM_LESS_P ((FIXNUM_TO_BIGNUM (n)), m)))
  246.      : (BIGNUM_LESS_P (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m))));
  247. }
  248.  
  249. SCHEME_OBJECT
  250. DEFUN (integer_negate, (n), SCHEME_OBJECT n)
  251. {
  252.   return
  253.     ((FIXNUM_P (n))
  254.      ? (long_to_integer (- (FIXNUM_TO_LONG (n))))
  255.      : (bignum_to_integer (bignum_negate (n))));
  256. }
  257.  
  258. SCHEME_OBJECT
  259. DEFUN (integer_add, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  260. {
  261.   return
  262.     ((FIXNUM_P (n))
  263.      ? ((FIXNUM_P (m))
  264.     ? (long_to_integer ((FIXNUM_TO_LONG (n)) + (FIXNUM_TO_LONG (m))))
  265.     : (bignum_to_integer (bignum_add ((FIXNUM_TO_BIGNUM (n)), m))))
  266.      : (bignum_to_integer
  267.     (bignum_add (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  268. }
  269.  
  270. SCHEME_OBJECT
  271. DEFUN (integer_add_1, (n), SCHEME_OBJECT n)
  272. {
  273.   return
  274.     ((FIXNUM_P (n))
  275.      ? (long_to_integer ((FIXNUM_TO_LONG (n)) + 1))
  276.      : (bignum_to_integer (bignum_add (n, (long_to_bignum (1))))));
  277. }
  278.  
  279. SCHEME_OBJECT
  280. DEFUN (integer_subtract, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  281. {
  282.   return
  283.     ((FIXNUM_P (n))
  284.      ? ((FIXNUM_P (m))
  285.     ? (long_to_integer ((FIXNUM_TO_LONG (n)) - (FIXNUM_TO_LONG (m))))
  286.     : (bignum_to_integer (bignum_subtract ((FIXNUM_TO_BIGNUM (n)), m))))
  287.      : (bignum_to_integer
  288.     (bignum_subtract (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  289. }
  290.  
  291. SCHEME_OBJECT
  292. DEFUN (integer_subtract_1, (n), SCHEME_OBJECT n)
  293. {
  294.   return
  295.     ((FIXNUM_P (n))
  296.      ? (long_to_integer ((FIXNUM_TO_LONG (n)) - 1))
  297.      : (bignum_to_integer (bignum_subtract (n, (long_to_bignum (1))))));
  298. }
  299.  
  300. SCHEME_OBJECT
  301. DEFUN (integer_multiply, (n, m), SCHEME_OBJECT n AND SCHEME_OBJECT m)
  302. {
  303.   extern SCHEME_OBJECT EXFUN (Mul, (SCHEME_OBJECT, SCHEME_OBJECT));
  304.   fast SCHEME_OBJECT result;
  305.   return
  306.     ((FIXNUM_P (n))
  307.      ? ((FIXNUM_P (m))
  308.     ? ((result = (Mul (n, m))),
  309.        ((result != SHARP_F)
  310.         ? result
  311.         : (bignum_to_integer
  312.            (bignum_multiply ((FIXNUM_TO_BIGNUM (n)),
  313.                  (FIXNUM_TO_BIGNUM (m)))))))
  314.     : (bignum_to_integer (bignum_multiply ((FIXNUM_TO_BIGNUM (n)), m))))
  315.      : (bignum_to_integer
  316.     (bignum_multiply (n, ((FIXNUM_P (m)) ? (FIXNUM_TO_BIGNUM (m)) : m)))));
  317. }
  318.  
  319. Boolean
  320. DEFUN (integer_divide, (n, d, q, r),
  321.        SCHEME_OBJECT n AND SCHEME_OBJECT d
  322.        AND SCHEME_OBJECT * q AND SCHEME_OBJECT * r)
  323. {
  324.   if (FIXNUM_P (n))
  325.     {
  326.       if (FIXNUM_P (d))
  327.     {
  328.       /* Now, unbelievable hair because C doesn't fully specify
  329.          / and % when their arguments are negative.  We must get
  330.          consistent answers for all valid arguments. */
  331.       fast long lx = (FIXNUM_TO_LONG (n));
  332.       fast long ly = (FIXNUM_TO_LONG (d));
  333.       fast long quotient;
  334.       fast long remainder;
  335.       if (ly == 0)
  336.         return (true);
  337.       if (lx < 0)
  338.         {
  339.           lx = (-lx);
  340.           if (ly < 0)
  341.         {
  342.           ly = (-ly);
  343.           quotient = (lx / ly);
  344.         }
  345.           else
  346.         quotient = (- (lx / ly));
  347.           remainder = (- (lx % ly));
  348.         }
  349.       else
  350.         {
  351.           if (ly < 0)
  352.         {
  353.           ly = (-ly);
  354.           quotient = (- (lx / ly));
  355.         }
  356.           else
  357.         quotient = (lx / ly);
  358.           remainder = (lx % ly);
  359.         }
  360.       (*q) = (long_to_integer (quotient));
  361.       (*r) = (LONG_TO_FIXNUM (remainder));
  362.       return (false);
  363.     }
  364.       n = (FIXNUM_TO_BIGNUM (n));
  365.     }
  366.   else
  367.     {
  368.       if (FIXNUM_P (d))
  369.     d = (FIXNUM_TO_BIGNUM (d));
  370.     }
  371.   {
  372.     SCHEME_OBJECT quotient;
  373.     SCHEME_OBJECT remainder;
  374.     if (bignum_divide (n, d, ("ient), (&remainder)))
  375.       return (true);
  376.     (*q) = (bignum_to_integer (quotient));
  377.     (*r) = (bignum_to_integer (remainder));
  378.     return (false);
  379.   }
  380. }
  381.  
  382. SCHEME_OBJECT
  383. DEFUN (integer_quotient, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
  384. {
  385.   if (FIXNUM_P (n))
  386.     {
  387.       if (FIXNUM_P (d))
  388.     {
  389.       fast long lx = (FIXNUM_TO_LONG (n));
  390.       fast long ly = (FIXNUM_TO_LONG (d));
  391.       return
  392.         ((ly == 0)
  393.          ? SHARP_F
  394.          : (long_to_integer
  395.         ((lx < 0)
  396.          ? ((ly < 0)
  397.             ? ((-lx) / (-ly))
  398.             : (- ((-lx) / ly)))
  399.          : ((ly < 0)
  400.             ? (- (lx / (-ly)))
  401.             : (lx / ly)))));
  402.     }
  403.       n = (FIXNUM_TO_BIGNUM (n));
  404.     }
  405.   else
  406.     {
  407.       if (FIXNUM_P (d))
  408.     d = (FIXNUM_TO_BIGNUM (d));
  409.     }
  410.   {
  411.     SCHEME_OBJECT result = (bignum_quotient (n, d));
  412.     return
  413.       ((result == SHARP_F)
  414.        ? SHARP_F
  415.        : (bignum_to_integer (result)));
  416.   }
  417. }
  418.  
  419. SCHEME_OBJECT
  420. DEFUN (integer_remainder, (n, d), SCHEME_OBJECT n AND SCHEME_OBJECT d)
  421. {
  422.   if (FIXNUM_P (n))
  423.     {
  424.       if (FIXNUM_P (d))
  425.     {
  426.       fast long lx = (FIXNUM_TO_LONG (n));
  427.       fast long ly = (FIXNUM_TO_LONG (d));
  428.       return
  429.         ((ly == 0)
  430.          ? SHARP_F
  431.          : (long_to_integer
  432.         ((lx < 0)
  433.          ? (- ((-lx) % ((ly < 0) ? (-ly) : ly)))
  434.          : (lx % ((ly < 0) ? (-ly) : ly)))));
  435.     }
  436.       n = (FIXNUM_TO_BIGNUM (n));
  437.     }
  438.   else
  439.     {
  440.       if (FIXNUM_P (d))
  441.     d = (FIXNUM_TO_BIGNUM (d));
  442.     }
  443.   {
  444.     SCHEME_OBJECT result = (bignum_remainder (n, d));
  445.     return
  446.       ((result == SHARP_F)
  447.        ? SHARP_F
  448.        : (bignum_to_integer (result)));
  449.   }
  450. }
  451.  
  452. static unsigned long
  453. DEFUN (unsigned_long_length_in_bits, (n), unsigned long n)
  454. {
  455.   unsigned long result = 0;
  456.   while (n > 0)
  457.     {
  458.       result += 1;
  459.       n >>= 1;
  460.     }
  461.   return (result);
  462. }
  463.  
  464. SCHEME_OBJECT
  465. DEFUN (integer_length_in_bits, (n), SCHEME_OBJECT n)
  466. {
  467.   if (FIXNUM_P (n))
  468.     {
  469.       long n1 = (FIXNUM_TO_LONG (n));
  470.       return (LONG_TO_UNSIGNED_FIXNUM
  471.           (unsigned_long_length_in_bits ((n1 < 0) ? (- n1) : n1)));
  472.     }
  473.   else
  474.     return (bignum_to_integer (bignum_length_in_bits (n)));
  475. }
  476.  
  477. SCHEME_OBJECT
  478. DEFUN (integer_shift_left, (n, m), SCHEME_OBJECT n AND unsigned long m)
  479. {
  480.   if ((m == 0) || (!integer_positive_p (n)))
  481.     return (n);
  482.   if (FIXNUM_P (n))
  483.     {
  484.       unsigned long n1 = (UNSIGNED_FIXNUM_TO_LONG (n));
  485.       unsigned long ln = (unsigned_long_length_in_bits (n1));
  486.       unsigned long lr = (ln + m);
  487.       return
  488.     ((lr <= FIXNUM_LENGTH)
  489.      ? (LONG_TO_UNSIGNED_FIXNUM (n1 << m))
  490.      : (unsigned_long_to_shifted_bignum (n1, m, 0)));
  491.     }
  492.   else
  493.     return (bignum_shift_left (n, m));
  494. }
  495.