Back to index

plt-scheme  4.2.1
number.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include "nummacs.h"
00028 #include <math.h>
00029 #include <string.h>
00030 #include <ctype.h>
00031 #ifndef DONT_IGNORE_FPE_SIGNAL
00032 #include <signal.h>
00033 #endif
00034 #ifdef IGNORE_BY_BORLAND_CONTROL_87
00035 #include <float.h>
00036 #endif
00037 #ifdef IGNORE_BY_MS_CONTROL_87
00038 #include <float.h>
00039 #endif
00040 
00041 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
00042 # ifndef MZ_USE_SINGLE_FLOATS
00043 #  undef USE_SINGLE_FLOATS_AS_DEFAULT
00044 # endif
00045 #endif
00046 
00047 #ifdef SIXTY_FOUR_BIT_INTEGERS
00048 # define MAX_SHIFT_TRY 61
00049 # define MAX_SHIFT_EVER 64
00050 #else
00051 # define MAX_SHIFT_TRY 29
00052 # define MAX_SHIFT_EVER 32
00053 #endif
00054 
00055 /* globals */
00056 double scheme_infinity_val, scheme_minus_infinity_val;
00057 
00058 /* locals */
00059 static Scheme_Object *number_p (int argc, Scheme_Object *argv[]);
00060 static Scheme_Object *complex_p (int argc, Scheme_Object *argv[]);
00061 static Scheme_Object *real_p (int argc, Scheme_Object *argv[]);
00062 static Scheme_Object *rational_p (int argc, Scheme_Object *argv[]);
00063 static Scheme_Object *integer_p (int argc, Scheme_Object *argv[]);
00064 static Scheme_Object *exact_integer_p (int argc, Scheme_Object *argv[]);
00065 static Scheme_Object *exact_nonnegative_integer_p (int argc, Scheme_Object *argv[]);
00066 static Scheme_Object *exact_positive_integer_p (int argc, Scheme_Object *argv[]);
00067 static Scheme_Object *fixnum_p (int argc, Scheme_Object *argv[]);
00068 static Scheme_Object *inexact_real_p (int argc, Scheme_Object *argv[]);
00069 static Scheme_Object *exact_p (int argc, Scheme_Object *argv[]);
00070 static Scheme_Object *even_p (int argc, Scheme_Object *argv[]);
00071 static Scheme_Object *bitwise_or (int argc, Scheme_Object *argv[]);
00072 static Scheme_Object *bitwise_xor (int argc, Scheme_Object *argv[]);
00073 static Scheme_Object *bitwise_not (int argc, Scheme_Object *argv[]);
00074 static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[]);
00075 static Scheme_Object *bitwise_bit_field (int argc, Scheme_Object *argv[]);
00076 static Scheme_Object *integer_length (int argc, Scheme_Object *argv[]);
00077 static Scheme_Object *gcd (int argc, Scheme_Object *argv[]);
00078 static Scheme_Object *lcm (int argc, Scheme_Object *argv[]);
00079 static Scheme_Object *floor_prim (int argc, Scheme_Object *argv[]);
00080 static Scheme_Object *ceiling (int argc, Scheme_Object *argv[]);
00081 static Scheme_Object *sch_truncate (int argc, Scheme_Object *argv[]);
00082 static Scheme_Object *sch_round (int argc, Scheme_Object *argv[]);
00083 static Scheme_Object *numerator (int argc, Scheme_Object *argv[]);
00084 static Scheme_Object *denominator (int argc, Scheme_Object *argv[]);
00085 static Scheme_Object *exp_prim (int argc, Scheme_Object *argv[]);
00086 static Scheme_Object *log_prim (int argc, Scheme_Object *argv[]);
00087 static Scheme_Object *sin_prim (int argc, Scheme_Object *argv[]);
00088 static Scheme_Object *cos_prim (int argc, Scheme_Object *argv[]);
00089 static Scheme_Object *tan_prim (int argc, Scheme_Object *argv[]);
00090 static Scheme_Object *asin_prim (int argc, Scheme_Object *argv[]);
00091 static Scheme_Object *acos_prim (int argc, Scheme_Object *argv[]);
00092 static Scheme_Object *atan_prim (int argc, Scheme_Object *argv[]);
00093 static Scheme_Object *make_rectangular (int argc, Scheme_Object *argv[]);
00094 static Scheme_Object *real_part (int argc, Scheme_Object *argv[]);
00095 static Scheme_Object *imag_part (int argc, Scheme_Object *argv[]);
00096 static Scheme_Object *magnitude (int argc, Scheme_Object *argv[]);
00097 static Scheme_Object *angle (int argc, Scheme_Object *argv[]);
00098 static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]);
00099 static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]);
00100 
00101 static double not_a_number_val;
00102 
00103 Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
00104 
00105 #define zeroi scheme_exact_zero
00106 
00107 Scheme_Object *scheme_zerod, *scheme_nzerod, *scheme_pi, *scheme_half_pi, *scheme_plus_i, *scheme_minus_i;
00108 #ifdef MZ_USE_SINGLE_FLOATS
00109 Scheme_Object *scheme_zerof, *scheme_nzerof, *scheme_single_pi;
00110 Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_object, *scheme_single_nan_object;
00111 #endif
00112 
00113 double scheme_floating_point_zero = 0.0;
00114 double scheme_floating_point_nzero = 0.0; /* negated below; many compilers treat -0.0 as 0.0, 
00115                                         but otherwise correctly implement fp negation */
00116 
00117 #ifdef FREEBSD_CONTROL_387
00118 #include <machine/floatingpoint.h>
00119 #endif
00120 #ifdef LINUX_CONTROL_387
00121 #include <fpu_control.h>
00122 #endif
00123 #ifdef ALPHA_CONTROL_FP
00124 #include <machine/fpu.h>
00125 #endif
00126 
00127 void
00128 scheme_init_number (Scheme_Env *env)
00129 {
00130   Scheme_Object *p;
00131 
00132   REGISTER_SO(scheme_pi);
00133   REGISTER_SO(scheme_half_pi);
00134   REGISTER_SO(scheme_zerod);
00135   REGISTER_SO(scheme_nzerod);
00136 #ifdef MZ_USE_SINGLE_FLOATS
00137   REGISTER_SO(scheme_single_pi);
00138   REGISTER_SO(scheme_zerof);
00139   REGISTER_SO(scheme_nzerof);
00140 #endif
00141   REGISTER_SO(scheme_plus_i);
00142   REGISTER_SO(scheme_minus_i);
00143   REGISTER_SO(scheme_inf_object);
00144   REGISTER_SO(scheme_minus_inf_object);
00145   REGISTER_SO(scheme_nan_object);
00146 #ifdef MZ_USE_SINGLE_FLOATS
00147   REGISTER_SO(scheme_single_inf_object);
00148   REGISTER_SO(scheme_single_minus_inf_object);
00149   REGISTER_SO(scheme_single_nan_object);
00150 #endif
00151     
00152   START_XFORM_SKIP;
00153 #ifndef DONT_IGNORE_FPE_SIGNAL
00154   MZ_SIGSET(SIGFPE, SIG_IGN);
00155 #endif
00156 #ifdef FREEBSD_CONTROL_387
00157   __fpsetreg(FP_MSKS_FLD, FP_MSKS_REG, FP_MSKS_FLD, FP_MSKS_OFF);
00158 #endif
00159 #ifdef LINUX_CONTROL_387
00160   __setfpucw(_FPU_EXTENDED + _FPU_RC_NEAREST + 0x3F);
00161 #endif
00162 #ifdef IGNORE_BY_BORLAND_CONTROL_87
00163   {
00164     int bits = 0x3F + RC_NEAR + PC_64;
00165     _control87(bits, 0xFFFF);
00166   }
00167 #endif
00168 #ifdef IGNORE_BY_MS_CONTROL_87
00169   /* Shouldn't be necessary, because the C library
00170      should do this, but explictly masking exceptions
00171      makes MzScheme work under Bochs 2.1.1 with Win95 */
00172   _control87(_MCW_EM, _MCW_EM);
00173 #endif
00174 #ifdef ALPHA_CONTROL_FP
00175   {
00176     long flags = ieee_get_fp_control();
00177     flags |= IEEE_TRAP_ENABLE_MASK;
00178     ieee_set_fp_control(flags);
00179   }
00180 #endif
00181 #ifdef ASM_DBLPREC_CONTROL_87
00182   {
00183     /* Make x87 computations double-precision instead of 
00184        extended-precision, so that if/when the JIT generates
00185        x87 instructions, it's consistent with everything else. */
00186     int _dblprec = 0x27F;
00187     asm ("fldcw %0" : : "m" (_dblprec));
00188   }
00189 #endif
00190   END_XFORM_SKIP;
00191 
00192 #if defined(HUGE_VAL) && !defined(USE_DIVIDE_MAKE_INFINITY)
00193   scheme_infinity_val = HUGE_VAL;
00194 #else
00195 #ifndef USE_INFINITY_FUNC
00196   scheme_infinity_val = 1.0 / scheme_floating_point_zero;
00197 #else
00198   scheme_infinity_val = infinity();
00199 #endif
00200 #endif
00201 
00202 #ifdef ZERO_MINUS_ZERO_IS_POS_ZERO
00203   scheme_floating_point_nzero = -1.0 / scheme_infinity_val;
00204 #else
00205   scheme_floating_point_nzero = - scheme_floating_point_nzero;
00206 #endif
00207 
00208   scheme_minus_infinity_val = -scheme_infinity_val;
00209   not_a_number_val = scheme_infinity_val + scheme_minus_infinity_val;
00210   
00211   scheme_zerod = scheme_make_double(1.0);
00212   SCHEME_DBL_VAL(scheme_zerod) = 0.0;
00213   scheme_nzerod = scheme_make_double(-1.0);
00214   SCHEME_DBL_VAL(scheme_nzerod) = scheme_floating_point_nzero;
00215   
00216   scheme_pi = scheme_make_double(atan2(0.0, -1.0));
00217   scheme_half_pi = scheme_make_double(atan2(0.0, -1.0)/2);
00218 #ifdef MZ_USE_SINGLE_FLOATS
00219   scheme_zerof = scheme_make_float(0.0f);
00220   scheme_nzerof = scheme_make_float(-0.0f);
00221   scheme_single_pi = scheme_make_float((float)atan2(0.0, -1.0));
00222 #endif
00223   scheme_plus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(1));
00224   scheme_minus_i = scheme_make_complex(scheme_make_integer(0), scheme_make_integer(-1));
00225   
00226   scheme_inf_object = scheme_make_double(scheme_infinity_val);
00227   scheme_minus_inf_object = scheme_make_double(scheme_minus_infinity_val);
00228 #ifdef NAN_EQUALS_ANYTHING
00229   scheme_nan_object = scheme_make_double(1);
00230   SCHEME_DBL_VAL(scheme_nan_object) = not_a_number_val;
00231 #else
00232   scheme_nan_object = scheme_make_double(not_a_number_val);
00233 #endif
00234 #ifdef MZ_USE_SINGLE_FLOATS
00235   scheme_single_inf_object = scheme_make_float((float)scheme_infinity_val);
00236   scheme_single_minus_inf_object = scheme_make_float((float)scheme_minus_infinity_val);
00237   scheme_single_nan_object = scheme_make_float((float)not_a_number_val);
00238 #endif
00239 
00240   p = scheme_make_folding_prim(number_p, "number?", 1, 1, 1);
00241   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00242   scheme_add_global_constant("number?", p, env);
00243 
00244   scheme_add_global_constant("complex?", 
00245                           scheme_make_folding_prim(complex_p,
00246                                                 "complex?",
00247                                                 1, 1, 1),
00248                           env);
00249 
00250   p = scheme_make_folding_prim(real_p, "real?", 1, 1, 1);
00251   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00252   scheme_add_global_constant("real?", p, env);
00253 
00254   scheme_add_global_constant("rational?", 
00255                           scheme_make_folding_prim(rational_p,
00256                                                 "rational?",
00257                                                 1, 1, 1),
00258                           env);
00259   scheme_add_global_constant("integer?", 
00260                           scheme_make_folding_prim(integer_p,
00261                                                 "integer?",
00262                                                 1, 1, 1),
00263                           env);
00264 
00265   p = scheme_make_folding_prim(exact_integer_p, "exact-integer?", 1, 1, 1);
00266   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00267   scheme_add_global_constant("exact-integer?", p, env);
00268 
00269   p = scheme_make_folding_prim(exact_nonnegative_integer_p, "exact-nonnegative-integer?", 1, 1, 1);
00270   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00271   scheme_add_global_constant("exact-nonnegative-integer?", p, env);
00272 
00273   p = scheme_make_folding_prim(exact_positive_integer_p, "exact-positive-integer?", 1, 1, 1);
00274   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00275   scheme_add_global_constant("exact-positive-integer?", p, env);
00276 
00277   p = scheme_make_noncm_prim(fixnum_p, "fixnum?", 1, 1);
00278   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00279   scheme_add_global_constant("fixnum?", p, env);
00280 
00281   p = scheme_make_folding_prim(inexact_real_p, "inexact-real?", 1, 1, 1);
00282   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00283   scheme_add_global_constant("inexact-real?", p, env);
00284 
00285   scheme_add_global_constant("exact?", 
00286                           scheme_make_folding_prim(exact_p,
00287                                                 "exact?",
00288                                                 1, 1, 1),
00289                           env);
00290   scheme_add_global_constant("inexact?", 
00291                           scheme_make_folding_prim(scheme_inexact_p,
00292                                                 "inexact?",
00293                                                 1, 1, 1),
00294                           env);
00295   scheme_add_global_constant("odd?", 
00296                           scheme_make_folding_prim(scheme_odd_p,
00297                                                 "odd?",
00298                                                 1, 1, 1),
00299                           env);
00300   scheme_add_global_constant("even?", 
00301                           scheme_make_folding_prim(even_p,
00302                                                 "even?",
00303                                                 1, 1, 1),
00304                           env);
00305 
00306   p = scheme_make_folding_prim(scheme_bitwise_and, "bitwise-and", 0, -1, 1);
00307   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00308   scheme_add_global_constant("bitwise-and", p, env);
00309 
00310   p = scheme_make_folding_prim(bitwise_or, "bitwise-ior", 0, -1, 1);
00311   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00312   scheme_add_global_constant("bitwise-ior", p, env);
00313 
00314   p = scheme_make_folding_prim(bitwise_xor, "bitwise-xor", 0, -1, 1);
00315   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00316   scheme_add_global_constant("bitwise-xor", p, env);
00317 
00318   p = scheme_make_folding_prim(bitwise_not, "bitwise-not", 1, 1, 1);
00319   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00320   scheme_add_global_constant("bitwise-not", p, env);
00321 
00322   p = scheme_make_folding_prim(bitwise_bit_set_p, "bitwise-bit-set?", 2, 2, 1);
00323   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00324   scheme_add_global_constant("bitwise-bit-set?", p, env);
00325 
00326   scheme_add_global_constant("bitwise-bit-field",
00327                              scheme_make_folding_prim(bitwise_bit_field, 
00328                                                       "bitwise-bit-field",
00329                                                       3, 3, 1), 
00330                              env);
00331 
00332   p = scheme_make_folding_prim(scheme_bitwise_shift, "arithmetic-shift", 2, 2, 1);
00333   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00334   scheme_add_global_constant("arithmetic-shift", p, env);
00335 
00336   scheme_add_global_constant("integer-length",
00337                              scheme_make_folding_prim(integer_length, 
00338                                                       "integer-length", 
00339                                                       1, 1, 1), 
00340                              env);
00341 
00342   scheme_add_global_constant("gcd", 
00343                           scheme_make_folding_prim(gcd,
00344                                                 "gcd", 
00345                                                 0, -1, 1),
00346                           env);
00347   scheme_add_global_constant("lcm", 
00348                           scheme_make_folding_prim(lcm,
00349                                                 "lcm", 
00350                                                 0, -1, 1),
00351                           env);
00352   scheme_add_global_constant("floor", 
00353                           scheme_make_folding_prim(floor_prim,
00354                                                 "floor",
00355                                                 1, 1, 1),
00356                           env);
00357   scheme_add_global_constant("ceiling", 
00358                           scheme_make_folding_prim(ceiling,
00359                                                 "ceiling",
00360                                                 1, 1, 1),
00361                           env);
00362   scheme_add_global_constant("truncate", 
00363                           scheme_make_folding_prim(sch_truncate,
00364                                                 "truncate",
00365                                                 1, 1, 1),
00366                           env);
00367   scheme_add_global_constant("round", 
00368                           scheme_make_folding_prim(sch_round,
00369                                                 "round",
00370                                                 1, 1, 1),
00371                           env);
00372   scheme_add_global_constant("numerator", 
00373                           scheme_make_folding_prim(numerator,
00374                                                 "numerator",
00375                                                 1, 1, 1),
00376                           env);
00377   scheme_add_global_constant("denominator", 
00378                           scheme_make_folding_prim(denominator,
00379                                                 "denominator",
00380                                                 1, 1, 1),
00381                           env);
00382   scheme_add_global_constant("exp", 
00383                           scheme_make_folding_prim(exp_prim,
00384                                                 "exp",
00385                                                 1, 1, 1),
00386                           env);
00387   scheme_add_global_constant("log", 
00388                           scheme_make_folding_prim(log_prim,
00389                                                 "log",
00390                                                 1, 1, 1),
00391                           env);
00392   scheme_add_global_constant("sin", 
00393                           scheme_make_folding_prim(sin_prim,
00394                                                 "sin",
00395                                                 1, 1, 1),
00396                           env);
00397   scheme_add_global_constant("cos", 
00398                           scheme_make_folding_prim(cos_prim,
00399                                                 "cos",
00400                                                 1, 1, 1),
00401                           env);
00402   scheme_add_global_constant("tan", 
00403                           scheme_make_folding_prim(tan_prim,
00404                                                 "tan",
00405                                                 1, 1, 1),
00406                           env);
00407   scheme_add_global_constant("asin", 
00408                           scheme_make_folding_prim(asin_prim,
00409                                                 "asin",
00410                                                 1, 1, 1),
00411                           env);
00412   scheme_add_global_constant("acos", 
00413                           scheme_make_folding_prim(acos_prim,
00414                                                 "acos",
00415                                                 1, 1, 1),
00416                           env);
00417   scheme_add_global_constant("atan", 
00418                           scheme_make_folding_prim(atan_prim,
00419                                                 "atan",
00420                                                 1, 2, 1),
00421                           env);
00422   scheme_add_global_constant("sqrt", 
00423                           scheme_make_folding_prim(scheme_sqrt,
00424                                                 "sqrt",
00425                                                 1, 1, 1),
00426                           env);
00427   scheme_add_global_constant("integer-sqrt", 
00428                           scheme_make_folding_prim(int_sqrt,
00429                                                 "integer-sqrt",
00430                                                 1, 1, 1),
00431                           env);
00432   scheme_add_global_constant("integer-sqrt/remainder", 
00433                           scheme_make_prim_w_arity2(int_sqrt_rem,
00434                                                  "integer-sqrt/remainder",
00435                                                  1, 1,
00436                                                  2, 2),
00437                           env);
00438   scheme_add_global_constant("expt", 
00439                           scheme_make_folding_prim(scheme_expt,
00440                                                 "expt", 
00441                                                 2, 2, 1),
00442                           env);
00443   scheme_add_global_constant("make-rectangular", 
00444                           scheme_make_folding_prim(make_rectangular,
00445                                                 "make-rectangular", 
00446                                                 2, 2, 1),
00447                           env);
00448   scheme_add_global_constant("make-polar", 
00449                           scheme_make_folding_prim(scheme_make_polar,
00450                                                 "make-polar", 
00451                                                 2, 2, 1),
00452                           env);
00453   scheme_add_global_constant("real-part", 
00454                           scheme_make_folding_prim(real_part,
00455                                                 "real-part",
00456                                                 1, 1, 1),
00457                           env);
00458   scheme_add_global_constant("imag-part", 
00459                           scheme_make_folding_prim(imag_part,
00460                                                 "imag-part",
00461                                                 1, 1, 1),
00462                           env);
00463   scheme_add_global_constant("angle", 
00464                           scheme_make_folding_prim(angle,
00465                                                 "angle",
00466                                                 1, 1, 1),
00467                           env);
00468   scheme_add_global_constant("magnitude", 
00469                           scheme_make_folding_prim(magnitude,
00470                                                 "magnitude",
00471                                                 1, 1, 1),
00472                           env);
00473   scheme_add_global_constant("exact->inexact", 
00474                           scheme_make_folding_prim(scheme_exact_to_inexact,
00475                                                 "exact->inexact",
00476                                                 1, 1, 1),
00477                           env);
00478   scheme_add_global_constant("inexact->exact", 
00479                           scheme_make_folding_prim(scheme_inexact_to_exact,
00480                                                 "inexact->exact",
00481                                                 1, 1, 1),
00482                           env);
00483 }
00484 
00485 
00486 Scheme_Object *
00487 scheme_make_integer_value(long i)
00488 {
00489   Scheme_Object *o = scheme_make_integer(i);
00490   
00491   if (SCHEME_INT_VAL(o) == i)
00492     return o;
00493   else
00494     return scheme_make_bignum(i);
00495 }
00496 
00497 Scheme_Object *
00498 scheme_make_integer_value_from_unsigned(unsigned long i)
00499 {
00500   Scheme_Object *o = scheme_make_integer(i);
00501   
00502   if ((SCHEME_INT_VAL(o) >= 0)
00503       && ((unsigned long)SCHEME_INT_VAL(o)) == i)
00504     return o;
00505   else
00506     return scheme_make_bignum_from_unsigned(i);
00507 }
00508 
00509 Scheme_Object *scheme_make_integer_value_from_long_long(mzlonglong i)
00510 {
00511 #if defined(SIXTY_FOUR_BIT_INTEGERS)
00512   return scheme_make_integer_value(i);
00513 #else
00514   if (i < 0) {
00515     if (!(((i >> 32) & 0xFFFFFFFF) ^ 0xFFFFFFFF)
00516        && (i & 0x80000000)) {
00517       return scheme_make_integer_value((long)i);
00518     } else
00519       return scheme_make_bignum_from_long_long(i);
00520   } else {
00521     return scheme_make_integer_value_from_unsigned_long_long(i);
00522   }
00523 #endif
00524 }
00525 
00526 Scheme_Object *scheme_make_integer_value_from_unsigned_long_long(umzlonglong i)
00527 {
00528 #if defined(SIXTY_FOUR_BIT_INTEGERS)
00529   return scheme_make_integer_value_from_unsigned(i);
00530 #else
00531   if (!((i >> 32) & 0xFFFFFFFF))
00532     return scheme_make_integer_value_from_unsigned((long)i);
00533   else
00534     return scheme_make_bignum_from_unsigned_long_long(i);
00535 #endif
00536 }
00537 
00538 static Scheme_Object * fixnum_expt (long x, long y);
00539 
00540 Scheme_Object *
00541 scheme_make_integer_value_from_unsigned_long_halves(unsigned long lowhalf,
00542                                               unsigned long hihalf)
00543 {
00544 #ifdef NO_LONG_LONG_TYPE
00545   /*  Paste the two halves together by 
00546       hihalf * (2 ** 32) + lowhalf
00547       
00548       There may be a more efficient way to do this, but this way
00549       does not depend upon the representation of bignums.
00550   */
00551   
00552   return
00553     scheme_bin_plus
00554     (scheme_make_integer_value_from_unsigned (lowhalf),
00555      scheme_bin_mult (scheme_make_integer_value_from_unsigned (hihalf),
00556                     fixnum_expt (2, 32)));
00557 #else
00558   umzlonglong v;
00559 
00560   v = ((umzlonglong)lowhalf) | ((umzlonglong)hihalf << 32);
00561 
00562   return scheme_make_integer_value_from_unsigned_long_long(v);
00563 #endif
00564 }
00565 
00566 Scheme_Object *
00567 scheme_make_integer_value_from_long_halves(unsigned long lowhalf,
00568                                       unsigned long hihalf)
00569 {
00570 #ifdef NO_LONG_LONG_TYPE
00571   /* hihalf and lowhalf form the two halves of a 64bit 
00572      number in 2's complement form.  This means that if the 
00573      topmost bit in hihalf is set, the number is actually 
00574      the negative version of the complement plus one.
00575   */
00576   
00577   return (hihalf < 0x80000000L
00578          ? scheme_make_integer_value_from_unsigned_long_long (lowhalf, hihalf)
00579          : scheme_bin_minus
00580          (scheme_make_integer (0),
00581           scheme_make_integer_value_from_unsigned_long_long
00582           ((lowhalf ^ 0xFFFFFFFFL) + 1,
00583            (hihalf  ^ 0xFFFFFFFFL) + (lowhalf == 0))));
00584 #else
00585   mzlonglong v;
00586 
00587   v = (mzlonglong)lowhalf | ((mzlonglong)hihalf << 32);
00588 
00589   return scheme_make_integer_value_from_long_long(v);
00590 #endif
00591 }
00592 
00593 
00594 int scheme_get_int_val(Scheme_Object *o, long *v)
00595 {
00596   if (SCHEME_INTP(o)) {
00597     *v = SCHEME_INT_VAL(o);
00598     return 1;
00599   } else if (SCHEME_BIGNUMP(o))
00600     return scheme_bignum_get_int_val(o, v);
00601   else
00602     return 0;
00603 }
00604 
00605 int scheme_get_unsigned_int_val(Scheme_Object *o, unsigned long *v)
00606 {
00607   if (SCHEME_INTP(o)) {
00608     long i = SCHEME_INT_VAL(o);
00609     if (i < 0)
00610       return 0;
00611     *v = i;
00612     return 1;
00613   } else if (SCHEME_BIGNUMP(o))
00614     return scheme_bignum_get_unsigned_int_val(o, v);
00615   else
00616     return 0;
00617 }
00618 
00619 int scheme_get_long_long_val(Scheme_Object *o, mzlonglong *v)
00620 {
00621   if (SCHEME_INTP(o)) {
00622     *v = SCHEME_INT_VAL(o);
00623     return 1;
00624   } else if (SCHEME_BIGNUMP(o))
00625     return scheme_bignum_get_long_long_val(o, v);
00626   else
00627     return 0;
00628 }
00629 
00630 int scheme_get_unsigned_long_long_val(Scheme_Object *o, umzlonglong *v)
00631 {
00632   if (SCHEME_INTP(o)) {
00633     long i = SCHEME_INT_VAL(o);
00634     if (i < 0)
00635       return 0;
00636     *v = i;
00637     return 1;
00638   } else if (SCHEME_BIGNUMP(o))
00639     return scheme_bignum_get_unsigned_long_long_val(o, v);
00640   else
00641     return 0;
00642 }
00643 
00644 int scheme_nonneg_exact_p(Scheme_Object *n)
00645 {
00646   return ((SCHEME_INTP(n) && (SCHEME_INT_VAL(n) >= 0))
00647          || (SCHEME_BIGNUMP(n) && SCHEME_BIGPOS(n)));
00648 }
00649 
00650 double scheme_real_to_double(Scheme_Object *r)
00651 {
00652   if (SCHEME_INTP(r))
00653     return (double)SCHEME_INT_VAL(r);
00654   else if (SCHEME_DBLP(r))
00655     return SCHEME_DBL_VAL(r);
00656 #ifdef MZ_USE_SINGLE_FLOATS
00657   else if (SCHEME_FLTP(r))
00658     return SCHEME_FLT_VAL(r);
00659 #endif
00660   else if (SCHEME_BIGNUMP(r))
00661     return scheme_bignum_to_double(r);
00662   else if (SCHEME_RATIONALP(r))
00663     return scheme_rational_to_double(r);
00664   else
00665     return 0.0;
00666 }
00667 
00668 XFORM_NONGCING static MZ_INLINE int minus_zero_p(double d)
00669 {
00670   return (1 / d) < 0;
00671 }
00672 
00673 int scheme_minus_zero_p(double d)
00674 {
00675   return minus_zero_p(d);
00676 }
00677 
00678 #ifdef MZ_USE_SINGLE_FLOATS
00679 static int rational_flt_p(float f) {
00680   return !(MZ_IS_NAN(f)
00681            || MZ_IS_INFINITY(f));
00682 }
00683 #endif
00684 
00685 static int rational_dbl_p(double f) {
00686   return !(MZ_IS_NAN(f)
00687            || MZ_IS_INFINITY(f));
00688 }
00689 
00690 #ifdef DEFEAT_FP_COMP_OPTIMIZATION
00691 int scheme_both_nan(double a, double b)
00692 {
00693   /* Called by the MZ_IS_NAN() macro for certain compilers.
00694      A and B are actually the same FP number, but the compiler
00695      optimizes (A == A) to TRUE, so we use a function call to
00696      hide the fact that A and B are the same. */
00697   return a != b;
00698 }
00699 #endif
00700 
00701 #ifdef USE_PALM_INF_TESTS
00702 int scheme_is_pos_inf(double d)
00703 {
00704   return (d == scheme_infinity_val);
00705 }
00706 
00707 int scheme_is_neg_inf(double d)
00708 {
00709   return (d == scheme_minus_infinity_val);
00710 }
00711 
00712 int scheme_is_nan(double d)
00713 {
00714   return (!(d == d));
00715 }
00716 #endif
00717 
00718 Scheme_Object *scheme_make_double(double d)
00719 {
00720   GC_CAN_IGNORE Scheme_Double *sd;
00721 
00722   if (d == 0.0) {
00723     if (minus_zero_p(d))
00724       return scheme_nzerod;
00725 #ifdef NAN_EQUALS_ANYTHING
00726     else if (MZ_IS_NAN(d))
00727       return scheme_nan_object;
00728 #endif
00729     else
00730       return scheme_zerod;
00731   }
00732 
00733   sd = (Scheme_Double *)scheme_malloc_small_atomic_tagged(sizeof(Scheme_Double));
00734   CLEAR_KEY_FIELD(&sd->so);
00735   sd->so.type = scheme_double_type;
00736   SCHEME_DBL_VAL(sd) = d;
00737   return (Scheme_Object *)sd;
00738 }
00739 
00740 #ifdef MZ_USE_SINGLE_FLOATS
00741 Scheme_Object *scheme_make_float(float f)
00742 {
00743   Scheme_Float *sf;
00744 
00745   sf = (Scheme_Float *)scheme_malloc_small_atomic_tagged(sizeof(Scheme_Float));
00746   CLEAR_KEY_FIELD(&sf->so);
00747   sf->so.type = scheme_float_type;
00748   SCHEME_FLT_VAL(sf) = f;
00749   return (Scheme_Object *)sf;
00750 }
00751 #endif
00752 
00753 /* locals */
00754 
00755 static Scheme_Object *
00756 number_p(int argc, Scheme_Object *argv[])
00757 {
00758   Scheme_Object *o = argv[0];
00759   return (SCHEME_NUMBERP(o) ? scheme_true : scheme_false);
00760 }
00761 
00762 static Scheme_Object *
00763 complex_p(int argc, Scheme_Object *argv[])
00764 {
00765   Scheme_Object *o = argv[0];
00766   return (SCHEME_NUMBERP(o) ? scheme_true : scheme_false);
00767 }
00768 
00769 static Scheme_Object *
00770 real_p(int argc, Scheme_Object *argv[])
00771 {
00772   Scheme_Object *o = argv[0];
00773   return (SCHEME_REALP(o) ? scheme_true : scheme_false);
00774 }
00775 
00776 static Scheme_Object *
00777 rational_p(int argc, Scheme_Object *argv[])
00778 {
00779   Scheme_Object *o = argv[0];
00780 
00781   if (SCHEME_FLOATP(o))
00782     return (rational_dbl_p(SCHEME_FLOAT_VAL(o)) ? scheme_true : scheme_false);
00783   else
00784     return (SCHEME_REALP(o) ? scheme_true : scheme_false);
00785 }
00786 
00787 int scheme_is_integer(const Scheme_Object *o)
00788 {
00789   if (SCHEME_INTP(o) || SCHEME_BIGNUMP(o))
00790     return 1;
00791 
00792   if (SCHEME_FLOATP(o)) {
00793     double d;
00794     d = SCHEME_FLOAT_VAL(o);
00795 # ifdef NAN_EQUALS_ANYTHING
00796     if (MZ_IS_NAN(d))
00797       return 0;
00798 # endif
00799     if (MZ_IS_INFINITY(d))
00800       return 0;
00801     if (floor(d) == d)
00802       return 1;
00803   }
00804 
00805   return 0;
00806 }
00807 
00808 
00809 static Scheme_Object *
00810 integer_p (int argc, Scheme_Object *argv[])
00811 {
00812   return scheme_is_integer(argv[0]) ? scheme_true : scheme_false;
00813 }
00814 
00815 static Scheme_Object *
00816 exact_integer_p (int argc, Scheme_Object *argv[])
00817 {
00818   Scheme_Object *n = argv[0];
00819   if (SCHEME_INTP(n))
00820     return scheme_true;
00821   else if (SCHEME_BIGNUMP(n))
00822     return scheme_true;
00823   else
00824     return scheme_false;
00825 }
00826 
00827 static Scheme_Object *
00828 exact_nonnegative_integer_p (int argc, Scheme_Object *argv[])
00829 {
00830   Scheme_Object *n = argv[0];
00831   if (SCHEME_INTP(n))
00832     return ((SCHEME_INT_VAL(n) >= 0) ? scheme_true : scheme_false);
00833   else if (SCHEME_BIGNUMP(n))
00834     return (SCHEME_BIGPOS(n) ? scheme_true : scheme_false);
00835   else
00836     return scheme_false;
00837 }
00838 
00839 static Scheme_Object *
00840 exact_positive_integer_p (int argc, Scheme_Object *argv[])
00841 {
00842   Scheme_Object *n = argv[0];
00843   if (SCHEME_INTP(n))
00844     return ((SCHEME_INT_VAL(n) > 0) ? scheme_true : scheme_false);
00845   else if (SCHEME_BIGNUMP(n))
00846     return (SCHEME_BIGPOS(n) ? scheme_true : scheme_false);
00847   else
00848     return scheme_false;
00849 }
00850 
00851 static Scheme_Object *
00852 fixnum_p (int argc, Scheme_Object *argv[])
00853 {
00854   Scheme_Object *n = argv[0];
00855   if (SCHEME_INTP(n))
00856     return scheme_true;
00857   else
00858     return scheme_false;
00859 }
00860 
00861 static Scheme_Object *
00862 inexact_real_p (int argc, Scheme_Object *argv[])
00863 {
00864   Scheme_Object *n = argv[0];
00865   if (SCHEME_FLOATP(n))
00866     return scheme_true;
00867   else
00868     return scheme_false;
00869 }
00870 
00871 int scheme_is_exact(const Scheme_Object *n)
00872 {
00873   if (SCHEME_INTP(n)) {
00874     return 1;
00875   } else {
00876     Scheme_Type type = _SCHEME_TYPE(n);
00877     if ((type == scheme_bignum_type)
00878        || (type == scheme_rational_type))
00879       return 1;
00880     else if (type == scheme_complex_type) {
00881       return scheme_is_complex_exact(n);
00882     } else if (type == scheme_double_type)
00883       return 0;
00884 #ifdef MZ_USE_SINGLE_FLOATS
00885     else if (type == scheme_float_type)
00886       return 0;
00887 #endif
00888     else {
00889       return -1;
00890     }
00891   }
00892 }
00893 
00894 Scheme_Object *
00895 exact_p (int argc, Scheme_Object *argv[])
00896 {
00897   int v;
00898   v = scheme_is_exact(argv[0]);
00899   if (v < 0) {
00900     scheme_wrong_type("exact?", "number", 0, argc, argv);
00901     ESCAPED_BEFORE_HERE;
00902   }
00903   return (v ? scheme_true : scheme_false);
00904 }
00905 
00906 int scheme_is_inexact(const Scheme_Object *n)
00907 {
00908   if (SCHEME_INTP(n)) {
00909     return 0;
00910   } else {
00911     Scheme_Type type = _SCHEME_TYPE(n);
00912     if ((type == scheme_bignum_type)
00913        || (type == scheme_rational_type))
00914       return 0;
00915     else if (type == scheme_complex_type) {
00916       return !scheme_is_complex_exact(n);
00917     } else if (type == scheme_double_type)
00918       return 1;
00919 #ifdef MZ_USE_SINGLE_FLOATS
00920     else if (type == scheme_float_type)
00921       return 1;
00922 #endif
00923     else {
00924       return -1;
00925     }
00926   }
00927 }
00928 
00929 Scheme_Object *
00930 scheme_inexact_p (int argc, Scheme_Object *argv[])
00931 {
00932   int v;
00933   v = scheme_is_inexact(argv[0]);
00934   if (v < 0) {
00935     scheme_wrong_type("inexact?", "number", 0, argc, argv);
00936     ESCAPED_BEFORE_HERE;
00937   }
00938   return (v ? scheme_true : scheme_false);
00939 }
00940 
00941 
00942 Scheme_Object *
00943 scheme_odd_p (int argc, Scheme_Object *argv[])
00944 {
00945   Scheme_Object *v = argv[0];
00946 
00947   if (SCHEME_INTP(v))
00948     return (SCHEME_INT_VAL(v) & 0x1) ? scheme_true : scheme_false;
00949   if (SCHEME_BIGNUMP(v))
00950     return (SCHEME_BIGDIG(v)[0] & 0x1) ? scheme_true : scheme_false;
00951   
00952   if (scheme_is_integer(v)) {
00953     double d = SCHEME_FLOAT_VAL(v);
00954     if (MZ_IS_INFINITY(d))
00955       return scheme_true;
00956     return (fmod(d, 2.0) == 0.0) ? scheme_false : scheme_true;
00957   }
00958 
00959   NEED_INTEGER(odd?);
00960 
00961   ESCAPED_BEFORE_HERE;
00962 }
00963 
00964 static Scheme_Object *
00965 even_p (int argc, Scheme_Object *argv[])
00966 {
00967   Scheme_Object *v = argv[0];
00968 
00969   if (SCHEME_INTP(v))
00970     return (SCHEME_INT_VAL(v) & 0x1) ? scheme_false : scheme_true;
00971   if (SCHEME_BIGNUMP(v))
00972     return (SCHEME_BIGDIG(v)[0] & 0x1) ? scheme_false : scheme_true;
00973 
00974   if (scheme_is_integer(v)) {
00975     double d = SCHEME_FLOAT_VAL(v);
00976     if (MZ_IS_INFINITY(d))
00977       return scheme_true;
00978     return (fmod(d, 2.0) == 0.0) ? scheme_true : scheme_false;
00979   }
00980 
00981   NEED_INTEGER(even?);
00982 
00983   ESCAPED_BEFORE_HERE;
00984 }
00985 
00986 static Scheme_Object *bin_lcm (Scheme_Object *n1, Scheme_Object *n2);
00987 
00988 static Scheme_Object *int_abs(Scheme_Object *v)
00989 {
00990   if (scheme_is_negative(v))
00991     return scheme_bin_minus(scheme_make_integer(0), v);
00992   else
00993     return v;
00994 }
00995 
00996 GEN_NARY_OP(static, gcd, "gcd", scheme_bin_gcd, 0, scheme_is_integer, "integer", int_abs)
00997 GEN_NARY_OP(static, lcm, "lcm", bin_lcm, 1, scheme_is_integer, "integer", int_abs)
00998 
00999 Scheme_Object *
01000 scheme_bin_gcd (const Scheme_Object *n1, const Scheme_Object *n2)
01001 {
01002   if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
01003     long i1, i2, a, b, r;
01004 
01005     i1 = SCHEME_INT_VAL(n1);
01006     i2 = SCHEME_INT_VAL(n2);
01007     if (i1 < 0)
01008       i1 = -i1;
01009     if (i2 < 0)
01010       i2 = -i2;
01011     if (i1 > i2) {
01012       a = i1;
01013       b = i2;
01014     } else {
01015       a = i2;
01016       b = i1;
01017     }
01018     
01019     while (b > 0) {
01020       r = a % b;
01021       a = b;
01022       b = r;
01023     }
01024     return (scheme_make_integer(a));
01025   } else if (SCHEME_FLOATP(n1) || SCHEME_FLOATP(n2)) {
01026     double i1, i2, a, b, r;
01027 #ifdef MZ_USE_SINGLE_FLOATS
01028 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01029     int was_single = !(SCHEME_DBLP(n1) || SCHEME_DBLP(n2));
01030 # else
01031     int was_single = (SCHEME_FLTP(n1) || SCHEME_FLTP(n2));
01032 # endif
01033 #endif
01034 
01035     if (SCHEME_INTP(n1))
01036       i1 = SCHEME_INT_VAL(n1);
01037     else if (SCHEME_FLOATP(n1))
01038       i1 = SCHEME_FLOAT_VAL(n1);
01039     else
01040       i1 = scheme_bignum_to_double(n1);
01041 
01042     if (SCHEME_INTP(n2))
01043       i2 = SCHEME_INT_VAL(n2);
01044     else if (SCHEME_FLOATP(n2))
01045       i2 = SCHEME_FLOAT_VAL(n2);
01046     else
01047       i2 = scheme_bignum_to_double(n2);
01048 
01049     if (i1 < 0)
01050       i1 = -i1;
01051     if (i2 < 0)
01052       i2 = -i2;
01053     if (i1 > i2) {
01054       a = i1;
01055       b = i2;
01056     } else {
01057       a = i2;
01058       b = i1;
01059     }
01060 
01061 #if 0
01062     /* Shouldn't happen, since +nan.0 isn't an integer */
01063     if (MZ_IS_NAN(a) || MZ_IS_NAN(b))
01064       return nan_object;
01065 #endif
01066     if (MZ_IS_POS_INFINITY(a)) {
01067 #ifdef MZ_USE_SINGLE_FLOATS
01068       if (was_single)
01069        return scheme_make_float((float)b);
01070 #endif
01071       return scheme_make_double(b);
01072     }
01073     
01074     while (b > 0) {
01075       r = fmod(a, b);
01076       a = b;
01077       b = r;
01078     }
01079 
01080 #ifdef MZ_USE_SINGLE_FLOATS
01081     if (was_single)
01082       return scheme_make_float((float)a);
01083 #endif
01084 
01085     return scheme_make_double(a);
01086   } else {
01087     n1 = scheme_to_bignum(n1);
01088     n2 = scheme_to_bignum(n2);
01089 
01090     if (!SCHEME_BIGPOS(n1))
01091       n1 = scheme_bignum_negate(n1);
01092     if (!SCHEME_BIGPOS(n2))
01093       n2 = scheme_bignum_negate(n2);
01094 
01095     return scheme_bignum_gcd(n1, n2);
01096   }
01097 }
01098 
01099 static Scheme_Object *
01100 bin_lcm (Scheme_Object *n1, Scheme_Object *n2)
01101 {
01102   Scheme_Object *d, *ret;
01103 
01104   d = scheme_bin_gcd(n1, n2);
01105 
01106   if (scheme_is_zero(d))
01107     return d;
01108   
01109   ret = scheme_bin_mult(n1, scheme_bin_quotient(n2, d));
01110 
01111   return scheme_abs(1, &ret);
01112 }
01113 
01114 static Scheme_Object *
01115 floor_prim (int argc, Scheme_Object *argv[])
01116 {
01117   Scheme_Object *o = argv[0];
01118   Scheme_Type t;
01119 
01120   if (SCHEME_INTP(o))
01121     return o;
01122   t = _SCHEME_TYPE(o);
01123 #ifdef MZ_USE_SINGLE_FLOATS
01124   if (t == scheme_float_type) {
01125     float d = SCHEME_FLT_VAL(o);
01126     return scheme_make_float(floor(d));
01127   }
01128 #endif
01129   if (t == scheme_double_type) {
01130     double d = SCHEME_DBL_VAL(o);
01131     return scheme_make_double(floor(d));
01132   }
01133   if (t == scheme_bignum_type)
01134     return o;
01135   if (t == scheme_rational_type)
01136     return scheme_rational_floor(o);
01137 
01138   NEED_REAL(floor);
01139 
01140   ESCAPED_BEFORE_HERE;
01141 }
01142 
01143 static Scheme_Object *
01144 ceiling (int argc, Scheme_Object *argv[])
01145 {
01146   Scheme_Object *o = argv[0];
01147   Scheme_Type t;
01148 
01149   if (SCHEME_INTP(o))
01150     return o;
01151   t = _SCHEME_TYPE(o);
01152 #ifdef MZ_USE_SINGLE_FLOATS
01153   if (t == scheme_float_type) {
01154     float d = SCHEME_FLT_VAL(o);
01155     return scheme_make_float(ceil(d));
01156   }
01157 #endif
01158   if (t == scheme_double_type) {
01159     double d = SCHEME_DBL_VAL(o);
01160     return scheme_make_double(ceil(d));
01161   }
01162   if (t == scheme_bignum_type)
01163     return o;
01164   if (t == scheme_rational_type)
01165     return scheme_rational_ceiling(o);
01166 
01167   NEED_REAL(ceiling);
01168 
01169   ESCAPED_BEFORE_HERE;
01170 }
01171 
01172 static Scheme_Object *
01173 sch_truncate (int argc, Scheme_Object *argv[])
01174 {
01175   Scheme_Object *o = argv[0];
01176   Scheme_Type t;
01177 
01178   if (SCHEME_INTP(o))
01179     return o;
01180   t = _SCHEME_TYPE(o);
01181 #ifdef MZ_USE_SINGLE_FLOATS
01182   if (t == scheme_float_type) {
01183     float v = SCHEME_FLT_VAL(o);
01184     if (v > 0)
01185       v = floor(v);
01186     else
01187       v = ceil(v);
01188     return scheme_make_float(v);
01189   }
01190 #endif
01191   if (t == scheme_double_type) {
01192     double v = SCHEME_DBL_VAL(o);
01193     if (v > 0)
01194       v = floor(v);
01195     else
01196       v = ceil(v);
01197     return scheme_make_double(v);
01198   }
01199   if (t == scheme_bignum_type)
01200     return o;
01201   if (t == scheme_rational_type)
01202     return scheme_rational_truncate(o);
01203 
01204   NEED_REAL(truncate);
01205 
01206   ESCAPED_BEFORE_HERE;
01207 }
01208 
01209 static Scheme_Object *
01210 sch_round (int argc, Scheme_Object *argv[])
01211 {
01212   Scheme_Object *o = argv[0];
01213   Scheme_Type t;
01214 
01215   if (SCHEME_INTP(o))
01216     return o;
01217   t = _SCHEME_TYPE(o);
01218 #ifdef MZ_USE_SINGLE_FLOATS
01219   if (t == scheme_float_type) {
01220     double d = SCHEME_FLT_VAL(o);
01221     double i, frac;
01222     int invert;
01223 
01224     if (d < 0) {
01225       d = -d;
01226       invert = 1;
01227     } else
01228       invert = 0;
01229 
01230     frac = modf(d, &i);
01231     if (frac < 0.5)
01232       d = i;
01233     else if (frac > 0.5)
01234       d = i + 1;
01235     else if (fmod(i, 2.0) != 0.0)
01236       d = i + 1;
01237     else
01238       d = i;
01239 
01240     if (invert)
01241       d = -d;
01242 
01243     return scheme_make_float((float)d);
01244   }
01245 #endif
01246   if (t == scheme_double_type) {
01247     double d = SCHEME_DBL_VAL(o);
01248     double i, frac;
01249     int invert;
01250 
01251 #ifdef FMOD_CAN_RETURN_POS_ZERO
01252     if ((d == 0.0) && minus_zero_p(d))
01253       return o;
01254 #endif
01255 
01256     if (d < 0) {
01257       d = -d;
01258       invert = 1;
01259     } else
01260       invert = 0;
01261 
01262     frac = modf(d, &i);
01263     if (frac < 0.5)
01264       d = i;
01265     else if (frac > 0.5)
01266       d = i + 1;
01267     else if (fmod(i, 2.0) != 0.0)
01268       d = i + 1;
01269     else
01270       d = i;
01271 
01272     if (invert)
01273       d = -d;
01274 
01275     return scheme_make_double(d);
01276   }
01277   if (t == scheme_bignum_type)
01278     return o;
01279   if (t == scheme_rational_type)
01280     return scheme_rational_round(o);
01281 
01282   NEED_REAL(round);
01283 
01284   ESCAPED_BEFORE_HERE;
01285 }
01286 
01287 #ifdef MZ_USE_SINGLE_FLOATS
01288 
01289 #define TO_FLOAT_VAL scheme_get_val_as_float
01290 
01291 float TO_FLOAT_VAL(const Scheme_Object *n)
01292 {
01293   Scheme_Type t;
01294 
01295   if (SCHEME_INTP(n))
01296     return (float)SCHEME_INT_VAL(n);
01297   t = _SCHEME_TYPE(n);
01298   if (t == scheme_float_type)
01299     return SCHEME_FLT_VAL(n);
01300   if (t == scheme_double_type)
01301     return SCHEME_DBL_VAL(n);
01302   if (t == scheme_bignum_type)
01303     return scheme_bignum_to_float(n);
01304   if (t == scheme_rational_type)
01305     return scheme_rational_to_float(n);
01306   return 0.0f;
01307 }
01308 
01309 static Scheme_Object *TO_FLOAT(const Scheme_Object *n)
01310 {
01311   if (SCHEME_FLTP(n))
01312     return (Scheme_Object *)n;
01313   else
01314     return scheme_make_float(TO_FLOAT_VAL(n));
01315 }
01316 #endif
01317 
01318 #define TO_DOUBLE_VAL scheme_get_val_as_double
01319 
01320 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01321 
01322 double TO_DOUBLE_VAL(const Scheme_Object *n)
01323 {
01324   Scheme_Type t;
01325 
01326   if (SCHEME_INTP(n))
01327     return (double)SCHEME_INT_VAL(n);
01328   t = _SCHEME_TYPE(n);
01329   if (t == scheme_float_type)
01330     return SCHEME_FLT_VAL(n);
01331   if (t == scheme_double_type)
01332     return SCHEME_DBL_VAL(n);
01333   if (t == scheme_bignum_type)
01334     return scheme_bignum_to_double(n);
01335   if (t == scheme_rational_type)
01336     return scheme_rational_to_double(n);
01337   return 0.0;
01338 }
01339 
01340 Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n)
01341 {
01342   if (SCHEME_DBLP(n))
01343     return (Scheme_Object *)n;
01344   else
01345     return scheme_make_double(TO_DOUBLE_VAL(n));
01346 }
01347 
01348 #else
01349 
01350 Scheme_Object *scheme_TO_DOUBLE(const Scheme_Object *n)
01351 {
01352   return scheme_exact_to_inexact(1, (Scheme_Object **)&n);
01353 }
01354 
01355 double TO_DOUBLE_VAL(const Scheme_Object *n)
01356 {
01357   return SCHEME_DBL_VAL(scheme_TO_DOUBLE(n));
01358 }
01359 
01360 #endif
01361 
01362 #define TO_DOUBLE scheme_TO_DOUBLE
01363 
01364 Scheme_Object *scheme_to_bignum(const Scheme_Object *o)
01365 {
01366   if (SCHEME_INTP(o))
01367     return scheme_make_bignum(SCHEME_INT_VAL(o));
01368   else
01369     return (Scheme_Object *)o;
01370 }
01371 
01372 static Scheme_Object *get_frac(char *name, int low_p, 
01373                             int argc, Scheme_Object *argv[])
01374 {
01375   Scheme_Object *n = argv[0], *orig;
01376 
01377   orig = n;
01378 
01379   if (SCHEME_FLOATP(n)) {
01380     double d = SCHEME_FLOAT_VAL(n);
01381     
01382     if (MZ_IS_NAN(d)
01383         || MZ_IS_INFINITY(d)) {
01384       scheme_wrong_type(name, "rational number", 0, argc, argv);
01385       ESCAPED_BEFORE_HERE;
01386     }
01387     
01388 #ifdef MZ_USE_SINGLE_FLOATS
01389     if (SCHEME_FLTP(n))
01390       n = scheme_rational_from_float((float)d);
01391     else
01392 #endif
01393       n = scheme_rational_from_double(d);
01394   }
01395   
01396   if (SCHEME_INTP(n) || SCHEME_BIGNUMP(n))
01397     n = low_p ? scheme_make_integer(1) : n;
01398   else if (SCHEME_RATIONALP(n)) {
01399     if (low_p)
01400       n = scheme_rational_denominator(n);
01401     else
01402       n = scheme_rational_numerator(n);
01403   } else {
01404     scheme_wrong_type(name, "rational number", 0, argc, argv);
01405     ESCAPED_BEFORE_HERE;   
01406   }
01407   
01408   if (SCHEME_DBLP(orig))
01409     return TO_DOUBLE(n);
01410 #ifdef MZ_USE_SINGLE_FLOATS
01411   if (SCHEME_FLTP(orig))
01412     return TO_FLOAT(n);
01413 #endif
01414   else
01415     return n;
01416 }
01417 
01418 static Scheme_Object *un_exp(Scheme_Object *o);
01419 static Scheme_Object *un_log(Scheme_Object *o);
01420 
01421 static Scheme_Object *un_exp(Scheme_Object *o)
01422 {
01423   return exp_prim(1, &o);
01424 }
01425 
01426 static Scheme_Object *un_log(Scheme_Object *o)
01427 {
01428   return log_prim(1, &o);
01429 }
01430 
01431 static Scheme_Object *numerator(int argc, Scheme_Object *argv[])
01432 {
01433   return get_frac("numerator", 0, argc, argv);
01434 }
01435 
01436 static Scheme_Object *denominator(int argc, Scheme_Object *argv[])
01437 {
01438   return get_frac("denominator", 1, argc, argv);
01439 }
01440 
01441 static Scheme_Object *complex_exp(Scheme_Object *c);
01442 
01443 static Scheme_Object *complex_exp(Scheme_Object *c)
01444 {
01445   Scheme_Object *r = _scheme_complex_real_part(c);
01446   Scheme_Object *i = _scheme_complex_imaginary_part(c);
01447   Scheme_Object *cos_a, *sin_a;
01448 
01449   r = exp_prim(1, &r);
01450   cos_a = cos_prim(1, &i);
01451   sin_a = sin_prim(1, &i);
01452 
01453   return scheme_bin_mult(r, scheme_bin_plus(cos_a, scheme_bin_mult(sin_a, scheme_plus_i)));
01454 }
01455 
01456 static Scheme_Object *complex_log(Scheme_Object *c);
01457 
01458 static Scheme_Object *complex_log(Scheme_Object *c)
01459 {
01460   Scheme_Object *m, *theta;
01461 
01462   m = magnitude(1, &c);
01463   theta = angle(1, &c);
01464 
01465   return scheme_bin_plus(log_prim(1, &m), scheme_bin_mult(scheme_plus_i, theta));
01466 }
01467 
01468 static Scheme_Object *bignum_log(Scheme_Object *b)
01469 {
01470   Scheme_Object *rem;
01471   int d_count = 0;
01472   double d;
01473 
01474   if (!SCHEME_BIGPOS(b))
01475     return complex_log(b);
01476 
01477   /* Assume that each digit is no bigger than 64 bits: */
01478   while (SCHEME_BIGLEN(b) >= 15) {
01479     b = scheme_integer_sqrt_rem(b, &rem);
01480     d_count++;
01481   }
01482 
01483   if (SCHEME_BIGNUMP(b))
01484     d = scheme_bignum_to_double(b);
01485   else
01486     d = SCHEME_INT_VAL(b);
01487   d = log(d);
01488 
01489   while (d_count--) {
01490     d = d * 2;
01491   }
01492 
01493   return scheme_make_double(d);
01494 }
01495 
01496 static Scheme_Object *complex_sin(Scheme_Object *c);
01497 
01498 static Scheme_Object *complex_sin(Scheme_Object *c)
01499 {
01500   Scheme_Object *i_c;
01501 
01502   i_c = scheme_bin_mult(c, scheme_plus_i);
01503   
01504   return scheme_bin_div(scheme_bin_minus(un_exp(i_c),
01505                                     un_exp(scheme_bin_minus(zeroi, i_c))),
01506                      scheme_bin_mult(scheme_make_integer(2), scheme_plus_i));
01507 }
01508 
01509 static Scheme_Object *complex_cos(Scheme_Object *c);
01510 
01511 static Scheme_Object *complex_cos(Scheme_Object *c)
01512 {
01513   Scheme_Object *i_c;
01514 
01515   i_c = scheme_bin_mult(c, scheme_plus_i);
01516   
01517   return scheme_bin_div(scheme_bin_plus(un_exp(i_c),
01518                                    un_exp(scheme_bin_minus(zeroi, i_c))),
01519                      scheme_make_integer(2));
01520 }
01521 
01522 static Scheme_Object *complex_tan(Scheme_Object *c);
01523 
01524 static Scheme_Object *complex_tan(Scheme_Object *c)
01525 {
01526   return scheme_bin_div(complex_sin(c), complex_cos(c));
01527 }
01528 
01529 static Scheme_Object *complex_asin(Scheme_Object *c);
01530 static Scheme_Object *complex_atan(Scheme_Object *c);
01531 
01532 static Scheme_Object *complex_asin(Scheme_Object *c)
01533 {
01534   Scheme_Object *one_minus_c_sq, *sqrt_1_minus_c_sq;
01535 
01536   one_minus_c_sq = scheme_bin_minus(scheme_make_integer(1),
01537                                 scheme_bin_mult(c, c));
01538   sqrt_1_minus_c_sq = scheme_sqrt(1, &one_minus_c_sq);
01539   return scheme_bin_mult(scheme_make_integer(2),
01540                          complex_atan(scheme_bin_div(c,
01541                                                      scheme_bin_plus(scheme_make_integer(1),
01542                                                                      sqrt_1_minus_c_sq))));
01543 }
01544 
01545 static Scheme_Object *complex_acos(Scheme_Object *c);
01546 
01547 static Scheme_Object *complex_acos(Scheme_Object *c)
01548 {
01549   Scheme_Object *a, *r;
01550   a = complex_asin(c);
01551   if (scheme_is_zero(_scheme_complex_imaginary_part(c))
01552       && (scheme_bin_gt(_scheme_complex_real_part(c), scheme_make_integer(1))
01553           || scheme_bin_lt(_scheme_complex_real_part(c), scheme_make_integer(-1)))) {
01554     /* Make sure real part is 0 or pi */
01555     if (scheme_is_negative(_scheme_complex_real_part(c)))
01556       r = scheme_pi;
01557     else
01558       r = scheme_make_integer(0);
01559     return scheme_make_complex(r, scheme_bin_minus(scheme_make_integer(0),
01560                                                    _scheme_complex_imaginary_part(a)));
01561   } else {
01562     return scheme_bin_minus(scheme_half_pi, a);
01563   }
01564 }
01565 
01566 static Scheme_Object *complex_atan(Scheme_Object *c)
01567 {
01568   if (scheme_complex_eq(c, scheme_plus_i) || scheme_complex_eq(c, scheme_minus_i))
01569     return scheme_minus_inf_object;
01570 
01571   return scheme_bin_mult(scheme_plus_i,
01572                       scheme_bin_mult(
01573 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01574                                     scheme_make_float(0.5)
01575 #else
01576                                     scheme_make_double(0.5)
01577 #endif
01578                                     ,
01579                                     un_log(scheme_bin_div(scheme_bin_plus(scheme_plus_i, c),
01580                                                         scheme_bin_plus(scheme_plus_i, 
01581                                                                       scheme_bin_minus(zeroi, c))))));
01582 }
01583 
01584 #define GEN_ZERO_IS_ZERO() if (o == zeroi) return zeroi;
01585 #define GEN_ZERO_IS_ONE() if (o == zeroi) return scheme_make_integer(1);
01586 #define GEN_ONE_IS_ZERO() if (o == scheme_exact_one) return zeroi;
01587 #define GEN_ONE_IS_ZERO_AND_ZERO_IS_ERR() if (o == scheme_exact_one) return zeroi; else if (o == zeroi) scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO, "log: undefined for 0");
01588 #define GEN_ZERO_IS_HALF_PI() if (o == zeroi) return scheme_half_pi;
01589 
01590 #define NEVER_RESORT_TO_COMPLEX(d) 0
01591 #define NEGATIVE_USES_COMPLEX(d) d < 0.0
01592 #define OVER_ONE_MAG_USES_COMPLEX(d) (d > 1.0) || (d < -1.0)
01593 
01594 #ifdef TRIG_ZERO_NEEDS_SIGN_CHECK
01595 #define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { if (d == 0.0) return d; else return c_trig(d); }
01596 MK_SCH_TRIG(SCH_TAN, tan)
01597 MK_SCH_TRIG(SCH_SIN, sin)
01598 MK_SCH_TRIG(SCH_ASIN, asin)
01599 # define SCH_COS cos
01600 #else
01601 # ifdef SIN_COS_NEED_DEOPTIMIZE
01602 #  pragma optimize("g", off)
01603 #  define MK_SCH_TRIG(SCH_TRIG, c_trig) static double SCH_TRIG(double d) { return c_trig(d); }
01604 MK_SCH_TRIG(SCH_SIN, sin)
01605 MK_SCH_TRIG(SCH_COS, cos)
01606 MK_SCH_TRIG(SCH_TAN, tan)
01607 #  pragma optimize("g", on)
01608 # else
01609 #  define SCH_SIN sin
01610 #  define SCH_COS cos
01611 #  define SCH_TAN tan
01612 # endif
01613 # define SCH_ASIN asin
01614 #endif
01615 
01616 #ifdef LOG_ZERO_ISNT_NEG_INF
01617 double SCH_LOG(double d) { if (d == 0.0) return scheme_minus_infinity_val; else return log(d); }
01618 #else
01619 # define SCH_LOG log
01620 #endif
01621 #define BIGNUM_LOG(o) return bignum_log(o);
01622 
01623 static Scheme_Object *scheme_inf_plus_pi()
01624 {
01625   return scheme_make_complex(scheme_inf_object, scheme_pi);
01626 }
01627 
01628 #ifdef MZ_USE_SINGLE_FLOATS
01629 static Scheme_Object *scheme_single_inf_plus_pi()
01630 {
01631   return scheme_make_complex(scheme_single_inf_object, scheme_single_pi);
01632 }
01633 #endif
01634 
01635 GEN_UNARY_OP(exp_prim, exp, exp, scheme_inf_object, scheme_single_inf_object, scheme_zerod, scheme_zerof, scheme_nan_object, scheme_single_nan_object, complex_exp, GEN_ZERO_IS_ONE, NEVER_RESORT_TO_COMPLEX, BIGNUMS_AS_DOUBLES)
01636 GEN_UNARY_OP(log_prim, log, SCH_LOG, scheme_inf_object, scheme_single_inf_object, scheme_inf_plus_pi(), scheme_single_inf_plus_pi(), scheme_nan_object, scheme_single_nan_object, complex_log, GEN_ONE_IS_ZERO_AND_ZERO_IS_ERR, NEGATIVE_USES_COMPLEX, BIGNUM_LOG)
01637 GEN_UNARY_OP(sin_prim, sin, SCH_SIN, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, complex_sin, GEN_ZERO_IS_ZERO, NEVER_RESORT_TO_COMPLEX, BIGNUMS_AS_DOUBLES)
01638 GEN_UNARY_OP(cos_prim, cos, SCH_COS, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, complex_cos, GEN_ZERO_IS_ONE, NEVER_RESORT_TO_COMPLEX, BIGNUMS_AS_DOUBLES)
01639 GEN_UNARY_OP(tan_prim, tan, SCH_TAN, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, complex_tan, GEN_ZERO_IS_ZERO, NEVER_RESORT_TO_COMPLEX, BIGNUMS_AS_DOUBLES)
01640 GEN_UNARY_OP(asin_prim, asin, SCH_ASIN, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, complex_asin, GEN_ZERO_IS_ZERO, OVER_ONE_MAG_USES_COMPLEX, BIGNUMS_AS_DOUBLES)
01641 GEN_UNARY_OP(acos_prim, acos, acos, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, scheme_nan_object, scheme_single_nan_object, complex_acos, GEN_ONE_IS_ZERO, OVER_ONE_MAG_USES_COMPLEX, BIGNUMS_AS_DOUBLES)
01642 
01643 static Scheme_Object *
01644 atan_prim (int argc, Scheme_Object *argv[])
01645 {
01646   double v;
01647   Scheme_Object *n1;
01648 #ifdef MZ_USE_SINGLE_FLOATS
01649 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01650   int dbl = 0;
01651 # define MZ_USE_SINGLE !dbl
01652 # else
01653   int single = 0;
01654 # define MZ_USE_SINGLE single == 2
01655 #endif
01656 #endif
01657 
01658   n1 = argv[0];
01659 
01660   if (SCHEME_INTP(n1))
01661     v = SCHEME_INT_VAL(n1);
01662 #ifdef MZ_USE_SINGLE_FLOATS
01663   else if (SCHEME_FLTP(n1)) {
01664     v = SCHEME_FLT_VAL(n1);
01665 # ifndef USE_SINGLE_FLOATS_AS_DEFAULT
01666     single++;
01667 # endif
01668   }
01669 #endif
01670   else if (SCHEME_DBLP(n1)) {
01671 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01672     dbl++;
01673 # endif
01674     v = SCHEME_DBL_VAL(n1);
01675   } else if (SCHEME_BIGNUMP(n1))
01676     v = scheme_bignum_to_double(n1);
01677   else if (SCHEME_RATIONALP(n1))
01678     v = scheme_rational_to_double(n1);
01679   else if (SCHEME_COMPLEXP(n1)) {
01680     if (argc > 1) {
01681       scheme_wrong_type("atan (with two arguments)", REAL_NUMBER_STR, 0, argc, argv);
01682       ESCAPED_BEFORE_HERE;
01683     } else
01684       return complex_atan(n1);
01685   } else {
01686     NEED_NUMBER(atan);
01687     ESCAPED_BEFORE_HERE;
01688   }
01689 
01690   if (argc == 2) {
01691     double v2;
01692     Scheme_Object *n2;
01693     
01694     n2 = argv[1];
01695 
01696     if ((n1 == zeroi) && (n2 == zeroi)) {
01697       scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
01698                      "atan: undefined for 0 and 0");
01699       ESCAPED_BEFORE_HERE;
01700     }
01701 
01702     if (SCHEME_INTP(n2))
01703       v2 = SCHEME_INT_VAL(n2);
01704 #ifdef MZ_USE_SINGLE_FLOATS
01705     else if (SCHEME_FLTP(n2)) {
01706       v2 = SCHEME_FLT_VAL(n2);
01707 # ifndef USE_SINGLE_FLOATS_AS_DEFAULT
01708       single++;
01709 # endif
01710     }
01711 #endif
01712     else if (SCHEME_DBLP(n2)) {
01713 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
01714       dbl++;
01715 # endif
01716       v2 = SCHEME_DBL_VAL(n2);
01717     } else if (SCHEME_BIGNUMP(n2))
01718       v2 = scheme_bignum_to_double(n2);
01719     else if (SCHEME_RATIONALP(n2))
01720       v2 = scheme_rational_to_double(n2);
01721     else {
01722       scheme_wrong_type("atan", REAL_NUMBER_STR, 1, argc, argv);
01723       ESCAPED_BEFORE_HERE;
01724     }
01725 
01726     if ((v == 0.0) && (v2 == 0.0)) {
01727 #ifdef MZ_USE_SINGLE_FLOATS
01728       if (MZ_USE_SINGLE)
01729        return scheme_zerof;
01730 #endif      
01731       return scheme_zerod;
01732     }
01733 
01734 #ifdef ATAN2_DOESNT_WORK_WITH_INFINITIES
01735     if (MZ_IS_INFINITY(v) && MZ_IS_INFINITY(v2)) {
01736       v = MZ_IS_POS_INFINITY(v) ? 1.0 : -1.0;
01737       v2 = MZ_IS_POS_INFINITY(v2) ? 1.0 : -1.0;
01738     }
01739 #endif
01740 #ifdef ATAN2_DOESNT_WORK_WITH_NAN
01741     if (MZ_IS_NAN(v) || MZ_IS_NAN(v2))
01742       return scheme_nan_object;
01743 #endif
01744 
01745     v = atan2(v, v2);
01746   } else {
01747     if (argv[0] == zeroi)
01748       return zeroi;
01749 
01750 #ifdef TRIG_ZERO_NEEDS_SIGN_CHECK
01751     if (v == 0.0) {
01752       /* keep v the same */
01753     } else
01754 #endif
01755       v = atan(v);
01756 
01757 #ifdef MZ_USE_SINGLE_FLOATS
01758 # ifndef USE_SINGLE_FLOATS_AS_DEFAULT
01759     single++;
01760 # endif
01761 #endif    
01762   }
01763 
01764 #ifdef MZ_USE_SINGLE_FLOATS
01765   if (MZ_USE_SINGLE)
01766     return scheme_make_float((float)v);
01767 #endif
01768 
01769   return scheme_make_double(v);
01770 
01771 #undef MZ_USE_SINGLE
01772 }
01773 
01774 #ifdef NEED_TO_DEFINE_MATHERR
01775 int _RTLENTRY _EXPFUNC _matherr(struct exception* e)
01776 {
01777    e->retval=1.0;
01778    return 1;
01779 }
01780 #endif
01781 
01782 Scheme_Object *scheme_sqrt (int argc, Scheme_Object *argv[])
01783 {
01784   int imaginary = 0;
01785   Scheme_Object *n;
01786   
01787   n = argv[0];
01788 
01789   if (SCHEME_COMPLEXP(n))
01790     return scheme_complex_sqrt(n);
01791 
01792   if (!SCHEME_REALP(n))
01793     scheme_wrong_type("sqrt", "number", 0, argc, argv);
01794 
01795   if (scheme_is_negative(n)) {
01796     n = scheme_bin_minus(zeroi, n);
01797     imaginary = 1;
01798   }
01799 
01800   if (SCHEME_INTP(n) || SCHEME_BIGNUMP(n))
01801     n = scheme_integer_sqrt(n);
01802 #ifdef MZ_USE_SINGLE_FLOATS
01803   else if (SCHEME_FLTP(n))
01804     n = scheme_make_float((float)sqrt(SCHEME_FLT_VAL(n)));
01805 #endif
01806   else if (SCHEME_DBLP(n)) {
01807     double d = SCHEME_DBL_VAL(n);
01808 #ifdef SQRT_NAN_IS_WRONG
01809     if (MZ_IS_NAN(d))
01810       return scheme_nan_object;
01811 #endif
01812     n = scheme_make_double(sqrt(d));
01813   } else if (SCHEME_RATIONALP(n))
01814     n = scheme_rational_sqrt(n);
01815 
01816   if (imaginary)
01817     return scheme_make_complex(zeroi, n);
01818   else
01819     return n;
01820 }
01821 
01822 Scheme_Object *do_int_sqrt (const char *name, int argc, Scheme_Object *argv[], int w_rem)
01823 {
01824   Scheme_Object *v = argv[0], *rem = NULL;
01825 
01826   if (!scheme_is_integer(v)) {
01827     scheme_wrong_type(name, "integer", 0, argc, argv);
01828     return NULL;
01829   }
01830 
01831   if (SCHEME_INTP(v) || SCHEME_BIGNUMP(v)) {
01832     int imaginary = 0;
01833     
01834     if (scheme_is_negative(v)) {
01835       v = scheme_bin_minus(zeroi, v);
01836       imaginary = 1;
01837     }
01838 
01839     v = scheme_integer_sqrt_rem(v, &rem);
01840 
01841     if (imaginary) {
01842       v = scheme_make_complex(zeroi, v);
01843       rem = scheme_bin_minus(zeroi, rem);
01844     }
01845   } else {
01846     /* Must be inexact. Compose normal sqrt and floor, which should
01847        handle infinities and NAN just fine. */
01848     rem = v;
01849     v = scheme_sqrt(1, &v);
01850     if (SCHEME_COMPLEXP(v)) {
01851       v = scheme_complex_imaginary_part(v);
01852       v = floor_prim(1, &v);
01853       v = scheme_make_complex(scheme_make_integer(0), v);
01854     } else
01855       v = floor_prim(1, &v);
01856     
01857     if (w_rem) {
01858       rem = scheme_bin_minus(rem, scheme_bin_mult(v, v));
01859     }
01860   }
01861 
01862   if (w_rem) {
01863     Scheme_Object *a[2];
01864     a[0] = v;
01865     a[1] = rem;
01866     return scheme_values(2, a);
01867   } else
01868     return v;
01869 }
01870 
01871 Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[])
01872 {
01873   return do_int_sqrt("integer-sqrt", argc, argv, 0);
01874 }
01875 
01876 Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[])
01877 {
01878   return do_int_sqrt("integer-sqrt/remainder", argc, argv, 1);
01879 }
01880 
01881 static Scheme_Object *fixnum_expt(long x, long y)
01882 {
01883   int orig_x = x;
01884   int orig_y = y;
01885 
01886   if ((x == 2) && (y <= MAX_SHIFT_TRY))
01887     return scheme_make_integer((long)1 << y);
01888   else
01889   {
01890     long result = 1;
01891     int odd_result = (x < 0) && (y & 0x1);
01892 
01893     if (x < 0)
01894       x = -x;
01895     while (y > 0)
01896     {
01897       /* x^y*result is invariant and result <= x */
01898       if (x > 46339 && y > 1) /* x * x won't fit in 31 bits */
01899         return scheme_generic_integer_power(scheme_make_integer_value(orig_x), scheme_make_integer_value(orig_y));
01900 
01901       if (y & 0x1) /* if (odd?) */
01902       {
01903         long next_result = x * result;
01904         if (y == 1 && x > 46339 && !(next_result / x == result))
01905           return scheme_generic_integer_power(scheme_make_integer_value(orig_x), scheme_make_integer_value(orig_y));
01906         else
01907           result = next_result;
01908       }
01909       y = y >> 1;
01910       x = x * x;
01911     }
01912     return scheme_make_integer_value(odd_result ? -result : result);
01913   }
01914 }
01915 
01916 #ifdef POW_HANDLES_INF_CORRECTLY
01917 # define sch_pow pow
01918 #else
01919 static double sch_pow(double x, double y)
01920 {
01921   if (MZ_IS_POS_INFINITY(y)) {
01922     if ((x == 1.0) || (x == -1.0))
01923       return not_a_number_val;
01924     else if ((x < 1.0) && (x > -1.0))
01925       return 0.0;
01926     else
01927       return scheme_infinity_val;
01928   } else if (MZ_IS_NEG_INFINITY(y)) {
01929     if ((x == 1.0) || (x == -1.0))
01930       return not_a_number_val;
01931     else if ((x < 1.0) && (x > -1.0))
01932       return scheme_infinity_val;
01933     else
01934       return 0.0;
01935   } else if (MZ_IS_POS_INFINITY(x)) {
01936     if (y == 0.0)
01937       return 1.0;
01938     else if (y < 0)
01939       return 0.0;
01940     else
01941       return scheme_infinity_val;
01942   } else if (MZ_IS_NEG_INFINITY(x)) {
01943     if (y == 0.0)
01944       return 1.0;
01945     else {
01946       int neg = 0;
01947       if (y < 0) {
01948        neg = 1;
01949        y = -y;
01950       }
01951       if (fmod(y, 2.0) == 1.0) {
01952        if (neg)
01953          return scheme_floating_point_nzero;
01954        else
01955          return scheme_minus_infinity_val;
01956       } else {
01957        if (neg)
01958          return 0.0;
01959        else
01960          return scheme_infinity_val;
01961       }
01962     }
01963   } else
01964     return pow(x, y);
01965 }
01966 #endif
01967 
01968 GEN_BIN_PROT(bin_expt);
01969 
01970 # define F_EXPT(x, y) (((x < 0.0) && (y != floor(y))) \
01971                        ? scheme_complex_power(scheme_real_to_complex(scheme_make_double(x)), \
01972                                           scheme_real_to_complex(scheme_make_double(y))) \
01973                        : scheme_make_double(sch_pow((double)x, (double)y)))
01974 # define FS_EXPT(x, y) (((x < 0.0) && (y != floor(y))) \
01975                        ? scheme_complex_power(scheme_real_to_complex(scheme_make_float(x)), \
01976                                           scheme_real_to_complex(scheme_make_float(y))) \
01977                         : scheme_make_float(sch_pow((double)x, (double)y)))
01978 
01979 static GEN_BIN_OP(bin_expt, "expt", fixnum_expt, F_EXPT, FS_EXPT, scheme_generic_integer_power, scheme_rational_power, scheme_complex_power, GEN_RETURN_0_USUALLY, GEN_RETURN_1, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
01980 
01981 Scheme_Object *
01982 scheme_expt(int argc, Scheme_Object *argv[])
01983 {
01984   int invert = 0;
01985   Scheme_Object *e, *r, *n;
01986 
01987   n = argv[0];
01988   e = argv[1];
01989 
01990   if (!SCHEME_NUMBERP(n))
01991     scheme_wrong_type("expt", "number", 0, argc, argv);
01992 
01993   if (e == zeroi)
01994     return scheme_make_integer(1);
01995   if (e == scheme_exact_one)
01996     return n;
01997   if (n == scheme_exact_one) {
01998     /* Power of one: */
01999     if (SCHEME_NUMBERP(e))
02000       return n;
02001   }
02002   if (SCHEME_RATIONALP(e)
02003       && (((Scheme_Rational *)e)->num == scheme_exact_one)
02004       && (((Scheme_Rational *)e)->denom == scheme_make_integer(2))) {
02005     return scheme_sqrt(1, argv);
02006   }
02007 
02008   if (n == zeroi) {
02009     /* Power of exact zero */
02010     int neg;
02011 
02012     if (SCHEME_FLOATP(e)) {
02013       double d = SCHEME_FLOAT_VAL(e);
02014       if (MZ_IS_NAN(d)) {
02015 #ifdef MZ_USE_SINGLE_FLOATS
02016        if (SCHEME_FLTP(e))
02017          return scheme_single_nan_object;
02018 #endif
02019        return scheme_nan_object;
02020       }
02021     }
02022 
02023     if (!SCHEME_COMPLEXP(e)) {
02024       neg = scheme_is_negative(e);
02025     } else {
02026       neg = !scheme_is_positive(scheme_complex_real_part(e));
02027     }
02028     
02029     if (neg) {
02030       scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
02031                      "expt: undefined for 0 and %s",
02032                      scheme_make_provided_string(e, 0, NULL));
02033       ESCAPED_BEFORE_HERE;
02034     }
02035   }
02036 
02037   if (!SCHEME_FLOATP(n)) {
02038     /* negative integer power of exact: compute positive power and invert */
02039     if (SCHEME_INTP(e) || SCHEME_BIGNUMP(e)) {
02040       if (!scheme_is_positive(e)) {
02041        e = scheme_bin_minus(zeroi, e);
02042        invert = 1;
02043       }
02044     }
02045   } else {
02046     /* real power of inexact zero? */
02047     /* (Shouldn't have to do this, but pow() is especially unreliable.) */
02048     double d = SCHEME_FLOAT_VAL(n);
02049     if ((d == 0.0)
02050 #ifdef NAN_EQUALS_ANYTHING
02051        && !MZ_IS_NAN(d)
02052 #endif
02053        ) {
02054       if (SCHEME_REALP(e)) {
02055        int norm = 0;
02056 
02057        if (SCHEME_FLOATP(e)) {
02058          double d2;
02059          d2 = SCHEME_FLOAT_VAL(e);
02060          
02061          if ((d2 == 0.0)
02062              || MZ_IS_INFINITY(d2)
02063              || MZ_IS_NAN(d2))
02064            norm = 1;
02065        }
02066 
02067        if (!norm) {
02068          int isnonneg, iseven, negz;
02069 #ifdef MZ_USE_SINGLE_FLOATS
02070          int single = !SCHEME_DBLP(n) && !SCHEME_DBLP(e);
02071 #endif
02072 
02073          if (scheme_is_integer(e)) {
02074            iseven = SCHEME_FALSEP(scheme_odd_p(1, &e));
02075          } else {
02076            /* Treat it as even for sign purposes: */
02077            iseven = 1;
02078          }
02079          isnonneg = !scheme_is_negative(e);
02080          negz = scheme_minus_zero_p(d);
02081 
02082          if (isnonneg) {
02083            if (iseven || !negz) {
02084 #ifdef MZ_USE_SINGLE_FLOATS
02085              if (single)
02086               return scheme_zerof;
02087 #endif
02088              return scheme_zerod;
02089            } else {
02090 #ifdef MZ_USE_SINGLE_FLOATS
02091              if (single)
02092               return scheme_nzerof;
02093 #endif
02094              return scheme_nzerod;
02095            }
02096          } else {
02097            if (iseven || !negz) {
02098 #ifdef MZ_USE_SINGLE_FLOATS
02099              if (single)
02100               return scheme_single_inf_object;
02101 #endif
02102              return scheme_inf_object;
02103            } else {
02104 #ifdef MZ_USE_SINGLE_FLOATS
02105              if (single)
02106               return scheme_single_minus_inf_object;
02107 #endif
02108              return scheme_minus_inf_object;
02109            }
02110          }
02111        }
02112       }
02113     }
02114   }
02115 
02116   r = bin_expt(argv[0], e);
02117   if (invert)
02118     r = scheme_bin_div(scheme_make_integer(1), r);
02119 
02120   return r;
02121 }
02122 
02123 
02124 static Scheme_Object *make_rectangular (int argc, Scheme_Object *argv[])
02125 {
02126   Scheme_Object *a, *b;
02127   int af, bf;
02128 
02129   a = argv[0];
02130   b = argv[1];
02131   if (!SCHEME_REALP(a))
02132     scheme_wrong_type("make-rectangular", REAL_NUMBER_STR, 0, argc, argv);
02133   if (!SCHEME_REALP(b))
02134     scheme_wrong_type("make-rectangular", REAL_NUMBER_STR, 1, argc, argv);
02135 
02136   af = SCHEME_FLOATP(a);
02137   bf = SCHEME_FLOATP(b);
02138 
02139   if (af && !bf) {
02140     if (b != zeroi)
02141       b = scheme_exact_to_inexact(1, &b);
02142   }
02143   if (bf && !af) {
02144     if (a != zeroi)
02145       a = scheme_exact_to_inexact(1, &a);
02146   }
02147 
02148   return scheme_make_complex(a, b);
02149 }
02150 
02151 Scheme_Object *scheme_make_polar (int argc, Scheme_Object *argv[])
02152 {
02153   Scheme_Object *a, *b, *r, *i, *v;
02154 
02155   a = argv[0];
02156   b = argv[1];
02157   if (!SCHEME_REALP(a))
02158     scheme_wrong_type("make-polar", REAL_NUMBER_STR, 0, argc, argv);
02159   if (!SCHEME_REALP(b))
02160     scheme_wrong_type("make-polar", REAL_NUMBER_STR, 1, argc, argv);
02161 
02162   if (b == zeroi)
02163     return a;
02164 
02165   v = b;
02166 
02167   r = scheme_bin_mult(a, cos_prim(1, &v));
02168   i = scheme_bin_mult(a, sin_prim(1, &v));
02169 
02170   return scheme_make_complex(r, i);
02171 }
02172 
02173 static Scheme_Object *real_part (int argc, Scheme_Object *argv[])
02174 {
02175   Scheme_Object *o = argv[0];
02176 
02177   if (!SCHEME_NUMBERP(o))
02178     scheme_wrong_type("real-part", "number", 0, argc, argv);
02179 
02180   if (SCHEME_COMPLEXP(o))
02181     return _scheme_complex_real_part(o);
02182   else
02183     return argv[0];
02184 }
02185 
02186 static Scheme_Object *imag_part (int argc, Scheme_Object *argv[])
02187 {
02188   Scheme_Object *o = argv[0];
02189 
02190   if (!SCHEME_NUMBERP(o))
02191     scheme_wrong_type("imag-part", "number", 0, argc, argv);
02192 
02193   if (SCHEME_COMPLEXP(o))
02194     return scheme_complex_imaginary_part(o);
02195 
02196   return zeroi;
02197 }
02198 
02199 static Scheme_Object *magnitude(int argc, Scheme_Object *argv[])
02200 {
02201   Scheme_Object *o = argv[0];
02202 
02203   if (!SCHEME_NUMBERP(o))
02204     scheme_wrong_type("magnitude", "number", 0, argc, argv);
02205 
02206   if (SCHEME_COMPLEXP(o)) {
02207     Scheme_Object *r = _scheme_complex_real_part(o);
02208     Scheme_Object *i = _scheme_complex_imaginary_part(o);
02209     Scheme_Object *a[1], *q;
02210     a[0] = r;
02211     r = scheme_abs(1, a);
02212     a[0] = i;
02213     i = scheme_abs(1, a);
02214     
02215     if (SAME_OBJ(r, scheme_make_integer(0)))
02216       return i;
02217 
02218     if (scheme_bin_lt(i, r)) {
02219       Scheme_Object *tmp;
02220       tmp = i;
02221       i = r;
02222       r = tmp;
02223     }
02224     if (scheme_is_zero(r)) {
02225       a[0] = i;
02226       return scheme_exact_to_inexact(1, a);
02227     }
02228     if (SCHEME_FLOATP(i)) {
02229       double d;
02230       d = SCHEME_FLOAT_VAL(i);
02231       if (MZ_IS_POS_INFINITY(d)) {
02232         if (SCHEME_FLOATP(r)) {
02233           d = SCHEME_FLOAT_VAL(r);
02234           if (MZ_IS_NAN(d))
02235             return scheme_nan_object;
02236         }
02237         return scheme_inf_object;
02238       }
02239     }
02240     q = scheme_bin_div(r, i);
02241     q = scheme_bin_plus(scheme_make_integer(1),
02242                      scheme_bin_mult(q, q));
02243     a[0] = q;
02244     return scheme_bin_mult(i, scheme_sqrt(1, a));
02245   } else
02246     return scheme_abs(1, argv);
02247 }
02248 
02249 static Scheme_Object *angle(int argc, Scheme_Object *argv[])
02250 {
02251   Scheme_Object *o = argv[0];
02252 
02253   if (!SCHEME_NUMBERP(o))
02254     scheme_wrong_type("angle", "number", 0, argc, argv);
02255 
02256   if (SCHEME_COMPLEXP(o)) {
02257     Scheme_Object *r = (Scheme_Object *)_scheme_complex_real_part(o);
02258     Scheme_Object *i = (Scheme_Object *)_scheme_complex_imaginary_part(o);
02259     double rd, id, v;
02260 #ifdef MZ_USE_SINGLE_FLOATS
02261 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
02262     int was_single = !(SCHEME_DBLP(r) || SCHEME_DBLP(i));
02263 # else
02264     int was_single = (SCHEME_FLTP(r) || SCHEME_FLTP(i));
02265 # endif
02266 #endif
02267 
02268     id = TO_DOUBLE_VAL(i);
02269     rd = TO_DOUBLE_VAL(r);
02270 
02271     v = atan2(id, rd);
02272 
02273 #ifdef MZ_USE_SINGLE_FLOATS
02274     if (was_single)
02275       return scheme_make_float((float)v);
02276 #endif
02277 
02278     return scheme_make_double(v);
02279   } else {
02280 #ifdef MZ_USE_SINGLE_FLOATS
02281     if (SCHEME_FLTP(o)) {
02282       float v = SCHEME_FLT_VAL(o);
02283       if (MZ_IS_NAN(v))
02284        return scheme_single_nan_object;
02285       else if (v == 0.0f) {
02286        int neg;
02287        neg = minus_zero_p(v);
02288        v = (neg ? -1.0f : 1.0f);
02289       }
02290       if (v > 0)
02291        return zeroi;
02292       else
02293        return scheme_single_pi;
02294     }
02295 #endif
02296     if (SCHEME_DBLP(o)) {
02297       double v = SCHEME_DBL_VAL(o);
02298       if (MZ_IS_NAN(v))
02299        return scheme_nan_object;
02300       else if (v == 0.0) {
02301        int neg;
02302        neg = minus_zero_p(v);
02303        v = (neg ? -1.0 : 1.0);
02304       }
02305       if (v > 0)
02306        return zeroi;
02307       else
02308        return scheme_pi;
02309     } else if (o == zeroi) {
02310       scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
02311                      "angle: undefined for 0");
02312       ESCAPED_BEFORE_HERE;
02313     } else if (scheme_is_positive(o))
02314       return zeroi;
02315     else {
02316 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
02317       return scheme_single_pi;
02318 # endif
02319       return scheme_pi;
02320     }
02321   }
02322 }
02323 
02324 Scheme_Object *
02325 scheme_exact_to_inexact (int argc, Scheme_Object *argv[])
02326 {
02327   Scheme_Object *o = argv[0];
02328   Scheme_Type t;
02329 
02330   if (SCHEME_INTP(o)) {
02331 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
02332     return scheme_make_float(SCHEME_INT_VAL(o));
02333 #else
02334     return scheme_make_double(SCHEME_INT_VAL(o));
02335 #endif
02336   }
02337   t = _SCHEME_TYPE(o);
02338 #ifdef MZ_USE_SINGLE_FLOATS
02339   if (t == scheme_float_type)
02340     return o;
02341 #endif
02342   if (t == scheme_double_type)
02343     return o;
02344   if (t == scheme_bignum_type) {
02345 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
02346     return scheme_make_float(scheme_bignum_to_float(o));
02347 #else
02348     return scheme_make_double(scheme_bignum_to_double(o));
02349 #endif
02350   }
02351   if (t == scheme_rational_type) {
02352 #ifdef USE_SINGLE_FLOATS_AS_DEFAULT
02353     return scheme_make_float(scheme_rational_to_float(o));
02354 #else
02355     return scheme_make_double(scheme_rational_to_double(o));
02356 #endif
02357   }
02358   if (t == scheme_complex_type) {
02359     Scheme_Object *realpart, *imaginarypart;
02360 
02361     realpart = _scheme_complex_real_part(o);
02362     imaginarypart = _scheme_complex_imaginary_part(o);
02363 
02364     realpart = scheme_exact_to_inexact(1, &realpart);
02365     imaginarypart = scheme_exact_to_inexact(1, &imaginarypart);
02366 
02367     return scheme_make_complex(realpart, imaginarypart);
02368   }
02369 
02370   NEED_NUMBER(exact->inexact);
02371 
02372   ESCAPED_BEFORE_HERE;
02373 }
02374 
02375 Scheme_Object *
02376 scheme_inexact_to_exact (int argc, Scheme_Object *argv[])
02377 {
02378   Scheme_Object *o = argv[0];
02379   Scheme_Type t;
02380 
02381   if (SCHEME_INTP(o))
02382     return o;
02383   t = _SCHEME_TYPE(o);
02384   if (t == scheme_double_type
02385 #ifdef MZ_USE_SINGLE_FLOATS
02386       || t == scheme_float_type
02387 #endif
02388       ) {
02389     double d = SCHEME_FLOAT_VAL(o);
02390 
02391     /* Try simple case: */
02392     Scheme_Object *i = scheme_make_integer((long)d);
02393     if ((double)SCHEME_INT_VAL(i) == d) {
02394 # ifdef NAN_EQUALS_ANYTHING
02395       if (!MZ_IS_NAN(d))
02396 #endif
02397        return i;
02398     }
02399 
02400     return scheme_rational_from_double(d);
02401   }
02402   if (t == scheme_bignum_type)
02403     return o;
02404   if (t == scheme_rational_type)
02405     return o;
02406   if (t == scheme_complex_type) {
02407     Scheme_Object *realpart, *imaginarypart;
02408 
02409     realpart = _scheme_complex_real_part(o);
02410     imaginarypart = _scheme_complex_imaginary_part(o);
02411 
02412     realpart = scheme_inexact_to_exact(1, &realpart);
02413     imaginarypart = scheme_inexact_to_exact(1, &imaginarypart);
02414 
02415     return scheme_make_complex(realpart, imaginarypart);
02416   }
02417 
02418   NEED_NUMBER(inexact->exact);
02419 
02420   ESCAPED_BEFORE_HERE;
02421 }
02422 
02423 #ifdef MZ_USE_SINGLE_FLOATS
02424 int scheme_check_float(const char *where, float f, const char *dest)
02425 {
02426   return scheme_check_double(where, f, dest);
02427 }
02428 #endif
02429 
02430 GEN_BIN_PROT(bin_bitwise_and);
02431 GEN_BIN_PROT(bin_bitwise_or);
02432 GEN_BIN_PROT(bin_bitwise_xor);
02433 
02434 GEN_BIN_INT_OP(bin_bitwise_and, "bitwise-and", &, scheme_bignum_and)
02435 GEN_BIN_INT_OP(bin_bitwise_or, "bitwise-ior", |, scheme_bignum_or)
02436 GEN_BIN_INT_OP(bin_bitwise_xor, "bitwise-xor", ^, scheme_bignum_xor)
02437 
02438 #define MZ_PUBLIC 
02439 
02440 GEN_NARY_OP(MZ_PUBLIC, scheme_bitwise_and, "bitwise-and", bin_bitwise_and, -1, SCHEME_EXACT_INTEGERP, "exact integer", GEN_IDENT)
02441 GEN_NARY_OP(static, bitwise_or, "bitwise-ior", bin_bitwise_or, 0, SCHEME_EXACT_INTEGERP, "exact integer", GEN_IDENT)
02442 GEN_NARY_OP(static, bitwise_xor, "bitwise-xor", bin_bitwise_xor, 0, SCHEME_EXACT_INTEGERP, "exact integer", GEN_IDENT)
02443 
02444 static Scheme_Object *
02445 bitwise_not(int argc, Scheme_Object *argv[])
02446 {
02447   Scheme_Object *o = argv[0];
02448 
02449   if (SCHEME_INTP(o)) {
02450     long a = SCHEME_INT_VAL(o);
02451 
02452     a = ~a;
02453     return scheme_make_integer(a);
02454   } else if (_SCHEME_TYPE(o) == scheme_bignum_type)
02455     return scheme_bignum_not(o);
02456    
02457   scheme_wrong_type("bitwise-not", "exact integer", 0, argc, argv);
02458   ESCAPED_BEFORE_HERE;
02459 }
02460 
02461 Scheme_Object *
02462 scheme_bitwise_shift(int argc, Scheme_Object *argv[])
02463 {
02464   Scheme_Object *v, *so;
02465   long shift;
02466 
02467   v = argv[0];
02468   
02469   if (!SCHEME_EXACT_INTEGERP(v)) {
02470     scheme_wrong_type("arithmetic-shift", "exact integer", 0, argc, argv);
02471     ESCAPED_BEFORE_HERE;
02472   }
02473   so = argv[1];
02474   if (!SCHEME_INTP(so)) {
02475     if (SCHEME_BIGNUMP(so)) {
02476       if (!SCHEME_BIGPOS(so)) {
02477        if (scheme_is_negative(v))
02478          return scheme_make_integer(-1);
02479        else
02480          return scheme_make_integer(0);
02481       } else
02482        scheme_raise_out_of_memory("arithmetic-shift", NULL);
02483     } else
02484       scheme_wrong_type("arithmetic-shift", "exact integer", 1, argc, argv);
02485     ESCAPED_BEFORE_HERE;
02486   }
02487   
02488   shift = SCHEME_INT_VAL(so);
02489   if (!shift)
02490     return v;
02491 
02492   if (SCHEME_INTP(v)) {
02493     long i = SCHEME_INT_VAL(v);
02494 
02495     if (!i)
02496       return v;
02497 
02498     if (i > 0) {
02499       if (shift < 0) {
02500        int shft = -shift;
02501        if (shft < MAX_SHIFT_EVER) {
02502          i = i >> shft;
02503          return scheme_make_integer(i);
02504        } else
02505          return scheme_make_integer(0);
02506       } else if (shift <= MAX_SHIFT_TRY) {
02507        long n;
02508        
02509        n = i << shift;
02510        if ((n > 0) && (SCHEME_INT_VAL(scheme_make_integer(n)) >> shift == i))
02511          return scheme_make_integer(n);
02512       }
02513     }
02514 
02515     v = scheme_make_bignum(i);
02516   }
02517 
02518   return scheme_bignum_shift(v, shift);
02519 }
02520 
02521 static Scheme_Object *bitwise_bit_set_p (int argc, Scheme_Object *argv[])
02522 {
02523   Scheme_Object *so, *sb;
02524 
02525   so = argv[0];
02526   if (!SCHEME_EXACT_INTEGERP(so)) {
02527     scheme_wrong_type("bitwise-bit-set?", "exact integer", 0, argc, argv);
02528     ESCAPED_BEFORE_HERE;
02529   }
02530   sb = argv[1];
02531   if (SCHEME_INTP(sb)) {
02532     long v;
02533     v = SCHEME_INT_VAL(sb);
02534     if (v < 0) {
02535       scheme_wrong_type("bitwise-bit-set?", "nonnegative exact integer", 1, argc, argv);
02536       ESCAPED_BEFORE_HERE;
02537     }
02538     if (SCHEME_INTP(so)) {
02539       if (v < (sizeof(long) * 8))
02540         return ((((long)1 << v) & SCHEME_INT_VAL(so)) ? scheme_true : scheme_false);
02541       else
02542         return ((SCHEME_INT_VAL(so) < 0) ? scheme_true : scheme_false);
02543     } else {
02544       bigdig d;
02545       long vd, vb;
02546       vd = v / (sizeof(bigdig) * 8);
02547       vb = v & ((sizeof(bigdig) * 8) - 1);
02548       if (vd >= ((Scheme_Bignum *)so)->len)
02549         return (SCHEME_BIGPOS(so) ? scheme_false : scheme_true);
02550       if (SCHEME_BIGPOS(so)) {
02551         d = ((Scheme_Bignum *)so)->digits[vd];
02552         return ((((bigdig)1 << vb) & d) ? scheme_true : scheme_false);
02553       } else {
02554         /* Testing a bit in a negative bignum. Just use the slow way for now. */
02555         Scheme_Object *bit;
02556         bit = scheme_bignum_shift(scheme_make_bignum(1), v);
02557         if (SCHEME_INTP(bit))
02558           bit = scheme_make_bignum(SCHEME_INT_VAL(bit));
02559         bit = scheme_bignum_and(bit, so);
02560         return (SAME_OBJ(bit, scheme_make_integer(0)) ? scheme_false : scheme_true);
02561       }
02562     }
02563   } else if (SCHEME_BIGNUMP(sb) && SCHEME_BIGPOS(sb)) {
02564     if (SCHEME_INTP(so))
02565       return ((SCHEME_INT_VAL(so) < 0) ? scheme_true : scheme_false);
02566     else
02567       return (SCHEME_BIGPOS(so) ? scheme_false : scheme_true);
02568   } else {
02569     scheme_wrong_type("bitwise-bit-set?", "nonnegative exact integer", 1, argc, argv);
02570     ESCAPED_BEFORE_HERE;
02571   }
02572 }
02573 
02574 static Scheme_Object *slow_bitwise_bit_field (int argc, Scheme_Object *argv[],
02575                                               Scheme_Object *so, Scheme_Object *sb1, Scheme_Object *sb2)
02576 {
02577   Scheme_Object *a[2];
02578 
02579   if (!SCHEME_EXACT_INTEGERP(so))
02580     scheme_wrong_type("bitwise-bit-field", "exact integer", 0, argc, argv);
02581 
02582   if (!((SCHEME_INTP(sb1) && (SCHEME_INT_VAL(sb1) >= 0))
02583         || (SCHEME_BIGNUMP(sb1) && SCHEME_BIGPOS(sb1))))
02584     scheme_wrong_type("bitwise-bit-field", "nonnegative exact integer", 1, argc, argv);
02585   if (!((SCHEME_INTP(sb2) && (SCHEME_INT_VAL(sb2) >= 0))
02586         || (SCHEME_BIGNUMP(sb2) && SCHEME_BIGPOS(sb2))))
02587     scheme_wrong_type("bitwise-bit-field", "nonnegative exact integer", 2, argc, argv);
02588 
02589   if (!scheme_bin_lt_eq(sb1, sb2))
02590     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02591                      "bitwise-bit-field: first index: %V is more than second index: %V",
02592                      sb1, sb2);
02593   
02594   sb2 = scheme_bin_minus(sb2, sb1);
02595   sb1 = scheme_bin_minus(scheme_make_integer(0), sb1);
02596   
02597   a[0] = so;
02598   a[1] = sb1;
02599   so = scheme_bitwise_shift(2, a);
02600   
02601   a[0] = scheme_make_integer(1);
02602   a[1] = sb2;
02603   sb2 = scheme_bitwise_shift(2, a);
02604   
02605   sb2 = scheme_bin_minus(sb2, scheme_make_integer(1));
02606   
02607   a[0] = so;
02608   a[1] = sb2;
02609   return scheme_bitwise_and(2, a);    
02610 }
02611 
02612 static Scheme_Object *bitwise_bit_field (int argc, Scheme_Object *argv[])
02613 {
02614   Scheme_Object *so, *sb1, *sb2;
02615 
02616   so = argv[0];
02617   sb1 = argv[1];
02618   sb2 = argv[2];
02619   if (SCHEME_EXACT_INTEGERP(so)) {
02620     /* Fast path is when sb1 < sizeof(long), sb2 - sb1 < sizeof(long),
02621        and argument is positive (though the fixnum negative case is also
02622        handled here). */
02623     if (SCHEME_INTP(sb1)) {
02624       long v1;
02625       v1 = SCHEME_INT_VAL(sb1);
02626       if (v1 >= 0) {
02627         if (SCHEME_INTP(sb2)) {
02628           long v2;
02629           v2 = SCHEME_INT_VAL(sb2);
02630           if (v2 >= v1) {
02631             v2 -= v1;
02632             if (v2 < (sizeof(long) * 8)) {
02633               if (SCHEME_INTP(so)) {
02634                 if (v1 < (sizeof(long) * 8)) {
02635                   long res;
02636                   res = ((SCHEME_INT_VAL(so) >> v1) & ((1 << v2) - 1));
02637                   return scheme_make_integer(res);
02638                 } else if (SCHEME_INT_VAL(so) > 0) 
02639                   return scheme_make_integer(0);
02640               } else if (SCHEME_BIGPOS(so)) {
02641                 bigdig d;
02642                 long vd, vb, avail;
02643                 vd = v1 / (sizeof(bigdig) * 8);
02644                 vb = v1 & ((sizeof(bigdig) * 8) - 1);
02645                 if (vd >= ((Scheme_Bignum *)so)->len)
02646                   return scheme_make_integer(0);
02647                 d = ((Scheme_Bignum *)so)->digits[vd];
02648                 d >>= vb;
02649                 avail = (sizeof(bigdig) * 8) - vb;
02650                 if ((avail < v2)
02651                     && ((vd + 1) < ((Scheme_Bignum *)so)->len)) {
02652                   /* Pull in more bits from next digit: */
02653                   d |= (((Scheme_Bignum *)so)->digits[vd + 1] << avail);
02654                 }
02655                 d = (d & ((1 << v2) - 1));
02656                 return scheme_make_integer(d);
02657               }
02658             }
02659           }
02660         }
02661       }
02662     }
02663   }
02664 
02665   return slow_bitwise_bit_field(argc, argv, so, sb1, sb2);
02666 }
02667 
02668 static Scheme_Object *
02669 integer_length(int argc, Scheme_Object *argv[])
02670 {
02671   Scheme_Object *o = argv[0];
02672   unsigned long n;
02673   int base;
02674 
02675   if (SCHEME_INTP(o)) {
02676     long a = SCHEME_INT_VAL(o);
02677 
02678     if (a < 0)
02679       a = ~a;
02680     
02681     n = a;
02682     base = 0;
02683   } else if (_SCHEME_TYPE(o) == scheme_bignum_type) {
02684     bigdig d;
02685 
02686     if (!SCHEME_BIGPOS(o)) {
02687       /* Maybe we could do better... */
02688       o = scheme_bignum_not(o);
02689     }
02690 
02691     base = ((Scheme_Bignum *)o)->len;
02692     d = ((Scheme_Bignum *)o)->digits[base - 1];
02693     base = (base - 1) * (sizeof(bigdig) * 8);
02694 
02695 #ifdef USE_LONG_LONG_FOR_BIGDIG
02696     n = (unsigned long)d;
02697     if ((bigdig)n != d) {
02698       /* Must have been overflow */
02699       d >>= (sizeof(unsigned long) * 8);
02700       base += (sizeof(unsigned long) * 8);
02701       n = (unsigned long)d;
02702     }
02703 #else
02704     n = d;
02705 #endif
02706   } else {
02707     scheme_wrong_type("integer-length", "exact integer", 0, argc, argv);
02708     ESCAPED_BEFORE_HERE;
02709   }
02710 
02711   while (n) {
02712     n >>= 1;
02713     base++;
02714   }
02715 
02716   return scheme_make_integer(base);
02717 }
02718 
02719 long scheme_integer_length(Scheme_Object *n)
02720 {
02721   Scheme_Object *a[1], *r;
02722   a[0] = n;
02723   r = integer_length(1, a);
02724   return SCHEME_INT_VAL(r);
02725 }