static ScmObj force_cc(ScmObj result, void **data)
{
ScmPromise *p = (ScmPromise*)data[0];
ScmObj handlers = (ScmObj)data[1];
/* Check if the original promise is forced by evaluating
the delayed expr to detect recursive force situation */
if (!p->content->forced) {
if (SCM_PROMISEP(result)) {
/* Deal with a recursive promise introduced by lazy operation.
See srfi-45 for the details. */
p->content->forced = SCM_PROMISE(result)->content->forced;
p->content->code = SCM_PROMISE(result)->content->code;
SCM_PROMISE(result)->content = p->content;
} else {
/* This isn't supposed to happen if 'lazy' is used properly
on the promise-yielding procedure, but we can't prevent
one from writing (lazy 3). So play safe. */
p->content->forced = TRUE;
p->content->code = result;
}
}
if (--p->content->count == 0) {
p->content->owner = NULL;
SCM_INTERNAL_MUTEX_UNLOCK(p->content->mutex);
}
Scm_VM()->handlers = handlers;
SCM_RETURN(Scm_Force(SCM_OBJ(p)));
}
ScmObj Scm_MakeObjCError(ScmObj name, ScmObj reason)
{
ScmObj e = objc_error_allocate(SCM_CLASS_OBJC_ERROR, SCM_NIL);
SCM_OBJC_ERROR(e)->name = name;
SCM_OBJC_ERROR(e)->reason = reason;
SCM_RETURN(e);
}
static ScmObj objc_error_allocate(ScmClass *klass, ScmObj initargs)
{
ScmObjCError *err = SCM_ALLOCATE(ScmObjCError, klass);
SCM_SET_CLASS(err, klass);
err->name = SCM_FALSE;
err->reason = SCM_FALSE;
SCM_RETURN(SCM_OBJ(err));
}
ScmObj Scm_Force(ScmObj obj)
{
if (!SCM_PROMISEP(obj)) {
SCM_RETURN(obj);
} else {
ScmPromiseContent *c = SCM_PROMISE(obj)->content;
if (c->forced) SCM_RETURN(c->code);
else {
ScmVM *vm = Scm_VM();
void *data[2];
data[0] = obj;
data[1] = vm->handlers;
if (c->owner == vm) {
/* we already have the lock and evaluating this promise. */
c->count++;
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
} else {
/* TODO: check if the executing thread terminates
prematurely */
SCM_INTERNAL_MUTEX_LOCK(c->mutex);
if (c->forced) {
SCM_INTERNAL_MUTEX_UNLOCK(c->mutex);
SCM_RETURN(c->code);
}
SCM_ASSERT(c->owner == NULL);
c->owner = vm;
install_release_thunk(vm, obj);
c->count++;
/* mutex is unlocked by force_cc. */
Scm_VMPushCC(force_cc, data, 2);
SCM_RETURN(Scm_VMApply0(c->code));
}
}
}
}
static ScmObj objc_error_reason_get(ScmObjCError *err)
{
SCM_RETURN(err->reason);
}
static ScmObj objc_error_name_get(ScmObjCError *err)
{
SCM_RETURN(err->name);
}
