PARROT_WARN_UNUSED_RESULT
static UINTVAL
utf16_decode(SHIM_INTERP, ARGIN(const utf16_t *p))
{
ASSERT_ARGS(utf16_decode)
UINTVAL c = *p;
if (UNICODE_IS_HIGH_SURROGATE(c))
c = UNICODE_DECODE_SURROGATE(c, p[1]);
return c;
}
static void
mark_interp(PARROT_INTERP)
{
ASSERT_ARGS(mark_interp)
PObj *obj;
/* mark the list of iglobals */
Parrot_gc_mark_PMC_alive(interp, interp->iglobals);
/* mark the current continuation */
obj = (PObj *)interp->current_cont;
if (obj && obj != (PObj *)NEED_CONTINUATION)
Parrot_gc_mark_PMC_alive(interp, (PMC *)obj);
/* mark the current context. */
Parrot_gc_mark_PMC_alive(interp, CURRENT_CONTEXT(interp));
/* mark the vtables: the data, Class PMCs, etc. */
Parrot_vtbl_mark_vtables(interp);
/* mark the root_namespace */
Parrot_gc_mark_PMC_alive(interp, interp->root_namespace);
/* mark the concurrency scheduler */
Parrot_gc_mark_PMC_alive(interp, interp->scheduler);
/* mark caches and freelists */
mark_object_cache(interp);
/* Now mark the class hash */
Parrot_gc_mark_PMC_alive(interp, interp->class_hash);
/* Now mark the HLL stuff */
Parrot_gc_mark_PMC_alive(interp, interp->HLL_info);
Parrot_gc_mark_PMC_alive(interp, interp->HLL_namespace);
/* Mark the registry */
PARROT_ASSERT(interp->gc_registry);
Parrot_gc_mark_PMC_alive(interp, interp->gc_registry);
/* Mark the MMD cache. */
if (interp->op_mmd_cache)
Parrot_mmd_cache_mark(interp, interp->op_mmd_cache);
/* Walk the iodata */
Parrot_IOData_mark(interp, interp->piodata);
if (!PMC_IS_NULL(interp->final_exception))
Parrot_gc_mark_PMC_alive(interp, interp->final_exception);
if (interp->parent_interpreter)
mark_interp(interp->parent_interpreter);
}
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
Parrot_Int
imcc_get_pir_compreg_api(Parrot_PMC interp_pmc, int add_compreg, ARGOUT(Parrot_PMC *compiler))
{
ASSERT_ARGS(imcc_get_pir_compreg_api)
IMCC_API_CALLIN(interp_pmc, interp)
*compiler = get_compreg_pmc(interp, 0, add_compreg);
if (PMC_IS_NULL(*compiler))
Parrot_ex_throw_from_c_noargs(interp, EXCEPTION_UNEXPECTED_NULL,
"Could not create PIR compiler PMC");
IMCC_API_CALLOUT(interp_pmc, interp)
}
PARROT_EXPORT
INTVAL
Parrot_io_poll_handle(PARROT_INTERP, ARGMOD(PMC *pmc), INTVAL which, INTVAL sec, INTVAL usec)
{
ASSERT_ARGS(Parrot_io_poll_handle)
Parrot_Socket_attributes *io = PARROT_SOCKET(pmc);
if (Parrot_io_socket_is_closed(interp, pmc))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_PIO_ERROR,
"Can't poll closed socket");
return Parrot_io_poll(interp, io->os_handle, which, sec, usec);
}
PARROT_DOES_NOT_RETURN
void
IMCC_fatal_standalone(ARGMOD(imc_info_t * imcc), int code, ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_fatal_standalone)
va_list ap;
STRING * s = STRINGNULL;
va_start(ap, fmt);
s = Parrot_vsprintf_c(imcc->interp, fmt, ap);
va_end(ap);
Parrot_ex_throw_from_c_args(imcc->interp, NULL, code, "%Ss", s);
}
PARROT_EXPORT
PARROT_DOES_NOT_RETURN
void
IMCC_fatal_standalone(PARROT_INTERP, int code, ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_fatal_standalone)
va_list ap;
va_start(ap, fmt);
imcc_vfprintf(interp, Parrot_io_STDERR(interp), fmt, ap);
va_end(ap);
Parrot_exit(interp, code);
}
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static STRING *
getchr_va(PARROT_INTERP, SHIM(INTVAL size), ARGIN(SPRINTF_OBJ *obj))
{
ASSERT_ARGS(getchr_va)
va_list *arg = (va_list *)(obj->data);
/* char promoted to int */
char ch = (char)va_arg(*arg, int);
return Parrot_str_new_init(interp, &ch, 1, Parrot_latin1_encoding_ptr, 0);
}
PARROT_EXPORT
void
IMCC_debug(PARROT_INTERP, int level, ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_debug)
va_list ap;
if (!(level & IMCC_INFO(interp)->debug))
return;
va_start(ap, fmt);
imcc_vfprintf(interp, Parrot_io_STDERR(interp), fmt, ap);
va_end(ap);
}
PARROT_EXPORT
PARROT_DOES_NOT_RETURN
void
IMCC_fataly(PARROT_INTERP, SHIM(int code), ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_fataly)
va_list ap;
va_start(ap, fmt);
IMCC_INFO(interp)->error_message = Parrot_vsprintf_c(interp, fmt, ap);
va_end(ap);
IMCC_THROW(IMCC_INFO(interp)->jump_buf, IMCC_FATALY_EXCEPTION);
}
PARROT_EXPORT
void
IMCC_warning(PARROT_INTERP, ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_warning)
va_list ap;
if (IMCC_INFO(interp)->imcc_warn)
return;
va_start(ap, fmt);
imcc_vfprintf(interp, Parrot_io_STDERR(interp), fmt, ap);
va_end(ap);
}
PARROT_API
Parrot_Int
Parrot_api_string_export_ascii(ARGIN(Parrot_PMC interp_pmc), ARGIN(Parrot_String string),
ARGOUT(char ** strout))
{
ASSERT_ARGS(Parrot_api_string_export_ascii)
EMBED_API_CALLIN(interp_pmc, interp);
if (!STRING_IS_NULL(string))
*strout = Parrot_str_to_cstring(interp, string);
else
*strout = NULL;
EMBED_API_CALLOUT(interp_pmc, interp);
}
PARROT_EXPORT
size_t
PackFile_ConstTable_pack_size(PARROT_INTERP, ARGIN(PackFile_Segment *seg))
{
ASSERT_ARGS(PackFile_ConstTable_pack_size)
opcode_t i;
const PackFile_ConstTable* const self = (const PackFile_ConstTable *) seg;
size_t size = 1; /* const_count */
for (i = 0; i < self->const_count; ++i)
size += PackFile_Constant_pack_size(interp, self->constants[i], self);
return size;
}
void
IMCC_info(ARGMOD(imc_info_t * imcc), int level, ARGIN(const char *fmt), ...)
{
ASSERT_ARGS(IMCC_info)
va_list ap;
if (level > imcc->verbose)
return;
va_start(ap, fmt);
imcc_vfprintf(imcc, Parrot_io_STDERR(imcc->interp), fmt, ap);
va_end(ap);
}
static void
pf_const_dump_str(PARROT_INTERP, ARGIN(const STRING *self))
{
ASSERT_ARGS(pf_const_dump_str)
Parrot_io_printf(interp, " [ 'PFC_STRING', {\n");
pobj_flag_dump(interp, (long)PObj_get_FLAGS(self));
Parrot_io_printf(interp, " ENCODING => %s,\n", self->encoding->name);
Parrot_io_printf(interp, " SIZE => %ld,\n", self->bufused);
Parrot_io_printf(interp, " DATA => \"%Ss\"\n",
Parrot_str_escape(interp, self));
Parrot_io_printf(interp, " } ],\n");
}
static void
verify_CD(ARGIN(char *external_data), ARGMOD_NULLOK(PMC *user_data))
{
ASSERT_ARGS(verify_CD)
PARROT_INTERP = NULL;
PMC *interp_pmc;
STRING *sc;
/*
* 1.) user_data is from external code so:
* verify that we get a PMC that is one that we have passed in
* as user data, when we prepared the callback
*/
/* a NULL pointer or a pointer not aligned is very likely wrong */
if (!user_data)
PANIC(interp, "user_data is NULL");
if (PMC_IS_NULL(user_data))
PANIC(interp, "user_data is PMCNULL");
if ((UINTVAL)user_data & 3)
PANIC(interp, "user_data doesn't look like a pointer");
/* Fetch original interpreter from prop */
LOCK(interpreter_array_mutex);
interp = interpreter_array[0];
sc = CONST_STRING(interp, "_interpreter");
interp_pmc = VTABLE_getprop(interp, user_data, sc);
GETATTR_ParrotInterpreter_interp(interp, interp_pmc, interp);
UNLOCK(interpreter_array_mutex);
if (!interp)
PANIC(interp, "interpreter not found for callback");
/*
* 2) some more checks
* now we should have the interpreter where that callback
* did originate - do some further checks on the PMC
*/
/* if that doesn't look like a PMC we are still lost */
if (!PObj_is_PMC_TEST(user_data))
PANIC(interp, "user_data isn't a PMC");
if (!user_data->vtable)
PANIC(interp, "user_data hasn't a vtable");
/*
* ok fine till here
*/
callback_CD(interp, external_data, user_data);
}
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
STRING *
encoding_to_encoding(PARROT_INTERP, ARGIN(const STRING *src),
ARGIN(const STR_VTABLE *encoding), double avg_bytes)
{
ASSERT_ARGS(encoding_to_encoding)
STRING *result;
String_iter src_iter, dest_iter;
UINTVAL src_len, alloc_bytes;
UINTVAL max_bytes = encoding->max_bytes_per_codepoint;
if (src->encoding == encoding)
return Parrot_str_clone(interp, src);
src_len = src->strlen;
result = Parrot_gc_new_string_header(interp, 0);
result->encoding = encoding;
result->strlen = src_len;
if (!src_len)
return result;
alloc_bytes = (UINTVAL)(src_len * avg_bytes);
if (alloc_bytes < max_bytes)
alloc_bytes = max_bytes;
Parrot_gc_allocate_string_storage(interp, result, alloc_bytes);
result->bufused = alloc_bytes;
STRING_ITER_INIT(interp, &src_iter);
STRING_ITER_INIT(interp, &dest_iter);
while (src_iter.charpos < src_len) {
const UINTVAL c = STRING_iter_get_and_advance(interp, src, &src_iter);
const UINTVAL needed = dest_iter.bytepos + max_bytes;
if (needed > result->bufused) {
alloc_bytes = src_len - src_iter.charpos;
alloc_bytes = (UINTVAL)(alloc_bytes * avg_bytes);
alloc_bytes += needed;
Parrot_gc_reallocate_string_storage(interp, result, alloc_bytes);
result->bufused = alloc_bytes;
}
STRING_iter_set_and_advance(interp, result, &dest_iter, c);
}
result->bufused = dest_iter.bytepos;
return result;
}
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
INTVAL
Parrot_io_send_handle(PARROT_INTERP, ARGMOD(PMC *pmc), ARGMOD(STRING *buf))
{
ASSERT_ARGS(Parrot_io_send_handle)
Parrot_Socket_attributes *io = PARROT_SOCKET(pmc);
if (Parrot_io_socket_is_closed(interp, pmc))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_PIO_ERROR,
"Can't send to closed socket");
return Parrot_io_send(interp, io->os_handle, buf->strstart, buf->bufused);
}
PARROT_CAN_RETURN_NULL
FILE *
open_file(ARGIN(char const * const filename), ARGIN(char const * const mode))
{
ASSERT_ARGS(open_file)
FILE *fp = NULL;
#ifdef _MSC_VER
fopen_s(&fp, filename, mode);
#else
fp = fopen(filename, mode);
#endif
return fp;
}
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static const utf16_t *
utf16_skip_forward(ARGIN(const utf16_t *p), UINTVAL count)
{
ASSERT_ARGS(utf16_skip_forward)
UINTVAL i;
for (i = 0; i < count; ++i) {
p += UTF16SKIP(*p);
}
return p;
}
PARROT_WARN_UNUSED_RESULT
INTVAL
encoding_find_cclass(PARROT_INTERP, INTVAL flags, ARGIN(const STRING *src),
UINTVAL offset, UINTVAL count)
{
ASSERT_ARGS(encoding_find_cclass)
String_iter iter;
UINTVAL codepoint;
UINTVAL end = offset + count;
static UINTVAL last_char_offset;
static String_iter cached_iter;
static STRING *last_string = 0;
if (last_string == src && offset > last_char_offset) {
iter = cached_iter;
STRING_iter_skip(interp, src, &iter, offset - last_char_offset);
}
else if (last_string == src && offset == last_char_offset) {
iter = cached_iter;
}
else {
STRING_ITER_INIT(interp, &iter);
STRING_iter_skip(interp, src, &iter, offset);
}
end = src->strlen < end ? src->strlen : end;
while (iter.charpos < end) {
codepoint = STRING_iter_get_and_advance(interp, src, &iter);
if (codepoint >= 256) {
if (u_iscclass(interp, codepoint, flags))
goto return_and_cache;
}
else {
if (Parrot_iso_8859_1_typetable[codepoint] & flags)
goto return_and_cache;
}
}
return end;
return_and_cache:
if (iter.charpos > 128) {
last_char_offset = iter.charpos;
cached_iter = iter;
last_string = (STRING*)PTR2INTVAL(src);
}
return iter.charpos - 1;
}
static void
callback_CD(PARROT_INTERP, ARGIN(char *external_data), ARGMOD(PMC *user_data))
{
ASSERT_ARGS(callback_CD)
PMC *passed_interp; /* the interp that originated the CB */
PMC *passed_synchronous; /* flagging synchronous execution */
int synchronous = 0; /* cb is hitting this sub somewhen
* inmidst, or not */
STRING *sc;
/*
* 3) check interpreter ...
*/
sc = CONST_STRING(interp, "_interpreter");
passed_interp = VTABLE_getprop(interp, user_data, sc);
if (VTABLE_get_pointer(interp, passed_interp) != interp)
PANIC(interp, "callback gone to wrong interpreter");
sc = CONST_STRING(interp, "_synchronous");
passed_synchronous = VTABLE_getprop(interp, user_data, sc);
if (!PMC_IS_NULL(passed_synchronous) &&
VTABLE_get_bool(interp, passed_synchronous))
synchronous = 1;
/*
* 4) check if the call_back is synchronous:
* - if yes we are inside the NCI call
* we could run the Sub immediately now (I think)
* - if no, and that's always safe, post a callback event
*/
if (synchronous) {
/*
* just call the sub
*/
Parrot_run_callback(interp, user_data, external_data);
}
else {
/*
* create a CB_EVENT, put user_data and data inside and finito
*
* *if* this function is finally no void, i.e. the calling
* C program awaits a return result from the callback,
* then wait for the CB_EVENT_xx to finish and return the
* result
*/
Parrot_cx_schedule_callback(interp, user_data, external_data);
}
}
PARROT_EXPORT
int
Parrot_fprintf(PARROT_INTERP, ARGIN(Parrot_PMC pio),
ARGIN(const char *s), ...)
{
ASSERT_ARGS(Parrot_fprintf)
va_list args;
INTVAL retval;
va_start(args, s);
retval = Parrot_vfprintf(interp, pio, s, args);
va_end(args);
return retval;
}
PARROT_CAN_RETURN_NULL
static PMC *
make_local_copy(PARROT_INTERP, ARGIN(Parrot_Interp from), ARGIN(PMC *arg))
{
ASSERT_ARGS(make_local_copy)
PMC *ret_val;
STRING * const _sub = interp->vtables[enum_class_Sub]->whoami;
STRING * const _multi_sub = interp->vtables[enum_class_MultiSub]->whoami;
if (PMC_IS_NULL(arg)) {
ret_val = PMCNULL;
}
else if (PObj_is_PMC_shared_TEST(arg)) {
ret_val = arg;
}
else if (VTABLE_isa(from, arg, _multi_sub)) {
INTVAL i = 0;
const INTVAL n = VTABLE_elements(from, arg);
ret_val = Parrot_pmc_new(interp, enum_class_MultiSub);
for (i = 0; i < n; ++i) {
PMC *const orig = VTABLE_get_pmc_keyed_int(from, arg, i);
PMC *const copy = make_local_copy(interp, from, orig);
VTABLE_push_pmc(interp, ret_val, copy);
}
}
else if (VTABLE_isa(from, arg, _sub)) {
/* this is a workaround for cloning subroutines not actually
* working as one might expect mainly because the segment is
* not correctly copied
*/
Parrot_Sub_attributes *ret_val_sub, *arg_sub;
ret_val = Parrot_clone(interp, arg);
PMC_get_sub(interp, ret_val, ret_val_sub);
PMC_get_sub(interp, arg, arg_sub);
ret_val_sub->seg = arg_sub->seg;
/* Skip vtable overrides and methods. */
if (ret_val_sub->vtable_index == -1
&& !(ret_val_sub->comp_flags & SUB_COMP_FLAG_METHOD)) {
Parrot_ns_store_sub(interp, ret_val);
}
}
else {
ret_val = Parrot_clone(interp, arg);
}
return ret_val;
}
PARROT_EXPORT
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
PMC *
Parrot_io_stdhandle(PARROT_INTERP, INTVAL fileno, ARGIN_NULLOK(PMC *newhandle))
{
ASSERT_ARGS(Parrot_io_stdhandle)
PMC * result = PMCNULL;
if (fileno == PIO_STDIN_FILENO || fileno == PIO_STDOUT_FILENO ||
fileno == PIO_STDERR_FILENO) {
result = interp->piodata->table[fileno];
if (! PMC_IS_NULL(newhandle))
interp->piodata->table[fileno] = newhandle;
}
return result;
}
void
Parrot_runcore_exec_init(PARROT_INTERP)
{
ASSERT_ARGS(Parrot_runcore_exec_init)
Parrot_runcore_t *coredata = mem_allocate_typed(Parrot_runcore_t);
coredata->name = CONST_STRING(interp, "exec");
coredata->id = PARROT_EXEC_CORE;
coredata->opinit = PARROT_CORE_OPLIB_INIT;
coredata->runops = runops_exec_core;
coredata->destroy = NULL;
coredata->prepare_run = NULL;
coredata->flags = 0;
Parrot_runcore_register(interp, coredata);
}
PARROT_EXPORT
int
Parrot_vfprintf(PARROT_INTERP, ARGIN(Parrot_PMC pio),
ARGIN(const char *s), va_list args)
{
ASSERT_ARGS(Parrot_vfprintf)
STRING * str;
INTVAL retval;
PARROT_CALLIN_START(interp);
str = Parrot_vsprintf_c(interp, s, args);
retval = Parrot_io_putps(interp, pio, str);
PARROT_CALLIN_END(interp);
return retval;
}
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static const utf16_t *
utf16_skip_backward(ARGIN(const utf16_t *p), UINTVAL count)
{
ASSERT_ARGS(utf16_skip_backward)
UINTVAL i;
for (i = 0; i < count; ++i) {
--p;
if (UNICODE_IS_LOW_SURROGATE(*p))
--p;
}
return p;
}
static void
restore_context(PARROT_INTERP, ARGIN(Parrot_Context * const initialctx))
{
ASSERT_ARGS(restore_context)
Parrot_Context *curctx = CONTEXT(interp);
if (curctx != initialctx) {
Parrot_warn((interp), PARROT_WARNINGS_NONE_FLAG,
"popping context in Parrot_ext_try");
do {
Parrot_pop_context(interp);
curctx = CONTEXT(interp);
if (curctx == NULL)
PANIC(interp, "cannot restore context");
} while (curctx != initialctx);
}
}
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static const utf16_t *
utf16_skip_forward(ARGIN(const utf16_t *p), UINTVAL count)
{
ASSERT_ARGS(utf16_skip_forward)
UINTVAL i;
for (i = 0; i < count; ++i) {
if (UNICODE_IS_HIGH_SURROGATE(*p))
p += 2;
else
p += 1;
}
return p;
}
PARROT_WARN_UNUSED_RESULT
INTVAL
encoding_is_cclass(PARROT_INTERP, INTVAL flags, ARGIN(const STRING *src), UINTVAL offset)
{
ASSERT_ARGS(encoding_is_cclass)
UINTVAL codepoint;
if (offset >= src->strlen)
return 0;
codepoint = STRING_ord(interp, src, offset);
if (codepoint >= 256)
return u_iscclass(interp, codepoint, flags) != 0;
return (Parrot_iso_8859_1_typetable[codepoint] & flags) ? 1 : 0;
}
