/* Helper for finding a slot number. */
static INTVAL try_get_slot(PARROT_INTERP, P6opaqueREPRData *repr_data, PMC *class_key, STRING *name) {
INTVAL slot = -1;
if (repr_data->name_to_index_mapping) {
P6opaqueNameMap *cur_map_entry = repr_data->name_to_index_mapping;
while (cur_map_entry->class_key != NULL) {
if (cur_map_entry->class_key == class_key) {
if (!PMC_IS_NULL(cur_map_entry->name_map)) {
PMC *slot_pmc = VTABLE_get_pmc_keyed_str(interp, cur_map_entry->name_map, name);
if (!PMC_IS_NULL(slot_pmc))
slot = VTABLE_get_integer(interp, slot_pmc);
break;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Null attribute map for P6opaque in class '%Ss'",
VTABLE_get_string(interp, introspection_call(interp,
class_key, STABLE(class_key)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
}
cur_map_entry++;
}
}
return slot;
}
/* Helper for finding a slot number. */
static INTVAL try_get_slot(PARROT_INTERP, CStructREPRData *repr_data, PMC *class_key, STRING *name) {
INTVAL slot = -1;
if (repr_data->name_to_index_mapping) {
CStructNameMap *cur_map_entry = repr_data->name_to_index_mapping;
while (cur_map_entry->class_key != NULL) {
if (cur_map_entry->class_key == class_key) {
PMC *slot_pmc = VTABLE_get_pmc_keyed_str(interp, cur_map_entry->name_map, name);
if (!PMC_IS_NULL(slot_pmc))
slot = VTABLE_get_integer(interp, slot_pmc);
break;
}
cur_map_entry++;
}
}
return slot;
}
void
get_complex_value_from_pmc(PARROT_INTERP, PMC * value, FLOATVAL * real,
FLOATVAL * imag)
{
if (PMC_IS_NULL(value)) {
*real = 0.0;
*imag = 0.0;
}
else if (VTABLE_does(interp, value, Parrot_str_new(interp, "complex", 7))) {
*real = VTABLE_get_number_keyed_int(interp, value, 0);
*imag = VTABLE_get_number_keyed_int(interp, value, 1);
}
else if (VTABLE_does(interp, value, Parrot_str_new(interp, "array", 5))) {
const INTVAL size = VTABLE_elements(interp, value);
if(size <= 2) {
*real = (size == 0) ? 0.0 : VTABLE_get_number_keyed_int(interp, value, 0);
*imag = (size < 2) ? 0.0 : VTABLE_get_number_keyed_int(interp, value, 1);
}
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS,
"PLA: array too long to be converted into complex number");
}
else if (VTABLE_does(interp, value, Parrot_str_new(interp, "float", 5))) {
*real = VTABLE_get_number(interp, value);
*imag = 0.0;
}
else if (VTABLE_does(interp, value, Parrot_str_new(interp, "integer", 7))) {
const INTVAL _r = VTABLE_get_integer(interp, value);
*real = (FLOATVAL)_r;
*imag = 0.0;
}
else if (VTABLE_does(interp, value, Parrot_str_new(interp, "string", 6))) {
PMC * const c = get_external_pmc_init(interp, enum_class_Complex, value);
*real = VTABLE_get_number_keyed_int(interp, c, 0);
*imag = VTABLE_get_number_keyed_int(interp, c, 1);
}
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_OUT_OF_BOUNDS,
"PLA: cannot set unknown PMC type");
}
static void
PackFile_Constant_dump(PARROT_INTERP, ARGIN(const PackFile_ConstTable *ct),
ARGIN(const PackFile_Constant *self))
{
ASSERT_ARGS(PackFile_Constant_dump)
PMC *key;
size_t i;
switch (self->type) {
case PFC_NUMBER:
Parrot_io_printf(interp, " [ 'PFC_NUMBER', %g ],\n", self->u.number);
break;
case PFC_STRING:
Parrot_io_printf(interp, " [ 'PFC_STRING', {\n");
pobj_flag_dump(interp, (long)PObj_get_FLAGS(self->u.string));
Parrot_io_printf(interp, " CHARSET => %ld,\n",
self->u.string->charset);
i = self->u.string->bufused;
Parrot_io_printf(interp, " SIZE => %ld,\n",
(long)i);
Parrot_io_printf(interp, " DATA => \"%Ss\"\n",
Parrot_str_escape(interp, self->u.string));
Parrot_io_printf(interp, " } ],\n");
break;
case PFC_KEY:
for (i = 0, key = self->u.key; key; i++) {
GETATTR_Key_next_key(interp, key, key);
}
/* number of key components */
Parrot_io_printf(interp, " [ 'PFC_KEY' (%ld items)\n", i);
/* and now type / value per component */
for (key = self->u.key; key;) {
opcode_t type = PObj_get_FLAGS(key);
Parrot_io_printf(interp, " {\n");
type &= KEY_type_FLAGS;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(key));
switch (type) {
case KEY_integer_FLAG:
Parrot_io_printf(interp, " TYPE => INTEGER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => NUMBER\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_NUMBER);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => %ld\n", detail->u.number);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_string_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => STRING\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_STRING);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => '%Ss'\n",
detail->u.string);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_integer_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => I REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => N REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_string_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => S REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_pmc_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => P REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
default:
Parrot_io_eprintf(NULL, "PackFile_Constant_pack: "
"unsupported constant type\n");
Parrot_exit(interp, 1);
}
GETATTR_Key_next_key(interp, key, key);
}
Parrot_io_printf(interp, " ],\n");
break;
case PFC_PMC:
Parrot_io_printf(interp, " [ 'PFC_PMC', {\n");
{
PMC * const pmc = self->u.key;
Parrot_Sub_attributes *sub;
STRING * const null = Parrot_str_new_constant(interp, "(null)");
STRING *namespace_description;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(pmc));
switch (pmc->vtable->base_type) {
case enum_class_FixedBooleanArray:
case enum_class_FixedFloatArray:
case enum_class_FixedPMCArray:
case enum_class_FixedStringArray:
case enum_class_ResizableBooleanArray:
case enum_class_ResizableIntegerArray:
case enum_class_ResizableFloatArray:
case enum_class_ResizablePMCArray:
case enum_class_ResizableStringArray:
{
const int n = VTABLE_get_integer(interp, pmc);
STRING* const out_buffer = VTABLE_get_repr(interp, pmc);
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\telement count => %d,\n"
"\telements => %Ss,\n",
pmc->vtable->whoami,
n,
out_buffer);
}
break;
case enum_class_Sub:
case enum_class_Coroutine:
PMC_get_sub(interp, pmc, sub);
if (sub->namespace_name) {
switch (sub->namespace_name->vtable->base_type) {
case enum_class_String:
namespace_description = Parrot_str_new(interp, "'", 1);
namespace_description = Parrot_str_append(interp,
namespace_description,
VTABLE_get_string(interp, sub->namespace_name));
namespace_description = Parrot_str_append(interp,
namespace_description,
Parrot_str_new(interp, "'", 1));
break;
case enum_class_Key:
namespace_description =
key_set_to_string(interp, sub->namespace_name);
break;
default:
namespace_description = sub->namespace_name->vtable->whoami;
}
}
else {
namespace_description = null;
}
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\tstart_offs => %d,\n"
"\tend_offs => %d,\n"
"\tname => '%Ss',\n"
"\tsubid => '%Ss',\n"
"\tmethod => '%Ss',\n"
"\tnsentry => '%Ss',\n"
"\tnamespace => %Ss\n"
"\tHLL_id => %d,\n",
pmc->vtable->whoami,
sub->start_offs,
sub->end_offs,
sub->name,
sub->subid,
sub->method_name,
sub->ns_entry_name,
namespace_description,
sub->HLL_id);
break;
case enum_class_FixedIntegerArray:
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\trepr => '%Ss'\n",
pmc->vtable->whoami,
VTABLE_get_repr(interp, pmc));
break;
default:
Parrot_io_printf(interp, "\tno dump info for PMC %ld %Ss\n",
pmc->vtable->base_type, pmc->vtable->whoami);
Parrot_io_printf(interp, "\tclass => %Ss,\n", pmc->vtable->whoami);
}
}
Parrot_io_printf(interp, " } ],\n");
break;
default:
Parrot_io_printf(interp, " [ 'PFC_\?\?\?', type '0x%x' ],\n",
self->type);
break;
}
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
SV *
blizkost_marshal_arg(BLIZKOST_NEXUS, PMC *arg) {
struct sv *result = NULL;
dBNPERL; dBNINTERP;
/* If it's a P5Scalar PMC, then we just fetch the SV from it - trivial
* round-tripping. */
if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Scalar"))) {
GETATTR_P5Scalar_sv(interp, arg, result);
}
/* XXX At this point, we should probably wrap it up in a tied Perl 5
* scalar so we can round-trip Parrot objects to. However, that's hard,
* so for now we cheat on a few special cases and just panic otherwise. */
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Integer"))) {
result = sv_2mortal(newSViv(VTABLE_get_integer(interp, arg)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "Float"))) {
result = sv_2mortal(newSVnv(VTABLE_get_number(interp, arg)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "P5Namespace"))) {
STRING *pkg;
char *c_str;
GETATTR_P5Namespace_ns_name(interp, arg, pkg);
c_str = Parrot_str_to_cstring(interp, pkg);
result = sv_2mortal(newSVpv(c_str, strlen(c_str)));
}
else if (VTABLE_isa(interp, arg, CONST_STRING(interp, "String"))) {
char *c_str = Parrot_str_to_cstring(interp, VTABLE_get_string(interp, arg));
result = sv_2mortal(newSVpv(c_str, strlen(c_str)));
}
else if (VTABLE_does(interp, arg, CONST_STRING(interp, "invokable"))) {
CV *wrapper = blizkost_wrap_callable(nexus, arg);
result = sv_2mortal(newRV_inc((SV*)wrapper));
}
else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "array"))) {
PMC *iter;
struct av *array = newAV();
iter = VTABLE_get_iter(interp, arg);
while (VTABLE_get_bool(interp, iter)) {
PMC *item = VTABLE_shift_pmc(interp, iter);
struct sv *marshaled =
blizkost_marshal_arg(nexus, item);
av_push( array, marshaled);
}
result = newRV_inc((SV*)array);
}
else if ( VTABLE_does(interp, arg, CONST_STRING(interp, "hash"))) {
PMC *iter = VTABLE_get_iter(interp, arg);
struct hv *hash = newHV();
INTVAL n = VTABLE_elements(interp, arg);
INTVAL i;
for(i = 0; i < n; i++) {
STRING *s = VTABLE_shift_string(interp, iter);
char *c_str = Parrot_str_to_cstring(interp, s);
struct sv *val = blizkost_marshal_arg(nexus,
VTABLE_get_pmc_keyed_str(interp, arg, s));
hv_store(hash, c_str, strlen(c_str), val, 0);
}
result = newRV_inc((SV*)hash);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"Sorry, we do not support marshaling most things to Perl 5 yet.");
}
return result;
}
