Example #1
0
static void
primitive_invoke_continuation (rep_continuation *c, repv ret)
{
    char water_mark;
    rep_barrier **dest_hist = 0, *dest_root = 0, *anc, *ptr;
    int depth;

    /* try to find a route from the current root barrier to the
       root barrier of the continuation, without crossing any
       closed barriers */

    dest_root = FIXUP (rep_barrier *, c, c->barriers);
    dest_hist = alloca (sizeof (rep_barrier *) * dest_root->depth);
    depth = trace_barriers (c, dest_hist);

    anc = common_ancestor (barriers, dest_hist, depth);
    if (anc == 0)
    {
	DEFSTRING (unreachable, "unreachable continuation");
	Fsignal (Qerror, rep_LIST_1 (rep_VAL (&unreachable)));
	return;
    }

    /* Handle any `out' barrier functions */
    for (ptr = barriers; ptr != anc; ptr = ptr->next)
    {
	DB (("invoke: outwards through %p (%d)\n", ptr, ptr->depth));
	if (ptr->out != 0)
	{
	    repv cont = rep_VAL (c);
	    rep_GC_root gc_cont, gc_ret;
	    rep_PUSHGC (gc_cont, cont);
	    rep_PUSHGC (gc_ret, ret);
	    ptr->out (ptr->data);
	    rep_POPGC; rep_POPGC;
	}
    }

    /* save the return value and recurse up the stack until there's
       room to invoke the continuation. Note that invoking this subr
       will already have restored the original environment since the
       call to Fmake_closure () will have saved its old state.. */

    invoked_continuation = c;
    invoked_continuation_ret = ret;
    invoked_continuation_ancestor = anc;

    DB (("invoke: calling continuation %p\n", c));
    grow_stack_and_invoke (c, &water_mark);
}
Example #2
0
static char *
rep_ffi_marshal (unsigned int type_id, repv value, char *ptr)
{
    rep_ffi_type *type = ffi_types[type_id];

    switch (type->subtype)
    {
	DEFSTRING (err, "unknown ffi type id");
	DEFSTRING (err2, "ffi struct expected a vector or list");

    case rep_FFI_PRIMITIVE:
	switch (type->type->type)
	{
	case FFI_TYPE_VOID:
	    return ptr;

	case FFI_TYPE_INT:
	    *(int *)ptr = (int) rep_get_long_int (value);
	    return ptr + sizeof (int);

	case FFI_TYPE_FLOAT:
	    *(float *)ptr = (float) rep_get_float (value);
	    return ptr + sizeof (float);

	case FFI_TYPE_DOUBLE:
	    *(double *)ptr = (double) rep_get_float (value);
	    return ptr + sizeof (double);

#if FFI_TYPE_LONGDOUBLE != FFI_TYPE_DOUBLE
	case FFI_TYPE_LONGDOUBLE:
	    *(long double *)ptr = (long double) rep_get_float (value);
	    return ptr + sizeof (long double);
#endif

	case FFI_TYPE_UINT8:
	    *(uint8_t *)ptr = (uint8_t) rep_get_long_int (value);
	    return ptr + sizeof (uint8_t);

	case FFI_TYPE_SINT8:
	    *(int8_t *)ptr = (int8_t) rep_get_long_int (value);
	    return ptr + sizeof (int8_t);

	case FFI_TYPE_UINT16:
	    *(uint16_t *)ptr = (uint16_t) rep_get_long_int (value);
	    return ptr + sizeof (uint16_t);

	case FFI_TYPE_SINT16:
	    *(int16_t *)ptr = (int16_t) rep_get_long_int (value);
	    return ptr + sizeof (int16_t);

	case FFI_TYPE_UINT32:
	    *(uint32_t *)ptr = (uint32_t) rep_get_long_int (value);
	    return ptr + sizeof (uint32_t);

	case FFI_TYPE_SINT32:
	    *(int32_t *)ptr = (int32_t) rep_get_long_int (value);
	    return ptr + sizeof (int32_t);

	case FFI_TYPE_UINT64:
	    *(uint64_t *)ptr = (uint64_t) rep_get_longlong_int (value);
	    return ptr + sizeof (uint64_t);

	case FFI_TYPE_SINT64:
	    *(int64_t *)ptr = (int64_t) rep_get_longlong_int (value);
	    return ptr + sizeof (int64_t);

	case FFI_TYPE_POINTER:
	    *(void **)ptr = (rep_STRINGP(value)) ? rep_STR (value) : rep_get_pointer (value);
	    return ptr + sizeof (void *);

	case FFI_TYPE_STRUCT:		/* FIXME: */
	default:
	    Fsignal (Qerror, rep_list_2 (rep_VAL (&err),
					 rep_MAKE_INT (type_id)));
	    return NULL;
	}
	/* not reached */

    case rep_FFI_STRUCT: {
	rep_ffi_struct *s = (rep_ffi_struct *) type;
	rep_GC_root gc_value;
	int i;

	rep_PUSHGC (gc_value, value);

	for (i = 0; i < s->n_elements; i++)
	{
	    repv elt;

	    if (rep_VECTORP (value))
		elt = rep_VECTI (value, i);
	    else if (rep_CONSP (value)) {
		elt = rep_CAR (value);
		value = rep_CDR (value);
	    } else {
		rep_POPGC;
		Fsignal (Qerror, rep_list_2 (rep_VAL (&err2), value));
		return NULL;
	    }

	    ptr = rep_ffi_marshal (s->element_ids[i], elt, ptr);

	    if (ptr == NULL) {
		rep_POPGC;
		return NULL;
	    }
	}

	rep_POPGC;
	return ptr;
    }

    case rep_FFI_ALIAS: {
	rep_ffi_alias *s = (rep_ffi_alias *) type;

	if (s->conv_in != rep_NULL) {
	    value = rep_call_lisp1 (s->conv_in, value);
	    if (value == rep_NULL)
		return NULL;
	}

	return rep_ffi_marshal (s->base, value, ptr);
    }

    default:
	Fsignal (Qerror, rep_list_2 (rep_VAL (&err), rep_MAKE_INT (type_id)));
	return NULL;
    }
}