void scheme_sfs_used(SFS_Info *info, int pos)
{
if (info->pass)
return;
pos += info->stackpos;
if ((pos < 0) || (pos >= info->depth)) {
scheme_signal_error("internal error: stack use out of bounds");
}
if (pos == info->tlpos)
scheme_signal_error("internal error: misuse of toplevel pointer");
SFS_LOG(printf("touch %d %d\n", pos, info->ip));
if (info->max_used[pos] >= FAR_VALUE_FOR_MAX_USED) {
info->max_used[pos] = (FAR_VALUE_FOR_MAX_USED + 1);
return;
}
if ((info->min_touch == -1)
|| (pos < info->min_touch))
info->min_touch = pos;
if (pos > info->max_touch)
info->max_touch = pos;
info->max_used[pos] = info->ip;
}
/**
* Create a list of available services.
*/
static Scheme_Object *
loudbus_services (int argc, Scheme_Object **argv)
{
GDBusProxy *proxy;
GError *error = NULL;
GVariant *result;
//Build the proxy.
proxy = g_dbus_proxy_new_for_bus_sync (G_BUS_TYPE_SESSION,
G_DBUS_PROXY_FLAGS_NONE,
NULL,
"org.freedesktop.DBus",
"/",
"org.freedesktop.DBus",
NULL,
&error);
// Check for an error
if (proxy == NULL)
{
if (error != NULL)
{
scheme_signal_error ("Could not create proxy because %s",
error->message);
} // if (error != NULL)
else // if (error == NULL)
{
scheme_signal_error ("Could not create proxy for unknown reasons.");
} // if (error == NULL)
return scheme_void;
} // if (proxy == NULL)
// Get a list of available services.
result = g_dbus_proxy_call_sync (proxy,
"ListNames",
NULL,
0,
-1,
NULL,
&error);
// Check whether an error occurred.
if (result == NULL)
{
if (error != NULL)
{
scheme_signal_error ("Could not list services because: %s",
error->message);
} // if (error != NULL)
else // if (error == NULL)
{
scheme_signal_error ("Could not list services for unknown reason");
} // if (error == NULL)
return scheme_void;
} // if (error == NULL)
// Return the created list.
return g_variant_to_scheme_object (result);
} // loudbus_services
static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info)
{
Scheme_Object *v;
if (!info->pass)
scheme_signal_error("internal error: wrong pass to get saved info");
if (!SCHEME_PAIRP(info->saved))
scheme_signal_error("internal error: no saved info");
v = SCHEME_CAR(info->saved);
info->saved = SCHEME_CDR(info->saved);
return v;
}
static Scheme_Object *startmidi(int argc, Scheme_Object **argv)
{
int status=midi_io.initialise();
if(status < 0){
switch(status) {
case ERROR_OPEN_INPUT: scheme_signal_error("Error opening input port");
break;
case ERROR_OPEN_OUTPUT: scheme_signal_error("Error opening output port");
break;
default: scheme_signal_error("Unknown error");
break;
} // switch
}
return scheme_void;
} // startmidi()
static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v)
{
if (info->pass)
scheme_signal_error("internal error: wrong pass to save info");
v = scheme_make_pair(v, info->saved);
info->saved = v;
}
void *dlopen(const char *filename, int flags)
{
scheme_signal_error("load-extension: can't use with a statically-linked"
" MrEd");
return NULL;
}
static Scheme_Object *with_immed_mark_sfs(Scheme_Object *o, SFS_Info *info)
{
Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o;
Scheme_Object *k, *v, *b, *vec;
int pos, save_mnt;
scheme_sfs_start_sequence(info, 3, 1);
k = scheme_sfs_expr(wcm->key, info, -1);
v = scheme_sfs_expr(wcm->val, info, -1);
scheme_sfs_push(info, 1, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
b = scheme_sfs_expr(wcm->body, info, -1);
wcm->key = k;
wcm->val = v;
wcm->body = b;
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
}
return o;
}
/**
* A wrapper for rdbus_get_object.
*/
Scheme_Object *pardbus_get_object (int argc, Scheme_Object *argv[])
{
char *service;
char *path;
char *interface;
int object;
// Verify the number of parameters
if (argc != 3)
{
scheme_signal_error ("rdbus-get-object: Requires exactly three parameters.\n");
return scheme_void;
} // if we have the wrong number of parameters
// Verify the type of the parameters
if ( (! stringp (argv[0]))
|| (! stringp (argv[1]))
|| (! stringp (argv[2])) )
{
scheme_signal_error ("rdbus-get-object: All three parameters must be strings");
} // if one of the parameters is not a string
// Extract the parameters
service = tostring (argv[0]);
path = tostring (argv[1]);
interface = tostring (argv[2]);
// Rely on rdbus_get_object to do the real work
object = rdbus_get_object (service, path, interface);
// Sanity check. rdbus_get_object returns a negative number upon error.
if (object < 0)
{
scheme_signal_error ("Could not create bus object.");
return scheme_void;
} // if (object < 0)
// We're done. Return the damn integer.
return scheme_make_integer (object);
} // pardbus_get_object
static Scheme_Object *
case_lambda_sfs(Scheme_Object *expr, SFS_Info *info)
{
Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr;
Scheme_Object *le, *clears = scheme_null;
int i;
scheme_sfs_start_sequence(info, seq->count, 0);
for (i = 0; i < seq->count; i++) {
le = seq->array[i];
le = scheme_sfs_expr(le, info, -1);
if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) {
/* Some clearing actions were added to the closure.
Lift them out. */
int j;
Scheme_Sequence *cseq = (Scheme_Sequence *)le;
if (!cseq->count)
scheme_signal_error("internal error: empty sequence");
for (j = 1; j < cseq->count; j++) {
int pos;
pos = SCHEME_LOCAL_POS(cseq->array[j]);
clears = scheme_make_pair(scheme_make_integer(pos), clears);
}
le = cseq->array[0];
}
if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type)
&& !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) {
scheme_signal_error("internal error: not a lambda for case-lambda: %d",
SCHEME_TYPE(le));
}
seq->array[i] = le;
}
if (!SCHEME_NULLP(clears)) {
return scheme_sfs_add_clears(expr, clears, 0);
} else
return expr;
}
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
info->stackpos -= cnt;
if (info->stackpos < 0)
scheme_signal_error("internal error: pushed too deep");
if (track) {
while (cnt--) {
scheme_sfs_used(info, cnt);
}
}
}
void scheme_sfs_push(SFS_Info *info, int cnt, int track)
{
info->stackpos -= cnt;
SFS_LOG(printf("push %d [%d]: %d\n", cnt, track, info->stackpos));
if (info->stackpos < 0)
scheme_signal_error("internal error: pushed too deep");
if (track) {
while (cnt--) {
scheme_sfs_used(info, cnt);
}
}
}
/**
* A wrapper for rdbus_call_method that makes it easier to export our function
* to Scheme.
*/
Scheme_Object *
pardbus_call_method (int argc, Scheme_Object *argv[])
{
// Verify that we have the appropriate number of arguments.
if (argc < 2)
{
scheme_signal_error ("Call method needs at least two parameters.");
return NULL;
} // if there are insufficiently many arguments available.
// rdbus_call_method does the heavy lifting
// Hack! Right now, we are going to assume zeroary procedures
return rdbus_call_method (SCHEME_INT_VAL (argv[0]), argv[1],
make_object_list (argc-2, argv+2));
} // pardbus_call_method
Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth)
{
int init, i;
SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o)));
if (!info) {
info = scheme_new_sfs_info(max_let_depth);
}
info->pass = 0;
info->ip = 1;
info->abs_ip = 1;
info->saved = scheme_null;
info->min_touch = -1;
info->max_touch = -1;
info->tail_pos = 1;
init = info->stackpos;
o = scheme_sfs_expr(o, info, -1);
if (info->seqn)
scheme_signal_error("ended in the middle of an expression?");
# if MAX_SFS_CLEARING
info->max_nontail = info->ip;
info->abs_max_nontail = info->abs_ip;
# endif
for (i = info->depth; i-- > init; ) {
info->max_calls[i] = info->max_nontail;
}
{
Scheme_Object *v;
v = scheme_reverse(info->saved);
info->saved = v;
}
info->pass = 1;
info->seqn = 0;
info->ip = 1;
info->abs_ip = 1;
info->tail_pos = 1;
info->stackpos = init;
o = scheme_sfs_expr(o, info, -1);
return o;
}
static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_Void *lv = (Scheme_Let_Void *)o;
Scheme_Object *body;
int i, pos, save_mnt;
Scheme_Object *vec;
scheme_sfs_push(info, lv->count, 1);
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(lv->count + 1, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (!SCHEME_VECTORP(vec))
scheme_signal_error("internal error: not a vector");
for (i = 0; i < lv->count; i++) {
info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]);
info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]);
}
body = scheme_sfs_expr(lv->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail);
for (i = 0; i < lv->count; i++) {
n = info->max_used[pos + i];
SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n);
}
} else {
info->max_nontail = save_mnt;
}
lv->body = body;
return o;
}
/**
* Call a function, using the proxy, function name, and external name
* stored in prim.
*
* argc/argv give the parameters for the function call.
*/
Scheme_Object *
loudbus_call_with_closure (int argc, Scheme_Object **argv, Scheme_Object *prim)
{
Scheme_Object *wrapped_proxy = NULL;
Scheme_Object *wrapped_dbus_name = NULL;
Scheme_Object *wrapped_external_name = NULL;
Scheme_Object *result = NULL;
LouDBusProxy *proxy = NULL;
gchar *dbus_name;
gchar *external_name;
// Probably too many things are annotated here, but better safe than
// sorry.
MZ_GC_DECL_REG (5);
MZ_GC_VAR_IN_REG (0, argv);
MZ_GC_VAR_IN_REG (1, prim);
MZ_GC_VAR_IN_REG (2, wrapped_proxy);
MZ_GC_VAR_IN_REG (3, wrapped_dbus_name);
MZ_GC_VAR_IN_REG (4, wrapped_external_name);
MZ_GC_REG ();
// Extract information from the closure.
wrapped_proxy = SCHEME_PRIM_CLOSURE_ELS (prim)[0];
wrapped_dbus_name = SCHEME_PRIM_CLOSURE_ELS (prim)[1];
wrapped_external_name = SCHEME_PRIM_CLOSURE_ELS (prim)[2];
dbus_name = scheme_object_to_string (wrapped_dbus_name);
external_name = scheme_object_to_string (wrapped_external_name);
proxy = scheme_object_to_proxy (wrapped_proxy);
// Sanity check
if (proxy == NULL)
{
MZ_GC_UNREG ();
scheme_signal_error ("Could not obtain proxy to call %s.\n",
external_name);
} // if (proxy == NULL)
// And do the dirty work
result = dbus_call_kernel (proxy,
dbus_name, external_name,
argc, argv);
MZ_GC_UNREG ();
return result;
} // loudbus_call_with_closure
static Scheme_Object *flatten_sequence(Scheme_Object *o)
{
/* At this point, we sometimes have (begin ... (begin ... (begin ...))).
Flatten those out. */
Scheme_Sequence *s = (Scheme_Sequence *)o, *s2;
int i, extra = 0;
o = s->array[s->count - 1];
while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
s2 = (Scheme_Sequence *)o;
extra += s2->count - 1;
o = s2->array[s2->count - 1];
}
if (extra) {
s2 = scheme_malloc_sequence(s->count + extra);
s2->so.type = scheme_sequence_type;
s2->count = s->count + extra;
extra = 0;
o = (Scheme_Object *)s;
while (SAME_TYPE(SCHEME_TYPE(o), scheme_sequence_type)) {
s = (Scheme_Sequence *)o;
for (i = 0; i < s->count - 1; i++) {
s2->array[extra++] = s->array[i];
}
o = s->array[i];
}
s2->array[extra++] = o;
if (extra != s2->count) scheme_signal_error("internal error: flatten failed");
return (Scheme_Object *)s2;
} else
return (Scheme_Object *)s;
}
/**
*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
/**
* The kernel of the various mechanisms for calling D-Bus functions.
*/
static Scheme_Object *
dbus_call_kernel (LouDBusProxy *proxy,
gchar *dbus_name,
gchar *external_name,
int argc,
Scheme_Object **argv)
{
GDBusMethodInfo *method;
// Information on the actual method
int arity; // The arity of that method
GVariant *actuals; // The actual parameters
GVariant *gresult; // The result from the function call as a GVariant
Scheme_Object *sresult;
// That Scheme result as a Scheme object
GError *error; // Possible error from call
// Grab the method information.
method = g_dbus_interface_info_lookup_method (proxy->iinfo, dbus_name);
if (method == NULL)
{
scheme_signal_error ("no such method: %s", dbus_name);
} // if the method is invalid
// Get the arity
arity = g_dbus_method_info_num_formals (method);
if (arity != argc)
{
scheme_signal_error ("%s expected %d params, received %d",
external_name, arity, argc);
} // if the arity is incorrect
// Build the actuals
actuals = scheme_objects_to_parameter_tuple (external_name,
argc,
argv,
method->in_args);
if (actuals == NULL)
{
scheme_signal_error ("%s: could not convert parameters",
external_name);
} // if (actuals == NULL)
// Call the function.
error = NULL;
gresult = g_dbus_proxy_call_sync (proxy->proxy,
dbus_name,
actuals,
0,
-1,
NULL,
&error);
if (gresult == NULL)
{
if (error != NULL)
{
scheme_signal_error ("%s: call failed because %s",
external_name, error->message);
} // if (error != NULL)
else
{
scheme_signal_error ("%s: call failed for unknown reason",
external_name);
} // if something went wrong, but there's no error
} // if (gresult == NULL)
// Convert to Scheme form
sresult = g_variant_to_scheme_object (gresult);
if (sresult == NULL)
{
scheme_signal_error ("%s: could not convert return values",
external_name);
} // if (sresult == NULL)
// And we're done.
return sresult;
} // dbus_call_kernel
/**
* Convert a GVariant to a Scheme object. Returns NULL if there's a
* problem.
*/
static Scheme_Object *
g_variant_to_scheme_object (GVariant *gv)
{
const GVariantType *type; // The type of the GVariant
const gchar *typestring; // A string that describes the type
int i; // A counter variable
int len; // Length of arrays and tuples
Scheme_Object *lst = NULL; // A list that we build as a result
Scheme_Object *sval = NULL; // One value
Scheme_Object *result = NULL; // One result to return.
// Special case: We'll treat NULL as void.
if (gv == NULL)
{
return scheme_void;
} // if (gv == NULL)
// Get the type
type = g_variant_get_type (gv);
typestring = g_variant_get_type_string (gv);
// ** Handle most of the basic types **
// Integer
if (g_variant_type_equal (type, G_VARIANT_TYPE_INT32))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
int i;
i = g_variant_get_int32 (gv);
result = scheme_make_integer (i);
return result;
} // if it's an integer
// Double
if (g_variant_type_equal (type, G_VARIANT_TYPE_DOUBLE))
{
double d;
d = g_variant_get_double (gv);
result = scheme_make_double (d);
return result;
} // if it's a double
// String
if (g_variant_type_equal (type, G_VARIANT_TYPE_STRING))
{
// We don't refer to any Scheme objects across allocating calls,
// so no need for GC code.
const gchar *str;
str = g_variant_get_string (gv, NULL);
result = scheme_make_locale_string (str);
return result;
} // if it's a string
// ** Handle some special cases **
// We treat arrays of bytes as bytestrings
if (g_strcmp0 (typestring, "ay") == 0)
{
gsize size;
guchar *data;
data = (guchar *) g_variant_get_fixed_array (gv, &size, sizeof (guchar));
return scheme_make_sized_byte_string ((char *) data, size, 1);
} // if it's an array of bytes
// ** Handle the compound types **
// Tuple or Array
if ( (g_variant_type_is_tuple (type))
|| (g_variant_type_is_array (type)) )
{
// Find out how many values to put into the list.
len = g_variant_n_children (gv);
// Here, we are referring to stuff across allocating calls, so we
// need to be careful.
MZ_GC_DECL_REG (2);
MZ_GC_VAR_IN_REG (0, lst);
MZ_GC_VAR_IN_REG (1, sval);
MZ_GC_REG ();
// Start with the empty list.
lst = scheme_null;
// Step through the items, right to left, adding them to the list.
for (i = len-1; i >= 0; i--)
{
sval = g_variant_to_scheme_object (g_variant_get_child_value (gv, i));
lst = scheme_make_pair (sval, lst);
} // for
// Okay, we've made it through the list, now we can clean up.
MZ_GC_UNREG ();
if ((g_variant_type_is_array (type)))
{
//If type is array, convert to vector
scheme_list_to_vector ((char*)lst);
}//If array
// And we're done.
return lst;
} // if it's a tuple or an array
// Unknown. Give up.
scheme_signal_error ("Unknown type %s", typestring);
return scheme_void;
} // g_variant_to_scheme_object
static Scheme_Object *write_let_one(Scheme_Object *obj)
{
scheme_signal_error("let-one writer shouldn't be used");
return NULL;
}
/**
* Create a new proxy.
*/
static Scheme_Object *
loudbus_proxy (int argc, Scheme_Object **argv)
{
gchar *service = NULL; // A string giving the service
gchar *path = NULL; // A string giving the path to the object
gchar *interface = NULL; // A string giving the interface
LouDBusProxy *proxy = NULL; // The proxy we build
Scheme_Object *result = NULL; // The proxy wrapped as a Scheme object
GError *error = NULL; // A place to hold errors
service = scheme_object_to_string (argv[0]);
// Annotations for garbage collection
MZ_GC_DECL_REG (5);
MZ_GC_VAR_IN_REG (0, argv);
MZ_GC_VAR_IN_REG (1, service);
MZ_GC_VAR_IN_REG (2, path);
MZ_GC_VAR_IN_REG (3, interface);
MZ_GC_VAR_IN_REG (4, result);
MZ_GC_REG ();
// Extract parameters
service = scheme_object_to_string (argv[0]);
path = scheme_object_to_string (argv[1]);
interface = scheme_object_to_string (argv[2]);
// Check parameters
if (service == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 0, argc, argv);
}
if (path == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 1, argc, argv);
}
if (interface == NULL)
{
MZ_GC_UNREG ();
scheme_wrong_type ("loudbus-proxy", "string", 2, argc, argv);
}
// Do the actual work in building the proxy.
proxy = loudbus_proxy_new (service, path, interface, &error);
if (proxy == NULL)
{
if (error == NULL)
{
MZ_GC_UNREG ();
scheme_signal_error ("loudbus-proxy: "
"Could not create proxy for an unknown reason.");
}
else
{
MZ_GC_UNREG ();
scheme_signal_error ("loudbus-proxy: "
"Could not create proxy because %s",
error->message);
}
} // if (proxy == NULL)
// Wrap the proxy into a Scheme type
result = scheme_make_cptr (proxy, LOUDBUS_PROXY_TAG);
// Log info during development
LOG ("loudbus_proxy: Built proxy %p, Scheme object %p", proxy, result);
// Find out information on what we just built.
SCHEME_LOG ("result is", result);
SCHEME_LOG ("result type is", SCHEME_CPTR_TYPE (result));
// Register the finalizer
scheme_register_finalizer (result, loudbus_proxy_finalize, NULL, NULL, NULL);
// And we're done
MZ_GC_UNREG ();
return result;
} // loudbus_proxy
static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info)
{
Scheme_Let_One *lo = (Scheme_Let_One *)o;
Scheme_Object *body, *rhs, *vec;
int pos, save_mnt, ip, et;
int unused = 0;
scheme_sfs_start_sequence(info, 2, 1);
scheme_sfs_push(info, 1, 1);
ip = info->ip;
pos = info->stackpos;
save_mnt = info->max_nontail;
if (!info->pass) {
vec = scheme_make_vector(3, NULL);
scheme_sfs_save(info, vec);
} else {
vec = scheme_sfs_next_saved(info);
if (SCHEME_VEC_SIZE(vec) != 3)
scheme_signal_error("internal error: bad vector length");
info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]);
info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]);
info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]);
}
rhs = scheme_sfs_expr(lo->value, info, -1);
body = scheme_sfs_expr(lo->body, info, -1);
# if MAX_SFS_CLEARING
if (!info->pass)
info->max_nontail = info->ip;
# endif
if (!info->pass) {
int n;
info->max_calls[pos] = info->max_nontail;
n = info->max_used[pos];
SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n);
n = info->max_calls[pos];
SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n);
SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail);
} else {
info->max_nontail = save_mnt;
if (info->max_used[pos] <= ip) {
/* No one is using it, so don't actually push the value at run time
(but keep the check that the result is single-valued).
The optimizer normally would have converted away the binding, but
it might not because (1) it was introduced late by inlining,
or (2) the rhs expression doesn't always produce a single
value. */
if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) {
rhs = scheme_false;
} else if ((ip < info->max_calls[pos])
&& SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) {
/* Unusual case: we can't just drop the global-variable access,
because it might be undefined, but we don't need the value,
and we want to avoid an SFS clear in the interpreter loop.
So, bind #f and then access in the global in a `begin'. */
Scheme_Sequence *s;
s = scheme_malloc_sequence(2);
s->so.type = scheme_sequence_type;
s->count = 2;
s->array[0] = rhs;
s->array[1] = body;
body = (Scheme_Object *)s;
rhs = scheme_false;
}
unused = 1;
}
}
lo->value = rhs;
lo->body = body;
et = scheme_get_eval_type(lo->value);
SCHEME_LET_EVAL_TYPE(lo) = (et
| (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM))
| (unused ? LET_ONE_UNUSED : 0));
return o;
}
static Scheme_Object *write_application(Scheme_Object *obj)
{
scheme_signal_error("app writer shouldn't be used");
return NULL;
}
static Scheme_Object *write_branch(Scheme_Object *obj)
{
scheme_signal_error("branch writer shouldn't be used");
return NULL;
}
int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *syncing)
/* When syncing is supplied, o can contain Scheme_Channel_Syncer
and never-evt values, and just_try must be 0. */
{
Scheme_Sema **semas = (Scheme_Sema **)o;
int v, i, ii;
if (just_try) {
/* assert: n == 1, !syncing */
Scheme_Sema *sema = semas[0];
if (just_try > 0) {
if (sema->so.type == scheme_sema_type) {
v = scheme_try_plain_sema((Scheme_Object *)sema);
} else {
v = try_channel(sema, syncing, 0, NULL);
}
} else {
Scheme_Cont_Frame_Data cframe;
scheme_push_break_enable(&cframe, 1, 1);
scheme_wait_sema((Scheme_Object *)sema, 0);
scheme_pop_break_enable(&cframe, 0);
return 1;
}
} else {
int start_pos;
#if 0
/* Use the "immutable" flag bit on a semaphore to check for
inconsistent use in atomic and non-atomic modes, which
can lead to an attempt to suspend in atomic mode. */
if ((n == 1) && SCHEME_SEMAP(o[0])) {
if (!do_atomic) {
SCHEME_SET_IMMUTABLE(o[0]);
} else if (SCHEME_IMMUTABLEP(o[0])) {
if (!on_atomic_timeout
|| (do_atomic > atomic_timeout_atomic_level)) {
scheme_signal_error("using a seaphore in both atomic and non-atomic mode");
}
}
}
#endif
if (n > 1) {
if (syncing)
start_pos = syncing->start_pos;
else {
Scheme_Object *rand_state;
rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_SCHEDULER_RANDOM_STATE);
start_pos = scheme_rand((Scheme_Random_State *)rand_state);
}
} else
start_pos = 0;
/* Initial poll */
while (1) {
i = 0;
for (ii = 0; ii < n; ii++) {
/* Randomized start position for poll ensures fairness: */
i = (start_pos + ii) % n;
if (semas[i]->so.type == scheme_sema_type) {
if (semas[i]->value) {
if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
--semas[i]->value;
if (syncing) {
syncing->result = i + 1;
if (syncing->accepts && syncing->accepts[i])
scheme_accept_sync(syncing, i);
}
break;
}
} else if (semas[i]->so.type == scheme_never_evt_type) {
/* Never ready. */
} else if (semas[i]->so.type == scheme_channel_syncer_type) {
if (((Scheme_Channel_Syncer *)semas[i])->picked)
break;
} else if (try_channel(semas[i], syncing, i, NULL))
break;
}
if (ii >= n) {
if (!scheme_wait_until_suspend_ok()) {
break;
} else {
/* there may have been some action on one of the waitables;
try again, if no result, yet */
if (syncing && syncing->result) {
i = syncing->result - 1;
ii = 0;
break;
}
}
} else
break;
}
/* In the following, syncers get changed back to channels,
and channel puts */
if (ii >= n) {
Scheme_Channel_Syncer **ws, *w;
ws = MALLOC_N(Scheme_Channel_Syncer*, n);
for (i = 0; i < n; i++) {
if (semas[i]->so.type == scheme_channel_syncer_type) {
ws[i] = (Scheme_Channel_Syncer *)semas[i];
semas[i] = (Scheme_Sema *)ws[i]->obj;
} else {
w = MALLOC_ONE_RT(Scheme_Channel_Syncer);
ws[i] = w;
w->so.type = scheme_channel_syncer_type;
w->p = scheme_current_thread;
w->syncing = syncing;
w->obj = (Scheme_Object *)semas[i];
w->syncing_i = i;
}
}
while (1) {
int out_of_a_line;
/* Get into line */
for (i = 0; i < n; i++) {
if (!ws[i]->in_line) {
get_into_line(semas[i], ws[i]);
}
}
if (!scheme_current_thread->next) {
void **a;
/* We're not allowed to suspend the main thread. Delay
breaks so we get a chance to clean up. */
scheme_current_thread->suspend_break++;
a = MALLOC_N(void*, 3);
a[0] = scheme_make_integer(n);
a[1] = ws;
a[2] = scheme_current_thread;
scheme_main_was_once_suspended = 0;
scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0);
--scheme_current_thread->suspend_break;
} else {
/* Mark the thread to indicate that we need to clean up
if the thread is killed. */
int old_nkc;
old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP);
if (!old_nkc)
scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP;
scheme_weak_suspend_thread(scheme_current_thread);
if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP))
scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP;
}
/* We've been resumed. But was it for the semaphore, or a signal? */
out_of_a_line = 0;
/* If we get the post, we must return WITHOUT BLOCKING.
GRacket, for example, depends on this special property, which
ensures that the thread can't be broken or killed between
receiving the post and returning. */
if (!syncing) {
/* Poster can't be sure that we really will get it,
so we have to decrement the sema count here. */
i = 0;
for (ii = 0; ii < n; ii++) {
i = (start_pos + ii) % n;
if (ws[i]->picked) {
out_of_a_line = 1;
if (semas[i]->value) {
if (semas[i]->value > 0)
--(semas[i]->value);
break;
}
}
}
if (ii >= n)
i = n;
} else {
if (syncing->result) {
out_of_a_line = 1;
i = syncing->result - 1;
} else {
out_of_a_line = 0;
i = n;
}
}
if (!out_of_a_line) {
/* We weren't woken by any semaphore/channel. Get out of line, block once
(to handle breaks/kills) and then loop to get back into line. */
for (i = 0; i < n; i++) {
if (ws[i]->in_line)
get_outof_line(semas[i], ws[i]);
}
scheme_thread_block(0); /* ok if it returns multiple times */
scheme_current_thread->ran_some = 1;
/* [but why would it return multiple times?! there must have been a reason...] */
} else {
if ((scheme_current_thread->running & MZTHREAD_KILLED)
|| ((scheme_current_thread->running & MZTHREAD_USER_SUSPENDED)
&& !(scheme_current_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP))) {
/* We've been killed or suspended! */
i = -1;
}
/* We got a post from semas[i], or we were killed.
Did any (other) semaphore pick us?
(This only happens when syncing == NULL.) */
if (!syncing) {
int j;
for (j = 0; j < n; j++) {
if (j != i) {
if (ws[j]->picked) {
if (semas[j]->value) {
/* Consume the value and repost, because no one else
has been told to go, and we're accepting a different post. */
if (semas[j]->value > 0)
--semas[j]->value;
scheme_post_sema((Scheme_Object *)semas[j]);
}
}
}
}
}
/* If we're done, get out of all lines that we're still in. */
if (i < n) {
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
}
}
if (i == -1) {
scheme_thread_block(0); /* dies or suspends */
scheme_current_thread->ran_some = 1;
}
if (i < n)
break;
}
/* Otherwise: !syncing and someone stole the post, or we were
suspended and we have to start over. Either way, poll then
loop to get back in line an try again. */
for (ii = 0; ii < n; ii++) {
i = (start_pos + ii) % n;
if (semas[i]->so.type == scheme_sema_type) {
if (semas[i]->value) {
if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
--semas[i]->value;
if (syncing && syncing->accepts && syncing->accepts[i])
scheme_accept_sync(syncing, i);
break;
}
} else if (semas[i]->so.type == scheme_never_evt_type) {
/* Never ready. */
} else if (try_channel(semas[i], syncing, i, NULL))
break;
}
if (ii < n) {
/* Get out of any line that we still might be in: */
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
}
break;
}
if (!syncing) {
/* Looks like this thread is a victim of unfair semaphore access.
Go into fair mode by allocating a syncing: */
syncing = MALLOC_ONE_RT(Syncing);
#ifdef MZTAG_REQUIRED
syncing->type = scheme_rt_syncing;
#endif
syncing->start_pos = start_pos;
/* Get out of all lines, and set syncing field before we get back in line: */
{
int j;
for (j = 0; j < n; j++) {
if (ws[j]->in_line)
get_outof_line(semas[j], ws[j]);
ws[j]->syncing = syncing;
}
}
}
/* Back to top of loop to sync again */
}
Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos)
/* closure_self_pos == -2 => immediately in sequence */
{
Scheme_Type type = SCHEME_TYPE(expr);
int seqn, stackpos, tp;
seqn = info->seqn;
stackpos = info->stackpos;
tp = info->tail_pos;
if (seqn) {
info->seqn = 0;
info->tail_pos = 0;
}
info->ip++;
switch (type) {
case scheme_local_type:
case scheme_local_unbox_type:
if (!info->pass)
scheme_sfs_used(info, SCHEME_LOCAL_POS(expr));
else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) {
int pos, at_ip;
pos = SCHEME_LOCAL_POS(expr);
at_ip = info->max_used[info->stackpos + pos];
if (at_ip < info->max_calls[info->stackpos + pos]) {
if (at_ip == info->ip) {
/* Clear on read: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ);
} else {
/* Someone else clears it: */
expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS);
}
} else {
# if MAX_SFS_CLEARING
scheme_signal_error("should have been cleared somewhere");
# endif
}
}
break;
case scheme_application_type:
expr = sfs_application(expr, info);
break;
case scheme_application2_type:
expr = sfs_application2(expr, info);
break;
case scheme_application3_type:
expr = sfs_application3(expr, info);
break;
case scheme_sequence_type:
expr = sfs_sequence(expr, info, closure_self_pos != -2);
break;
case scheme_splice_sequence_type:
expr = sfs_sequence(expr, info, 0);
break;
case scheme_branch_type:
expr = sfs_branch(expr, info);
break;
case scheme_with_cont_mark_type:
expr = sfs_wcm(expr, info);
break;
case scheme_unclosed_procedure_type:
expr = sfs_closure(expr, info, closure_self_pos);
break;
case scheme_let_value_type:
expr = sfs_let_value(expr, info);
break;
case scheme_let_void_type:
expr = sfs_let_void(expr, info);
break;
case scheme_letrec_type:
expr = sfs_letrec(expr, info);
break;
case scheme_let_one_type:
expr = sfs_let_one(expr, info);
break;
case scheme_closure_type:
{
Scheme_Closure *c = (Scheme_Closure *)expr;
if (ZERO_SIZED_CLOSUREP(c)) {
Scheme_Object *code;
code = sfs_closure((Scheme_Object *)c->code, info, closure_self_pos);
if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type)) {
Scheme_Sequence *seq = (Scheme_Sequence *)code;
c->code = (Scheme_Closure_Data *)seq->array[0];
seq->array[0] = expr;
expr = code;
} else {
c->code = (Scheme_Closure_Data *)code;
}
}
}
break;
case scheme_toplevel_type:
{
int c = SCHEME_TOPLEVEL_DEPTH(expr);
if (info->stackpos + c != info->tlpos)
scheme_signal_error("toplevel access not at expected place");
}
break;
case scheme_case_closure_type:
{
/* FIXME: maybe need to handle eagerly created closure */
}
break;
case scheme_define_values_type:
expr = define_values_sfs(expr, info);
break;
case scheme_define_syntaxes_type:
expr = define_syntaxes_sfs(expr, info);
break;
case scheme_begin_for_syntax_type:
expr = begin_for_syntax_sfs(expr, info);
break;
case scheme_set_bang_type:
expr = set_sfs(expr, info);
break;
case scheme_boxenv_type:
expr = bangboxenv_sfs(expr, info);
break;
case scheme_begin0_sequence_type:
expr = begin0_sfs(expr, info);
break;
case scheme_require_form_type:
expr = top_level_require_sfs(expr, info);
break;
case scheme_varref_form_type:
expr = ref_sfs(expr, info);
break;
case scheme_apply_values_type:
expr = apply_values_sfs(expr, info);
break;
case scheme_case_lambda_sequence_type:
expr = case_lambda_sfs(expr, info);
break;
case scheme_module_type:
expr = module_sfs(expr, info);
break;
case scheme_inline_variant_type:
expr = inline_variant_sfs(expr, info);
break;
default:
break;
}
info->ip++;
if (seqn) {
info->seqn = seqn - 1;
memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int));
info->stackpos = stackpos;
info->tail_pos = tp;
}
return expr;
}