static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
if (SCHEME_INTP(argv[0])) {
intptr_t v;
v = SCHEME_INT_VAL(argv[0]);
if ((v >= 0)
&& (v <= 0x10FFFF)
&& ((v < 0xD800) || (v > 0xDFFF)))
return _scheme_make_char((int)v);
} else if (SCHEME_BIGNUMP(argv[0])
&& SCHEME_BIGPOS(argv[0])) {
/* On 32-bit machines, there's still a chance... */
intptr_t y;
if (scheme_get_int_val(argv[0], &y)) {
if (y <= 0x10FFFF)
return _scheme_make_char((int)y);
}
}
scheme_wrong_contract("integer->char",
"(and/c (integer-in 0 #x10FFFF) (not/c (integer-in #xD800 #xDFFF)))",
0, argc, argv);
return NULL;
}
static Scheme_Object *
integer_to_char (int argc, Scheme_Object *argv[])
{
if (SCHEME_INTP(argv[0])) {
long v;
v = SCHEME_INT_VAL(argv[0]);
if ((v >= 0)
&& (v <= 0x10FFFF)
&& ((v < 0xD800) || (v > 0xDFFF)))
return _scheme_make_char(v);
} else if (SCHEME_BIGNUMP(argv[0])
&& SCHEME_BIGPOS(argv[0])) {
/* On 32-bit machines, there's still a chance... */
long y;
if (scheme_get_int_val(argv[0], &y)) {
if (y <= 0x10FFFF)
return _scheme_make_char(y);
}
}
scheme_wrong_type("integer->char",
"exact integer in [0,#x10FFFF], not in [#xD800,#xDFFF]",
0, argc, argv);
return NULL;
}
static Scheme_Object *set_input_device(int argc, Scheme_Object **argv)
{
intptr_t device;
scheme_get_int_val(argv[0],&device);
midi_io.set_input_device((int)device);
return scheme_void;
} // set_input_device()
static Scheme_Object *note_off(int argc, Scheme_Object **argv)
{
intptr_t channel,note,velocity;
PmEvent event;
scheme_get_int_val(argv[0],&channel);
scheme_get_int_val(argv[1],¬e);
scheme_get_int_val(argv[2],&velocity);
event.message=Pm_Message(0x80+(unsigned char)channel,
(unsigned char)note,
(unsigned char)velocity);
event.timestamp=0;
midi_io.write_event(&event);
return scheme_void;
} // note_off()
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
GVariant *rvalue;
Scheme_Object *firstelement;
int length;
long i;
char* rstring;
double rdouble;
rvalue = NULL;
length = scheme_list_length (list);
if (length == 0)
{
return rvalue ;
}
else if (length == 1)
{
// Get the first element of the argument
firstelement = scheme_car (list);
// checking the scheme_type to see whether it is an integer or not
// Eventually see if we can convert this to a switch statement.
if (SCHEME_TYPE (firstelement)== scheme_integer_type)
{
// we saved the return value at &i
scheme_get_int_val (list,&i);
// we concert it to g_variant
rvalue = g_variant_new ("(i)", i);
return rvalue;
} // if it's an integer
else if (SCHEME_TYPE (firstelement) == scheme_char_type)
{
//getting the string out of the scheme_object
rstring = SCHEME_BYTE_STR_VAL(list);
// we will convert it to g_variant
rvalue = g_variant_new_string(rstring);
return rvalue;
} // if it's a character
else if (SCHEME_TYPE (firstelement) == scheme_double_type)
{
//getting the double out of the scheme_object
rdouble = scheme_real_to_double(list);
// we will convert it to g_variant
rvalue = g_variant_new_double(rdouble);
return rvalue;
} // if it's a double
} // if we have a single element
return rvalue;
} // scheme_obj_to_gvariant
static Scheme_Object *note_on(int argc, Scheme_Object **argv)
{
intptr_t channel,note,velocity;
PmEvent event;
scheme_get_int_val(argv[0],&channel);
scheme_get_int_val(argv[1],¬e);
scheme_get_int_val(argv[2],&velocity);
/*
#define Pm_Message(status, data1, data2) \
((((data2) << 16) & 0xFF0000) | \
(((data1) << 8) & 0xFF00) | \
((status) & 0xFF))
*/
event.message=Pm_Message(0x90+(int)channel,(int)note,(int)velocity);
event.timestamp=0;
midi_io.write_event(&event);
return scheme_void;
} // note_on()
intptr_t scheme_get_semaphore_init(const char *who, int n, Scheme_Object **p)
{
intptr_t v;
if (n) {
if (!SCHEME_INTP(p[0])) {
if (!SCHEME_BIGNUMP(p[0]) || !SCHEME_BIGPOS(p[0]))
scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, n, p);
}
if (!scheme_get_int_val(p[0], &v)) {
scheme_raise_exn(MZEXN_FAIL,
"%s: starting value %s is too large",
who,
scheme_make_provided_string(p[0], 0, NULL));
} else if (v < 0)
scheme_wrong_contract(who, "exact-nonnegative-integer?", 0, n, p);
} else
v = 0;
return v;
}