Scheme_Object *scheme_rational_normalize(const Scheme_Object *o)
{
Scheme_Rational *r = (Scheme_Rational *)o;
Scheme_Object *gcd, *tmpn;
int negate = 0;
if (r->num == scheme_exact_zero)
return scheme_make_integer(0);
if (SCHEME_INTP(r->denom)) {
if (SCHEME_INT_VAL(r->denom) < 0) {
tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->denom));
r->denom = tmpn;
negate = 1;
}
} else if (!SCHEME_BIGPOS(r->denom)) {
tmpn = scheme_bignum_negate(r->denom);
r->denom = tmpn;
negate = 1;
}
if (negate) {
if (SCHEME_INTP(r->num)) {
tmpn = scheme_make_integer_value(-SCHEME_INT_VAL(r->num));
r->num = tmpn;
} else {
tmpn = scheme_bignum_negate(r->num);
r->num = tmpn;
}
}
if (r->denom == one)
return r->num;
gcd = scheme_bin_gcd(r->num, r->denom);
if (gcd == one)
return (Scheme_Object *)o;
tmpn = scheme_bin_quotient(r->num, gcd);
r->num = tmpn;
tmpn = scheme_bin_quotient(r->denom, gcd);
r->denom = tmpn;
if (r->denom == one)
return r->num;
return (Scheme_Object *)r;
}
Scheme_Object *
gvariant_to_schemeobj (GVariant *ivalue)
{
Scheme_Object *fvalue = NULL;
const gchar *fstring;
gsize length;
gsize *plength;
gint64 r1;
length = g_variant_get_size(ivalue);
plength = &length;
if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_INT64))
{
g_variant_get (ivalue,"(i)", &r1);
fvalue = scheme_make_integer_value(r1);
return fvalue;
}
else if (g_variant_is_of_type (ivalue,G_VARIANT_TYPE_STRING))
{
fstring = g_variant_get_string (ivalue, plength);
fvalue = scheme_make_utf8_string (fstring);
return fvalue;
}
return fvalue;
}
Scheme_Object *
scheme_abs(int argc, Scheme_Object *argv[])
{
Scheme_Type t;
Scheme_Object *o;
o = argv[0];
if (SCHEME_INTP(o)) {
intptr_t n = SCHEME_INT_VAL(o);
return scheme_make_integer_value(ABS(n));
}
t = _SCHEME_TYPE(o);
#ifdef MZ_USE_SINGLE_FLOATS
if (t == scheme_float_type)
return scheme_make_float(fabs(SCHEME_FLT_VAL(o)));
#endif
if (t == scheme_double_type)
return scheme_make_double(fabs(SCHEME_DBL_VAL(o)));
if (t == scheme_bignum_type) {
if (SCHEME_BIGPOS(o))
return o;
return scheme_bignum_negate(o);
}
if (t == scheme_rational_type) {
if (scheme_is_rational_positive(o))
return o;
else
return scheme_rational_negate(o);
}
NEED_REAL(abs);
ESCAPED_BEFORE_HERE;
}
static Scheme_Object *negate_simple(Scheme_Object *v)
{
if (SCHEME_INTP(v))
return scheme_make_integer_value(-SCHEME_INT_VAL(v));
else
return scheme_bignum_negate(v);
}
static Scheme_Object *
char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char->integer", "character", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
Scheme_Object *
scheme_checked_char_to_integer (int argc, Scheme_Object *argv[])
{
mzchar c;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_contract("char->integer", "char?", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
return scheme_make_integer_value(c);
}
static Scheme_Object *char_map_list (int argc, Scheme_Object *argv[])
{
int i, bottom, top, uniform;
Scheme_Object *l = scheme_null;
# define icons scheme_make_immutable_pair
for (i = 2 * (NUM_UCHAR_RANGES - 1); i >= 0; i -= 2) {
bottom = mapped_uchar_ranges[i];
top = mapped_uchar_ranges[i + 1];
if (top & URANGE_VARIES) {
top -= URANGE_VARIES;
uniform = 0;
} else
uniform = 1;
l = icons(icons(scheme_make_integer_value(bottom),
icons(scheme_make_integer_value(top),
icons((uniform ? scheme_true : scheme_false),
scheme_null))),
l);
}
return l;
}
/**
*Translating the gvariant to Scheme Object
*/
Scheme_Object *
gvariant_to_schemeobj (GVariant *ivalue)
{
gint32 i;
GVariant *temp;
const gchar *fstring;
gsize length = 0;
gsize size = 0;
gint32 r1 = 0;
gdouble r2 = 0;
Scheme_Object *fint;
Scheme_Object *fstringss;
Scheme_Object *fdouble;
Scheme_Object *sflist = NULL;
gchar *tmp;
//scheme_signal_error ("Not tuple yet");
tmp = g_variant_print (ivalue, FALSE);
fprintf (stderr, "gvariant_to_schemobj(%s)\n", tmp);
g_free (tmp);
size = g_variant_get_size (ivalue);
// fprintf (stderr, "Exploring the return value.\n");
/* if (ivalue == NULL)
{
fprintf (stderr, "Return value is <NULL>\n");
} // if (ivalue == NULL)
else // if (ivalue != NULL)
{
type = g_variant_get_type (ivalue);
typestring = g_variant_type_dup_string (type);
fprintf (stderr, "Got type %s\n", typestring);
g_free (typestring);
description = g_variant_print (ivalue, TRUE);
fprintf (stderr, "Got value %s\n", description);
g_free (description);
} // if (ivalue != NULL)*/
if (ivalue == NULL)
{
return scheme_void;
}
if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_INT32))
{
r1 = g_variant_get_int32 (ivalue);
fint = scheme_make_integer_value(r1);
return fint;
}// else if
else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_STRING))
{
fprintf ( stderr, "Type_string\n");
// scheme_signal_error ("%d", size);
fstring = g_variant_get_string(ivalue, &size);
fstringss = scheme_make_locale_string(fstring);
return fstringss;
}// else if
else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_BYTESTRING))
{
fprintf (stderr, "Bytestring\n");
scheme_signal_error("stringbyeerror");
fstring = g_variant_get_bytestring (ivalue);
fstringss = scheme_make_locale_string(fstring);
return fstringss;
}// else if
else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_DOUBLE))
{
r2 = g_variant_get_double (ivalue);
fdouble = scheme_make_double (r2);
return fdouble;
}// else if
else if (g_variant_is_of_type (ivalue, G_VARIANT_TYPE_TUPLE))
{
int i;
Scheme_Object *result; // The list we're building
Scheme_Object *element; // One element of that list
fprintf (stderr, "Handling a tuple.\n");
result = scheme_null;
for (i = g_variant_n_children (ivalue) - 1; i >= 0; i--)
{
fprintf (stderr, "Handling child %d\n", i);
element = gvariant_to_schemeobj (g_variant_get_child_value (ivalue, i));
result = scheme_make_pair (element, result);
} // for
return result;
} // if it's a tuple
// Default. Give up
else
{
scheme_signal_error ("could not convert type");
} // default
} //gvariant_to_schemeobj
Scheme_Object *
do_bin_quotient(const char *name, const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **bn_rem)
{
Scheme_Object *q;
if (!scheme_is_integer(n1)) {
Scheme_Object *a[2];
a[0] = (Scheme_Object *)n1;
a[1] = (Scheme_Object *)n2;
scheme_wrong_contract(name, "integer?", 0, 2, a);
}
if (!scheme_is_integer(n2)) {
Scheme_Object *a[2];
a[0] = (Scheme_Object *)n1;
a[1] = (Scheme_Object *)n2;
scheme_wrong_contract(name, "integer?", 1, 2, a);
}
if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"%s: undefined for 0", name);
if (
#ifdef MZ_USE_SINGLE_FLOATS
(SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
#endif
(SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0)))
scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
"%s: undefined for 0.0", name);
if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
/* Beware that most negative fixnum divided by -1
isn't a fixnum: */
return (scheme_make_integer_value(SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
}
if (SCHEME_DBLP(n1) || SCHEME_DBLP(n2)) {
Scheme_Object *r;
double d, d2;
r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
if (SCHEME_DBLP(r)) {
d = SCHEME_DBL_VAL(r);
if (d > 0)
d2 = floor(d);
else
d2 = ceil(d);
if (d2 == d)
return r;
else
return scheme_make_double(d2);
} else
return r;
}
#ifdef MZ_USE_SINGLE_FLOATS
if (SCHEME_FLTP(n1) || SCHEME_FLTP(n2)) {
Scheme_Object *r;
float d, d2;
r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
if (SCHEME_FLTP(r)) {
d = SCHEME_FLT_VAL(r);
if (d > 0)
d2 = floor(d);
else
d2 = ceil(d);
if (d2 == d)
return r;
else
return scheme_make_float(d2);
} else
return r;
}
#endif
#if 0
/* I'm pretty sure this isn't needed, but I'm keeping the code just
in case... 03/19/2000 */
if (SCHEME_RATIONALP(n1))
wrong_contract(name, "integer?", n1);
if (SCHEME_RATIONALP(n2))
wrong_contract(name, "integer?", n2);
#endif
n1 = scheme_to_bignum(n1);
n2 = scheme_to_bignum(n2);
scheme_bignum_divide(n1, n2, &q, bn_rem, 1);
return q;
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Env *mod_env;
mod_env = scheme_primitive_module(scheme_intern_symbol("make-gl-info-helper"), env);
scheme_add_global("gl-byte-size",
scheme_make_integer_value(sizeof(GLbyte)),
mod_env);
scheme_add_global("gl-ubyte-size",
scheme_make_integer_value(sizeof(GLubyte)),
mod_env);
scheme_add_global("gl-short-size",
scheme_make_integer_value(sizeof(GLshort)),
mod_env);
scheme_add_global("gl-ushort-size",
scheme_make_integer_value(sizeof(GLushort)),
mod_env);
scheme_add_global("gl-int-size",
scheme_make_integer_value(sizeof(GLint)),
mod_env);
scheme_add_global("gl-uint-size",
scheme_make_integer_value(sizeof(GLuint)),
mod_env);
scheme_add_global("gl-float-size",
scheme_make_integer_value(sizeof(GLfloat)),
mod_env);
scheme_add_global("gl-double-size",
scheme_make_integer_value(sizeof(GLdouble)),
mod_env);
scheme_add_global("gl-boolean-size",
scheme_make_integer_value(sizeof(GLboolean)),
mod_env);
scheme_add_global("gl-sizei-size",
scheme_make_integer_value(sizeof(GLsizei)),
mod_env);
scheme_add_global("gl-clampf-size",
scheme_make_integer_value(sizeof(GLclampf)),
mod_env);
scheme_add_global("gl-clampd-size",
scheme_make_integer_value(sizeof(GLclampd)),
mod_env);
scheme_add_global("gl-enum-size",
scheme_make_integer_value(sizeof(GLenum)),
mod_env);
scheme_add_global("gl-bitfield-size",
scheme_make_integer_value(sizeof(GLbitfield)),
mod_env);
scheme_finish_primitive_module(mod_env);
return scheme_void;
}
