static SCM
create_subr (int define, const char *name,
unsigned int nreq, unsigned int nopt, unsigned int rest,
SCM (*fcn) (), SCM *generic_loc)
{
SCM ret, sname;
scm_t_bits flags;
scm_t_bits nfree = generic_loc ? 3 : 2;
sname = scm_from_utf8_symbol (name);
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2);
SCM_SET_CELL_WORD_1 (ret, get_subr_stub_code (nreq, nopt, rest));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, scm_from_pointer (fcn, NULL));
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, sname);
if (generic_loc)
SCM_PROGRAM_FREE_VARIABLE_SET (ret, 2,
scm_from_pointer (generic_loc, NULL));
if (define)
scm_define (sname, ret);
return ret;
}
static int servlet_run(lua_State *l)
{
SCM run_ref = (SCM)lua_touserdata(l, lua_upvalueindex(1));
SCM s = scm_from_pointer(l, NULL);
scm_call_1(run_ref, s);
return 0;
}
SCM llvm_get_function_address(SCM scm_llvm, SCM scm_name)
{
struct llvm_module_t *self = get_llvm(scm_llvm);
char *name = scm_to_locale_string(scm_name);
void *address = (void *)LLVMGetFunctionAddress(self->engine, name);
free(name);
return scm_from_pointer(address, NULL);
}
SCM gc_malloc(SCM scm_size)
{
size_t size = scm_to_int(scm_size);
void *ptr = scm_gc_malloc(size, "gc-malloc");
SCM *p = ptr;
int i;
for (i=0; i<size; i+=8)
*p++ = SCM_BOOL_F;
return scm_from_pointer(ptr, NULL);
}
static SCM list_audio_frame_info(struct ffmpeg_t *self, AVFrame *frame)
{
int channels = audio_codec_ctx(self)->channels;
int64_t offsets[AV_NUM_DATA_POINTERS];
offsets_from_pointers(frame->data, offsets, AV_NUM_DATA_POINTERS);
int frame_size =
av_samples_get_buffer_size(NULL, channels, frame->nb_samples, frame->format, 1);
return scm_list_n(scm_from_int(frame->format),
scm_list_2(scm_from_int(frame->nb_samples), scm_from_int(channels)),
scm_from_int(self->audio_codec_ctx->sample_rate),
from_non_zero_array(offsets, AV_NUM_DATA_POINTERS, 1),
scm_from_pointer(*frame->data, NULL),
scm_from_int(frame_size),
SCM_UNDEFINED);
}
SCM tf_from_tensor(SCM scm_self)
{
struct tf_tensor_t *self = get_tf_tensor(scm_self);
int type = TF_TensorType(self->tensor);
int num_dims = TF_NumDims(self->tensor);
int count = 1;
SCM scm_shape = SCM_EOL;
for (int i=num_dims - 1; i>=0; i--) {
scm_shape = scm_cons(scm_from_int(TF_Dim(self->tensor, i)), scm_shape);
count = count * TF_Dim(self->tensor, i);
};
size_t size = TF_TensorByteSize(self->tensor);
void *data;
if (type == TF_STRING) {
int64_t *offsets = TF_TensorData(self->tensor);
void *pointer = offsets + count;
size_t str_len;
data = scm_gc_malloc(sizeof(SCM) * count, "from-tensor");
SCM *result = data;
for (int i=0; i<count; i++) {
const char *str;
size_t len;
TF_StringDecode(pointer + *offsets, size - *offsets, &str, &len, status());
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("from-tensor", TF_Message(_status), SCM_EOL);
*result++ = scm_from_locale_stringn(str, len);
offsets++;
};
} else {
data = scm_gc_malloc_pointerless(size, "from-tensor");
memcpy(data, TF_TensorData(self->tensor), size);
};
return scm_list_3(scm_from_int(type),
scm_shape,
scm_from_pointer(data, NULL));
}
static SCM list_video_frame_info(struct ffmpeg_t *self, AVFrame *frame)
{
// note that the pointer offsets can be negative for FFmpeg frames because av_frame_get_buffer
// allocates separate memory locations for each image plane.
int64_t offsets[AV_NUM_DATA_POINTERS];
offsets_from_pointers(frame->data, offsets, AV_NUM_DATA_POINTERS);
int64_t linesize[AV_NUM_DATA_POINTERS];
int_array_to_long(linesize, frame->linesize, AV_NUM_DATA_POINTERS);
#ifdef HAVE_IMAGE_BUFFER_SIZE
int size = av_image_get_buffer_size(frame->format, frame->width, frame->height, 32);
#else
int size = avpicture_get_size(frame->format, frame->width, frame->height);
#endif
return scm_list_n(scm_from_int(frame->format),
scm_list_2(scm_from_int(frame->height), scm_from_int(frame->width)),
from_non_zero_array(offsets, AV_NUM_DATA_POINTERS, 1),
from_non_zero_array(linesize, AV_NUM_DATA_POINTERS, 1),
scm_from_pointer(*frame->data, NULL),
scm_from_int(size),
SCM_UNDEFINED);
}
VISIBLE SCM
scm_from_rexp_match_t (rexp_match_t _m)
{
return scm_call_1 (_pointer_to_rexp_match (), scm_from_pointer (_m, NULL));
}
VISIBLE SCM
scm_from_rexp_t (rexp_t _re)
{
return scm_call_1 (_pointer_to_rexp (), scm_from_pointer (_re, NULL));
}
SCM gc_malloc_pointerless(SCM scm_size)
{
size_t size = scm_to_int(scm_size);
void *ptr = scm_gc_malloc_pointerless(size, "gc-malloc-pointerless");
return scm_from_pointer(ptr, NULL);
}
SCM py2scm(PyObject *value)
{
if (value == Py_None) {
return SCM_UNSPECIFIED;
}
if (PyBool_Check(value)) {
int v = PyObject_IsTrue(value);
if (v == -1)
return NULL;
return scm_from_bool(v);
}
if (PyInt_Check(value)) {
long v = PyInt_AsLong(value);
if (PyErr_Occurred())
return NULL;
return scm_from_long(v);
}
if (PyFloat_Check(value)) {
double v = PyFloat_AsDouble(value);
if (PyErr_Occurred())
return NULL;
return scm_from_double(v);
}
if (PyString_Check(value)) {
const char *s = PyString_AsString(value);
if (s == NULL)
return NULL;
return scm_from_utf8_stringn(s, PyString_Size(value));
}
if (PyUnicode_Check(value)) {
scm_dynwind_begin(0);
PyObject *utf8_str = PyUnicode_AsUTF8String(value);
if (utf8_str == NULL) {
scm_dynwind_end();
return NULL;
}
scm_dynwind_py_decref(utf8_str);
const char *s = PyString_AsString(utf8_str);
if (s == NULL) {
scm_dynwind_end();
return NULL;
}
SCM result = scm_from_utf8_stringn(s, PyString_Size(utf8_str));
scm_dynwind_end();
return result;
}
if (PySequence_Check(value)) {
unsigned int i = PySequence_Size(value);
SCM r = SCM_EOL;
while (i-- > 0) {
PyObject *item = PySequence_GetItem(value, i);
r = scm_cons(py2scm(item), r);
}
return r;
}
if (PyObject_TypeCheck(value, &ProcedureType))
return ((Procedure *)value)->proc;
if (PyCallable_Check(value)) {
SCM gsubr = scm_c_make_gsubr(
"<Python function>", 0, 0, 1, &call_callable);
Py_INCREF(value);
SCM ptr = scm_from_pointer(value, (void (*)(void *))Py_DecRef);
gsubr_alist = scm_acons(gsubr, ptr, gsubr_alist);
return gsubr;
}
char buf[BUFSIZ];
snprintf(buf, BUFSIZ, "Python type \"%.50s\" doesn't have a "
"corresponding Guile type",
value->ob_type->tp_name);
scm_error(scm_from_utf8_symbol("misc-error"), NULL, buf,
SCM_EOL, SCM_EOL);
/* does not return */
fprintf(stderr, "*** scm_error shouldn't have returned ***\n");
return SCM_UNSPECIFIED;
}
