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 / bigprm.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  6KB  |  174 lines
  1. /* -*-C-*-
  2.  
  3. $Id: bigprm.c,v 1.6 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. /* Bignum Primitives */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "zones.h"
  27.  
  28. #define BIGNUM_TEST(predicate)                        \
  29. {                                    \
  30.   PRIMITIVE_HEADER (1);                            \
  31.   Set_Time_Zone (Zone_Math);                        \
  32.   CHECK_ARG (1, BIGNUM_P);                        \
  33.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (predicate (ARG_REF (1))));    \
  34. }
  35.  
  36. DEFINE_PRIMITIVE ("BIGNUM-ZERO?", Prim_bignum_zero_p, 1, 1, 0)
  37.      BIGNUM_TEST (BIGNUM_ZERO_P)
  38. DEFINE_PRIMITIVE ("BIGNUM-NEGATIVE?", Prim_bignum_negative_p, 1, 1, 0)
  39.      BIGNUM_TEST (BIGNUM_NEGATIVE_P)
  40. DEFINE_PRIMITIVE ("BIGNUM-POSITIVE?", Prim_bignum_positive_p, 1, 1, 0)
  41.      BIGNUM_TEST (BIGNUM_POSITIVE_P)
  42.  
  43. #define BIGNUM_COMPARISON(predicate)                    \
  44. {                                    \
  45.   PRIMITIVE_HEADER (2);                            \
  46.   Set_Time_Zone (Zone_Math);                        \
  47.   CHECK_ARG (1, BIGNUM_P);                        \
  48.   CHECK_ARG (2, BIGNUM_P);                        \
  49.   PRIMITIVE_RETURN                            \
  50.     (BOOLEAN_TO_OBJECT (predicate ((ARG_REF (1)), (ARG_REF (2)))));    \
  51. }
  52.  
  53. DEFINE_PRIMITIVE ("BIGNUM-EQUAL?", Prim_bignum_equal_p, 2, 2, 0)
  54.      BIGNUM_COMPARISON (bignum_equal_p)
  55. DEFINE_PRIMITIVE ("BIGNUM-LESS?", Prim_bignum_less_p, 2, 2, 0)
  56.      BIGNUM_COMPARISON (BIGNUM_LESS_P)
  57.  
  58. #define BIGNUM_BINARY(operator)                        \
  59. {                                    \
  60.   PRIMITIVE_HEADER (2);                            \
  61.   Set_Time_Zone (Zone_Math);                        \
  62.   CHECK_ARG (1, BIGNUM_P);                        \
  63.   CHECK_ARG (2, BIGNUM_P);                        \
  64.   PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2))));        \
  65. }
  66.  
  67. DEFINE_PRIMITIVE ("BIGNUM-ADD", Prim_bignum_add, 2, 2, 0)
  68.      BIGNUM_BINARY (bignum_add)
  69. DEFINE_PRIMITIVE ("BIGNUM-SUBTRACT", Prim_bignum_subtract, 2, 2, 0)
  70.      BIGNUM_BINARY (bignum_subtract)
  71. DEFINE_PRIMITIVE ("BIGNUM-MULTIPLY", Prim_bignum_multiply, 2, 2, 0)
  72.      BIGNUM_BINARY (bignum_multiply)
  73.  
  74. DEFINE_PRIMITIVE ("BIGNUM-DIVIDE", Prim_bignum_divide, 2, 2, 0)
  75. {
  76.   SCHEME_OBJECT quotient;
  77.   SCHEME_OBJECT remainder;
  78.   PRIMITIVE_HEADER (2);
  79.   Set_Time_Zone (Zone_Math);
  80.   CHECK_ARG (1, BIGNUM_P);
  81.   CHECK_ARG (2, BIGNUM_P);
  82.   if (bignum_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
  83.     error_bad_range_arg (2);
  84.   PRIMITIVE_RETURN (cons (quotient, remainder));
  85. }
  86.  
  87. #define BIGNUM_QR(operator)                        \
  88. {                                    \
  89.   SCHEME_OBJECT result;                            \
  90.   PRIMITIVE_HEADER (2);                            \
  91.   Set_Time_Zone (Zone_Math);                        \
  92.   CHECK_ARG (1, BIGNUM_P);                        \
  93.   CHECK_ARG (2, BIGNUM_P);                        \
  94.   result = (operator ((ARG_REF (1)), (ARG_REF (2))));            \
  95.   if (result == SHARP_F)                        \
  96.     error_bad_range_arg (2);                        \
  97.   PRIMITIVE_RETURN (result);                        \
  98. }
  99.  
  100. DEFINE_PRIMITIVE ("BIGNUM-QUOTIENT", Prim_bignum_quotient, 2, 2, 0)
  101.      BIGNUM_QR (bignum_quotient)
  102. DEFINE_PRIMITIVE ("BIGNUM-REMAINDER", Prim_bignum_remainder, 2, 2, 0)
  103.      BIGNUM_QR (bignum_remainder)
  104.  
  105. static void
  106. DEFUN (listify_bignum_consumer, (previous_cdr, digit),
  107.        PTR previous_cdr AND
  108.        long digit)
  109. {
  110.   (* ((SCHEME_OBJECT *) previous_cdr)) =
  111.     (cons ((LONG_TO_UNSIGNED_FIXNUM (digit)),
  112.        (* ((SCHEME_OBJECT *) previous_cdr))));
  113. }
  114.  
  115. DEFINE_PRIMITIVE ("LISTIFY-BIGNUM", Prim_listify_bignum, 2, 2,
  116.   "Returns a list of the digits of BIGNUM in RADIX.")
  117. {
  118.   PRIMITIVE_HEADER (2);
  119.   Set_Time_Zone (Zone_Math);
  120.   CHECK_ARG (1, BIGNUM_P);
  121.   {
  122.     SCHEME_OBJECT bignum = (ARG_REF (1));
  123.     long radix =
  124.       (arg_integer_in_range (2, 2, (bignum_max_digit_stream_radix ())));
  125.     if (BIGNUM_ZERO_P (bignum))
  126.       PRIMITIVE_RETURN (cons ((LONG_TO_UNSIGNED_FIXNUM (0)), EMPTY_LIST));
  127.     {
  128.       SCHEME_OBJECT previous_cdr = EMPTY_LIST;
  129.       bignum_to_digit_stream
  130.     (bignum, radix, listify_bignum_consumer, (&previous_cdr));
  131.       PRIMITIVE_RETURN (previous_cdr);
  132.     }
  133.   }
  134. }
  135.  
  136. DEFINE_PRIMITIVE ("FIXNUM->BIGNUM", Prim_fixnum_to_bignum, 1, 1, 0)
  137. {
  138.   PRIMITIVE_HEADER (1);
  139.   Set_Time_Zone (Zone_Math);
  140.   CHECK_ARG (1, FIXNUM_P);
  141.   PRIMITIVE_RETURN (FIXNUM_TO_BIGNUM (ARG_REF (1)));
  142. }
  143.  
  144. DEFINE_PRIMITIVE ("BIGNUM->FIXNUM", Prim_bignum_to_fixnum, 1, 1, 0)
  145. {
  146.   PRIMITIVE_HEADER (1);
  147.   Set_Time_Zone (Zone_Math);
  148.   CHECK_ARG (1, BIGNUM_P);
  149.   PRIMITIVE_RETURN (bignum_to_fixnum (ARG_REF (1)));
  150. }
  151.  
  152. DEFINE_PRIMITIVE ("FLONUM->BIGNUM", Prim_flonum_to_bignum, 1, 1, 0)
  153. {
  154.   PRIMITIVE_HEADER (1);
  155.   Set_Time_Zone (Zone_Math);
  156.   CHECK_ARG (1, FLONUM_P);
  157.   PRIMITIVE_RETURN (FLONUM_TO_BIGNUM (ARG_REF (1)));
  158. }
  159.  
  160. DEFINE_PRIMITIVE ("BIGNUM->FLONUM", Prim_bignum_to_flonum, 1, 1, 0)
  161. {
  162.   PRIMITIVE_HEADER (1);
  163.   Set_Time_Zone (Zone_Math);
  164.   CHECK_ARG (1, BIGNUM_P);
  165.   PRIMITIVE_RETURN (bignum_to_flonum (ARG_REF (1)));
  166. }
  167.  
  168. DEFINE_PRIMITIVE ("BIGNUM-LENGTH-IN-BITS", Prim_bignum_length_in_bits, 1, 1, 0)
  169. {
  170.   PRIMITIVE_HEADER (1);
  171.   CHECK_ARG (1, BIGNUM_P);
  172.   PRIMITIVE_RETURN (bignum_length_in_bits (ARG_REF (1)));
  173. }
  174.