Back to index

plt-scheme  4.2.1
nummacs.h
Go to the documentation of this file.
00001 /*
00002   Mzscheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995 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 #define NEED_NUMBER(name) \
00027   scheme_wrong_type(#name, "number", 0, argc, argv)
00028 #define NEED_REAL(name) \
00029   scheme_wrong_type(#name, REAL_NUMBER_STR, 0, argc, argv)
00030 #define NEED_INTEGER(name) \
00031   scheme_wrong_type(#name, "integer", 0, argc, argv)
00032 
00033 #define rat_from_float(d, sr) force_rat(scheme_rational_from_float(d), sr)
00034 #define rat_from_double(d, sr) force_rat(scheme_rational_from_double(d), sr)
00035 
00036 #ifdef MZ_USE_SINGLE_FLOATS
00037 # define FLOATWRAP(x) x
00038 # ifdef USE_SINGLE_FLOATS_AS_DEFAULT
00039 #  define D_FLOATWRAP(x) /* empty */
00040 #  define S_FLOATWRAP(x) x
00041 # else
00042 #  define D_FLOATWRAP(x) x
00043 #  define S_FLOATWRAP(x) /* empty */
00044 # endif
00045 #else
00046 # define FLOATWRAP(x) /* empty */
00047 # define D_FLOATWRAP(x) x
00048 # define S_FLOATWRAP(x) /* empty */
00049 #endif
00050 
00051 #define GEN_BIN_COMP_PROT(name) \
00052 static int name (Scheme_Object *n1, Scheme_Object *n2)
00053 
00054 #define GEN_NARY_COMP(name, scheme_name, bin_name, TYPEP, type) \
00055 static Scheme_Object *name (int argc, Scheme_Object *argv[]); \
00056 static MZ_INLINE Scheme_Object * \
00057 name ## __slow (Scheme_Object *p, int argc, Scheme_Object *argv[]) \
00058 { \
00059   Scheme_Object *o; \
00060   int i; \
00061   for (i = 1; i < argc; i++) {\
00062     o = argv[i]; \
00063     if (!TYPEP(o)) { \
00064       scheme_wrong_type(scheme_name, type, i, argc, argv); \
00065       return NULL; \
00066     } \
00067     if (!bin_name(p, o)) { \
00068         for (i++; i < argc; i++) { \
00069           if (!TYPEP(argv[i])) \
00070            scheme_wrong_type(scheme_name, type, i, argc, argv); \
00071         } \
00072         return scheme_false; \
00073     } \
00074     p = o; \
00075   } \
00076   return scheme_true; \
00077 } \
00078 static MZ_INLINE Scheme_Object *name ## __bin(Scheme_Object *a, Scheme_Object *b) { \
00079   return (bin_name(a, b) ? scheme_true : scheme_false); \
00080 } \
00081 Scheme_Object * \
00082 name (int argc, Scheme_Object *argv[]) \
00083 { \
00084   Scheme_Object *p, *p2; \
00085   p = argv[0]; \
00086   if (!TYPEP(p)) \
00087    scheme_wrong_type(scheme_name, type, 0, argc, argv); \
00088   if (argc == 2) { \
00089     p2 = argv[1]; \
00090     if (!TYPEP(p2)) \
00091       scheme_wrong_type(scheme_name, type, 1, argc, argv); \
00092     return name ## __bin(p, p2); \
00093   } else \
00094     return name ## __slow(p, argc, argv); \
00095 }
00096 
00097 #define GEN_BIN_PROT(name) \
00098 static Scheme_Object *name (const Scheme_Object *n1, const Scheme_Object *n2)
00099 
00100 #define cx_NO_CHECK(n1, n2) /* empty */
00101 
00102 /* This macro is used to implement most all binary math and comparison functions (!): */
00103 #define GEN_BIN_THING(rettype, name, scheme_name, \
00104                       iop, fop, fsop, bn_op, rop, cxop, \
00105                       wrap, combineinf, \
00106                       waybigf, swaybigf, waysmallf, swaysmallf, \
00107                       waybigs, swaybigs, waysmalls, swaysmalls, \
00108                       combinezero, firstzero, sfirstzero, secondzero, ssecondzero, \
00109                       nanchk, snanchk, nanchk_more, snanchk_more, \
00110                       complexwrap, noniziwrap, exactzerowrapl, exactzerowrapr, numbertype,\
00111                       toi_or_toe, \
00112                       check_exact_zero1, check_exact_one1, check_exact_zero2, check_exact_one2) \
00113 rettype name (const Scheme_Object *n1, const Scheme_Object *n2); \
00114 static rettype name ## __wrong_type(const Scheme_Object *v) \
00115 { \
00116   Scheme_Object *a[1]; \
00117   a[0] = (Scheme_Object *)v; \
00118   scheme_wrong_type(scheme_name, numbertype, -1, 0, a); \
00119   return 0; \
00120 } \
00121 static MZ_INLINE rettype name ## __int_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
00122         Small_Bignum sb; \
00123         check_exact_zero1(n1, n2); \
00124         check_exact_one1(n1, n2); \
00125         return bn_op((scheme_make_small_bignum(SCHEME_INT_VAL(n1), \
00126                                           &sb)), \
00127                    (n2)); \
00128 } \
00129 static MZ_INLINE rettype name ## __int_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \
00130   Small_Rational sr1; \
00131   check_exact_zero1(n1, n2); \
00132   check_exact_one1(n1, n2); \
00133   return rop((scheme_make_small_rational(SCHEME_INT_VAL(n1), \
00134                                     &sr1)), \
00135             (n2)); \
00136 } \
00137 complexwrap( \
00138 static MZ_INLINE rettype name ## __int_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \
00139   Small_Complex sc; \
00140   check_exact_zero1(n1, n2); \
00141   check_exact_one1(n1, n2); \
00142   return cxop((scheme_make_small_complex(n1, &sc)), \
00143               (n2)); \
00144 }) \
00145 FLOATWRAP( \
00146 static MZ_INLINE rettype name ## __flt_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
00147   Small_Rational sr2; \
00148   snanchk_more(d1); \
00149   wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \
00150   wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \
00151   return toi_or_toe(fsop(d1, scheme_bignum_to_float(n2)), \
00152                     rop(rat_from_float(d1, &sr2), scheme_integer_to_rational(n2))); \
00153 }) \
00154 FLOATWRAP( \
00155 static MZ_INLINE rettype name ## __flt_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \
00156   Small_Rational sr3; \
00157   snanchk_more(d1); \
00158   wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(swaybigf, n2);) \
00159   wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(swaysmallf, n2);) \
00160   wrap(if (d1 == 0.0) return combinezero(sfirstzero, n2, d1);) \
00161   return toi_or_toe(fsop(d1, scheme_rational_to_float(n2)), \
00162                     rop(rat_from_float(d1, &sr3), (n2))); \
00163 })\
00164 FLOATWRAP(complexwrap(  \
00165 static MZ_INLINE rettype name ## __flt_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \
00166   Small_Complex sc; \
00167   snanchk_more(d1); \
00168   return cxop((scheme_make_small_complex(n1, &sc)), \
00169   (n2)); \
00170 }))    \
00171 static MZ_INLINE rettype name ## __dbl_big(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
00172   toi_or_toe(,Small_Rational sr4); \
00173   nanchk_more(d1); \
00174   wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \
00175   wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \
00176   return toi_or_toe(fop(d1, scheme_bignum_to_double(n2)), \
00177                     rop(rat_from_double(d1, &sr4), scheme_integer_to_rational(n2))); \
00178 } \
00179 static MZ_INLINE rettype name ## __dbl_rat(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
00180   toi_or_toe(,Small_Rational sr5);       \
00181   nanchk_more(d1); \
00182   wrap(if (MZ_IS_POS_INFINITY(d1)) return combineinf(waybigf, n2);) \
00183   wrap(if (MZ_IS_NEG_INFINITY(d1)) return combineinf(waysmallf, n2);) \
00184   wrap(if (d1 == 0.0) return combinezero(firstzero, n2, d1);) \
00185   return toi_or_toe(fop(d1, scheme_rational_to_double(n2)), \
00186                     rop(rat_from_double(d1, &sr5), (n2))); \
00187 } \
00188 complexwrap( \
00189 static MZ_INLINE rettype name ## __dbl_comp(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
00190   Small_Complex sc; \
00191   nanchk_more(d1); \
00192   return cxop((scheme_make_small_complex(n1, &sc)), \
00193              (n2)); \
00194 }) \
00195 static MZ_INLINE rettype name ## __big_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
00196   Small_Bignum sb; \
00197   check_exact_zero2(n2, n1); \
00198   check_exact_one2(n2, n1); \
00199   return bn_op((n1), (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \
00200 } \
00201 FLOATWRAP( \
00202 static MZ_INLINE rettype name ## __big_flt(double d1, const Scheme_Object *n1, const Scheme_Object *n2) { \
00203   Small_Rational sr6; \
00204   float d2; \
00205   d2 = SCHEME_FLT_VAL(n2); \
00206   snanchk_more(d2); \
00207   wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \
00208   wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \
00209   return toi_or_toe(fsop(scheme_bignum_to_float(n1), d2), \
00210                     rop(scheme_integer_to_rational(n1), rat_from_float(d2, &sr6))); \
00211 }) \
00212 static MZ_INLINE rettype name ## __big_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \
00213   double d2; \
00214   toi_or_toe(,Small_Rational sr7); \
00215   d2 = SCHEME_DBL_VAL(n2); \
00216   nanchk_more(d2); \
00217   wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \
00218   wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \
00219   return toi_or_toe(fop(scheme_bignum_to_double(n1), d2), \
00220                     rop(scheme_integer_to_rational(n1), rat_from_double(d2, &sr7))); \
00221 } \
00222 static MZ_INLINE rettype name ## __big_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \
00223   return rop(scheme_integer_to_rational(n1), (n2)); \
00224 } \
00225 static MZ_INLINE rettype name ## __big_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \
00226   Small_Complex sc; \
00227   return cxop((scheme_make_small_complex(n1, &sc)), (n2)); \
00228 } \
00229 static MZ_INLINE rettype name ## __rat_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
00230   Small_Rational sr8; \
00231   check_exact_zero2(n2, n1); \
00232   check_exact_one2(n2, n1); \
00233   return rop((n1), \
00234              (scheme_make_small_rational(SCHEME_INT_VAL(n2), \
00235                                          &sr8))); \
00236 } \
00237 FLOATWRAP( \
00238 static MZ_INLINE rettype name ## __rat_flt(const Scheme_Object *n1, const Scheme_Object *n2) { \
00239   Small_Rational sr9; \
00240   float d2; \
00241   d2 = SCHEME_FLT_VAL(n2); \
00242   snanchk_more(d2); \
00243   wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(swaysmalls, n1);) \
00244   wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(swaybigs, n1);) \
00245   wrap(if (d2 == 0.0) return combinezero(ssecondzero, n1, d2);) \
00246   return toi_or_toe(fsop(scheme_rational_to_float(n1), d2), \
00247                     rop((n1), rat_from_float(d2, &sr9))); \
00248 }) \
00249 static MZ_INLINE rettype name ## __rat_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \
00250   double d2; \
00251   toi_or_toe(,Small_Rational sr10);      \
00252   d2 = SCHEME_DBL_VAL(n2); \
00253   nanchk_more(d2); \
00254   wrap(if (MZ_IS_POS_INFINITY(d2)) return combineinf(waysmalls, n1);) \
00255   wrap(if (MZ_IS_NEG_INFINITY(d2)) return combineinf(waybigs, n1);) \
00256   wrap(if (d2 == 0.0) return combinezero(secondzero, n1, d2);) \
00257   return toi_or_toe(fop(scheme_rational_to_double(n1), d2), \
00258                     rop((n1), rat_from_double(d2, &sr10))); \
00259 } \
00260 static MZ_INLINE rettype name ## __rat_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
00261   return rop((n1), scheme_integer_to_rational(n2)); \
00262 } \
00263 complexwrap( \
00264 static MZ_INLINE rettype name ## __rat_comp(const Scheme_Object *n1, const Scheme_Object *n2) { \
00265   Small_Complex sc; \
00266   return cxop((scheme_make_small_complex(n1, &sc)), (n2)); \
00267 }) \
00268 complexwrap( \
00269 static MZ_INLINE rettype name ## __comp_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
00270   Small_Complex sc; \
00271   check_exact_zero2(n2, n1); \
00272   check_exact_one2(n2, n1); \
00273   return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
00274 }) \
00275 FLOATWRAP(complexwrap( \
00276 static MZ_INLINE rettype name ## __comp_flt(const Scheme_Object *n1, const Scheme_Object *n2) { \
00277   Small_Complex sc; \
00278   snanchk_more(SCHEME_FLT_VAL(n2)); \
00279   return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
00280 }))                                                  \
00281 complexwrap( \
00282 static MZ_INLINE rettype name ## __comp_dbl(const Scheme_Object *n1, const Scheme_Object *n2) { \
00283   Small_Complex sc; \
00284   nanchk_more(SCHEME_DBL_VAL(n2)); \
00285   return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
00286 }) \
00287 complexwrap( \
00288 static MZ_INLINE rettype name ## __comp_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
00289   Small_Complex sc; \
00290   return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
00291 }) \
00292 complexwrap( \
00293 static MZ_INLINE rettype name ## __comp_rat(const Scheme_Object *n1, const Scheme_Object *n2) { \
00294   Small_Complex sc; \
00295   return cxop((n1), (scheme_make_small_complex(n2, &sc))); \
00296 }) \
00297 rettype \
00298 name (const Scheme_Object *n1, const Scheme_Object *n2) \
00299 { \
00300   Scheme_Type t1, t2; \
00301   exactzerowrapr( if (n2 == zeroi) ) \
00302   if (SCHEME_INTP(n1)) \
00303     { \
00304       exactzerowrapl( if (n1 == zeroi) ) \
00305       if (SCHEME_INTP(n2)) \
00306        return iop(SCHEME_INT_VAL(n1), SCHEME_INT_VAL(n2)); \
00307       t2 = _SCHEME_TYPE(n2); \
00308       FLOATWRAP( \
00309       if (t2 == scheme_float_type) { \
00310         float d = SCHEME_FLT_VAL(n2); \
00311         snanchk(d); \
00312         return fsop(SCHEME_INT_VAL(n1), d); \
00313       } \
00314       ) \
00315       if (t2 == scheme_double_type) { \
00316         double d = SCHEME_DBL_VAL(n2); \
00317         nanchk(d); \
00318         return fop(SCHEME_INT_VAL(n1), d); \
00319       } \
00320       if (t2 == scheme_bignum_type) { \
00321         return name ## __int_big(n1, n2); \
00322        } \
00323        if (t2 == scheme_rational_type) { \
00324         return name ## __int_rat(n1, n2); \
00325        } \
00326       complexwrap( \
00327       if (noniziwrap((t2 == scheme_complex_type))) {        \
00328         return name ## __int_comp(n1, n2); \
00329       } \
00330       ) \
00331       return name ## __wrong_type(n2); \
00332     } \
00333   else { \
00334    t1 = _SCHEME_TYPE(n1); \
00335    FLOATWRAP( \
00336    if (t1 == scheme_float_type) \
00337     { \
00338       float d1 = SCHEME_FLT_VAL(n1); \
00339       if (SCHEME_INTP(n2)) { \
00340         snanchk(d1); \
00341         return fsop(d1, SCHEME_INT_VAL(n2)); \
00342       } \
00343       t2 = _SCHEME_TYPE(n2); \
00344       if (t2 == scheme_float_type) { \
00345         float d2 = SCHEME_FLT_VAL(n2); \
00346         snanchk(d1); \
00347         snanchk(d2); \
00348         return fsop(d1, d2); \
00349       } \
00350       if (t2 == scheme_double_type) { \
00351         double d2 = SCHEME_DBL_VAL(n2); \
00352         nanchk(d1); \
00353         nanchk(d2); \
00354         return fop(d1, d2); \
00355       } \
00356       if (t2 == scheme_bignum_type) { \
00357         return name ## __flt_big(n1, n2); \
00358       } \
00359        if (t2 == scheme_rational_type) { \
00360         return name ## __flt_rat(n1, n2); \
00361       } \
00362       complexwrap( \
00363        if (noniziwrap((t2 == scheme_complex_type))) { \
00364         return name ## __flt_comp(n1, n2); \
00365       } \
00366       )\
00367       return name ## __wrong_type(n2); \
00368     } else \
00369    ) \
00370    if (t1 == scheme_double_type) \
00371     { \
00372       double d1 = SCHEME_DBL_VAL(n1); \
00373       if (SCHEME_INTP(n2)) { \
00374         nanchk(d1); \
00375         return fop(d1, SCHEME_INT_VAL(n2)); \
00376       } \
00377       t2 = _SCHEME_TYPE(n2); \
00378       FLOATWRAP( \
00379       if (t2 == scheme_float_type) { \
00380         double d2 = SCHEME_FLT_VAL(n2); \
00381         nanchk(d1); \
00382         nanchk(d2); \
00383         return fop(d1, d2); \
00384       } \
00385       ) \
00386       if (t2 == scheme_double_type) { \
00387         double d2 = SCHEME_DBL_VAL(n2); \
00388         nanchk(d1); \
00389         nanchk(d2); \
00390         return fop(d1, d2); \
00391       } \
00392       if (t2 == scheme_bignum_type) { \
00393         return name ## __dbl_big(d1, n1, n2);    \
00394       } \
00395        if (t2 == scheme_rational_type) { \
00396          return name ## __dbl_rat(d1, n1, n2);   \
00397       } \
00398       complexwrap( \
00399       if (noniziwrap((t2 == scheme_complex_type))) { \
00400         return name ## __dbl_comp(d1, n1, n2); \
00401       } \
00402       )\
00403       return name ## __wrong_type(n2); \
00404     } \
00405   else if (t1 == scheme_bignum_type) \
00406     { \
00407       if (SCHEME_INTP(n2)) { \
00408         return name ## __big_int(n1, n2); \
00409       } \
00410       t2 = _SCHEME_TYPE(n2); \
00411       FLOATWRAP( \
00412       if (t2 == scheme_float_type) { \
00413         return name ## __big_flt(n1, n2); \
00414       } \
00415       ) \
00416       if (t2 == scheme_double_type) { \
00417         return name ## __big_dbl(n1, n2); \
00418        } \
00419        if (t2 == scheme_bignum_type) \
00420          return bn_op((n1), (n2)); \
00421        if (t2 == scheme_rational_type) \
00422         return name ## __big_rat(n1, n2); \
00423        complexwrap( \
00424        if (noniziwrap((t2 == scheme_complex_type))) { \
00425         return name ## __big_comp(n1, n2); \
00426        } \
00427        )\
00428        return name ## __wrong_type(n2); \
00429     } \
00430   else if (t1 == scheme_rational_type) \
00431     { \
00432       if (SCHEME_INTP(n2)) { \
00433          return name ## __rat_int(n1, n2); \
00434       } \
00435       t2 = _SCHEME_TYPE(n2); \
00436       FLOATWRAP( \
00437       if (t2 == scheme_float_type) { \
00438          return name ## __rat_flt(n1, n2); \
00439        } \
00440        ) \
00441        if (t2 == scheme_double_type) { \
00442          return name ## __rat_dbl(n1, n2); \
00443        } \
00444        if (t2 == scheme_bignum_type) \
00445          return name ## __rat_big(n1, n2); \
00446        if (t2 == scheme_rational_type) \
00447         return rop((n1), (n2)); \
00448        complexwrap( \
00449        if (noniziwrap((t2 == scheme_complex_type))) { \
00450          return name ## __rat_comp(n1, n2); \
00451        } \
00452        )\
00453        return name ## __wrong_type(n2); \
00454     } \
00455   complexwrap( \
00456   else if (noniziwrap((t1 == scheme_complex_type))) \
00457     { \
00458        if (SCHEME_INTP(n2)) \
00459          return name ## __comp_int(n1, n2); \
00460        t2 = _SCHEME_TYPE(n2); \
00461        FLOATWRAP( \
00462        if (t2 == scheme_float_type) { \
00463          return name ## __comp_flt(n1, n2); \
00464        } \
00465        ) \
00466        if (t2 == scheme_double_type) { \
00467          return name ## __comp_dbl(n1, n2); \
00468        } \
00469        if (t2 == scheme_bignum_type) \
00470          return name ## __comp_big(n1, n2); \
00471        if (t2 == scheme_rational_type) \
00472          return name ## __comp_rat(n1, n2); \
00473        if (noniziwrap((t2 == scheme_complex_type))) \
00474         return cxop((n1), (n2)); \
00475        return name ## __wrong_type(n2); \
00476     } \
00477   ) \
00478   else \
00479        return name ## __wrong_type(n1); \
00480   } \
00481 }
00482 
00483 #ifdef NAN_EQUALS_ANYTHING
00484 # define GR_NAN_CHK(n2) MZ_IS_NAN(SCHEME_FLOAT_VAL(n2))
00485 #else
00486 # define GR_NAN_CHK(n2) 0
00487 #endif
00488 
00489 #define GEN_IDENT(x) x
00490 #define GEN_OMIT(x) 
00491 #define GEN_FIRST_ONLY(x, y) x
00492 #define GEN_APPLY(x, y) x(y)
00493 #define GEN_APPLY3(x, y, z) x(y, z)
00494 #define GEN_SCHEME_BOOL_APPLY(x, y, z) x(y)
00495 #define GEN_TOI(x, y) x
00496 #define GEN_TOE(x, y) y
00497 
00498 #define GEN_RETURN_0(x) x return zeroi;
00499 #define GEN_RETURN_0_USUALLY(x) x if (!SCHEME_FLOATP(n2) || GR_NAN_CHK(n2) || (SCHEME_FLOAT_VAL(n2) != 0)) return zeroi;
00500 #define GEN_RETURN_1(x) x return scheme_make_integer(1);
00501 #define GEN_RETURN_N1(x) x return (Scheme_Object *)n1;
00502 #define GEN_RETURN_N2(x) x return (Scheme_Object *)n2;
00503 #define GEN_SINGLE_SUBTRACT_N2(x) x if SCHEME_FLOATP(n2) return unary_minus(n2);
00504 
00505 #define GEN_SAME_INF(x) (scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object)
00506 #define GEN_OPP_INF(x) (!scheme_is_positive(x) ? scheme_inf_object : scheme_minus_inf_object)
00507 #define GEN_MAKE_PZERO(x) (!scheme_is_positive(x) ? scheme_nzerod : scheme_zerod)
00508 #define GEN_MAKE_NZERO(x) (!scheme_is_positive(x) ? scheme_zerod : scheme_nzerod)
00509 #define GEN_MAKE_ZERO_Z(x, y) (scheme_minus_zero_p(y) ? GEN_MAKE_NZERO(x) : GEN_MAKE_PZERO(x))
00510 #define GEN_SAME_INF_Z(x, y) (scheme_minus_zero_p(y) ?  GEN_OPP_INF(x) : GEN_SAME_INF(x))
00511 
00512 #define GEN_SAME_SINF(x) (scheme_is_positive(x) ? scheme_single_inf_object : scheme_single_minus_inf_object)
00513 #define GEN_OPP_SINF(x) (!scheme_is_positive(x) ? scheme_single_inf_object : scheme_single_minus_inf_object)
00514 #define GEN_MAKE_PSZERO(x) (!scheme_is_positive(x) ? scheme_nzerof : scheme_zerof)
00515 #define GEN_MAKE_NSZERO(x) (!scheme_is_positive(x) ? scheme_zerof : scheme_nzerof)
00516 #define GEN_MAKE_SZERO_Z(x, y) (scheme_minus_zero_p(y) ? GEN_MAKE_NSZERO(x) : GEN_MAKE_PSZERO(x))
00517 #define GEN_SAME_SINF_Z(x, y) (scheme_minus_zero_p(y) ?  GEN_OPP_SINF(x) : GEN_SAME_SINF(x))
00518 
00519 #define NO_NAN_CHECK(x) /* empty */
00520 #define NAN_RETURNS_NAN(x) if (MZ_IS_NAN(x)) return scheme_nan_object
00521 #define NAN_RETURNS_SNAN(x) if (MZ_IS_NAN(x)) return scheme_single_nan_object
00522 
00523 #ifdef NAN_EQUALS_ANYTHING
00524 # define NAN_CHECK_0_IF_WEIRD(x) if (MZ_IS_NAN(x)) return 0
00525 # define NAN_CHECK_NAN_IF_WEIRD(x) if (MZ_IS_NAN(x)) return scheme_nan_object
00526 # define SNAN_CHECK_NAN_IF_WEIRD(x) if (MZ_IS_NAN(x)) return scheme_single_nan_object
00527 #else
00528 # define NAN_CHECK_0_IF_WEIRD(x) /* empty */
00529 # define NAN_CHECK_NAN_IF_WEIRD(x) /* empty */
00530 # define SNAN_CHECK_NAN_IF_WEIRD(x) /* empty */
00531 #endif
00532 
00533 # define NAN_CHECK_0(x) if (MZ_IS_NAN(x)) return 0
00534 
00535 #define GEN_BIN_OP(name, scheme_name, iop, fop, fsop, bn_op, rop, cxop, exzeopl, exzeopr, nanckop, snanckop, c0_1, c1_1, c0_2, c1_2) \
00536   GEN_BIN_THING(Scheme_Object *, name, scheme_name, \
00537                 iop, fop, fsop, bn_op, rop, cxop, \
00538                 GEN_OMIT, GEN_FIRST_ONLY, \
00539                 0, 0, 0, 0, \
00540                 0, 0, 0, 0, \
00541                 GEN_SCHEME_BOOL_APPLY, badfunc, badfunc, badfunc, badfunc, \
00542                 nanckop, snanckop, nanckop, snanckop, \
00543                 GEN_IDENT, GEN_IDENT, exzeopl, exzeopr, "number", GEN_TOI, \
00544                 c0_1, c1_1, c0_2, c1_2)
00545 
00546 #define GEN_BIN_DIV_OP(name, scheme_name, iop, fop, fsop, bn_op, rop, cxop, c0_1, c1_1, c0_2, c1_2) \
00547   GEN_BIN_THING(Scheme_Object *, name, scheme_name, \
00548                 iop, fop, fsop, bn_op, rop, cxop, \
00549                 GEN_IDENT, GEN_APPLY, \
00550                 GEN_SAME_INF, GEN_SAME_SINF, GEN_OPP_INF, GEN_OPP_SINF, \
00551                 GEN_MAKE_NZERO, GEN_MAKE_NSZERO, GEN_MAKE_PZERO, GEN_MAKE_PSZERO, \
00552                 GEN_APPLY3, GEN_MAKE_ZERO_Z, GEN_MAKE_SZERO_Z, GEN_SAME_INF_Z, GEN_SAME_SINF_Z, \
00553                 NAN_CHECK_NAN_IF_WEIRD, SNAN_CHECK_NAN_IF_WEIRD, NAN_CHECK_NAN_IF_WEIRD, SNAN_CHECK_NAN_IF_WEIRD, \
00554                 GEN_IDENT, GEN_IDENT, GEN_RETURN_0, GEN_OMIT, "number", GEN_TOI, \
00555                 c0_1, c1_1, c0_2, c1_2)
00556 
00557 #define GEN_BIN_COMP(name, scheme_name, iop, fop, bn_op, rop, cxop, waybig, waysmall, firstzero, secondzero, complexwrap, noniziwrap, numbertype) \
00558  GEN_BIN_THING(int, name, scheme_name, \
00559                iop, fop, fop, bn_op, rop, cxop, \
00560                GEN_IDENT, GEN_FIRST_ONLY, \
00561                waybig, waybig, waysmall, waysmall, \
00562                waybig, waybig, waysmall, waysmall, \
00563                GEN_SCHEME_BOOL_APPLY, firstzero, firstzero, secondzero, secondzero, \
00564                NAN_CHECK_0_IF_WEIRD, NAN_CHECK_0_IF_WEIRD, NAN_CHECK_0, NAN_CHECK_0, \
00565                complexwrap, noniziwrap, GEN_OMIT, GEN_OMIT, numbertype, GEN_TOE, \
00566                cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK, cx_NO_CHECK)
00567 
00568 #define GEN_BIN_INT_OP(name, scheme_name, op, bigop) \
00569 static Scheme_Object *name (const Scheme_Object *n1, const Scheme_Object *n2); \
00570 static Scheme_Object *name ## __wrong_type(const Scheme_Object *v) \
00571 { \
00572   Scheme_Object *a[1]; \
00573   a[0] = (Scheme_Object *)v; \
00574   scheme_wrong_type(scheme_name, "exact integer", -1, 0, a); \
00575   return NULL; \
00576 } \
00577 static MZ_INLINE Scheme_Object * name ## __int_big(const Scheme_Object *n1, const Scheme_Object *n2) { \
00578   Small_Bignum sb; \
00579   return bigop((scheme_make_small_bignum(SCHEME_INT_VAL(n1), &sb)), n2); \
00580 } \
00581 static MZ_INLINE Scheme_Object * name ## __big_int(const Scheme_Object *n1, const Scheme_Object *n2) { \
00582   Small_Bignum sb; \
00583   return bigop(n1, (scheme_make_small_bignum(SCHEME_INT_VAL(n2), &sb))); \
00584 } \
00585 static Scheme_Object * \
00586 name (const Scheme_Object *n1, const Scheme_Object *n2) \
00587 { \
00588   if (SCHEME_INTP(n1)){ \
00589     if (SCHEME_INTP(n2)) { \
00590       long a, b; \
00591       a = SCHEME_INT_VAL(n1); \
00592       b = SCHEME_INT_VAL(n2); \
00593       return scheme_make_integer(a op b); \
00594     } else if (SCHEME_BIGNUMP(n2)) { \
00595       return name ## __int_big(n1, n2); \
00596     } \
00597   } else if (SCHEME_BIGNUMP(n1)) { \
00598     if (SCHEME_INTP(n2)) { \
00599       return name ## __big_int(n1, n2); \
00600     } \
00601     if (SCHEME_BIGNUMP(n2)) \
00602       return bigop(n1, n2); \
00603   } else { \
00604     return name ## __wrong_type(n1);       \
00605   } \
00606  \
00607   return name ## __wrong_type(n2); \
00608 }
00609 
00610 #define GEN_NARY_OP(stat, name, scheme_name, bin_name, ident, TYPEP, type, single) \
00611 stat Scheme_Object *name (int argc, Scheme_Object *argv[]); \
00612 static MZ_INLINE Scheme_Object * \
00613 name ## __slow (Scheme_Object *ret, int argc, Scheme_Object *argv[])  \
00614 { \
00615   int i; \
00616   for (i = 1 ; i<argc ; ++i ) { \
00617     Scheme_Object *o; \
00618     o = argv[i]; \
00619     if (!TYPEP(o)) { scheme_wrong_type(scheme_name, type, i, argc, argv); return NULL; } \
00620     ret = bin_name (ret, o); \
00621   } \
00622   return (ret); \
00623 }\
00624 Scheme_Object * \
00625 name (int argc, Scheme_Object *argv[]) \
00626 { \
00627   Scheme_Object *ret;                          \
00628   if (!argc) return scheme_make_integer(ident); \
00629   ret = argv[0]; \
00630   if (!TYPEP(ret)) { scheme_wrong_type(scheme_name, type, 0, argc, argv); return NULL; } \
00631   if (argc == 2) { \
00632     Scheme_Object *b; \
00633     b = argv[1]; \
00634     if (!TYPEP(b)) { scheme_wrong_type(scheme_name, type, 1, argc, argv); return NULL; } \
00635     return bin_name(ret, b); \
00636   } \
00637   if (argc == 1) { return single(ret); } \
00638   return name ## __slow(ret, argc, argv); \
00639 }
00640 
00641 #define GEN_TWOARY_OP(stat, name, scheme_name, bin_name, TYPEP, type) \
00642 stat Scheme_Object * name (int argc, Scheme_Object *argv[]); \
00643 static MZ_INLINE Scheme_Object * \
00644 name ## __slow (Scheme_Object *ret, int argc, Scheme_Object *argv[]) \
00645 {\
00646   int i; \
00647   for ( i=1 ; i<argc ; ++i ) { \
00648     if (!TYPEP(argv[i])) \
00649       scheme_wrong_type(scheme_name, type, i, argc, argv); \
00650     ret = bin_name (ret, argv[i]); \
00651   } \
00652   return ret; \
00653 }\
00654 Scheme_Object * \
00655 name (int argc, Scheme_Object *argv[]) \
00656 { \
00657   Scheme_Object *ret = argv[0]; \
00658   if (!TYPEP(ret)) \
00659     scheme_wrong_type(scheme_name, type, 0, argc, argv); \
00660   if (argc == 1) return ret; \
00661   if (argc == 2) { \
00662     if (!TYPEP(argv[1])) \
00663       scheme_wrong_type(scheme_name, type, 1, argc, argv); \
00664     return bin_name(ret, argv[1]); \
00665   } \
00666   return name ## __slow(ret, argc, argv); \
00667 }
00668 
00669 #define BIGNUMS_AS_DOUBLES(o) d = scheme_bignum_to_double(o);
00670 
00671 #define GEN_UNARY_OP(name, scheme_name, c_name, inf_val, sinf_val, neginf_val, sneginf_val, nan_val, snan_val, complex_fun, PRECHECK, USE_COMPLEX, BIGNUM_MODE) \
00672 static Scheme_Object * \
00673 name (int argc, Scheme_Object *argv[]) \
00674 { \
00675   Scheme_Type t; \
00676   double d; \
00677   FLOATWRAP( \
00678   D_FLOATWRAP( int is_single = 0; ) \
00679   S_FLOATWRAP( int is_double = 0; ) \
00680   ) \
00681   Scheme_Object *o = argv[0]; \
00682   PRECHECK() \
00683   if (SCHEME_INTP(o)) \
00684     d = SCHEME_INT_VAL(o); \
00685   else { \
00686    t = _SCHEME_TYPE(o); \
00687    FLOATWRAP( \
00688    if (t == scheme_float_type) { \
00689      D_FLOATWRAP( is_single = 1; ) \
00690      d = SCHEME_FLT_VAL(o); \
00691    } else ) \
00692    if (t == scheme_double_type) { \
00693      S_FLOATWRAP( is_double = 1; ) \
00694      d = SCHEME_DBL_VAL(o); \
00695    } else if (t == scheme_bignum_type) { \
00696      BIGNUM_MODE(o) \
00697    } else if (t == scheme_rational_type) { \
00698      d = scheme_rational_to_double(o); \
00699    } else if (t == scheme_complex_type) \
00700      return complex_fun(o); \
00701    else { \
00702      scheme_wrong_type(#scheme_name, "number", 0, argc, argv); \
00703      return NULL; \
00704     } \
00705   } \
00706   if (MZ_IS_NAN(d)) { FLOATWRAP(if (D_FLOATWRAP(is_single) S_FLOATWRAP(!is_double)) return snan_val; ) return nan_val; } \
00707   if (MZ_IS_POS_INFINITY(d)) { FLOATWRAP(if (D_FLOATWRAP(is_single) S_FLOATWRAP(!is_double)) return sinf_val; ) return inf_val; } \
00708   if (MZ_IS_NEG_INFINITY(d)) { FLOATWRAP(if (D_FLOATWRAP(is_single) S_FLOATWRAP(!is_double)) return sneginf_val; ) return neginf_val; } \
00709   if (USE_COMPLEX(d)) { \
00710       Small_Complex sc; \
00711       Scheme_Object *o; \
00712       FLOATWRAP( \
00713       D_FLOATWRAP( if (is_single) ) \
00714       S_FLOATWRAP( if (!is_double) ) \
00715       FLOATWRAP(    o = scheme_make_float((float)d); \
00716         else ) \
00717       ) \
00718       o = scheme_make_double(d); \
00719       return complex_fun(scheme_make_small_complex(o, &sc)); \
00720   } \
00721   d = c_name(d); \
00722   FLOATWRAP( \
00723   D_FLOATWRAP( if (is_single) ) \
00724   S_FLOATWRAP( if (!is_double) ) \
00725     FLOATWRAP(    return scheme_make_float((float)d); ) \
00726   ) \
00727   return scheme_make_double(d); \
00728 }
00729