static Scheme_Object *make_immutable_hash_table(int argc, Scheme_Object *argv[])
{
Scheme_Object *l = argv[0], *a;
Scheme_Hash_Table *ht;
if (scheme_proper_list_length(l) >= 0) {
for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
if (!SCHEME_PAIRP(a))
break;
}
}
if (!SCHEME_NULLP(l))
scheme_wrong_type("make-immutable-hash-table", "list of pairs", 0, argc, argv);
if (argc > 1) {
if (!SAME_OBJ(equal_symbol, argv[1]))
scheme_wrong_type("make-immutable-hash-table", "'equal", 1, argc, argv);
ht = scheme_make_hash_table_equal();
} else
ht = scheme_make_hash_table(SCHEME_hash_ptr);
for (l = argv[0]; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = SCHEME_CAR(l);
scheme_hash_set(ht, SCHEME_CAR(a), SCHEME_CDR(a));
}
SCHEME_SET_IMMUTABLE((Scheme_Object *)ht);
return (Scheme_Object *)ht;
}
static Scheme_Object *
scheme_append_bang (Scheme_Object *lst1, Scheme_Object *lst2)
{
if (SCHEME_NULLP(lst1))
return lst2;
else {
Scheme_Object *prev, *orig;
orig = lst1;
do {
prev = lst1;
if (!SCHEME_PAIRP(lst1))
scheme_wrong_type("append!", "proper list", -1, 0, &lst1);
lst1 = SCHEME_CDR(lst1);
SCHEME_USE_FUEL(1);
} while (!SCHEME_NULLP(lst1));
if (!SCHEME_MUTABLE_PAIRP(prev))
scheme_wrong_type("append!", "mutable proper list", -1, 0, &lst1);
SCHEME_CDR(prev) = lst2;
return orig;
}
}
/**
* A general call. Parameters are
* 0: The LouDBusProxy
* 1: The method name (string)
* others: Parameters to the method
*/
Scheme_Object *
loudbus_call (int argc, Scheme_Object **argv)
{
LouDBusProxy *proxy;
gchar *name;
// I don't think that I need to add annotations for garbage collection
// because scheme_object_to_string is the only allocating call, and we've
// dealt with all the other Scheme objects by the time we call it.
proxy = scheme_object_to_proxy (argv[0]);
name = scheme_object_to_string (argv[1]);
// Sanity checks
if (proxy == NULL)
{
scheme_wrong_type ("loudbus-call", "LouDBusProxy *", 0, argc, argv);
} // if we could not get the proxy
if (name == NULL)
{
scheme_wrong_type ("loudbus-call", "string", 1, argc, argv);
} // if we could not get the name
// Permit the use of dashes
score_it_all (name);
return dbus_call_kernel (proxy, name, name, argc-2, argv+2);
} // loudbus_call
static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[])
{
Scheme_Object *s1, *s2;
intptr_t istart, ifinish;
intptr_t ostart, ofinish;
int slow = 0;
s1 = argv[0];
if (SCHEME_NP_CHAPERONEP(s1)) {
slow = 1;
s1 = SCHEME_CHAPERONE_VAL(s1);
}
if (!SCHEME_MUTABLE_VECTORP(s1))
scheme_wrong_type("vector-copy!", "mutable vector", 0, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s1,
argc, argv, 1, 5,
&ostart, &ofinish, SCHEME_VEC_SIZE(s1));
s2 = argv[2];
if (SCHEME_NP_CHAPERONEP(s2)) {
slow = 1;
s2 = SCHEME_CHAPERONE_VAL(s2);
}
if (!SCHEME_VECTORP(s2))
scheme_wrong_type("vector-copy!", "vector", 2, argc, argv);
scheme_do_get_substring_indices("vector-copy!", s2,
argc, argv, 3, 4,
&istart, &ifinish, SCHEME_VEC_SIZE(s2));
if ((ofinish - ostart) < (ifinish - istart)) {
scheme_arg_mismatch("vector-copy!",
"not enough room in target vector: ",
argv[2]);
return NULL;
}
if (slow) {
int i, o;
for (i = istart, o = ostart; i < ifinish; i++, o++) {
scheme_chaperone_vector_set(argv[0], o, scheme_chaperone_vector_ref(argv[2], i));
}
} else {
memmove(SCHEME_VEC_ELS(s1) + ostart,
SCHEME_VEC_ELS(s2) + istart,
(ifinish - istart) * sizeof(Scheme_Object*));
}
return scheme_void;
}
static Scheme_Object *
length_prim (int argc, Scheme_Object *argv[])
{
int l;
if (!SCHEME_LISTP(argv[0]))
scheme_wrong_type("length", "proper list", 0, argc, argv);
l = scheme_proper_list_length(argv[0]);
if (l < 0)
scheme_wrong_type("length", "proper list", 0, argc, argv);
return scheme_make_integer(l);
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
size_t sz;
sz = VECTOR_BYTES(size);
if (REV_VECTOR_BYTES(sz) != size)
/* overflow */
scheme_raise_out_of_memory(NULL, NULL);
else
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, sz);
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *hash_table_count(int argc, Scheme_Object *argv[])
{
if (SCHEME_HASHTP(argv[0])) {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
return scheme_make_integer(t->count);
} else if (SCHEME_BUCKTP(argv[0])) {
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
int count = 0, weak, i;
Scheme_Bucket **buckets, *bucket;
const char *key;
buckets = t->buckets;
weak = t->weak;
for (i = t->size; i--; ) {
bucket = buckets[i];
if (bucket) {
if (weak) {
key = (const char *)HT_EXTRACT_WEAK(bucket->key);
} else {
key = bucket->key;
}
if (key)
count++;
}
SCHEME_USE_FUEL(1);
}
return scheme_make_integer(count);
} else {
scheme_wrong_type("hash-table-count", "hash-table", 0, argc, argv);
return NULL;
}
}
static Scheme_Object *do_chaperone_vector(const char *name, int is_impersonator, int argc, Scheme_Object **argv)
{
Scheme_Chaperone *px;
Scheme_Object *val = argv[0];
Scheme_Object *redirects;
Scheme_Hash_Tree *props;
if (SCHEME_CHAPERONEP(val))
val = SCHEME_CHAPERONE_VAL(val);
if (!SCHEME_VECTORP(val)
|| (is_impersonator && !SCHEME_MUTABLEP(val)))
scheme_wrong_type(name, is_impersonator ? "mutable vector" : "vector", 0, argc, argv);
scheme_check_proc_arity(name, 3, 1, argc, argv);
scheme_check_proc_arity(name, 3, 2, argc, argv);
props = scheme_parse_chaperone_props(name, 3, argc, argv);
redirects = scheme_make_pair(argv[1], argv[2]);
px = MALLOC_ONE_TAGGED(Scheme_Chaperone);
px->iso.so.type = scheme_chaperone_type;
px->props = props;
px->val = val;
px->prev = argv[0];
px->redirects = redirects;
if (is_impersonator)
SCHEME_CHAPERONE_FLAGS(px) |= SCHEME_CHAPERONE_IS_IMPERSONATOR;
return (Scheme_Object *)px;
}
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec, *ovec, *v;
intptr_t len, i;
vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector->immutable-vector", "vector", 0, argc, argv);
if (SCHEME_IMMUTABLEP(vec))
return argv[0];
ovec = vec;
len = SCHEME_VEC_SIZE(ovec);
vec = scheme_make_vector(len, NULL);
if (!SAME_OBJ(ovec, argv[0])) {
for (i = 0; i < len; i++) {
v = scheme_chaperone_vector_ref(argv[0], i);
SCHEME_VEC_ELS(vec)[i] = v;
}
} else {
for (i = 0; i < len; i++) {
SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(ovec)[i];
}
}
SCHEME_SET_IMMUTABLE(vec);
return vec;
}
static Scheme_Object *
vector_fill (int argc, Scheme_Object *argv[])
{
int i, sz;
Scheme_Object *v, *vec = argv[0];
if (SCHEME_NP_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_type("vector-fill!", "mutable vector", 0, argc, argv);
v = argv[1];
sz = SCHEME_VEC_SIZE(vec);
if (SAME_OBJ(vec, argv[0])) {
for (i = 0; i < sz; i++) {
SCHEME_VEC_ELS(argv[0])[i] = v;
}
} else {
for (i = 0; i < sz; i++) {
scheme_chaperone_vector_set(argv[0], i, v);
}
}
return scheme_void;
}
Scheme_Object *
scheme_checked_vector_set(int argc, Scheme_Object *argv[])
{
Scheme_Object *vec = argv[0];
intptr_t i, len;
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_MUTABLE_VECTORP(vec))
scheme_wrong_type("vector-set!", "mutable vector", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-set!", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-set!", argv[1], argv[0], 0);
if (!SAME_OBJ(vec, argv[0]))
scheme_chaperone_vector_set(argv[0], i, argv[2]);
else
SCHEME_VEC_ELS(vec)[i] = argv[2];
return scheme_void;
}
Scheme_Object *
scheme_checked_vector_ref (int argc, Scheme_Object *argv[])
{
intptr_t i, len;
Scheme_Object *vec;
vec = argv[0];
if (SCHEME_CHAPERONEP(vec))
vec = SCHEME_CHAPERONE_VAL(vec);
if (!SCHEME_VECTORP(vec))
scheme_wrong_type("vector-ref", "vector", 0, argc, argv);
len = SCHEME_VEC_SIZE(vec);
i = scheme_extract_index("vector-ref", 1, argc, argv, len, 0);
if (i >= len)
return bad_index("vector-ref", argv[1], argv[0], 0);
if (!SAME_OBJ(vec, argv[0]))
/* chaperone */
return scheme_chaperone_vector_ref(argv[0], i);
else
return (SCHEME_VEC_ELS(vec))[i];
}
Scheme_Object *
scheme_make_vector (intptr_t size, Scheme_Object *fill)
{
Scheme_Object *vec;
intptr_t i;
if (size < 0) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(VECTOR_BYTES(size));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged, VECTOR_BYTES(size));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
Scheme_Object *
scheme_make_vector (int size, Scheme_Object *fill)
{
Scheme_Object *vec;
int i;
if (size <= 0) {
if (size) {
vec = scheme_make_integer(size);
scheme_wrong_type("make-vector", "non-negative exact integer", -1, 0, &vec);
} else
return zero_length_vector;
}
if (size < 1024) {
vec = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
} else {
vec = (Scheme_Object *)scheme_malloc_fail_ok(scheme_malloc_tagged,
sizeof(Scheme_Vector)
+ (size - 1) * sizeof(Scheme_Object *));
}
vec->type = scheme_vector_type;
SCHEME_VEC_SIZE(vec) = size;
if (fill) {
for (i = 0; i < size; i++) {
SCHEME_VEC_ELS(vec)[i] = fill;
}
}
return vec;
}
static Scheme_Object *
car_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_PAIRP(argv[0]))
scheme_wrong_type("car", "pair", 0, argc, argv);
return (SCHEME_CAR (argv[0]));
}
static Scheme_Object *hash_table_get(int argc, Scheme_Object *argv[])
{
void *v;
if (!(SCHEME_HASHTP(argv[0]) || SCHEME_BUCKTP(argv[0])))
scheme_wrong_type("hash-table-get", "hash-table", 0, argc, argv);
if (SCHEME_BUCKTP(argv[0])){
Scheme_Bucket_Table *t = (Scheme_Bucket_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_lookup_in_table(t, (char *)argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
} else {
Scheme_Hash_Table *t = (Scheme_Hash_Table *)argv[0];
if (t->mutex) scheme_wait_sema(t->mutex, 0);
v = scheme_hash_get(t, argv[1]);
if (t->mutex) scheme_post_sema(t->mutex);
}
if (v)
return (Scheme_Object *)v;
else if (argc == 3)
return _scheme_tail_apply(argv[2], 0, NULL);
else {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"hash-table-get: no value found for key: %V",
argv[1]);
return scheme_void;
}
}
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 *
reverse_bang_prim (int argc, Scheme_Object *argv[])
{
Scheme_Object *lst, *prev, *next;
prev = NULL;
lst = argv[0];
while (!SCHEME_NULLP(lst)) {
if (!SCHEME_MUTABLE_PAIRP(lst))
scheme_wrong_type("reverse!", "mutable proper list", 0, argc, argv);
next = SCHEME_CDR(lst);
if (prev)
SCHEME_CDR(lst) = prev;
else
SCHEME_CDR(lst) = scheme_null;
prev = lst;
lst = next;
SCHEME_USE_FUEL(1);
}
if (prev)
return prev;
else
return scheme_null;
}
Scheme_Object *scheme_place_recv(int argc, Scheme_Object *args[]) {
if (argc == 1) {
Scheme_Object *mso;
Scheme_Place_Bi_Channel *ch;
if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_type)) {
ch = (Scheme_Place_Bi_Channel *) ((Scheme_Place *) args[0])->channel;
}
else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_place_bi_channel_type)) {
ch = (Scheme_Place_Bi_Channel *) args[0];
}
else {
ch = NULL;
scheme_wrong_type("place-channel-recv", "place-channel", 0, argc, args);
}
{
void *msg_memory = NULL;
mso = scheme_place_async_recv((Scheme_Place_Async_Channel *) ch->recvch, &msg_memory);
return scheme_places_deserialize(mso, msg_memory);
}
}
else {
scheme_wrong_count_m("place-channel-recv", 1, 1, argc, args, 0);
}
return scheme_true;
}
Scheme_Object *
irgb_new (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-red", "integer", 0, 3, argv);
if (! SCHEME_INTP (argv[1]))
scheme_wrong_type ("irgb-red", "integer", 1, 3, argv);
if (! SCHEME_INTP (argv[2]))
scheme_wrong_type ("irgb-red", "integer", 2, 3, argv);
int r = byte (SCHEME_INT_VAL (argv[0]));
int g = byte (SCHEME_INT_VAL (argv[1]));
int b = byte (SCHEME_INT_VAL (argv[2]));
return scheme_make_integer ((r << 16) | (g << 8) | b);
} // irgb_new
Scheme_Object *
scheme_append (Scheme_Object *lst1, Scheme_Object *lst2)
{
Scheme_Object *first, *last, *orig1, *v;
orig1 = lst1;
first = last = NULL;
while (SCHEME_PAIRP(lst1)) {
v = scheme_make_pair(SCHEME_CAR(lst1), scheme_null);
if (!first)
first = v;
else
SCHEME_CDR(last) = v;
last = v;
lst1 = SCHEME_CDR(lst1);
SCHEME_USE_FUEL(1);
}
if (!SCHEME_NULLP(lst1))
scheme_wrong_type("append", "proper list", -1, 0, &orig1);
if (!last)
return lst2;
SCHEME_CDR(last) = lst2;
return first;
}
Scheme_Object *
irgb_red (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-red", "integer", 1, 1, argv);
int color = SCHEME_INT_VAL (argv[0]);
return scheme_make_integer ((color >> 16) & 255);
} // irgb_red
Scheme_Object *
irgb_blue (int argc, Scheme_Object **argv)
{
if (! SCHEME_INTP (argv[0]))
scheme_wrong_type ("irgb-blue", "integer", 0, 1, argv);
int color = SCHEME_INT_VAL (argv[0]);
return scheme_make_integer (color & 255);
} // irgb_blue
static Scheme_Object *
vector_length (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector-length", "vector", 0, argc, argv);
return scheme_make_integer(SCHEME_VEC_SIZE(argv[0]));
}
static Scheme_Object *
vector_to_list (int argc, Scheme_Object *argv[])
{
if (!SCHEME_VECTORP(argv[0]))
scheme_wrong_type("vector->list", "vector", 0, argc, argv);
return scheme_vector_to_list(argv[0]);
}
static Scheme_Object *
set_cdr_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_MUTABLE_PAIRP(argv[0]))
scheme_wrong_type("set-cdr!", "mutable-pair", 0, argc, argv);
SCHEME_CDR (argv[0]) = argv[1];
return scheme_void;
}
/**
* Convert an array of Scheme objects to a GVariant that serves as
* the primary parameter to g_dbus_proxy_call.
*/
static GVariant *
scheme_objects_to_parameter_tuple (gchar *fun,
int arity,
Scheme_Object **objects,
GDBusArgInfo *formals[])
{
int i; // Counter variable
GVariantBuilder *builder;
// Something to let us build tuples
GVariant *result; // The GVariant we build
GVariant *actual; // One actual
builder = g_variant_builder_new (G_VARIANT_TYPE_TUPLE);
// Annotations for garbage collector.
// Since we're converting Scheme_Object values to GVariants, it should
// not be the case that we have an "allocating call". However, I am
// worried that conversion to a string, which requires
// scheme_char_string_to_byte_string_locale, might be considered an
// allocating call. So let's be in the safe side. The sample code suggests
// that we can put an array of GObjects in a single variable (see
// the supplied makeadder3m.c for more details).
MZ_GC_DECL_REG (1);
MZ_GC_VAR_IN_REG (0, objects);
MZ_GC_REG ();
// Process all the parameters
for (i = 0; i < arity; i++)
{
actual = scheme_object_to_parameter (objects[i], formals[i]->signature);
// If we can't convert the parameter, we give up.
if (actual == NULL)
{
// Early exit - Clean up for garbage collection
MZ_GC_UNREG ();
// Get rid of the builder
g_variant_builder_unref (builder);
// And return an arror message.
scheme_wrong_type (fun,
dbus_signature_to_string (formals[i]->signature),
i,
arity,
objects);
} // If we could not convert
// Otherwise, we add the value to the builder and go on
g_variant_builder_add_value (builder, actual);
} // for
// Clean up garbage collection info.
MZ_GC_UNREG ();
// And we're done.
result = g_variant_builder_end (builder);
return result;
} // scheme_objects_to_parameter_tuple
static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
{
Scheme_Object *bs;
if (!SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
bs = scheme_char_string_to_byte_string(argv[0]);
return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
}
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);
}
static Scheme_Object *char_general_category (int argc, Scheme_Object *argv[])
{
mzchar c;
int cat;
if (!SCHEME_CHARP(argv[0]))
scheme_wrong_type("char-general-category", "character", 0, argc, argv);
c = SCHEME_CHAR_VAL(argv[0]);
cat = scheme_general_category(c);
return general_category_symbols[cat];
}
