static SCM
ppscm_make_pp_type_error_exception (const char *message, SCM object)
{
char *msg = xstrprintf ("%s: ~S", message);
struct cleanup *cleanup = make_cleanup (xfree, msg);
SCM exception
= gdbscm_make_error (pp_type_error_symbol,
NULL /* func */, msg,
scm_list_1 (object), scm_list_1 (object));
do_cleanups (cleanup);
return exception;
}
static SCM
expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{
SCM test;
const long length = scm_ilength (clause);
ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
test = CAR (clause);
if (scm_is_eq (test, scm_sym_else) && elp)
{
const int last_clause_p = scm_is_null (rest);
ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
return expand_sequence (CDR (clause), env);
}
if (scm_is_null (rest))
rest = VOID (SCM_BOOL_F);
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
if (length >= 2
&& scm_is_eq (CADR (clause), scm_sym_arrow)
&& alp)
{
SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
SCM new_env = scm_acons (tmp, tmp, env);
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
return LET (SCM_BOOL_F,
scm_list_1 (tmp),
scm_list_1 (tmp),
scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
CALL (SCM_BOOL_F,
expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))),
rest));
}
/* FIXME length == 1 case */
else
return CONDITIONAL (SCM_BOOL_F,
expand (test, env),
expand_sequence (CDR (clause), env),
rest);
}
static AVFrame *allocate_output_video_frame(SCM scm_self, AVCodecContext *video_context)
{
AVFrame *retval = allocate_frame(scm_self);
int width = video_context->width;
int height = video_context->height;
retval->format = PIX_FMT;
retval->width = width;
retval->height = height;
#ifdef HAVE_AV_FRAME_GET_BUFFER
int err = av_frame_get_buffer(retval, 32);
if (err < 0) {
ffmpeg_destroy(scm_self);
scm_misc_error("allocate-output-frame", "Error allocating frame buffer: ~a",
scm_list_1(get_error_text(err)));
};
#else
int size = avpicture_get_size(PIX_FMT, width, height);
uint8_t *frame_buffer = (uint8_t *)av_malloc(size);
if (!frame_buffer) {
ffmpeg_destroy(scm_self);
scm_misc_error("allocate-output-video-frame", "Error allocating video frame memory", SCM_EOL);
};
avpicture_fill((AVPicture *)retval, frame_buffer, PIX_FMT, width, height);
#endif
return retval;
}
static SCM
scm_type_symbol_to_AnchorPointType (SCM symb, SCM who)
{
int type = INT_MIN;
if (scm_is_eq (symb, scm_symbol__mark ()))
type = at_mark;
else if (scm_is_eq (symb, scm_symbol__base ()))
type = at_basechar;
else if (scm_is_eq (symb, scm_symbol__ligature ()))
type = at_baselig;
else if (scm_is_eq (symb, scm_symbol__base_mark ()))
type = at_basemark;
else if (scm_is_eq (symb, scm_symbol__entry ()))
type = at_centry;
else if (scm_is_eq (symb, scm_symbol__exit ()))
type = at_cexit;
else
{
if (SCM_UNBNDP (who))
who = scm_from_latin1_string ("scm_type_symbol_to_AnchorPointType");
rnrs_raise_condition
(scm_list_4
(rnrs_make_assertion_violation (),
rnrs_make_who_condition (who),
rnrs_c_make_message_condition (_("unrecognized anchor point type")),
rnrs_make_irritants_condition (scm_list_1 (symb))));
}
return scm_from_int (type);
}
static void
check_flag (MuFlags flag, FlagData *fdata)
{
SCM flag_scm;
if (!(fdata->flags & flag))
return;
switch (flag) {
case MU_FLAG_NEW: flag_scm = SYMB_FLAG_NEW; break;
case MU_FLAG_PASSED: flag_scm = SYMB_FLAG_PASSED; break;
case MU_FLAG_REPLIED: flag_scm = SYMB_FLAG_REPLIED; break;
case MU_FLAG_SEEN: flag_scm = SYMB_FLAG_SEEN; break;
case MU_FLAG_TRASHED: flag_scm = SYMB_FLAG_TRASHED; break;
case MU_FLAG_SIGNED: flag_scm = SYMB_FLAG_SIGNED; break;
case MU_FLAG_DRAFT: flag_scm = SYMB_FLAG_DRAFT; break;
case MU_FLAG_FLAGGED: flag_scm = SYMB_FLAG_FLAGGED; break;
case MU_FLAG_ENCRYPTED: flag_scm = SYMB_FLAG_ENCRYPTED; break;
case MU_FLAG_HAS_ATTACH: flag_scm = SYMB_FLAG_HAS_ATTACH; break;
case MU_FLAG_UNREAD: flag_scm = SYMB_FLAG_UNREAD; break;
default: flag_scm = SCM_UNDEFINED;
}
fdata->lst = scm_append_x
(scm_list_2(fdata->lst,
scm_list_1 (flag_scm)));
}
SCM tf_add_gradient_(SCM scm_graph, SCM scm_expression, SCM scm_variables)
{
SCM retval;
if (scm_is_true(scm_list_p(scm_variables))) {
struct tf_graph_t *graph = get_tf_graph(scm_graph);
struct tf_output_t *expression = get_tf_output(scm_expression);
int nvariables = scm_ilength(scm_variables);
TF_Output *variables = scm_gc_calloc(sizeof(TF_Output) * nvariables, "tf-add-gradient_");
for (int i=0; i<nvariables; i++) {
variables[i] = get_tf_output(scm_car(scm_variables))->output;
scm_variables = scm_cdr(scm_variables);
};
TF_Output *output = scm_gc_calloc(sizeof(TF_Output) * nvariables, "tf-add-gradient_");
TF_AddGradients(graph->graph, &expression->output, 1, variables, nvariables, NULL, status(), output);
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("tf-add-gradient_", TF_Message(_status), SCM_EOL);
retval = SCM_EOL;
for (int i=nvariables-1; i>=0; i--) {
SCM element;
struct tf_output_t *result = scm_gc_calloc(sizeof(struct tf_output_t), "tf-add-gradient_");
SCM_NEWSMOB(element, tf_output_tag, result);
result->output = output[i];
retval = scm_cons(element, retval);
};
} else
retval = scm_car(tf_add_gradient_(scm_graph, scm_expression, scm_list_1(scm_variables)));
return retval;
}
void
scm_assert_foreign_object_type (SCM type, SCM val)
{
if (!SCM_IS_A_P (val, type))
scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
}
/*! \brief Runs a page hook.
* \par Function Description
* Runs a hook called \a name, which should expect the single #PAGE \a
* page as its argument.
*
* \param name name of hook to run
* \param page #PAGE argument for hook.
*/
void
g_run_hook_page (const char *name, PAGE *page)
{
SCM args = scm_list_1 (edascm_from_page (page));
scm_run_hook (g_get_hook_by_name (name), args);
scm_remember_upto_here_1 (args);
}
void *
gram_output_created_hook_run (void *data)
{
scm_c_run_hook (gram_output_created_hook,
scm_list_1 (gram_output_scm (*(const wlc_handle *) data)));
return SCM_UNSPECIFIED;
}
SCM tf_run(SCM scm_session, SCM scm_input, SCM scm_output)
{
SCM retval;
if (scm_is_true(scm_list_p(scm_output))) {
struct tf_session_t *session = get_tf_session(scm_session);
int ninputs = scm_ilength(scm_input);
TF_Output *inputs = scm_gc_malloc(sizeof(TF_Output) * ninputs, "tf-run");
TF_Tensor **input_values = scm_gc_malloc(sizeof(TF_Tensor *) * ninputs, "tf-run");
for (int i=0; i<ninputs; i++) {
memcpy(&inputs[i], &get_tf_output(scm_caar(scm_input))->output, sizeof(TF_Output));
input_values[i] = get_tf_tensor(scm_cdar(scm_input))->tensor;
scm_input = scm_cdr(scm_input);
};
int noutputs = scm_ilength(scm_output);
TF_Output *output = scm_gc_malloc(sizeof(TF_Output) * noutputs, "tf-run");
TF_Tensor **output_values = scm_gc_malloc(sizeof(TF_Tensor *) * noutputs, "tf-run");
for (int i=0; i<noutputs; i++) {
output[i] = get_tf_output(scm_car(scm_output))->output;
scm_output = scm_cdr(scm_output);
};
TF_SessionRun(session->session, NULL, inputs, input_values, ninputs, output, output_values, noutputs, NULL, 0, NULL, status());
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("tf-run", TF_Message(_status), SCM_EOL);
retval = SCM_EOL;
for (int i=noutputs-1; i>=0; i--) {
SCM element;
struct tf_tensor_t *result = (struct tf_tensor_t *)scm_gc_calloc(sizeof(struct tf_tensor_t), "make-tensor");
SCM_NEWSMOB(element, tf_tensor_tag, result);
result->tensor = output_values[i];
retval = scm_cons(element, retval);
};
} else
retval = scm_car(tf_run(scm_session, scm_input, scm_list_1(scm_output)));
return retval;
}
void
scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv,
scm_i_jmp_buf *current_registers)
{
SCM cont;
scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
scm_t_bits *prompt;
scm_t_dynstack_prompt_flags flags;
scm_t_ptrdiff fp_offset, sp_offset;
union scm_vm_stack_element *fp, *sp;
scm_t_uint32 *ip;
scm_i_jmp_buf *registers;
size_t i;
prompt = scm_dynstack_find_prompt (dynstack, tag,
&flags, &fp_offset, &sp_offset, &ip,
®isters);
if (!prompt)
scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag));
fp = vp->stack_top - fp_offset;
sp = vp->stack_top - sp_offset;
/* Only reify if the continuation referenced in the handler. */
if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY)
cont = SCM_BOOL_F;
else
{
scm_t_dynstack *captured;
captured = scm_dynstack_capture (dynstack, SCM_DYNSTACK_NEXT (prompt));
cont = reify_partial_continuation (vp, fp, sp, ip, registers, captured,
current_registers);
}
/* Unwind. */
scm_dynstack_unwind (dynstack, prompt);
/* Restore VM regs */
vp->fp = fp;
vp->sp = sp - n - 1;
vp->ip = ip;
/* Since we're jumping down, we should always have enough space. */
if (vp->sp < vp->stack_limit)
abort ();
/* Push vals */
vp->sp[n].as_scm = cont;
for (i = 0; i < n; i++)
vp->sp[n - i - 1].as_scm = argv[i];
/* Jump! */
SCM_I_LONGJMP (*registers, 1);
/* Shouldn't get here */
abort ();
}
static char*
map_file_contents (int fd, size_t len, int *is_read_only)
#define FUNC_NAME "load-thunk-from-file"
{
char *data;
#ifdef HAVE_SYS_MMAN_H
data = mmap (NULL, len, PROT_READ, MAP_PRIVATE, fd, 0);
if (data == MAP_FAILED)
SCM_SYSERROR;
*is_read_only = 1;
#else
if (lseek (fd, 0, SEEK_START) < 0)
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
SCM_SYSERROR;
}
/* Given that we are using the read fallback, optimistically assume
that the .go files were made with 8-byte alignment.
alignment. */
data = malloc (end);
if (!data)
{
(void) close (fd);
scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes",
scm_list_1 (scm_from_size_t (end)));
}
if (full_read (fd, data, end) != end)
{
int errno_save = errno;
(void) close (fd);
errno = errno_save;
if (errno)
SCM_SYSERROR;
scm_misc_error (FUNC_NAME, "short read while loading objcode",
SCM_EOL);
}
/* If our optimism failed, fall back. */
{
unsigned alignment = sniff_elf_alignment (data, end);
if (alignment != 8)
{
char *copy = copy_and_align_elf_data (data, end, alignment);
free (data);
data = copy;
}
}
*is_read_only = 0;
#endif
return data;
}
static AVCodec *find_encoder(SCM scm_self, enum AVCodecID codec_id, const char *output_type)
{
if (codec_id == AV_CODEC_ID_NONE) {// TODO: test (needs wav or mp3 container selection above first)
ffmpeg_destroy(scm_self);
scm_misc_error("make-ffmpeg-output", "File format does not support ~a encoding",
scm_list_1(scm_from_locale_string(output_type)));
};
AVCodec *retval = avcodec_find_encoder(codec_id);// TODO: autodetect or select video codec
if (!retval) {
ffmpeg_destroy(scm_self);
scm_misc_error("make-ffmpeg-output", "Error finding encoder for codec '~a'",
scm_list_1(scm_from_locale_string(avcodec_descriptor_get(codec_id)->name)));
};
return retval;
}
void
scm_assert_foreign_object_type (SCM type, SCM val)
{
/* FIXME: Add fast path for when type == struct vtable */
if (!SCM_IS_A_P (val, type))
scm_error (scm_arg_type_key, NULL, "Wrong type (expecting ~A): ~S",
scm_list_2 (scm_class_name (type), val), scm_list_1 (val));
}
SCM
python_import(SCM smodulename)
{
if (!SCM_STRINGP(smodulename)) {
scm_wrong_type_arg("python-import",SCM_ARG1,smodulename);
}
else {
char *mname = scm_to_locale_string(smodulename);
PyObject *pmodule = PyImport_ImportModule(mname);
PyObject *pexception = PyErr_Occurred();
if (pexception) {
PyObject *prepr = PyObject_Repr(pexception);
Py_XDECREF(pmodule);
PyErr_Clear();
SCM smname = scm_list_1(scm_mem2string(mname,strlen(mname)));
free(mname);
if (NULL == prepr) {
scm_misc_error("python-import", // NOT COVERED BY TESTS
"Python exception during module ~A import - could not be identified",
smname);
}
else {
int strlength = PyString_Size(prepr);
char *pstr = PyString_AsString(prepr);
SCM slist = scm_list_2(SCM_CAR(smname),scm_mem2string(pstr,strlength));
Py_DECREF(prepr);
scm_misc_error("python-import",
"Python exception during module ~A import: ~A",
slist);
}
}
// OK, exception did not occur. Do we have a module?
if (NULL == pmodule) {
SCM slist = scm_list_1(scm_mem2string(mname,strlen(mname)));
free(mname);
scm_misc_error("python-eval","could not import module ~S",
slist);
}
free(mname);
SCM smodule = wrap_pyobject(pmodule);
Py_DECREF(pmodule); // wrap_pyobject did Py_INCREF
return(smodule);
}
}
static SCM
scscm_printing_pre_unwind_handler (void *data, SCM key, SCM args)
{
SCM stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
gdbscm_print_exception_with_stack (SCM_BOOL_F, stack, key, args);
return SCM_UNSPECIFIED;
}
static SCM decode_video(struct ffmpeg_t *self, AVPacket *pkt, AVFrame *frame)
{
int got_frame;
int len = avcodec_decode_video2(self->video_codec_ctx, frame, &got_frame, pkt);
if (len < 0)
scm_misc_error("ffmpeg-decode-audio/video", "Error decoding frame: ~a", scm_list_1(get_error_text(len)));
consume_packet_data(pkt, pkt->size);
return got_frame ? list_timestamped_video(self, frame) : SCM_BOOL_F;
}
static void make_frame_writable(AVFrame *frame)
{
#ifdef HAVE_AV_FRAME_MAKE_WRITABLE
// Make frame writeable
int err = av_frame_make_writable(frame);
if (err < 0)
scm_misc_error("make-frame-writable", "Error making frame writeable: ~a",
scm_list_1(get_error_text(err)));
#endif
}
SCM llvm_verify_module(SCM scm_llvm)
{
struct llvm_module_t *llvm = get_llvm(scm_llvm);
char *error = NULL;
if (LLVMVerifyModule(llvm->module, LLVMPrintMessageAction, &error)) {
SCM scm_error = scm_from_locale_string(error);
LLVMDisposeMessage(error);
scm_misc_error("verify-module", "Module is not valid: ~a", scm_list_1(scm_error));
};
return SCM_UNSPECIFIED;
}
SCM
mu_guile_error (const char *func_name, int status,
const char *fmt, SCM args)
{
scm_error_scm (scm_from_locale_symbol ("MuError"),
scm_from_utf8_string (func_name ? func_name : "<nameless>"),
scm_from_utf8_string (fmt), args,
scm_list_1 (scm_from_int (status)));
return SCM_UNSPECIFIED;
}
static void *
sysdep_dynl_value (const char *symb, void *handle, const char *subr)
{
void *fptr;
fptr = lt_dlsym ((lt_dlhandle) handle, symb);
if (!fptr)
scm_misc_error (subr, "Symbol not found: ~a",
scm_list_1 (scm_from_locale_string (symb)));
return fptr;
}
static SCM scm_all_clients(void)
{
SCM clients = SCM_EOL;
SCM smob;
client_t *client = client_list;
while (client) {
SCM_NEWSMOB(smob, client_tag, client);
clients = scm_append(scm_list_2(clients, scm_list_1(smob)));
client = client->next;
}
return clients;
}
static scm_t_ptrdiff
find_prompt (SCM key)
{
scm_t_ptrdiff fp_offset;
if (!scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD->dynstack, key,
NULL, &fp_offset, NULL, NULL, NULL))
scm_misc_error ("make-stack", "Prompt tag not found while narrowing stack",
scm_list_1 (key));
return fp_offset;
}
static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{
if (scm_is_null (bindings))
return expand_sequence (body, env);
else
{
SCM bind, name, sym, init;
ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
bind = CAR (bindings);
ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
name = CAR (bind);
sym = scm_gensym (SCM_UNDEFINED);
init = CADR (bind);
return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
scm_list_1 (expand (init, env)),
expand_letstar_clause (CDR (bindings), body,
scm_acons (name, sym, env)));
}
}
SCM
gdbscm_scm_from_gdb_exception (struct gdb_exception exception)
{
SCM key;
if (exception.reason == RETURN_QUIT)
{
/* Handle this specially to be consistent with top-repl.scm. */
return gdbscm_make_error (signal_symbol, NULL, _("User interrupt"),
SCM_EOL, scm_list_1 (scm_from_int (SIGINT)));
}
if (exception.error == MEMORY_ERROR)
key = memory_error_symbol;
else
key = error_symbol;
return gdbscm_make_error (key, NULL, "~A",
scm_list_1 (gdbscm_scm_from_c_string
(exception.message)),
SCM_BOOL_F);
}
/*! \brief Runs a object hook for a list of objects.
* \par Function Description
* Runs a hook called \a name, which should expect a list of #OBJECT
* smobs as its argument, with \a obj_lst as the argument list.
*
* \see g_run_hook_object()
*
* \param name name of hook to run.
* \param obj_lst list of #OBJECT smobs as hook argument.
*/
void
g_run_hook_object_list (const char *name, GList *obj_lst)
{
SCM lst = SCM_EOL;
GList *iter;
for (iter = obj_lst; iter != NULL; iter = g_list_next (iter)) {
lst = scm_cons (edascm_from_object ((OBJECT *) iter->data), lst);
}
SCM args = scm_list_1 (scm_reverse_x (lst, SCM_EOL));
scm_run_hook (g_get_hook_by_name (name), args);
scm_remember_upto_here_2 (lst, args);
}
static void write_frame(struct ffmpeg_t *self, AVPacket *packet, AVCodecContext *codec, AVStream *stream, int stream_idx)
{
#ifdef HAVE_AV_PACKET_RESCALE_TS
av_packet_rescale_ts(packet, codec->time_base, stream->time_base);
#else
if (codec->coded_frame->pts != AV_NOPTS_VALUE)
packet->pts = av_rescale_q(codec->coded_frame->pts, codec->time_base, stream->time_base);
#endif
packet->stream_index = stream_idx;
int err = av_interleaved_write_frame(self->fmt_ctx, packet);
if (err < 0)
scm_misc_error("write-frame", "Error writing video frame: ~a",
scm_list_1(get_error_text(err)));
}
static SCM
expand_or (SCM expr, SCM env SCM_UNUSED)
{
SCM tail = CDR (expr);
const long length = scm_ilength (tail);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
return CONST (SCM_BOOL_F, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
return LET (SCM_BOOL_F,
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (CADR (expr), env)),
CONDITIONAL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
expand_or (CDR (expr),
scm_acons (tmp, tmp, env))));
}
}
SCM
gdbscm_make_type_error (const char *subr, int arg_pos, SCM bad_value,
const char *expected_type)
{
char *msg;
SCM result;
if (arg_pos > 0)
{
if (expected_type != NULL)
{
msg = xstrprintf (_("Wrong type argument in position %d"
" (expecting %s): ~S"),
arg_pos, expected_type);
}
else
{
msg = xstrprintf (_("Wrong type argument in position %d: ~S"),
arg_pos);
}
}
else
{
if (expected_type != NULL)
{
msg = xstrprintf (_("Wrong type argument (expecting %s): ~S"),
expected_type);
}
else
msg = xstrprintf (_("Wrong type argument: ~S"));
}
result = gdbscm_make_error (scm_arg_type_key, subr, msg,
scm_list_1 (bad_value), scm_list_1 (bad_value));
xfree (msg);
return result;
}
/* returns a (sec . usec) pair. It throws an 'a-sync-exception guile
exception if the library has been configured for monotonic time at
configuration time but it is not in fact supported, but this is not
worth testing for by user code as it should never happen - the
library configuration macros should always give the correct
answer */
static SCM get_time(void) {
#ifdef HAVE_MONOTONIC_CLOCK
struct timespec ts;
if (clock_gettime(CLOCK_MONOTONIC, &ts) == -1) {
scm_throw(scm_from_latin1_symbol("a-sync-exception"),
scm_list_4(scm_from_latin1_string("get-time"),
scm_from_latin1_string("guile-a-sync2: ~A"),
scm_list_1(scm_from_latin1_string("monotonic time not supported "
"by underlying implementation")),
scm_from_int(errno)));
}
return scm_cons(scm_from_size_t(ts.tv_sec), scm_from_long(ts.tv_nsec/1000L));
#else
return scm_gettimeofday();
#endif
}