Back to index

plt-scheme  4.2.1
numcomp.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-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 
00030 static Scheme_Object *eq (int argc, Scheme_Object *argv[]);
00031 static Scheme_Object *lt (int argc, Scheme_Object *argv[]);
00032 static Scheme_Object *gt (int argc, Scheme_Object *argv[]);
00033 static Scheme_Object *lt_eq (int argc, Scheme_Object *argv[]);
00034 static Scheme_Object *gt_eq (int argc, Scheme_Object *argv[]);
00035 static Scheme_Object *zero_p (int argc, Scheme_Object *argv[]);
00036 static Scheme_Object *positive_p (int argc, Scheme_Object *argv[]);
00037 static Scheme_Object *negative_p (int argc, Scheme_Object *argv[]);
00038 static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]);
00039 static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]);
00040 
00041 #define zeroi scheme_exact_zero
00042 
00043 void scheme_init_numcomp(Scheme_Env *env)
00044 {
00045   Scheme_Object *p;
00046 
00047   p = scheme_make_folding_prim(eq, "=", 2, -1, 1);
00048   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00049   scheme_add_global_constant("=", p, env);
00050 
00051   p = scheme_make_folding_prim(lt, "<", 2, -1, 1);
00052   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00053   scheme_add_global_constant("<", p, env);
00054 
00055   p = scheme_make_folding_prim(gt, ">", 2, -1, 1);
00056   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00057   scheme_add_global_constant(">", p, env);
00058 
00059   p = scheme_make_folding_prim(lt_eq, "<=", 2, -1, 1);
00060   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00061   scheme_add_global_constant("<=", p, env);
00062 
00063   p = scheme_make_folding_prim(gt_eq, ">=", 2, -1, 1);
00064   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00065   scheme_add_global_constant(">=", p, env);
00066 
00067   p = scheme_make_folding_prim(zero_p, "zero?", 1, 1, 1);
00068   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00069   scheme_add_global_constant("zero?", p, env);
00070 
00071   p = scheme_make_folding_prim(positive_p, "positive?", 1, 1, 1);
00072   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00073   scheme_add_global_constant("positive?", p, env);
00074 
00075   p = scheme_make_folding_prim(negative_p, "negative?", 1, 1, 1);
00076   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00077   scheme_add_global_constant("negative?", p, env);
00078 
00079   p = scheme_make_folding_prim(sch_max, "max", 1, -1, 1);
00080   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00081   scheme_add_global_constant("max", p, env);
00082 
00083   p = scheme_make_folding_prim(sch_min, "min", 1, -1, 1);
00084   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00085   scheme_add_global_constant("min", p, env);
00086 }
00087 
00088 /* Prototype needed for 3m conversion: */
00089 static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr);
00090 
00091 #ifdef MZ_XFORM
00092 START_XFORM_SKIP;
00093 #endif
00094 
00095 static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr)
00096 {
00097   Scheme_Type t = SCHEME_TYPE(n);
00098   if (t == scheme_rational_type)
00099     return n;
00100   else
00101     return scheme_make_small_bn_rational(n, sr);
00102 }
00103 
00104 #ifdef MZ_XFORM
00105 END_XFORM_SKIP;
00106 #endif
00107 
00108 GEN_NARY_COMP(eq, "=", scheme_bin_eq, SCHEME_NUMBERP, "number")
00109 GEN_NARY_COMP(lt, "<", scheme_bin_lt, SCHEME_REALP, REAL_NUMBER_STR)
00110 GEN_NARY_COMP(gt, ">", scheme_bin_gt, SCHEME_REALP, REAL_NUMBER_STR)
00111 GEN_NARY_COMP(lt_eq, "<=", scheme_bin_lt_eq, SCHEME_REALP, REAL_NUMBER_STR)
00112 GEN_NARY_COMP(gt_eq, ">=", scheme_bin_gt_eq, SCHEME_REALP, REAL_NUMBER_STR)
00113 
00114 #define EQUAL(x, y) (x == y)
00115 #define LESS_THAN(x, y) (x < y)
00116 #define GREATER_THAN(x, y) (x > y)
00117 #define LESS_OR_EQUAL(x, y) (x <= y)
00118 #define GREATER_OR_EQUAL(x, y) (x >= y)
00119 
00120 #ifdef NAN_LT_COMPARISON_WRONG
00121 # define fLESS_THAN(x, y) (!(x >= y) && (x == x) && (y == y))
00122 # define fLESS_OR_EQUAL(x, y) (!(x > y) && (x == x) && (y == y))
00123 #else
00124 # define fLESS_THAN LESS_THAN
00125 # define fLESS_OR_EQUAL LESS_OR_EQUAL
00126 #endif
00127 
00128 #define COMP_IZI_LT(a, b) scheme_bin_lt(IZI_REAL_PART(a), IZI_REAL_PART(b))
00129 #define COMP_IZI_GT(a, b) scheme_bin_gt(IZI_REAL_PART(a), IZI_REAL_PART(b))
00130 #define COMP_IZI_LT_EQ(a, b) scheme_bin_lt_eq(IZI_REAL_PART(a), IZI_REAL_PART(b))
00131 #define COMP_IZI_GT_EQ(a, b) scheme_bin_gt_eq(IZI_REAL_PART(a), IZI_REAL_PART(b))
00132 
00133 #define GEN_IDENT_FOR_IZI GEN_OMIT
00134 
00135 GEN_BIN_COMP(scheme_bin_eq, "=", EQUAL, EQUAL, scheme_bignum_eq, scheme_rational_eq, scheme_complex_eq, 0, 0, scheme_is_inexact, scheme_is_inexact, GEN_IDENT, GEN_IDENT, "number")
00136 GEN_BIN_COMP(scheme_bin_lt, "<", LESS_THAN, fLESS_THAN, scheme_bignum_lt, scheme_rational_lt, COMP_IZI_LT, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR)
00137 GEN_BIN_COMP(scheme_bin_gt, ">", GREATER_THAN, GREATER_THAN, scheme_bignum_gt, scheme_rational_gt, COMP_IZI_GT, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR)
00138 GEN_BIN_COMP(scheme_bin_lt_eq, "<=", LESS_OR_EQUAL, fLESS_OR_EQUAL, scheme_bignum_le, scheme_rational_le, COMP_IZI_LT_EQ, 0, 1, scheme_is_positive, scheme_is_negative, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR)
00139 GEN_BIN_COMP(scheme_bin_gt_eq, ">=", GREATER_OR_EQUAL, GREATER_OR_EQUAL, scheme_bignum_ge, scheme_rational_ge, COMP_IZI_GT_EQ, 1, 0, scheme_is_negative, scheme_is_positive, GEN_IDENT_FOR_IZI, GEN_OMIT, REAL_NUMBER_STR)
00140 
00141 int
00142 scheme_is_zero(const Scheme_Object *o)
00143 {
00144   Scheme_Type t;
00145 
00146   if (SCHEME_INTP(o))
00147     return o == zeroi;
00148   t = _SCHEME_TYPE(o);
00149 #ifdef MZ_USE_SINGLE_FLOATS
00150   if (t == scheme_float_type) {
00151 # ifdef NAN_EQUALS_ANYTHING
00152     if (MZ_IS_NAN(SCHEME_FLT_VAL(o)))
00153       return 0;
00154 # endif
00155     return SCHEME_FLT_VAL(o) == 0.0f;
00156   }
00157 #endif
00158   if (t == scheme_double_type) {
00159 #ifdef NAN_EQUALS_ANYTHING
00160     if (MZ_IS_NAN(SCHEME_DBL_VAL(o)))
00161       return 0;
00162 #endif
00163     return SCHEME_DBL_VAL(o) == 0.0;
00164   }
00165   if (t == scheme_complex_type) {
00166     if (scheme_is_zero(scheme_complex_imaginary_part(o)))
00167       return scheme_is_zero(scheme_complex_real_part(o));
00168     return 0;
00169   }
00170   
00171   if ((t >= scheme_bignum_type) && (t <= scheme_complex_type))
00172     return 0;
00173  
00174   return -1;
00175 }
00176 
00177 Scheme_Object *
00178 zero_p (int argc, Scheme_Object *argv[])
00179 {
00180   int v;
00181   v = scheme_is_zero(argv[0]);
00182   if (v < 0) {
00183     NEED_REAL(zero?);
00184     ESCAPED_BEFORE_HERE;
00185   }
00186   return (v ? scheme_true : scheme_false);
00187 }
00188 
00189 int
00190 scheme_is_positive(const Scheme_Object *o)
00191 {
00192   Scheme_Type t;
00193 
00194   if (SCHEME_INTP(o))
00195     return SCHEME_INT_VAL(o) > 0;
00196   t = _SCHEME_TYPE(o);
00197 #ifdef MZ_USE_SINGLE_FLOATS
00198   if (t == scheme_float_type) {
00199     float d = SCHEME_FLT_VAL(o);
00200 # ifdef NAN_EQUALS_ANYTHING
00201     if (MZ_IS_NAN(d))
00202       return 0;
00203 # endif
00204     return d > 0;
00205   }
00206 #endif
00207   if (t == scheme_double_type) {
00208     double d = SCHEME_DBL_VAL(o);
00209 #ifdef NAN_EQUALS_ANYTHING
00210     if (MZ_IS_NAN(d))
00211       return 0;
00212 #endif
00213     return d > 0;
00214   }
00215   if (t == scheme_bignum_type)
00216     return SCHEME_BIGPOS(o);
00217   if (t == scheme_rational_type)
00218     return scheme_is_rational_positive(o);
00219 
00220   return -1;
00221 }
00222 
00223 Scheme_Object *
00224 positive_p (int argc, Scheme_Object *argv[])
00225 {
00226   int v;
00227   v = scheme_is_positive(argv[0]);
00228   if (v < 0) {
00229     NEED_REAL(positive?);
00230     ESCAPED_BEFORE_HERE;
00231   }
00232   return (v ? scheme_true : scheme_false);
00233 }
00234 
00235 int
00236 scheme_is_negative(const Scheme_Object *o)
00237 {
00238   Scheme_Type t;
00239 
00240   if (SCHEME_INTP(o))
00241     return SCHEME_INT_VAL(o) < 0;
00242   t = _SCHEME_TYPE(o);
00243 #ifdef MZ_USE_SINGLE_FLOATS
00244   if (t == scheme_float_type) {
00245     float d = SCHEME_FLT_VAL(o);
00246 # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG)
00247     if (MZ_IS_NAN(d))
00248       return 0;
00249 # endif
00250     return d < 0;
00251   }
00252 #endif
00253   if (t == scheme_double_type) {
00254     double d = SCHEME_DBL_VAL(o);
00255 # if defined(NAN_EQUALS_ANYTHING) || defined(NAN_LT_COMPARISON_WRONG)
00256     if (MZ_IS_NAN(d))
00257       return 0;
00258 #endif
00259     return d < 0;
00260   }
00261   if (t == scheme_bignum_type)
00262     return !SCHEME_BIGPOS(o);
00263   if (t == scheme_rational_type)
00264     return !scheme_is_rational_positive(o);
00265 
00266   return -1;
00267 }
00268 
00269 Scheme_Object *
00270 negative_p (int argc, Scheme_Object *argv[])
00271 {
00272   int v;
00273   v = scheme_is_negative(argv[0]);
00274   if (v < 0) {
00275     NEED_REAL(negative?);
00276     ESCAPED_BEFORE_HERE;
00277   }
00278   return (v ? scheme_true : scheme_false);
00279 }
00280 
00281 #define MAX(n1,n2) scheme_make_integer((n1>n2) ? n1 : n2)
00282 #define MIN(n1,n2) scheme_make_integer((n1<n2) ? n1 : n2)
00283 #define F_MAX(n1,n2) scheme_make_double((n1>n2) ? n1 : n2)
00284 #define F_MIN(n1,n2) scheme_make_double((n1<n2) ? n1 : n2)
00285 
00286 #define FS_MAX(n1,n2) scheme_make_float((n1>n2) ? n1 : n2)
00287 #define FS_MIN(n1,n2) scheme_make_float((n1<n2) ? n1 : n2)
00288 
00289 #define MAX_IZI(a, b) bin_max(IZI_REAL_PART(a), IZI_REAL_PART(b))
00290 #define MIN_IZI(a, b) bin_min(IZI_REAL_PART(a), IZI_REAL_PART(b))
00291 
00292 static GEN_BIN_OP(bin_max, "max", MAX, F_MAX, FS_MAX, scheme_bignum_max, scheme_rational_max, MAX_IZI, GEN_OMIT, GEN_OMIT, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
00293 static GEN_BIN_OP(bin_min, "min", MIN, F_MIN, FS_MIN, scheme_bignum_min, scheme_rational_min, MIN_IZI, GEN_OMIT, GEN_OMIT, NAN_RETURNS_NAN, NAN_RETURNS_SNAN, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
00294 
00295 GEN_TWOARY_OP(static, sch_max, "max", bin_max, SCHEME_REALP, REAL_NUMBER_STR)
00296 GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, REAL_NUMBER_STR)