/* -*-C-*-
$Id: intprm.c,v 1.9 1999/01/02 06:11:34 cph Exp $
Copyright (c) 1989-1999 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/* Generic Integer Primitives */
#include "scheme.h"
#include "prims.h"
#include "zones.h"
#define INTEGER_TEST(test) \
{ \
PRIMITIVE_HEADER (1); \
Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (test (ARG_REF (1)))); \
}
DEFINE_PRIMITIVE ("INTEGER-ZERO?", Prim_integer_zero_p, 1, 1, 0)
INTEGER_TEST (integer_zero_p)
DEFINE_PRIMITIVE ("INTEGER-NEGATIVE?", Prim_integer_negative_p, 1, 1, 0)
INTEGER_TEST (integer_negative_p)
DEFINE_PRIMITIVE ("INTEGER-POSITIVE?", Prim_integer_positive_p, 1, 1, 0)
INTEGER_TEST (integer_positive_p)
#define INTEGER_COMPARISON(comparison) \
{ \
PRIMITIVE_HEADER (2); \
Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
PRIMITIVE_RETURN \
(BOOLEAN_TO_OBJECT (comparison ((ARG_REF (1)), (ARG_REF (2))))); \
}
DEFINE_PRIMITIVE ("INTEGER-EQUAL?", Prim_integer_equal_p, 2, 2, 0)
INTEGER_COMPARISON (integer_equal_p)
DEFINE_PRIMITIVE ("INTEGER-LESS?", Prim_integer_less_p, 2, 2, 0)
INTEGER_COMPARISON (integer_less_p)
DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
CHECK_ARG (2, INTEGER_P);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (integer_less_p ((ARG_REF (2)), (ARG_REF (1)))));
}
#define INTEGER_BINARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (2); \
Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \
}
DEFINE_PRIMITIVE ("INTEGER-ADD", Prim_integer_add, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_add)
DEFINE_PRIMITIVE ("INTEGER-SUBTRACT", Prim_integer_subtract, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_subtract)
DEFINE_PRIMITIVE ("INTEGER-MULTIPLY", Prim_integer_multiply, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_multiply)
#define INTEGER_UNARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (1); \
Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
PRIMITIVE_RETURN (operator (ARG_REF (1))); \
}
DEFINE_PRIMITIVE ("INTEGER-NEGATE", Prim_integer_negate, 1, 1, 0)
INTEGER_UNARY_OPERATION (integer_negate)
DEFINE_PRIMITIVE ("INTEGER-ADD-1", Prim_integer_add_1, 1, 1, 0)
INTEGER_UNARY_OPERATION (integer_add_1)
DEFINE_PRIMITIVE ("INTEGER-SUBTRACT-1", Prim_integer_subtract_1, 1, 1, 0)
INTEGER_UNARY_OPERATION (integer_subtract_1)
DEFINE_PRIMITIVE ("INTEGER-LENGTH-IN-BITS", Prim_integer_length_in_bits, 1, 1, 0)
INTEGER_UNARY_OPERATION (integer_length_in_bits)
DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0)
{
SCHEME_OBJECT quotient;
SCHEME_OBJECT remainder;
PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
CHECK_ARG (2, INTEGER_P);
if (integer_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
error_bad_range_arg (2);
PRIMITIVE_RETURN (cons (quotient, remainder));
}
#define INTEGER_QR(operator) \
{ \
SCHEME_OBJECT result; \
PRIMITIVE_HEADER (2); \
Set_Time_Zone (Zone_Math); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
result = (operator ((ARG_REF (1)), (ARG_REF (2)))); \
if (result == SHARP_F) \
error_bad_range_arg (2); \
PRIMITIVE_RETURN (result); \
}
DEFINE_PRIMITIVE ("INTEGER-QUOTIENT", Prim_integer_quotient, 2, 2, 0)
INTEGER_QR (integer_quotient)
DEFINE_PRIMITIVE ("INTEGER-REMAINDER", Prim_integer_remainder, 2, 2, 0)
INTEGER_QR (integer_remainder)
DEFINE_PRIMITIVE ("INTEGER?", Prim_integer_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
fast SCHEME_OBJECT integer = (ARG_REF (1));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (INTEGER_P (integer)));
}
}
DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
{
fast SCHEME_OBJECT integer = (ARG_REF (1));
fast long control = (arg_index_integer (2, 4));
if (FIXNUM_P (integer))
{
long X = (FIXNUM_TO_LONG (integer));
double Y = ((double) X);
if (((long) Y) == X)
PRIMITIVE_RETURN (FIXNUM_TO_FLONUM (integer));
if ((control & 2) != 0)
error_bad_range_arg (1);
PRIMITIVE_RETURN (SHARP_F);
}
if (bignum_fits_in_word_p
(integer,
(((control & 1) != 0) ? DBL_MANT_DIG : DBL_MAX_EXP),
0))
PRIMITIVE_RETURN (BIGNUM_TO_FLONUM (integer));
if ((control & 2) != 0)
error_bad_range_arg (1);
PRIMITIVE_RETURN (SHARP_F);
}
}
DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
Set_Time_Zone (Zone_Math);
CHECK_ARG (1, INTEGER_P);
{
SCHEME_OBJECT n = (ARG_REF (1));
if (integer_negative_p (n))
error_bad_range_arg (1);
PRIMITIVE_RETURN (integer_shift_left (n, (arg_ulong_integer (2))));
}
}
static unsigned int
DEFUN (list_to_integer_producer, (context), PTR context)
{
SCHEME_OBJECT * digits = context;
unsigned int digit = (UNSIGNED_FIXNUM_TO_LONG (PAIR_CAR (*digits)));
(*digits) = (PAIR_CDR (*digits));
return (digit);
}
DEFINE_PRIMITIVE ("LIST->INTEGER", Prim_list_to_integer, 3, 3,
"(list radix negative?)\n\
LIST is a non-null list of digits in RADIX, most-significant first.\n\
Converts the list to an integer. NEGATIVE? specifies the sign.")
{
PRIMITIVE_HEADER (3);
Set_Time_Zone (Zone_Math);
CHECK_ARG (1, PAIR_P);
{
SCHEME_OBJECT digits = (ARG_REF (1));
unsigned long radix = (arg_ulong_integer (2));
unsigned int n_digits;
if ((radix < 2)
|| (radix >= ((unsigned long) (bignum_max_digit_stream_radix ()))))
error_bad_range_arg (2);
{
SCHEME_OBJECT scan = digits;
n_digits = 0;
while (1)
{
SCHEME_OBJECT digit = (PAIR_CAR (scan));
if (!UNSIGNED_FIXNUM_P (digit))
error_wrong_type_arg (1);
if (((unsigned long) (UNSIGNED_FIXNUM_TO_LONG (digit))) >= radix)
error_bad_range_arg (1);
n_digits += 1;
scan = (PAIR_CDR (scan));
if (scan == EMPTY_LIST)
break;
if (!PAIR_P (scan))
error_wrong_type_arg (1);
}
}
PRIMITIVE_RETURN
(bignum_to_integer
(digit_stream_to_bignum (n_digits,
list_to_integer_producer,
(&digits),
radix,
(OBJECT_TO_BOOLEAN (ARG_REF (3))))));
}
}
syntax highlighted by Code2HTML, v. 0.9.1