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 / fixnum.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  9KB  |  349 lines
  1. /* -*-C-*-
  2.  
  3. $Id: fixnum.c,v 9.44 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* Support for fixed point arithmetic.  This should be used instead of
  23.    generic arithmetic when it is desired to tell the compiler to perform
  24.    open coding of fixnum arithmetic.  It is probably a short-term kludge
  25.    that will eventually go away. */
  26.  
  27. #include "scheme.h"
  28. #include "prims.h"
  29.  
  30. static long
  31. DEFUN (arg_fixnum, (n), int n)
  32. {
  33.   fast SCHEME_OBJECT argument = (ARG_REF (n));
  34.   if (! (FIXNUM_P (argument)))
  35.     error_wrong_type_arg (n);
  36.   return (FIXNUM_TO_LONG (argument));
  37. }
  38.  
  39. static long
  40. DEFUN (arg_unsigned_fixnum, (n), int n)
  41. {
  42.   fast SCHEME_OBJECT argument = (ARG_REF (n));
  43.   if (! (FIXNUM_P (argument)))
  44.     error_wrong_type_arg (n);
  45.   return (UNSIGNED_FIXNUM_TO_LONG (argument));
  46. }
  47.  
  48. /* Predicates */
  49.  
  50. DEFINE_PRIMITIVE ("FIXNUM?", Prim_zero_fixnum_p, 1, 1, 0)
  51. {
  52.   PRIMITIVE_HEADER (1);
  53.   {
  54.     SCHEME_OBJECT argument = (ARG_REF (1));
  55.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FIXNUM_P (argument)));
  56.   }
  57. }
  58.  
  59. DEFINE_PRIMITIVE ("INDEX-FIXNUM?", Prim_index_fixnum_p, 1, 1, 0)
  60. {
  61.   PRIMITIVE_HEADER (1);
  62.   {
  63.     SCHEME_OBJECT argument = (ARG_REF (1));
  64.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FIXNUM_P (argument) &&
  65.                      FIXNUM_TO_LONG(argument) >= 0));
  66.   }
  67. }
  68.  
  69. DEFINE_PRIMITIVE ("ZERO-FIXNUM?", Prim_zero_fixnum, 1, 1, 0)
  70. {
  71.   PRIMITIVE_HEADER (1);
  72.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) == 0));
  73. }
  74.  
  75. DEFINE_PRIMITIVE ("NEGATIVE-FIXNUM?", Prim_negative_fixnum, 1, 1, 0)
  76. {
  77.   PRIMITIVE_HEADER (1);
  78.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) < 0));
  79. }
  80.  
  81. DEFINE_PRIMITIVE ("POSITIVE-FIXNUM?", Prim_positive_fixnum, 1, 1, 0)
  82. {
  83.   PRIMITIVE_HEADER (1);
  84.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) > 0));
  85. }
  86.  
  87. DEFINE_PRIMITIVE ("EQUAL-FIXNUM?", Prim_equal_fixnum, 2, 2, 0)
  88. {
  89.   PRIMITIVE_HEADER (2);
  90.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) == (arg_fixnum (2))));
  91. }
  92.  
  93. DEFINE_PRIMITIVE ("LESS-THAN-FIXNUM?", Prim_less_fixnum, 2, 2, 0)
  94. {
  95.   PRIMITIVE_HEADER (2);
  96.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) < (arg_fixnum (2))));
  97. }
  98.  
  99. DEFINE_PRIMITIVE ("GREATER-THAN-FIXNUM?", Prim_greater_fixnum, 2, 2, 0)
  100. {
  101.   PRIMITIVE_HEADER (2);
  102.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((arg_fixnum (1)) > (arg_fixnum (2))));
  103. }
  104.  
  105. /* Operators */
  106.  
  107. #define FIXNUM_RESULT(fixnum)                        \
  108. {                                    \
  109.   fast long result = (fixnum);                        \
  110.   if (! (LONG_TO_FIXNUM_P (result)))                    \
  111.     error_bad_range_arg (1);                        \
  112.   PRIMITIVE_RETURN (LONG_TO_FIXNUM (result));                \
  113. }
  114.  
  115. DEFINE_PRIMITIVE ("ONE-PLUS-FIXNUM", Prim_one_plus_fixnum, 1, 1, 0)
  116. {
  117.   PRIMITIVE_HEADER (1);
  118.   FIXNUM_RESULT ((arg_fixnum (1)) + 1);
  119. }
  120.  
  121. DEFINE_PRIMITIVE ("MINUS-ONE-PLUS-FIXNUM", Prim_m_1_plus_fixnum, 1, 1, 0)
  122. {
  123.   PRIMITIVE_HEADER (1);
  124.   FIXNUM_RESULT ((arg_fixnum (1)) - 1);
  125. }
  126.  
  127. DEFINE_PRIMITIVE ("PLUS-FIXNUM", Prim_plus_fixnum, 2, 2, 0)
  128. {
  129.   PRIMITIVE_HEADER (2);
  130.   FIXNUM_RESULT ((arg_fixnum (1)) + (arg_fixnum (2)));
  131. }
  132.  
  133. DEFINE_PRIMITIVE ("MINUS-FIXNUM", Prim_minus_fixnum, 2, 2, 0)
  134. {
  135.   PRIMITIVE_HEADER (2);
  136.   FIXNUM_RESULT ((arg_fixnum (1)) - (arg_fixnum (2)));
  137. }
  138.  
  139. DEFINE_PRIMITIVE ("FIXNUM-NEGATE", Prim_fixnum_negate, 1, 1, 0)
  140. {
  141.   PRIMITIVE_HEADER (1);
  142.   FIXNUM_RESULT (- (arg_fixnum (1)));
  143. }
  144.  
  145. /* Fixnum multiplication routine with overflow detection. */
  146. #include "mul.c"
  147.  
  148. DEFINE_PRIMITIVE ("MULTIPLY-FIXNUM", Prim_multiply_fixnum, 2, 2, 0)
  149. {
  150.   PRIMITIVE_HEADER (2);
  151.   CHECK_ARG (1, FIXNUM_P);
  152.   CHECK_ARG (2, FIXNUM_P);
  153.   {
  154.     fast long result = (Mul ((ARG_REF (1)), (ARG_REF (2))));
  155.     if (result == SHARP_F)
  156.       error_bad_range_arg (1);
  157.     PRIMITIVE_RETURN (result);
  158.   }
  159. }
  160.  
  161. DEFINE_PRIMITIVE ("DIVIDE-FIXNUM", Prim_divide_fixnum, 2, 2, 0)
  162. {
  163.   fast long numerator;
  164.   fast long denominator;
  165.   fast long quotient;
  166.   fast long remainder;
  167.   PRIMITIVE_HEADER (2);
  168.   numerator = (arg_fixnum (1));
  169.   denominator = (arg_fixnum (2));
  170.   if (denominator == 0)
  171.     error_bad_range_arg (2);
  172.   /* Now, unbelievable hair because C doesn't fully specify / and %
  173.      when their arguments are negative.  We must get consistent
  174.      answers for all valid arguments. */
  175.   if (numerator < 0)
  176.     {
  177.       numerator = (- numerator);
  178.       if (denominator < 0)
  179.     {
  180.       denominator = (- denominator);
  181.       quotient = (numerator / denominator);
  182.     }
  183.       else
  184.     quotient = (- (numerator / denominator));
  185.       remainder = (- (numerator % denominator));
  186.     }
  187.   else
  188.     {
  189.       if (denominator < 0)
  190.     {
  191.       denominator = (- denominator);
  192.       quotient = (- (numerator / denominator));
  193.     }
  194.       else
  195.     quotient = (numerator / denominator);
  196.       remainder = (numerator % denominator);
  197.     }
  198.   if (! (LONG_TO_FIXNUM_P (quotient)))
  199.     error_bad_range_arg (1);
  200.   PRIMITIVE_RETURN
  201.     (cons ((LONG_TO_FIXNUM (quotient)), (LONG_TO_FIXNUM (remainder))));
  202. }
  203.  
  204. DEFINE_PRIMITIVE ("FIXNUM-QUOTIENT", Prim_fixnum_quotient, 2, 2, 0)
  205. {
  206.   PRIMITIVE_HEADER (2);
  207.   {
  208.     fast long numerator = (arg_fixnum (1));
  209.     fast long denominator = (arg_fixnum (2));
  210.     fast long quotient =
  211.       ((denominator > 0)
  212.        ? ((numerator < 0)
  213.       ? (- ((- numerator) / denominator))
  214.       : (numerator / denominator))
  215.        : (denominator < 0)
  216.        ? ((numerator < 0)
  217.       ? ((- numerator) / (- denominator))
  218.       : (- (numerator / (- denominator))))
  219.        : (error_bad_range_arg (2), 0));
  220.     if (! (LONG_TO_FIXNUM_P (quotient)))
  221.       error_bad_range_arg (1);
  222.     PRIMITIVE_RETURN (LONG_TO_FIXNUM (quotient));
  223.   }
  224. }
  225.  
  226. DEFINE_PRIMITIVE ("FIXNUM-REMAINDER", Prim_fixnum_remainder, 2, 2, 0)
  227. {
  228.   PRIMITIVE_HEADER (2);
  229.   {
  230.     fast long numerator = (arg_fixnum (1));
  231.     fast long denominator = (arg_fixnum (2));
  232.     PRIMITIVE_RETURN
  233.       (LONG_TO_FIXNUM
  234.        ((denominator > 0)
  235.     ? ((numerator < 0)
  236.        ? (- ((- numerator) % denominator))
  237.        : (numerator % denominator))
  238.     : (denominator < 0)
  239.     ? ((numerator < 0)
  240.        ? (- ((- numerator) % (- denominator)))
  241.        : (numerator % (- denominator)))
  242.     : (error_bad_range_arg (2), 0)));
  243.   }
  244. }
  245.  
  246. DEFINE_PRIMITIVE ("GCD-FIXNUM", Prim_gcd_fixnum, 2, 2, 0)
  247. {
  248.   fast long x;
  249.   fast long y;
  250.   fast long z;
  251.   PRIMITIVE_HEADER (2);
  252.   x = (arg_fixnum (1));
  253.   y = (arg_fixnum (2));
  254.   if (x < 0) x = (-x);
  255.   if (y < 0) y = (-y);
  256.   while (y != 0)
  257.     {
  258.       z = x;
  259.       x = y;
  260.       y = (z % y);
  261.     }
  262.   PRIMITIVE_RETURN (LONG_TO_FIXNUM (x));
  263. }
  264.  
  265. /* Bitwise operations */
  266.  
  267. #define FIXNUM_BOOLEAN_BODY(operation)                    \
  268. do                                    \
  269. {                                    \
  270.   fast unsigned long x, y, z;                        \
  271.                                     \
  272.   PRIMITIVE_HEADER (2);                            \
  273.                                     \
  274.   x = (arg_unsigned_fixnum (1));                    \
  275.   y = (arg_unsigned_fixnum (2));                    \
  276.                                     \
  277.   z = (x operation y);                            \
  278.   return (LONG_TO_FIXNUM (z));                        \
  279. } while (0)
  280.  
  281.  
  282. DEFINE_PRIMITIVE ("FIXNUM-ANDC", Prim_fixnum_andc, 2, 2, 0)
  283. {
  284.   FIXNUM_BOOLEAN_BODY(& ~);
  285. }
  286.  
  287.  
  288. DEFINE_PRIMITIVE ("FIXNUM-AND", Prim_fixnum_and, 2, 2, 0)
  289. {
  290.   FIXNUM_BOOLEAN_BODY(&);
  291. }
  292.  
  293.  
  294. DEFINE_PRIMITIVE ("FIXNUM-OR", Prim_fixnum_or, 2, 2, 0)
  295. {
  296.   FIXNUM_BOOLEAN_BODY(|);
  297. }
  298.  
  299.  
  300. DEFINE_PRIMITIVE ("FIXNUM-XOR", Prim_fixnum_xor, 2, 2, 0)
  301. {
  302.   FIXNUM_BOOLEAN_BODY(^);
  303. }
  304.  
  305.  
  306. DEFINE_PRIMITIVE ("FIXNUM-NOT", Prim_fixnum_not, 1, 1, 0)
  307. {
  308.   fast unsigned long x, z;
  309.  
  310.   PRIMITIVE_HEADER (1);
  311.  
  312.   x = (arg_unsigned_fixnum (1));
  313.  
  314.   z = (~ (x));
  315.   return (LONG_TO_FIXNUM (z));
  316. }
  317.  
  318. DEFINE_PRIMITIVE ("FIXNUM-LSH", Prim_fixnum_lsh, 2, 2, 0)
  319. {
  320.   fast unsigned long x, z;
  321.   fast long y;
  322.  
  323.   PRIMITIVE_HEADER (2);
  324.  
  325.   x = (arg_unsigned_fixnum (1));
  326.   y = (arg_fixnum (2));
  327.  
  328.   if (y < 0)
  329.   {
  330.     z = ((y < (- FIXNUM_LENGTH)) ? 0 : (x >> (- y)));
  331.   }
  332.   else
  333.   {
  334.     z = ((y > FIXNUM_LENGTH) ? 0 : (x << y));
  335.   }
  336.   return (LONG_TO_FIXNUM (z));
  337. }
  338.  
  339.  
  340. DEFINE_PRIMITIVE ("FIXNUM->FLONUM", Prim_fixnum_to_flonum, 1, 1,
  341. "(FIXNUM)\n\
  342. Equivalent to (INTEGER->FLONUM FIXNUM 2)")
  343. {
  344.   PRIMITIVE_HEADER (1);
  345.   {
  346.     PRIMITIVE_RETURN (double_to_flonum ((double) (arg_fixnum (1))));
  347.   }
  348. }
  349.