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 / intprm.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  8KB  |  235 lines
  1. /* -*-C-*-
  2.  
  3. $Id: intprm.c,v 1.9 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. /* Generic Integer Primitives */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "zones.h"
  27.  
  28. #define INTEGER_TEST(test)                        \
  29. {                                    \
  30.   PRIMITIVE_HEADER (1);                            \
  31.   Set_Time_Zone (Zone_Math);                        \
  32.   CHECK_ARG (1, INTEGER_P);                        \
  33.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (test (ARG_REF (1))));        \
  34. }
  35.  
  36. DEFINE_PRIMITIVE ("INTEGER-ZERO?", Prim_integer_zero_p, 1, 1, 0)
  37.      INTEGER_TEST (integer_zero_p)
  38. DEFINE_PRIMITIVE ("INTEGER-NEGATIVE?", Prim_integer_negative_p, 1, 1, 0)
  39.      INTEGER_TEST (integer_negative_p)
  40. DEFINE_PRIMITIVE ("INTEGER-POSITIVE?", Prim_integer_positive_p, 1, 1, 0)
  41.      INTEGER_TEST (integer_positive_p)
  42.  
  43. #define INTEGER_COMPARISON(comparison)                    \
  44. {                                    \
  45.   PRIMITIVE_HEADER (2);                            \
  46.   Set_Time_Zone (Zone_Math);                        \
  47.   CHECK_ARG (1, INTEGER_P);                        \
  48.   CHECK_ARG (2, INTEGER_P);                        \
  49.   PRIMITIVE_RETURN                            \
  50.     (BOOLEAN_TO_OBJECT (comparison ((ARG_REF (1)), (ARG_REF (2)))));    \
  51. }
  52.  
  53. DEFINE_PRIMITIVE ("INTEGER-EQUAL?", Prim_integer_equal_p, 2, 2, 0)
  54.      INTEGER_COMPARISON (integer_equal_p)
  55. DEFINE_PRIMITIVE ("INTEGER-LESS?", Prim_integer_less_p, 2, 2, 0)
  56.      INTEGER_COMPARISON (integer_less_p)
  57.  
  58. DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0)
  59. {
  60.   PRIMITIVE_HEADER (2);
  61.   Set_Time_Zone (Zone_Math);
  62.   CHECK_ARG (1, INTEGER_P);
  63.   CHECK_ARG (2, INTEGER_P);
  64.   PRIMITIVE_RETURN
  65.     (BOOLEAN_TO_OBJECT (integer_less_p ((ARG_REF (2)), (ARG_REF (1)))));
  66. }
  67.  
  68. #define INTEGER_BINARY_OPERATION(operator)                \
  69. {                                    \
  70.   PRIMITIVE_HEADER (2);                            \
  71.   Set_Time_Zone (Zone_Math);                        \
  72.   CHECK_ARG (1, INTEGER_P);                        \
  73.   CHECK_ARG (2, INTEGER_P);                        \
  74.   PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2))));        \
  75. }
  76.  
  77. DEFINE_PRIMITIVE ("INTEGER-ADD", Prim_integer_add, 2, 2, 0)
  78.      INTEGER_BINARY_OPERATION (integer_add)
  79. DEFINE_PRIMITIVE ("INTEGER-SUBTRACT", Prim_integer_subtract, 2, 2, 0)
  80.      INTEGER_BINARY_OPERATION (integer_subtract)
  81. DEFINE_PRIMITIVE ("INTEGER-MULTIPLY", Prim_integer_multiply, 2, 2, 0)
  82.      INTEGER_BINARY_OPERATION (integer_multiply)
  83.  
  84. #define INTEGER_UNARY_OPERATION(operator)                \
  85. {                                    \
  86.   PRIMITIVE_HEADER (1);                            \
  87.   Set_Time_Zone (Zone_Math);                        \
  88.   CHECK_ARG (1, INTEGER_P);                        \
  89.   PRIMITIVE_RETURN (operator (ARG_REF (1)));                \
  90. }
  91.  
  92. DEFINE_PRIMITIVE ("INTEGER-NEGATE", Prim_integer_negate, 1, 1, 0)
  93.      INTEGER_UNARY_OPERATION (integer_negate)
  94. DEFINE_PRIMITIVE ("INTEGER-ADD-1", Prim_integer_add_1, 1, 1, 0)
  95.      INTEGER_UNARY_OPERATION (integer_add_1)
  96. DEFINE_PRIMITIVE ("INTEGER-SUBTRACT-1", Prim_integer_subtract_1, 1, 1, 0)
  97.      INTEGER_UNARY_OPERATION (integer_subtract_1)
  98. DEFINE_PRIMITIVE ("INTEGER-LENGTH-IN-BITS", Prim_integer_length_in_bits, 1, 1, 0)
  99.      INTEGER_UNARY_OPERATION (integer_length_in_bits)
  100.  
  101. DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0)
  102. {
  103.   SCHEME_OBJECT quotient;
  104.   SCHEME_OBJECT remainder;
  105.   PRIMITIVE_HEADER (2);
  106.   Set_Time_Zone (Zone_Math);
  107.   CHECK_ARG (1, INTEGER_P);
  108.   CHECK_ARG (2, INTEGER_P);
  109.   if (integer_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
  110.     error_bad_range_arg (2);
  111.   PRIMITIVE_RETURN (cons (quotient, remainder));
  112. }
  113.  
  114. #define INTEGER_QR(operator)                        \
  115. {                                    \
  116.   SCHEME_OBJECT result;                            \
  117.   PRIMITIVE_HEADER (2);                            \
  118.   Set_Time_Zone (Zone_Math);                        \
  119.   CHECK_ARG (1, INTEGER_P);                        \
  120.   CHECK_ARG (2, INTEGER_P);                        \
  121.   result = (operator ((ARG_REF (1)), (ARG_REF (2))));            \
  122.   if (result == SHARP_F)                        \
  123.     error_bad_range_arg (2);                        \
  124.   PRIMITIVE_RETURN (result);                        \
  125. }
  126.  
  127. DEFINE_PRIMITIVE ("INTEGER-QUOTIENT", Prim_integer_quotient, 2, 2, 0)
  128.      INTEGER_QR (integer_quotient)
  129. DEFINE_PRIMITIVE ("INTEGER-REMAINDER", Prim_integer_remainder, 2, 2, 0)
  130.      INTEGER_QR (integer_remainder)
  131.  
  132. DEFINE_PRIMITIVE ("INTEGER?", Prim_integer_p, 1, 1, 0)
  133. {
  134.   PRIMITIVE_HEADER (1);
  135.   {
  136.     fast SCHEME_OBJECT integer = (ARG_REF (1));
  137.     PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (INTEGER_P (integer)));
  138.   }
  139. }
  140.  
  141. DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0)
  142. {
  143.   PRIMITIVE_HEADER (2);
  144.   Set_Time_Zone (Zone_Math);
  145.   CHECK_ARG (1, INTEGER_P);
  146.   {
  147.     fast SCHEME_OBJECT integer = (ARG_REF (1));
  148.     fast long control = (arg_index_integer (2, 4));
  149.     if (FIXNUM_P (integer))
  150.     {
  151.       long X = (FIXNUM_TO_LONG (integer));
  152.       double Y = ((double) X);
  153.  
  154.       if (((long) Y) == X)
  155.     PRIMITIVE_RETURN (FIXNUM_TO_FLONUM (integer));
  156.       if ((control & 2) != 0)
  157.     error_bad_range_arg (1);
  158.       PRIMITIVE_RETURN (SHARP_F);
  159.     }
  160.     if (bignum_fits_in_word_p
  161.     (integer,
  162.      (((control & 1) != 0) ? DBL_MANT_DIG : DBL_MAX_EXP),
  163.      0))
  164.       PRIMITIVE_RETURN (BIGNUM_TO_FLONUM (integer));
  165.     if ((control & 2) != 0)
  166.       error_bad_range_arg (1);
  167.     PRIMITIVE_RETURN (SHARP_F);
  168.   }
  169. }
  170.  
  171. DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
  172. {
  173.   PRIMITIVE_HEADER (2);
  174.   Set_Time_Zone (Zone_Math);
  175.   CHECK_ARG (1, INTEGER_P);
  176.   {
  177.     SCHEME_OBJECT n = (ARG_REF (1));
  178.     if (integer_negative_p (n))
  179.       error_bad_range_arg (1);
  180.     PRIMITIVE_RETURN (integer_shift_left (n, (arg_ulong_integer (2))));
  181.   }
  182. }
  183.  
  184. static unsigned int
  185. DEFUN (list_to_integer_producer, (context), PTR context)
  186. {
  187.   SCHEME_OBJECT * digits = context;
  188.   unsigned int digit = (UNSIGNED_FIXNUM_TO_LONG (PAIR_CAR (*digits)));
  189.   (*digits) = (PAIR_CDR (*digits));
  190.   return (digit);
  191. }
  192.  
  193. DEFINE_PRIMITIVE ("LIST->INTEGER", Prim_list_to_integer, 3, 3,
  194.   "(list radix negative?)\n\
  195. LIST is a non-null list of digits in RADIX, most-significant first.\n\
  196. Converts the list to an integer.  NEGATIVE? specifies the sign.")
  197. {
  198.   PRIMITIVE_HEADER (3);
  199.   Set_Time_Zone (Zone_Math);
  200.   CHECK_ARG (1, PAIR_P);
  201.   {
  202.     SCHEME_OBJECT digits = (ARG_REF (1));
  203.     unsigned long radix = (arg_ulong_integer (2));
  204.     unsigned int n_digits;
  205.     if ((radix < 2)
  206.     || (radix >= ((unsigned long) (bignum_max_digit_stream_radix ()))))
  207.       error_bad_range_arg (2);
  208.     {
  209.       SCHEME_OBJECT scan = digits;
  210.       n_digits = 0;
  211.       while (1)
  212.     {
  213.       SCHEME_OBJECT digit = (PAIR_CAR (scan));
  214.       if (!UNSIGNED_FIXNUM_P (digit))
  215.         error_wrong_type_arg (1);
  216.       if (((unsigned long) (UNSIGNED_FIXNUM_TO_LONG (digit))) >= radix)
  217.         error_bad_range_arg (1);
  218.       n_digits += 1;
  219.       scan = (PAIR_CDR (scan));
  220.       if (scan == EMPTY_LIST)
  221.         break;
  222.       if (!PAIR_P (scan))
  223.         error_wrong_type_arg (1);
  224.     }
  225.     }
  226.     PRIMITIVE_RETURN
  227.       (bignum_to_integer
  228.        (digit_stream_to_bignum (n_digits,
  229.                 list_to_integer_producer,
  230.                 (&digits),
  231.                 radix,
  232.                 (OBJECT_TO_BOOLEAN (ARG_REF (3))))));
  233.   }
  234. }
  235.