int
blizkost_slurpy_to_stack(BLIZKOST_NEXUS, PMC *positional, PMC *named) {
int num_pos, i, stkdepth;
PMC *iter;
dBNPERL; dBNINTERP; dSP;
stkdepth = 0;
/* Stick on positional arguments. */
num_pos = VTABLE_elements(interp, positional);
for (i = 0; i < num_pos; i++) {
PMC *pos_arg = VTABLE_get_pmc_keyed_int(interp, positional, i);
XPUSHs(blizkost_marshal_arg(nexus, pos_arg));
stkdepth++;
}
/* Stick on named arguments (we unbundle them to a string
* followed by the argument. */
iter = VTABLE_get_iter(interp, named);
while (VTABLE_get_bool(interp, iter)) {
STRING *arg_name = VTABLE_shift_string(interp, iter);
PMC *arg_value = VTABLE_get_pmc_keyed_str(interp, named, arg_name);
char *c_arg_name = Parrot_str_to_cstring(interp, arg_name);
XPUSHs(sv_2mortal(newSVpv(c_arg_name, strlen(c_arg_name))));
XPUSHs(blizkost_marshal_arg(nexus, arg_value));
stkdepth += 2;
}
PUTBACK;
return stkdepth;
}
/* Given an SC and an index, fetch the object stored there. */
PMC * SC_get_object(PARROT_INTERP, PMC *sc, INTVAL idx) {
PMC *objects;
GETATTR_SerializationContext_root_objects(interp, sc, objects);
if (idx >= VTABLE_elements(interp, objects))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"No object at index %d", idx);
return VTABLE_get_pmc_keyed_int(interp, objects, idx);
}
INTVAL
Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs)
{
DWORD status = 0;
STARTUPINFO si;
PROCESS_INFORMATION pi;
int pmclen;
int cmdlinelen = 1000;
int cmdlinepos = 0;
char *cmdline = (char *)mem_sys_allocate(cmdlinelen);
int i;
/* Ensure there's something in the PMC array. */
pmclen = VTABLE_elements(interp, cmdargs);
if (pmclen == 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN,
"Empty argument array for spawnw");
/* Now build command line. */
for (i = 0; i < pmclen; i++) {
STRING * const s = VTABLE_get_string_keyed_int(interp, cmdargs, i);
char * const cs = Parrot_str_to_cstring(interp, s);
if (cmdlinepos + (int)s->strlen + 3 > cmdlinelen) {
cmdlinelen += s->strlen + 4;
cmdline = (char *)mem_sys_realloc(cmdline, cmdlinelen);
}
strcpy(cmdline + cmdlinepos, "\"");
strcpy(cmdline + cmdlinepos + 1, cs);
strcpy(cmdline + cmdlinepos + 1 + s->strlen, "\" ");
cmdlinepos += s->strlen + 3;
}
/* Start the child process. */
memset(&si, 0, sizeof (si));
si.cb = sizeof (si);
memset(&pi, 0, sizeof (pi));
if (!CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN,
"Can't spawn child process");
WaitForSingleObject(pi.hProcess, INFINITE);
/* Get exit code. */
if (!GetExitCodeProcess(pi.hProcess, &status)) {
Parrot_warn(interp, PARROT_WARNINGS_PLATFORM_FLAG,
"Process completed: Failed to get exit code.");
}
/* Clean up. */
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
mem_sys_free(cmdline);
/* Return exit code left shifted by 8 for POSIX emulation. */
return status << 8;
}
/* Given an SC, looks up the index of an object that is in its root set. */
INTVAL SC_find_object_idx(PARROT_INTERP, PMC *sc, PMC *obj) {
PMC *to_search;
INTVAL i, count;
GETATTR_SerializationContext_root_objects(interp, sc, to_search);
count = VTABLE_elements(interp, to_search);
for (i = 0; i < count; i++)
if (VTABLE_get_pmc_keyed_int(interp, to_search, i) == obj)
return i;
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Object does not exist in serialization context");
}
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;
}
/* Takes an STable and adds it to this SC's root set, and installs a
* reposession entry. */
void SC_repossess_stable(PARROT_INTERP, PMC *target_sc, PMC *orig_sc, PMC *st_pmc) {
PMC *rep_indexes, *rep_scs;
/* Add to root set. */
PMC *stables;
INTVAL new_slot;
GETATTR_SerializationContext_root_stables(interp, target_sc, stables);
new_slot = VTABLE_elements(interp, stables);
VTABLE_set_pmc_keyed_int(interp, stables, new_slot, st_pmc);
/* Add repossession entry. */
GETATTR_SerializationContext_rep_indexes(interp, target_sc, rep_indexes);
GETATTR_SerializationContext_rep_scs(interp, target_sc, rep_scs);
VTABLE_push_integer(interp, rep_indexes, (new_slot << 1) | 1);
VTABLE_push_pmc(interp, rep_scs, orig_sc);
}
INTVAL
Parrot_Run_OS_Command_Argv(PARROT_INTERP, PMC *cmdargs)
{
pid_t child;
int len = VTABLE_elements(interp, cmdargs);
if (len == 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN,
"Empty argument array for execvp");
child = fork();
/* Did we fail? */
if (-1 == child)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_NOSPAWN,
"Can't spawn child process");
/* Are we the parent or child? */
if (child) {
/* parent */
int status;
pid_t returnstat = waitpid(child, &status, 0);
UNUSED(returnstat);
return status;
}
else {
/* child. Be horribly profligate with memory, since we're
about to be something else */
int status, i;
STRING *s;
char *cmd;
char **argv = mem_gc_allocate_n_typed(interp, (len+1), char*);
for (i = 0; i < len; ++i) {
s = VTABLE_get_string_keyed_int(interp, cmdargs, i);
argv[i] = Parrot_str_to_cstring(interp, s);
}
cmd = argv[0];
argv[i] = NULL;
status = execvp(cmd, argv);
/* if we get here, something's horribly wrong... */
if (status) {
exit(status);
}
}
return 1; /* make gcc happy */
}
/* This function gets shared with perl6.ops for the perl6_parcel_from_rpa op. */
PMC *
Rakudo_binding_parcel_from_rpa(PARROT_INTERP, PMC *rpa, PMC *fill) {
PMC *type = Rakudo_types_parcel_get();
PMC *parcel = REPR(type)->allocate(interp, STABLE(type));
VTABLE_set_attr_keyed(interp, parcel, type, STORAGE_str, rpa);
if (!PMC_IS_NULL(fill)) {
INTVAL elems = VTABLE_elements(interp, rpa);
INTVAL i;
for (i = 0; i < elems; i++) {
if (PMC_IS_NULL(VTABLE_get_pmc_keyed_int(interp, rpa, i)))
VTABLE_set_pmc_keyed_int(interp, rpa, i, fill);
}
}
return parcel;
}
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");
}
/* Compile time trial binding; tries to determine at compile time whether
* certain binds will/won't work. */
INTVAL Rakudo_binding_trial_bind(PARROT_INTERP, PMC *sig_pmc, PMC *capture) {
INTVAL i, num_pos_args, got_prim;
INTVAL cur_pos_arg = 0;
Rakudo_Signature *sig = (Rakudo_Signature *)PMC_data(sig_pmc);
PMC *params = sig->params;
INTVAL num_params = VTABLE_elements(interp, params);
/* Grab arguments. */
struct Pcc_cell * pc_positionals = NULL;
if (capture->vtable->base_type == enum_class_CallContext)
GETATTR_CallContext_positionals(interp, capture, pc_positionals);
else
return TRIAL_BIND_NOT_SURE;
/* Set up statics. */
if (!smo_id)
setup_binder_statics(interp);
/* Walk through the signature and consider the parameters. */
num_pos_args = VTABLE_elements(interp, capture);
for (i = 0; i < num_params; i++) {
Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
VTABLE_get_pmc_keyed_int(interp, params, i));
/* If the parameter is anything other than a boring old
* required positional parameter, we won't analyze it. */
if (param->flags & ~(
SIG_ELEM_MULTI_INVOCANT | SIG_ELEM_IS_PARCEL |
SIG_ELEM_IS_COPY | SIG_ELEM_ARRAY_SIGIL |
SIG_ELEM_HASH_SIGIL | SIG_ELEM_NATIVE_VALUE))
return TRIAL_BIND_NOT_SURE;
if (!PMC_IS_NULL(param->named_names))
return TRIAL_BIND_NOT_SURE;
if (!PMC_IS_NULL(param->post_constraints))
return TRIAL_BIND_NOT_SURE;
if (!PMC_IS_NULL(param->type_captures))
return TRIAL_BIND_NOT_SURE;
/* Did we pass too few required arguments? If so, fail. */
if (cur_pos_arg >= num_pos_args)
return TRIAL_BIND_NO_WAY;
/* Otherwise, need to consider type. */
got_prim = pc_positionals[cur_pos_arg].type;
if (param->flags & SIG_ELEM_NATIVE_VALUE) {
if (got_prim == BIND_VAL_OBJ) {
/* We got an object; if we aren't sure we can unbox, we can't
* be sure about the dispatch. */
PMC *arg = pc_positionals[cur_pos_arg].u.p;
storage_spec spec = REPR(arg)->get_storage_spec(interp, STABLE(arg));
switch (param->flags & SIG_ELEM_NATIVE_VALUE) {
case SIG_ELEM_NATIVE_INT_VALUE:
if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_INT))
return TRIAL_BIND_NOT_SURE;
break;
case SIG_ELEM_NATIVE_NUM_VALUE:
if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_NUM))
return TRIAL_BIND_NOT_SURE;
break;
case SIG_ELEM_NATIVE_STR_VALUE:
if (!(spec.can_box & STORAGE_SPEC_CAN_BOX_STR))
return TRIAL_BIND_NOT_SURE;
break;
default:
/* WTF... */
return TRIAL_BIND_NOT_SURE;
}
}
else {
/* If it's the wrong type of native, there's no way it
* can ever bind. */
if ((param->flags & SIG_ELEM_NATIVE_INT_VALUE) && got_prim != BIND_VAL_INT ||
(param->flags & SIG_ELEM_NATIVE_NUM_VALUE) && got_prim != BIND_VAL_NUM ||
(param->flags & SIG_ELEM_NATIVE_STR_VALUE) && got_prim != BIND_VAL_STR)
return TRIAL_BIND_NO_WAY;
}
}
else {
/* Work out a parameter type to consider, and see if it matches. */
PMC * const arg =
got_prim == BIND_VAL_OBJ ? pc_positionals[cur_pos_arg].u.p :
got_prim == BIND_VAL_INT ? Rakudo_types_int_get() :
got_prim == BIND_VAL_NUM ? Rakudo_types_num_get() :
Rakudo_types_str_get();
if (param->nominal_type != Rakudo_types_mu_get() &&
!STABLE(arg)->type_check(interp, arg, param->nominal_type)) {
/* If it failed because we got a junction, may auto-thread;
* hand back "not sure" for now. */
if (STABLE(arg)->WHAT == Rakudo_types_junction_get())
return TRIAL_BIND_NOT_SURE;
/* It failed to, but that doesn't mean it can't work at runtime;
* we perhaps want an Int, and the most we know is we have an Any,
* which would include Int. However, the Int ~~ Str case can be
* rejected now, as there's no way it'd ever match. Basically, we
* just flip the type check around. */
return STABLE(param->nominal_type)->type_check(interp, param->nominal_type, arg) ?
TRIAL_BIND_NOT_SURE : TRIAL_BIND_NO_WAY;
}
}
/* Continue to next argument. */
cur_pos_arg++;
}
/* If we have any left over arguments, it's a binding fail. */
if (cur_pos_arg < num_pos_args)
return TRIAL_BIND_NO_WAY;
/* Otherwise, if we get there, all is well. */
return TRIAL_BIND_OK;
}
PARROT_CANNOT_RETURN_NULL
PMC *
Parrot_oo_clone_object(PARROT_INTERP, ARGIN(PMC *pmc), ARGMOD_NULLOK(PMC *dest))
{
ASSERT_ARGS(Parrot_oo_clone_object)
Parrot_Object_attributes *obj = PARROT_OBJECT(pmc);
Parrot_Object_attributes *cloned_guts;
Parrot_Class_attributes *_class;
PMC *cloned;
INTVAL num_classes;
INTVAL i, num_attrs;
if (!PMC_IS_NULL(dest)) {
cloned = dest;
}
else {
cloned = Parrot_pmc_new_noinit(interp, enum_class_Object);
}
_class = PARROT_CLASS(obj->_class);
PARROT_ASSERT(_class);
num_classes = VTABLE_elements(interp, _class->all_parents);
/* Set custom GC mark and destroy on the object. */
PObj_custom_mark_SET(cloned);
PObj_custom_destroy_SET(cloned);
/* Flag that it is an object */
PObj_is_object_SET(cloned);
/* Now clone attributes list.class. */
cloned_guts = (Parrot_Object_attributes *) PMC_data(cloned);
cloned_guts->_class = obj->_class;
cloned_guts->attrib_store = VTABLE_clone(interp, obj->attrib_store);
num_attrs = VTABLE_elements(interp, cloned_guts->attrib_store);
for (i = 0; i < num_attrs; ++i) {
PMC * const to_clone = VTABLE_get_pmc_keyed_int(interp, cloned_guts->attrib_store, i);
if (!PMC_IS_NULL(to_clone)) {
VTABLE_set_pmc_keyed_int(interp, cloned_guts->attrib_store, i,
VTABLE_clone(interp, to_clone));
}
}
/* Some of the attributes may have been the PMCs providing storage for any
* PMCs we inherited from; also need to clone those. */
if (CLASS_has_alien_parents_TEST(obj->_class)) {
int j;
/* Locate any PMC parents. */
for (j = 0; j < num_classes; ++j) {
PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp, _class->all_parents, j);
if (cur_class->vtable->base_type == enum_class_PMCProxy) {
/* Clone this PMC too. */
STRING * const proxy = CONST_STRING(interp, "proxy");
VTABLE_set_attr_keyed(interp, cloned, cur_class, proxy,
VTABLE_clone(interp,
VTABLE_get_attr_keyed(interp, cloned, cur_class, proxy)));
}
}
}
/* And we have ourselves a clone. */
return cloned;
}
/* Performs a change of type, where possible. */
static void change_type(PARROT_INTERP, PMC *obj, PMC *new_type) {
P6opaqueInstance *instance = (P6opaqueInstance *)PMC_data(obj);
P6opaqueREPRData *cur_repr_data = (P6opaqueREPRData *)STABLE(obj)->REPR_data;
P6opaqueREPRData *new_repr_data = (P6opaqueREPRData *)STABLE(new_type)->REPR_data;
STRING *mro_str = Parrot_str_new_constant(interp, "mro");
PMC *cur_mro, *new_mro;
INTVAL cur_mro_elems, new_mro_elems, mro_is_suffix;
/* Ensure we're not trying to change the type of a type object. */
if (PObj_flag_TEST(private0, obj))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Cannot change the type of a type object");
/* Ensure that the destination type REPR is P6opaque also. */
if (REPR(obj) != REPR(new_type))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"P6opaque can only change type to another type with P6opaque REPR");
/* Ensure that MRO of new type has current type's MRO as a suffix. */
mro_is_suffix = 1;
cur_mro = introspection_call(interp, STABLE(obj)->WHAT, STABLE(obj)->HOW, mro_str, 0);
new_mro = introspection_call(interp, STABLE(new_type)->WHAT, STABLE(new_type)->HOW, mro_str, 0);
cur_mro_elems = VTABLE_elements(interp, cur_mro);
new_mro_elems = VTABLE_elements(interp, new_mro);
if (new_mro_elems >= cur_mro_elems) {
INTVAL start = new_mro_elems - cur_mro_elems;
INTVAL i;
for (i = 0; i < cur_mro_elems; i++) {
PMC *cur_elem = VTABLE_get_pmc_keyed_int(interp, cur_mro, i);
PMC *new_elem = VTABLE_get_pmc_keyed_int(interp, new_mro, i + start);
if (decontainerize(interp, cur_elem) != decontainerize(interp, new_elem)) {
mro_is_suffix = 0;
break;
}
}
}
else {
mro_is_suffix = 0;
}
if (!mro_is_suffix)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"P6opaque only supports type changes where the MRO of the original type is a suffix of the MRO of the new type");
/* If the new REPR never calculated it's object layout, do so now. */
if (!new_repr_data->allocation_size) {
compute_allocation_strategy(interp, new_type, new_repr_data);
PARROT_GC_WRITE_BARRIER(interp, STABLE_PMC(new_type));
}
/* Reallocate ourself to the new allocation size, if needed, and
* ensure new chunk of the memory is zeroed. Note that we can't
* really re-alloc, we need to go deal with the fixed size pool
* allocator. */
if (new_repr_data->allocation_size > cur_repr_data->allocation_size) {
P6opaqueInstance *new_body = (P6opaqueInstance *) Parrot_gc_allocate_fixed_size_storage(interp, new_repr_data->allocation_size);
memset(new_body, 0, new_repr_data->allocation_size);
memcpy(new_body, instance, cur_repr_data->allocation_size);
PMC_data(obj) = new_body;
Parrot_gc_free_fixed_size_storage(interp, cur_repr_data->allocation_size, instance);
instance = new_body;
}
/* Finally, we're ready to switch the S-Table pointer. */
instance->common.stable = STABLE_PMC(new_type);
PARROT_GC_WRITE_BARRIER(interp, obj);
}
/* Locates all of the attributes. Puts them onto a flattened, ordered
* list of attributes (populating the passed flat_list). Also builds
* the index mapping for doing named lookups. Note index is not related
* to the storage position. */
static PMC * index_mapping_and_flat_list(PARROT_INTERP, PMC *WHAT, P6opaqueREPRData *repr_data) {
PMC *flat_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
PMC *class_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
PMC *attr_map_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
STRING *attributes_str = Parrot_str_new_constant(interp, "attributes");
STRING *parents_str = Parrot_str_new_constant(interp, "parents");
STRING *name_str = Parrot_str_new_constant(interp, "name");
STRING *mro_str = Parrot_str_new_constant(interp, "mro");
INTVAL current_slot = 0;
INTVAL num_classes, i;
P6opaqueNameMap * result = NULL;
/* Get the MRO. */
PMC *mro = introspection_call(interp, WHAT, STABLE(WHAT)->HOW, mro_str, 0);
INTVAL mro_idx = VTABLE_elements(interp, mro);
/* Walk through the parents list. */
while (mro_idx)
{
/* Get current class in MRO. */
PMC *current_class = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, mro, --mro_idx));
PMC *HOW = STABLE(current_class)->HOW;
/* Get its local parents. */
PMC *parents = introspection_call(interp, current_class, HOW, parents_str, 1);
INTVAL num_parents = VTABLE_elements(interp, parents);
/* Get attributes and iterate over them. */
PMC *attributes = introspection_call(interp, current_class, HOW, attributes_str, 1);
PMC *attr_map = PMCNULL;
PMC *attr_iter = VTABLE_get_iter(interp, attributes);
while (VTABLE_get_bool(interp, attr_iter)) {
/* Get attribute. */
PMC * attr = VTABLE_shift_pmc(interp, attr_iter);
/* Get its name. */
PMC *name_pmc = accessor_call(interp, attr, name_str);
STRING *name = VTABLE_get_string(interp, name_pmc);
/* Allocate a slot. */
if (PMC_IS_NULL(attr_map))
attr_map = Parrot_pmc_new(interp, enum_class_Hash);
VTABLE_set_pmc_keyed_str(interp, attr_map, name,
Parrot_pmc_new_init_int(interp, enum_class_Integer, current_slot));
current_slot++;
/* Push attr onto the flat list. */
VTABLE_push_pmc(interp, flat_list, attr);
}
/* Add to class list and map list. */
VTABLE_push_pmc(interp, class_list, current_class);
VTABLE_push_pmc(interp, attr_map_list, attr_map);
/* If there's more than one parent, flag that we in an MI
* situation. */
if (num_parents > 1)
repr_data->mi = 1;
}
/* We can now form the name map. */
num_classes = VTABLE_elements(interp, class_list);
result = (P6opaqueNameMap *) mem_sys_allocate_zeroed(sizeof(P6opaqueNameMap) * (1 + num_classes));
for (i = 0; i < num_classes; i++) {
result[i].class_key = VTABLE_get_pmc_keyed_int(interp, class_list, i);
result[i].name_map = VTABLE_get_pmc_keyed_int(interp, attr_map_list, i);
}
repr_data->name_to_index_mapping = result;
return flat_list;
}
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;
}
/* Takes a signature along with positional and named arguments and binds them
* into the provided lexpad (actually, anything that has a Hash interface will
* do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there
* is a failure and BIND_RESULT_JUNCTION if the failure was because of a
* Junction being passed (meaning we need to auto-thread). */
INTVAL
Rakudo_binding_bind_llsig(PARROT_INTERP, PMC *lexpad, PMC *llsig,
PMC *capture, INTVAL no_nom_type_check,
STRING **error) {
INTVAL i;
INTVAL bind_fail;
INTVAL cur_pos_arg = 0;
INTVAL num_pos_args = VTABLE_elements(interp, capture);
PMC *named_names = PMCNULL;
llsig_element **elements;
INTVAL num_elements;
PMC *named_to_pos_cache;
/* Lazily allocated array of bindings to positionals of nameds. */
PMC **pos_from_named = NULL;
/* If we do have some named args, we want to make a clone of the hash
* to work on. We'll delete stuff from it as we bind, and what we have
* left over can become the slurpy hash or - if we aren't meant to be
* taking one - tell us we have a problem. */
PMC *named_args_copy = PMCNULL;
/* If we have a |$foo that's followed by slurpies, then we can suppress
* any future arity checks. */
INTVAL suppress_arity_fail = 0;
/* Check that we have a valid signature and pull the bits out of it. */
if (!lls_id)
setup_binder_statics(interp);
if (llsig->vtable->base_type != lls_id)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Internal Error: Rakudo_binding_bind_llsig passed invalid signature");
GETATTR_P6LowLevelSig_elements(interp, llsig, elements);
GETATTR_P6LowLevelSig_num_elements(interp, llsig, num_elements);
GETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache);
/* Build nameds -> position hash for named positional arguments,
* if it was not yet built. */
if (PMC_IS_NULL(named_to_pos_cache)) {
named_to_pos_cache = pmc_new(interp, enum_class_Hash);
PARROT_GC_WRITE_BARRIER(interp, llsig);
SETATTR_P6LowLevelSig_named_to_pos_cache(interp, llsig, named_to_pos_cache);
for (i = 0; i < num_elements; i++) {
/* If we find a named argument, we're done with the positionals. */
if (!PMC_IS_NULL(elements[i]->named_names))
break;
/* Skip slurpies (may be a slurpy block, so can't just break). */
if (elements[i]->flags & SIG_ELEM_SLURPY)
continue;
/* Provided it has a name... */
if (!STRING_IS_NULL(elements[i]->variable_name)) {
/* Strip any sigil, then stick in named to positional array. */
STRING *store = elements[i]->variable_name;
STRING *sigil = Parrot_str_substr(interp, store, 0, 1);
STRING *twigil = Parrot_str_substr(interp, store, 1, 1);
if (Parrot_str_equal(interp, sigil, SCALAR_SIGIL_str)
|| Parrot_str_equal(interp, sigil, ARRAY_SIGIL_str)
|| Parrot_str_equal(interp, sigil, HASH_SIGIL_str))
store = Parrot_str_substr(interp, store, 1,
Parrot_str_byte_length(interp, store));
if (Parrot_str_equal(interp, twigil, BANG_TWIGIL_str))
store = Parrot_str_substr(interp, store, 1,
Parrot_str_byte_length(interp, store));
VTABLE_set_integer_keyed_str(interp, named_to_pos_cache, store, i);
}
}
}
/* If we've got a CallContext, just has an attribute with list of named
* parameter names. Otherwise, it's a Capture and we need to do .hash and
* grab out the keys. */
if (capture->vtable->base_type == enum_class_CallContext
|| VTABLE_isa(interp, capture, CALLCONTEXT_str)) {
named_names = VTABLE_get_attr_str(interp, capture, Parrot_str_new(interp, "named", 0));
}
else if (VTABLE_isa(interp, capture, CAPTURE_str)) {
PMC *meth = VTABLE_find_method(interp, capture, Parrot_str_new(interp, "!PARROT_NAMEDS", 0));
PMC *hash = PMCNULL;
PMC *iter;
Parrot_ext_call(interp, meth, "Pi->P", capture, &hash);
iter = VTABLE_get_iter(interp, hash);
if (VTABLE_get_bool(interp, iter)) {
named_names = pmc_new(interp, enum_class_ResizableStringArray);
while (VTABLE_get_bool(interp, iter))
VTABLE_push_string(interp, named_names, VTABLE_shift_string(interp, iter));
}
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Internal Error: Rakudo_binding_bind_llsig passed invalid Capture");
}
/* First, consider named arguments, to see if there are any that we will
* be wanting to bind positionally. */
if (!PMC_IS_NULL(named_names)) {
PMC *iter = VTABLE_get_iter(interp, named_names);
named_args_copy = pmc_new(interp, enum_class_Hash);
while (VTABLE_get_bool(interp, iter)) {
STRING *name = VTABLE_shift_string(interp, iter);
if (VTABLE_exists_keyed_str(interp, named_to_pos_cache, name)) {
/* Found one. We'll stash it away for quick access to bind it
* later. */
INTVAL pos = VTABLE_get_integer_keyed_str(interp, named_to_pos_cache, name);
if (!pos_from_named)
pos_from_named = mem_allocate_n_zeroed_typed(num_elements, PMC *);
pos_from_named[pos] = VTABLE_get_pmc_keyed_str(interp, capture, name);
}
else {
/* Otherwise, we'll enter it into the hash of things to bind
* to nameds. */
VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
VTABLE_get_pmc_keyed_str(interp, capture, name));
}
}
/* Takes a signature along with positional and named arguments and binds them
* into the provided lexpad (actually, anything that has a Hash interface will
* do). Returns BIND_RESULT_OK if binding works out, BIND_RESULT_FAIL if there
* is a failure and BIND_RESULT_JUNCTION if the failure was because of a
* Junction being passed (meaning we need to auto-thread). */
INTVAL
Rakudo_binding_bind(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
INTVAL no_nom_type_check, STRING **error) {
INTVAL i, num_pos_args;
INTVAL bind_fail = 0;
INTVAL cur_pos_arg = 0;
Rakudo_Signature *sig = (Rakudo_Signature *)PMC_data(sig_pmc);
PMC *params = sig->params;
INTVAL num_params = VTABLE_elements(interp, params);
Rakudo_BindVal cur_bv;
/* If we do have some named args, we want to make a clone of the hash
* to work on. We'll delete stuff from it as we bind, and what we have
* left over can become the slurpy hash or - if we aren't meant to be
* taking one - tell us we have a problem. */
PMC *named_args_copy = PMCNULL;
/* If we have a |$foo that's followed by slurpies, then we can suppress
* any future arity checks. */
INTVAL suppress_arity_fail = 0;
/* If it's a Parrot capture, it may contain natively typed arguments.
* NOTE: This is a really an encapsulation breakage; if Parrot folks
* change stuff and this breaks, it's not Parrot's fault. */
struct Pcc_cell * pc_positionals = NULL;
/* Set up statics. */
if (!smo_id)
setup_binder_statics(interp);
/* If we've got a CallContext, just has an attribute with list of named
* parameter names. Otherwise, it's probably a Perl 6 Capture and we need
* to extract its parts. */
if (capture->vtable->base_type == enum_class_CallContext) {
PMC *named_names = VTABLE_get_attr_str(interp, capture, NAMED_str);
if (!PMC_IS_NULL(named_names)) {
PMC *iter = VTABLE_get_iter(interp, named_names);
named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
while (VTABLE_get_bool(interp, iter)) {
STRING *name = VTABLE_shift_string(interp, iter);
VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
VTABLE_get_pmc_keyed_str(interp, capture, name));
}
}
GETATTR_CallContext_positionals(interp, capture, pc_positionals);
}
else if (capture->vtable->base_type == smo_id &&
STABLE(capture)->type_check(interp, capture, Rakudo_types_capture_get())) {
PMC *captype = Rakudo_types_capture_get();
PMC *list_part = VTABLE_get_attr_keyed(interp, capture, captype, LIST_str);
PMC *hash_part = VTABLE_get_attr_keyed(interp, capture, captype, HASH_str);
capture = Rakudo_isnqplist(list_part)
? list_part
: Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
if (hash_part->vtable->base_type == enum_class_Hash) {
PMC *iter = VTABLE_get_iter(interp, hash_part);
named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
while (VTABLE_get_bool(interp, iter)) {
STRING *arg_copy_name = VTABLE_shift_string(interp, iter);
VTABLE_set_pmc_keyed_str(interp, named_args_copy, arg_copy_name,
VTABLE_get_pmc_keyed_str(interp, hash_part, arg_copy_name));
}
}
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Internal Error: Rakudo_binding_bind passed invalid Capture");
}
/* Now we'll walk through the signature and go about binding things. */
num_pos_args = VTABLE_elements(interp, capture);
for (i = 0; i < num_params; i++) {
Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
VTABLE_get_pmc_keyed_int(interp, params, i));
/* Is it looking for us to bind a capture here? */
if (param->flags & SIG_ELEM_IS_CAPTURE) {
/* Capture the arguments from this point forwards into a Capture.
* Of course, if there's no variable name we can (cheaply) do pretty
* much nothing. */
if (STRING_IS_NULL(param->variable_name)) {
bind_fail = BIND_RESULT_OK;
}
else {
PMC *captype = Rakudo_types_capture_get();
PMC *capsnap = REPR(captype)->allocate(interp, STABLE(captype));
PMC *pos_args = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
PMC *named_args = Parrot_pmc_new(interp, enum_class_Hash);
INTVAL k;
VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args);
VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str, named_args);
for (k = cur_pos_arg; k < num_pos_args; k++) {
cur_bv = get_positional_bind_val(interp, pc_positionals, capture, k);
VTABLE_push_pmc(interp, pos_args, cur_bv.type == BIND_VAL_OBJ ?
cur_bv.val.o :
create_box(interp, cur_bv));
}
if (!PMC_IS_NULL(named_args_copy)) {
PMC *iter = VTABLE_get_iter(interp, named_args_copy);
while (VTABLE_get_bool(interp, iter)) {
STRING *name = VTABLE_shift_string(interp, iter);
VTABLE_set_pmc_keyed_str(interp, named_args, name,
VTABLE_get_pmc_keyed_str(interp, named_args_copy, name));
}
}
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = capsnap;
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv,
no_nom_type_check, error);
}
if (bind_fail) {
return bind_fail;
}
else if (i + 1 == num_params) {
/* Since a capture acts as "the ultimate slurpy" in a sense, if
* this is the last parameter in the signature we can return
* success right off the bat. */
return BIND_RESULT_OK;
}
else {
Rakudo_Parameter *next_param = (Rakudo_Parameter *)PMC_data(
VTABLE_get_pmc_keyed_int(interp, params, i + 1));
if (next_param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED))
suppress_arity_fail = 1;
}
}
/* Could it be a named slurpy? */
else if (param->flags & SIG_ELEM_SLURPY_NAMED) {
/* Can cheat a bit if it's the default method %_.
* We give the hash to the lexpad. */
if (param->flags & SIG_ELEM_METHOD_SLURPY_NAMED && lexpad->vtable->base_type == p6l_id) {
SETATTR_Perl6LexPad_default_named_slurpy(interp, lexpad, named_args_copy);
PARROT_GC_WRITE_BARRIER(interp, lexpad);
}
else {
/* We'll either take the current named arguments copy hash which
* will by definition contain all unbound named parameters and use
* that, or just create an empty one. */
PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
Parrot_pmc_new(interp, enum_class_Hash) :
named_args_copy;
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = Rakudo_binding_create_hash(interp, slurpy);
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, no_nom_type_check, error);
if (bind_fail)
return bind_fail;
}
/* Nullify named arguments hash now we've consumed it, to mark all
* is well. */
named_args_copy = PMCNULL;
}
/* Otherwise, maybe it's a positional. */
else if (PMC_IS_NULL(param->named_names)) {
/* Slurpy or LoL-slurpy? */
if (param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) {
/* Create Perl 6 array, create RPA of all remaining things, then
* store it. */
PMC *temp = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
while (cur_pos_arg < num_pos_args) {
cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
VTABLE_push_pmc(interp, temp, cur_bv.type == BIND_VAL_OBJ ?
cur_bv.val.o :
create_box(interp, cur_bv));
cur_pos_arg++;
}
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = param->flags & SIG_ELEM_SLURPY_POS ?
Rakudo_binding_create_positional(interp, temp) :
Rakudo_binding_create_lol(interp, temp);
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, no_nom_type_check, error);
if (bind_fail)
return bind_fail;
}
/* Otherwise, a positional. */
else {
/* Do we have a value?. */
if (cur_pos_arg < num_pos_args) {
/* Easy - just bind that. */
cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, no_nom_type_check, error);
if (bind_fail)
return bind_fail;
cur_pos_arg++;
}
else {
/* No value. If it's optional, fetch a default and bind that;
* if not, we're screwed. Note that we never nominal type check
* an optional with no value passed. */
if (param->flags & SIG_ELEM_IS_OPTIONAL) {
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, 0, error);
if (bind_fail)
return bind_fail;
}
else {
if (error)
*error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 0);
return BIND_RESULT_FAIL;
}
}
}
}
/* Else, it's a non-slurpy named. */
else {
/* Try and get hold of value. */
PMC *value = PMCNULL;
INTVAL num_names = VTABLE_elements(interp, param->named_names);
INTVAL j;
if (!PMC_IS_NULL(named_args_copy)) {
for (j = 0; j < num_names; j++) {
STRING *name = VTABLE_get_string_keyed_int(interp, param->named_names, j);
value = VTABLE_get_pmc_keyed_str(interp, named_args_copy, name);
if (!PMC_IS_NULL(value)) {
/* Found a value. Delete entry from to-bind args and stop looking. */
VTABLE_delete_keyed_str(interp, named_args_copy, name);
break;
}
}
}
/* Did we get one? */
if (PMC_IS_NULL(value)) {
/* Nope. We'd better hope this param was optional... */
if (param->flags & SIG_ELEM_IS_OPTIONAL) {
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, 0, error);
}
else if (!suppress_arity_fail) {
if (error)
*error = Parrot_sprintf_c(interp, "Required named parameter '%S' not passed",
VTABLE_get_string_keyed_int(interp, param->named_names, 0));
return BIND_RESULT_FAIL;
}
}
else {
cur_bv.type = BIND_VAL_OBJ;
cur_bv.val.o = value;
bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
cur_bv, 0, error);
}
/* If we got a binding failure, return it. */
if (bind_fail)
return bind_fail;
}
}
/* Do we have any left-over args? */
if (cur_pos_arg < num_pos_args && !suppress_arity_fail) {
/* Oh noes, too many positionals passed. */
if (error)
*error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 1);
return BIND_RESULT_FAIL;
}
if (!PMC_IS_NULL(named_args_copy) && VTABLE_elements(interp, named_args_copy)) {
/* Oh noes, unexpected named args. */
if (error) {
INTVAL num_extra = VTABLE_elements(interp, named_args_copy);
PMC *iter = VTABLE_get_iter(interp, named_args_copy);
if (num_extra == 1) {
*error = Parrot_sprintf_c(interp, "Unexpected named parameter '%S' passed",
VTABLE_shift_string(interp, iter));
}
else {
INTVAL first = 1;
STRING *comma = Parrot_str_new(interp, ", ", 0);
*error = Parrot_sprintf_c(interp, "%d unexpected named parameters passed (", num_extra);
while (VTABLE_get_bool(interp, iter)) {
STRING *name = VTABLE_shift_string(interp, iter);
if (!first)
*error = Parrot_str_concat(interp, *error, comma);
else
first = 0;
*error = Parrot_str_concat(interp, *error, name);
}
*error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, ")", 0));
}
}
return BIND_RESULT_FAIL;
}
/* If we get here, we're done. */
return BIND_RESULT_OK;
}
/* Registers a representation. It this is ever made public, it should first be
* made thread-safe. */
static void register_repr(PARROT_INTERP, STRING *name, PMC *repr) {
INTVAL ID = VTABLE_elements(interp, repr_registry);
VTABLE_push_pmc(interp, repr_registry, repr);
VTABLE_set_integer_keyed_str(interp, repr_name_to_id_map, name, ID);
}
/* Locates all of the attributes. Puts them onto a flattened, ordered
* list of attributes (populating the passed flat_list). Also builds
* the index mapping for doing named lookups. Note index is not related
* to the storage position. */
static PMC * index_mapping_and_flat_list(PARROT_INTERP, PMC *mro, CStructREPRData *repr_data) {
PMC *flat_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
PMC *class_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
PMC *attr_map_list = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
STRING *name_str = Parrot_str_new_constant(interp, "name");
INTVAL current_slot = 0;
INTVAL num_classes, i;
CStructNameMap * result = NULL;
/* Walk through the parents list. */
INTVAL mro_idx = VTABLE_elements(interp, mro);
while (mro_idx)
{
/* Get current class in MRO. */
PMC *type_info = VTABLE_get_pmc_keyed_int(interp, mro, --mro_idx);
PMC *current_class = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, type_info, 0));
/* Get its local parents; make sure we're not doing MI. */
PMC *parents = VTABLE_get_pmc_keyed_int(interp, type_info, 2);
INTVAL num_parents = VTABLE_elements(interp, parents);
if (num_parents <= 1) {
/* Get attributes and iterate over them. */
PMC *attributes = VTABLE_get_pmc_keyed_int(interp, type_info, 1);
PMC *attr_map = PMCNULL;
PMC *attr_iter = VTABLE_get_iter(interp, attributes);
while (VTABLE_get_bool(interp, attr_iter)) {
/* Get attribute. */
PMC * attr = VTABLE_shift_pmc(interp, attr_iter);
/* Get its name. */
PMC *name_pmc = VTABLE_get_pmc_keyed_str(interp, attr, name_str);
STRING *name = VTABLE_get_string(interp, name_pmc);
/* Allocate a slot. */
if (PMC_IS_NULL(attr_map))
attr_map = Parrot_pmc_new(interp, enum_class_Hash);
VTABLE_set_pmc_keyed_str(interp, attr_map, name,
Parrot_pmc_new_init_int(interp, enum_class_Integer, current_slot));
current_slot++;
/* Push attr onto the flat list. */
VTABLE_push_pmc(interp, flat_list, attr);
}
/* Add to class list and map list. */
VTABLE_push_pmc(interp, class_list, current_class);
VTABLE_push_pmc(interp, attr_map_list, attr_map);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStruct representation does not support multiple inheritance");
}
}
/* We can now form the name map. */
num_classes = VTABLE_elements(interp, class_list);
result = (CStructNameMap *) mem_sys_allocate_zeroed(sizeof(CStructNameMap) * (1 + num_classes));
for (i = 0; i < num_classes; i++) {
result[i].class_key = VTABLE_get_pmc_keyed_int(interp, class_list, i);
result[i].name_map = VTABLE_get_pmc_keyed_int(interp, attr_map_list, i);
}
repr_data->name_to_index_mapping = result;
return flat_list;
}
/* This works out an allocation strategy for the object. It takes care of
* "inlining" storage of attributes that are natively typed, as well as
* noting unbox targets. */
static void compute_allocation_strategy(PARROT_INTERP, PMC *repr_info, CStructREPRData *repr_data) {
STRING *type_str = Parrot_str_new_constant(interp, "type");
PMC *flat_list;
/*
* We have to block GC mark here. Because "repr" is assotiated with some
* PMC which is not accessible in this function. And we have to write
* barrier this PMC because we are poking inside it guts directly. We
* do have WB in caller function, but it can be triggered too late is
* any of allocation will cause GC run.
*
* This is kind of minor evil until after I'll find better solution.
*/
Parrot_block_GC_mark(interp);
/* Compute index mapping table and get flat list of attributes. */
flat_list = index_mapping_and_flat_list(interp, repr_info, repr_data);
/* If we have no attributes in the index mapping, then just the header. */
if (repr_data->name_to_index_mapping[0].class_key == NULL) {
repr_data->struct_size = 1; /* avoid 0-byte malloc */
}
/* Otherwise, we need to compute the allocation strategy. */
else {
/* We track the size of the struct, which is what we'll want offsets into. */
INTVAL cur_size = 0;
/* Get number of attributes and set up various counters. */
INTVAL num_attrs = VTABLE_elements(interp, flat_list);
INTVAL info_alloc = num_attrs == 0 ? 1 : num_attrs;
INTVAL cur_obj_attr = 0;
INTVAL cur_str_attr = 0;
INTVAL cur_init_slot = 0;
INTVAL i;
/* Allocate location/offset arrays and GC mark info arrays. */
repr_data->num_attributes = num_attrs;
repr_data->attribute_locations = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL));
repr_data->struct_offsets = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL));
repr_data->flattened_stables = (STable **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *));
repr_data->member_types = (PMC** ) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *));
/* Go over the attributes and arrange their allocation. */
for (i = 0; i < num_attrs; i++) {
/* Fetch its type; see if it's some kind of unboxed type. */
PMC *attr = VTABLE_get_pmc_keyed_int(interp, flat_list, i);
PMC *type = VTABLE_get_pmc_keyed_str(interp, attr, type_str);
INTVAL type_id = REPR(type)->ID;
INTVAL bits = sizeof(void *) * 8;
INTVAL align = ALIGNOF1(void *);
if (!PMC_IS_NULL(type)) {
/* See if it's a type that we know how to handle in a C struct. */
storage_spec spec = REPR(type)->get_storage_spec(interp, STABLE(type));
if (spec.inlineable == STORAGE_SPEC_INLINED &&
(spec.boxed_primitive == STORAGE_SPEC_BP_INT ||
spec.boxed_primitive == STORAGE_SPEC_BP_NUM)) {
/* It's a boxed int or num; pretty easy. It'll just live in the
* body of the struct. Instead of masking in i here (which
* would be the parallel to how we handle boxed types) we
* repurpose it to store the bit-width of the type, so
* that get_attribute_ref can find it later. */
bits = spec.bits;
align = spec.align;
if (bits % 8) {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStruct only supports native types that are a multiple of 8 bits wide (was passed: %ld)", bits);
}
repr_data->attribute_locations[i] = (bits << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_IN_STRUCT;
repr_data->flattened_stables[i] = STABLE(type);
if (REPR(type)->initialize) {
if (!repr_data->initialize_slots)
repr_data->initialize_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL));
repr_data->initialize_slots[cur_init_slot] = i;
cur_init_slot++;
}
}
else if(spec.can_box & STORAGE_SPEC_CAN_BOX_STR) {
/* It's a string of some kind. */
repr_data->num_child_objs++;
repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_STRING;
repr_data->member_types[i] = type;
}
else if(type_id == get_ca_repr_id()) {
/* It's a CArray of some kind. */
repr_data->num_child_objs++;
repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CARRAY;
repr_data->member_types[i] = type;
}
else if(type_id == get_cs_repr_id()) {
/* It's a CStruct. */
repr_data->num_child_objs++;
repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CSTRUCT;
repr_data->member_types[i] = type;
}
else if(type_id == get_cp_repr_id()) {
/* It's a CPointer. */
repr_data->num_child_objs++;
repr_data->attribute_locations[i] = (cur_obj_attr++ << CSTRUCT_ATTR_SHIFT) | CSTRUCT_ATTR_CPTR;
repr_data->member_types[i] = type;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStruct representation only implements native int and float members so far");
}
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStruct representation requires the types of all attributes to be specified");
}
/* Do allocation. */
/* C structure needs careful alignment. If cur_size is not aligned
* to align bytes (cur_size % align), make sure it is before we
* add the next element. */
if (cur_size % align) {
cur_size += align - cur_size % align;
}
repr_data->struct_offsets[i] = cur_size;
cur_size += bits / 8;
}
/* Finally, put computed allocation size in place; it's body size plus
* header size. Also number of markables and sentinels. */
repr_data->struct_size = cur_size;
if (repr_data->initialize_slots)
repr_data->initialize_slots[cur_init_slot] = -1;
}
Parrot_unblock_GC_mark(interp);
}
void
parrot_init_library_paths(PARROT_INTERP)
{
ASSERT_ARGS(parrot_init_library_paths)
PMC *paths;
STRING *entry;
STRING *versionlib = NULL;
STRING *builddir = NULL;
PMC * const iglobals = interp->iglobals;
PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, iglobals,
(INTVAL)IGLOBALS_CONFIG_HASH);
/* create the lib_paths array */
PMC * const lib_paths = Parrot_pmc_new_init_int(interp,
enum_class_FixedPMCArray, PARROT_LIB_PATH_SIZE);
VTABLE_set_pmc_keyed_int(interp, iglobals,
IGLOBALS_LIB_PATHS, lib_paths);
if (VTABLE_elements(interp, config_hash)) {
STRING * const libkey = CONST_STRING(interp, "libdir");
STRING * const verkey = CONST_STRING(interp, "versiondir");
STRING * const builddirkey = CONST_STRING(interp, "build_dir");
STRING * const installed = CONST_STRING(interp, "installed");
versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
versionlib = Parrot_str_concat(interp, versionlib, entry);
if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed))
builddir = VTABLE_get_string_keyed_str(interp,
config_hash, builddirkey);
}
/* each is an array of strings */
/* define include paths */
paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_INCLUDE, paths);
{ /* EXPERIMENTAL: add include path from environment */
const char *envvar = Parrot_getenv(interp,
Parrot_str_new_constant(interp, "PARROT_INCLUDE"));
if (envvar != NULL && envvar[0]) {
entry = Parrot_str_new(interp, envvar, 0);
VTABLE_push_string(interp, paths, entry);
}
}
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"));
VTABLE_push_string(interp, paths, entry);
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"));
VTABLE_push_string(interp, paths, entry);
}
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"));
VTABLE_push_string(interp, paths, entry);
}
/* define library paths */
paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_LIBRARY, paths);
{ /* EXPERIMENTAL: add library path from environment */
const char *envvar = Parrot_getenv(interp,
Parrot_str_new_constant(interp, "PARROT_LIBRARY"));
if (envvar != NULL && envvar[0]) {
entry = Parrot_str_new(interp, envvar, 0);
VTABLE_push_string(interp, paths, entry);
}
}
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"));
VTABLE_push_string(interp, paths, entry);
}
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/"));
VTABLE_push_string(interp, paths, entry);
}
/* define languages paths */
paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_LANG, paths);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"));
VTABLE_push_string(interp, paths, entry);
}
entry = CONST_STRING(interp, "./");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/"));
VTABLE_push_string(interp, paths, entry);
}
/* define dynext paths */
paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_PATH_DYNEXT, paths);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"));
VTABLE_push_string(interp, paths, entry);
}
entry = CONST_STRING(interp, "dynext/");
VTABLE_push_string(interp, paths, entry);
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/"));
VTABLE_push_string(interp, paths, entry);
}
/* shared exts */
paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
VTABLE_set_pmc_keyed_int(interp, lib_paths,
PARROT_LIB_DYN_EXTS, paths);
/* no CONST_STRING here - the c2str.pl preprocessor needs "real strs" */
entry = Parrot_str_new_constant(interp, PARROT_LOAD_EXT);
VTABLE_push_string(interp, paths, entry);
/* OS/X has .dylib and .bundle */
if (!STREQ(PARROT_LOAD_EXT, PARROT_SHARE_EXT)) {
entry = Parrot_str_new_constant(interp, PARROT_SHARE_EXT);
VTABLE_push_string(interp, paths, entry);
}
#ifdef PARROT_PLATFORM_LIB_PATH_INIT_HOOK
PARROT_PLATFORM_LIB_PATH_INIT_HOOK(interp, lib_paths);
#endif
}
static PMC* find_best_candidate(PARROT_INTERP, Rakudo_md_candidate_info **candidates,
INTVAL num_candidates, PMC *capture, opcode_t *next,
PMC *dispatcher, INTVAL many) {
Rakudo_md_candidate_info **cur_candidate = candidates;
Rakudo_md_candidate_info **possibles = mem_allocate_n_typed(num_candidates + 1, Rakudo_md_candidate_info *);
PMC *junctional_res = PMCNULL;
PMC *many_res = many ? Parrot_pmc_new(interp, enum_class_ResizablePMCArray) : PMCNULL;
const INTVAL num_args = VTABLE_elements(interp, capture);
INTVAL possibles_count = 0;
INTVAL pure_type_result = 1;
INTVAL type_check_count;
INTVAL type_mismatch;
/* We expect a Parrot capture in the multi-dispatcher, always. */
struct Pcc_cell * pc_positionals = NULL;
if (capture->vtable->base_type == enum_class_CallContext) {
GETATTR_CallContext_positionals(interp, capture, pc_positionals);
}
else {
mem_sys_free(possibles);
Parrot_ex_throw_from_c_args(interp, next, 1,
"INTERNAL ERROR: multi-dispatcher must be given a low level capture");
}
/* Iterate over the candidates and collect best ones; terminate
* when we see two nulls (may break out earlier). */
while (1) {
INTVAL i;
if (*cur_candidate == NULL) {
/* We've hit the end of a tied group now. If any of them have a
* bindability check requirement, we'll do any of those now. */
if (possibles_count) {
Rakudo_md_candidate_info **new_possibles = NULL;
INTVAL new_possibles_count = 0;
INTVAL i;
for (i = 0; i < possibles_count; i++) {
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), NULL);
/* First, if there's a required named parameter and it was
* not passed, we can very quickly eliminate this candidate
* without doing a full bindability check. */
if (possibles[i]->req_named) {
if (!VTABLE_exists_keyed_str(interp, capture, possibles[i]->req_named)) {
/* Required named arg not passed, so we eliminate
* it right here. Flag that we've built a list of
* new possibles, and that this was not a pure
* type-based result that we can cache. */
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
pure_type_result = 0;
continue;
}
}
/* Otherwise, may need full bind check. */
if (possibles[i]->bind_check) {
/* We'll invoke the sub (but not re-enter the runloop)
* and then attempt to bind the signature. */
PMC *cthunk, *lexpad, *sig;
opcode_t *where;
INTVAL bind_check_result;
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(possibles[i]->sub);
cthunk = Parrot_pmc_getprop(interp, code_obj->_do,
Parrot_str_new(interp, "COMPILER_THUNK", 0));
if (!PMC_IS_NULL(cthunk)) {
/* We need to do the tie-break on something not yet compiled.
* Get it compiled. */
Parrot_ext_call(interp, cthunk, "->");
}
Parrot_pcc_reuse_continuation(interp, CURRENT_CONTEXT(interp), next);
where = VTABLE_invoke(interp, possibles[i]->sub, next);
lexpad = Parrot_pcc_get_lex_pad(interp, CURRENT_CONTEXT(interp));
sig = possibles[i]->signature;
bind_check_result = Rakudo_binding_bind(interp, lexpad,
sig, capture, 0, NULL);
where = VTABLE_invoke(interp, Parrot_pcc_get_continuation(interp, CURRENT_CONTEXT(interp)), where);
/* If we haven't got a possibles storage space, allocate it now. */
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
/* If we don't fail, need to put this one onto the list
* (note that needing a junction dispatch is OK). */
if (bind_check_result != BIND_RESULT_FAIL) {
new_possibles[new_possibles_count] = possibles[i];
new_possibles_count++;
}
/* Since we had to do a bindability check, this is not
* a result we can cache on nominal type. */
pure_type_result = 0;
}
/* Otherwise, it's just nominal; accept it. */
else {
if (!new_possibles)
new_possibles = mem_allocate_n_typed(num_candidates, Rakudo_md_candidate_info *);
new_possibles[new_possibles_count] = possibles[i];
new_possibles_count++;
}
}
/* If we have an updated list of possibles, free old one and use this
* new one from here on in. */
if (new_possibles) {
mem_sys_free(possibles);
possibles = new_possibles;
possibles_count = new_possibles_count;
}
}
/* Now we have eliminated any that fail the bindability check.
* See if we need to push it onto the many list and continue.
* Otherwise, we have the result we were looking for. */
if (many) {
for (i = 0; i < possibles_count; i++)
VTABLE_push_pmc(interp, many_res, possibles[i]->sub);
possibles_count = 0;
}
else if (possibles_count) {
break;
}
/* Keep looping and looking, unless we really hit the end. */
if (cur_candidate[1]) {
cur_candidate++;
continue;
}
else {
break;
}
}
/*
=item C<static void print_constant_table(PARROT_INTERP, PMC *output)>
Prints the contents of the constants table.
=cut
*/
static void
print_constant_table(PARROT_INTERP, ARGIN(PMC *output))
{
ASSERT_ARGS(print_constant_table)
const PackFile_ConstTable *ct = interp->code->const_table;
INTVAL i;
/* TODO: would be nice to print the name of the file as well */
Parrot_io_fprintf(interp, output, "=head1 Constant-table\n\n");
for (i = 0; i < ct->num.const_count; i++)
Parrot_io_fprintf(interp, output, "NUM_CONST(%d): %f\n", i, ct->num.constants[i]);
for (i = 0; i < ct->str.const_count; i++)
Parrot_io_fprintf(interp, output, "STR_CONST(%d): %S\n", i, ct->str.constants[i]);
for (i = 0; i < ct->pmc.const_count; i++) {
PMC * const c = ct->pmc.constants[i];
Parrot_io_fprintf(interp, output, "PMC_CONST(%d): ", i);
switch (c->vtable->base_type) {
/* each PBC file has a ParrotInterpreter, but it can't
* stringify by itself */
case enum_class_ParrotInterpreter:
Parrot_io_fprintf(interp, output, "'ParrotInterpreter'");
break;
/* FixedIntegerArrays used for signatures, handy to print */
case enum_class_FixedIntegerArray:
{
const INTVAL n = VTABLE_elements(interp, c);
INTVAL j;
Parrot_io_fprintf(interp, output, "[");
for (j = 0; j < n; ++j) {
const INTVAL val = VTABLE_get_integer_keyed_int(interp, c, j);
Parrot_io_fprintf(interp, output, "%d", val);
if (j < n - 1)
Parrot_io_fprintf(interp, output, ",");
}
Parrot_io_fprintf(interp, output, "]");
break;
}
case enum_class_NameSpace:
case enum_class_String:
case enum_class_Key:
case enum_class_ResizableStringArray:
{
STRING * const s = VTABLE_get_string(interp, c);
if (s)
Parrot_io_fprintf(interp, output, "%Ss", s);
break;
}
case enum_class_Sub:
Parrot_io_fprintf(interp, output, "%S", VTABLE_get_string(interp, c));
break;
default:
Parrot_io_fprintf(interp, output, "(PMC constant)");
break;
}
Parrot_io_fprintf(interp, output, "\n");
}
Parrot_io_fprintf(interp, output, "\n=cut\n\n");
}
/* Binds a single argument into the lexpad, after doing any checks that are
* needed. Also handles any type captures. If there is a sub signature, then
* re-enters the binder. Returns one of the BIND_RESULT_* codes. */
static INTVAL
Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, Rakudo_Signature *signature, Rakudo_Parameter *param,
Rakudo_BindVal orig_bv, INTVAL no_nom_type_check, STRING **error) {
PMC *decont_value = NULL;
INTVAL desired_native;
Rakudo_BindVal bv;
/* Check if boxed/unboxed expections are met. */
desired_native = param->flags & SIG_ELEM_NATIVE_VALUE;
if (desired_native == 0 && orig_bv.type == BIND_VAL_OBJ ||
desired_native == SIG_ELEM_NATIVE_INT_VALUE && orig_bv.type == BIND_VAL_INT ||
desired_native == SIG_ELEM_NATIVE_NUM_VALUE && orig_bv.type == BIND_VAL_NUM ||
desired_native == SIG_ELEM_NATIVE_STR_VALUE && orig_bv.type == BIND_VAL_STR)
{
/* We have what we want. */
bv = orig_bv;
}
else if (desired_native == 0) {
/* We need to do a boxing operation. */
bv.type = BIND_VAL_OBJ;
bv.val.o = create_box(interp, orig_bv);
}
else {
storage_spec spec;
decont_value = Rakudo_cont_decontainerize(interp, orig_bv.val.o);
spec = REPR(decont_value)->get_storage_spec(interp, STABLE(decont_value));
switch (desired_native) {
case SIG_ELEM_NATIVE_INT_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_INT) {
bv.type = BIND_VAL_INT;
bv.val.i = REPR(decont_value)->box_funcs->get_int(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native int",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
case SIG_ELEM_NATIVE_NUM_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_NUM) {
bv.type = BIND_VAL_NUM;
bv.val.n = REPR(decont_value)->box_funcs->get_num(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native num",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
case SIG_ELEM_NATIVE_STR_VALUE:
if (spec.can_box & STORAGE_SPEC_CAN_BOX_STR) {
bv.type = BIND_VAL_STR;
bv.val.s = REPR(decont_value)->box_funcs->get_str(interp, STABLE(decont_value), OBJECT_BODY(decont_value));
}
else {
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native str",
param->variable_name);
return BIND_RESULT_FAIL;
}
break;
default:
if (error)
*error = Parrot_sprintf_c(interp, "Cannot unbox argument to '%S' as a native type",
param->variable_name);
return BIND_RESULT_FAIL;
}
decont_value = NULL;
}
/* By this point, we'll either have an object that we might be able to
* bind if it passes the type check, or a native value that needs no
* further checking. */
if (bv.type == BIND_VAL_OBJ) {
/* Ensure the value is a 6model object; if not, marshall it to one. */
if (bv.val.o->vtable->base_type != smo_id) {
bv.val.o = Rakudo_types_parrot_map(interp, bv.val.o);
if (bv.val.o->vtable->base_type != smo_id) {
*error = Parrot_sprintf_c(interp, "Unmarshallable foreign language value passed for parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
}
/* We pretty much always need to de-containerized value, so get it
* right off. */
decont_value = Rakudo_cont_decontainerize(interp, bv.val.o);
/* Skip nominal type check if not needed. */
if (!no_nom_type_check) {
PMC *nom_type;
/* Is the nominal type generic and in need of instantiation? (This
* can happen in (::T, T) where we didn't learn about the type until
* during the signature bind). */
if (param->flags & SIG_ELEM_NOMINAL_GENERIC) {
PMC *HOW = STABLE(param->nominal_type)->HOW;
PMC *ig = VTABLE_find_method(interp, HOW, INSTANTIATE_GENERIC_str);
Parrot_ext_call(interp, ig, "PiPP->P", HOW, param->nominal_type,
lexpad, &nom_type);
}
else {
nom_type = param->nominal_type;
}
/* If not, do the check. If the wanted nominal type is Mu, then
* anything goes. */
if (nom_type != Rakudo_types_mu_get() &&
(decont_value->vtable->base_type != smo_id ||
!STABLE(decont_value)->type_check(interp, decont_value, nom_type))) {
/* Type check failed; produce error if needed. */
if (error) {
PMC * got_how = STABLE(decont_value)->HOW;
PMC * exp_how = STABLE(nom_type)->HOW;
PMC * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
PMC * exp_name_meth = VTABLE_find_method(interp, exp_how, NAME_str);
STRING * expected, * got;
Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, bv.val.o, &got);
Parrot_ext_call(interp, exp_name_meth, "PiP->S", exp_how, nom_type, &expected);
*error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead",
param->variable_name, expected, got);
}
/* Report junction failure mode if it's a junction. */
return junc_or_fail(interp, decont_value);
}
/* Also enforce definedness constraints. */
if (param->flags & SIG_ELEM_DEFINEDNES_CHECK) {
INTVAL defined = IS_CONCRETE(decont_value);
if (defined && param->flags & SIG_ELEM_UNDEFINED_ONLY) {
if (error)
*error = Parrot_sprintf_c(interp,
"Parameter '%S' requires a type object, but an object instance was passed",
param->variable_name);
return junc_or_fail(interp, decont_value);
}
if (!defined && param->flags & SIG_ELEM_DEFINED_ONLY) {
if (error)
*error = Parrot_sprintf_c(interp,
"Parameter '%S' requires an instance, but a type object was passed",
param->variable_name);
return junc_or_fail(interp, decont_value);
}
}
}
}
/* Do we have any type captures to bind? */
if (!PMC_IS_NULL(param->type_captures)) {
Rakudo_binding_bind_type_captures(interp, lexpad, param, bv);
}
/* Do a coercion, if one is needed. */
if (!PMC_IS_NULL(param->coerce_type)) {
/* Coercing natives not possible - nothing to call a method on. */
if (bv.type != BIND_VAL_OBJ) {
*error = Parrot_sprintf_c(interp,
"Unable to coerce natively typed parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
/* Only coerce if we don't already have the correct type. */
if (!STABLE(decont_value)->type_check(interp, decont_value, param->coerce_type)) {
PMC *coerce_meth = VTABLE_find_method(interp, decont_value, param->coerce_method);
if (!PMC_IS_NULL(coerce_meth)) {
Parrot_ext_call(interp, coerce_meth, "Pi->P", decont_value, &decont_value);
}
else {
/* No coercion method availale; whine and fail to bind. */
if (error) {
PMC * got_how = STABLE(decont_value)->HOW;
PMC * got_name_meth = VTABLE_find_method(interp, got_how, NAME_str);
STRING * got;
Parrot_ext_call(interp, got_name_meth, "PiP->S", got_how, decont_value, &got);
*error = Parrot_sprintf_c(interp,
"Unable to coerce value for '%S' from %S to %S; no coercion method defined",
param->variable_name, got, param->coerce_method);
}
return BIND_RESULT_FAIL;
}
}
}
/* If it's not got attributive binding, we'll go about binding it into the
* lex pad. */
if (!(param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) && !STRING_IS_NULL(param->variable_name)) {
/* Is it native? If so, just go ahead and bind it. */
if (bv.type != BIND_VAL_OBJ) {
switch (bv.type) {
case BIND_VAL_INT:
VTABLE_set_integer_keyed_str(interp, lexpad, param->variable_name, bv.val.i);
break;
case BIND_VAL_NUM:
VTABLE_set_number_keyed_str(interp, lexpad, param->variable_name, bv.val.n);
break;
case BIND_VAL_STR:
VTABLE_set_string_keyed_str(interp, lexpad, param->variable_name, bv.val.s);
break;
}
}
/* Otherwise it's some objecty case. */
else if (param->flags & SIG_ELEM_IS_RW) {
/* XXX TODO Check if rw flag is set; also need to have a
* wrapper container that carries extra constraints. */
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
}
else if (param->flags & SIG_ELEM_IS_PARCEL) {
/* Just bind the thing as is into the lexpad. */
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bv.val.o);
}
else {
/* If it's an array, copy means make a new one and store,
* and a normal bind is a straightforward binding plus
* adding a constraint. */
if (param->flags & SIG_ELEM_ARRAY_SIGIL) {
PMC *bindee = decont_value;
if (param->flags & SIG_ELEM_IS_COPY) {
bindee = Rakudo_binding_create_positional(interp,
Parrot_pmc_new(interp, enum_class_ResizablePMCArray));
Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
}
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
}
/* If it's a hash, similar approach to array. */
else if (param->flags & SIG_ELEM_HASH_SIGIL) {
PMC *bindee = decont_value;
if (param->flags & SIG_ELEM_IS_COPY) {
bindee = Rakudo_binding_create_hash(interp,
Parrot_pmc_new(interp, enum_class_Hash));
Rakudo_cont_store(interp, bindee, decont_value, 0, 0);
}
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, bindee);
}
/* If it's a scalar, we always need to wrap it into a new
* container and store it, for copy or ro case (the rw bit
* in the container descriptor takes care of the rest). */
else {
PMC *new_cont = Rakudo_cont_scalar_from_descriptor(interp, param->container_descriptor);
Rakudo_cont_store(interp, new_cont, decont_value, 0, 0);
VTABLE_set_pmc_keyed_str(interp, lexpad, param->variable_name, new_cont);
}
}
}
/* Is it the invocant? If so, also have to bind to self lexical. */
if (param->flags & SIG_ELEM_INVOCANT)
VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, decont_value);
/* Handle any constraint types (note that they may refer to the parameter by
* name, so we need to have bound it already). */
if (!PMC_IS_NULL(param->post_constraints)) {
PMC * code_type = Rakudo_types_code_get();
PMC * const constraints = param->post_constraints;
INTVAL num_constraints = VTABLE_elements(interp, constraints);
INTVAL i;
for (i = 0; i < num_constraints; i++) {
/* Check we meet the constraint. */
PMC *cons_type = VTABLE_get_pmc_keyed_int(interp, constraints, i);
PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS);
PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
if (STABLE(cons_type)->type_check(interp, cons_type, code_type))
Parrot_sub_capture_lex(interp,
VTABLE_get_attr_keyed(interp, cons_type, code_type, DO_str));
VTABLE_push_pmc(interp, cappy, cons_type);
switch (bv.type) {
case BIND_VAL_OBJ:
VTABLE_push_pmc(interp, cappy, bv.val.o);
break;
case BIND_VAL_INT:
VTABLE_push_integer(interp, cappy, bv.val.i);
break;
case BIND_VAL_NUM:
VTABLE_push_float(interp, cappy, bv.val.n);
break;
case BIND_VAL_STR:
VTABLE_push_string(interp, cappy, bv.val.s);
break;
}
Parrot_pcc_invoke_from_sig_object(interp, accepts_meth, cappy);
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
if (!VTABLE_get_bool(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0))) {
if (error)
*error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'",
param->variable_name);
return BIND_RESULT_FAIL;
}
}
}
/* If it's attributive, now we assign it. */
if (param->flags & SIG_ELEM_BIND_ATTRIBUTIVE) {
INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, param, bv, decont_value, error);
if (result != BIND_RESULT_OK)
return result;
}
/* If it has a sub-signature, bind that. */
if (!PMC_IS_NULL(param->sub_llsig) && bv.type == BIND_VAL_OBJ) {
/* Turn value into a capture, unless we already have one. */
PMC *capture = PMCNULL;
INTVAL result;
if (param->flags & SIG_ELEM_IS_CAPTURE) {
capture = decont_value;
}
else {
PMC *meth = VTABLE_find_method(interp, decont_value, Parrot_str_new(interp, "Capture", 0));
if (PMC_IS_NULL(meth)) {
if (error)
*error = Parrot_sprintf_c(interp, "Could not turn argument into capture");
return BIND_RESULT_FAIL;
}
Parrot_ext_call(interp, meth, "Pi->P", decont_value, &capture);
}
/* Recurse into signature binder. */
result = Rakudo_binding_bind(interp, lexpad, param->sub_llsig,
capture, no_nom_type_check, error);
if (result != BIND_RESULT_OK)
{
if (error) {
/* Note in the error message that we're in a sub-signature. */
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " in sub-signature", 0));
/* Have we a variable name? */
if (!STRING_IS_NULL(param->variable_name)) {
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " of parameter ", 0));
*error = Parrot_str_concat(interp, *error, param->variable_name);
}
}
return result;
}
}
/* Binding of this parameter was thus successful - we're done. */
return BIND_RESULT_OK;
}
/* Performs a multiple dispatch using the candidates held in the passed
* DispatcherSub and using the arguments in the passed capture. */
PMC *nqp_multi_dispatch(PARROT_INTERP, PMC *dispatcher, PMC *capture) {
/* Get list and number of dispatchees. */
PMC *dispatchees = PARROT_DISPATCHERSUB(dispatcher)->dispatchees;
const INTVAL num_candidates = VTABLE_elements(interp, dispatchees);
/* Count arguments. */
const INTVAL num_args = VTABLE_elements(interp, capture);
/* Initialize dispatcher state. */
INTVAL type_mismatch;
INTVAL possibles_count = 0;
candidate_info **possibles = mem_allocate_n_typed(num_candidates, candidate_info *);
INTVAL type_check_count;
/* Get sorted candidate list.
* XXX We'll cache this in the future. */
candidate_info** candidates = sort_candidates(interp, dispatchees);
candidate_info** cur_candidate = candidates;
/* Ensure we know what is a 6model object and what is not. */
if (!smo_id)
smo_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "SixModelObject", 0));
/* Iterate over the candidates and collect best ones; terminate
* when we see two nulls (may break out earlier). */
while (1) {
INTVAL i;
if (*cur_candidate == NULL) {
/* If we have some possible candidate(s), we're done in this loop. */
if (possibles_count)
break;
/* Otherwise, we keep looping and looking, unless we really hit the end. */
if (cur_candidate[1]) {
cur_candidate++;
continue;
}
else {
break;
}
}
/* Check if it's admissable by arity. */
if (num_args < (*cur_candidate)->min_arity || num_args > (*cur_candidate)->max_arity) {
cur_candidate++;
continue;
}
/* Check if it's admissable by type. */
type_check_count = (*cur_candidate)->num_types > num_args
? num_args
: (*cur_candidate)->num_types;
type_mismatch = 0;
for (i = 0; i < type_check_count; i++) {
PMC * const param = VTABLE_get_pmc_keyed_int(interp, capture, i);
PMC * const param_type = param->vtable->base_type == smo_id ?
STABLE(param)->WHAT : PMCNULL;
PMC * const type_obj = (*cur_candidate)->types[i];
INTVAL const definedness = (*cur_candidate)->definednesses[i];
if (param_type != type_obj && !is_narrower_type(interp, param_type, type_obj)) {
type_mismatch = 1;
break;
}
if (definedness) {
/* Have a constraint on the definedness. */
INTVAL defined = param->vtable->base_type == smo_id ?
IS_CONCRETE(param) :
VTABLE_defined(interp, param);
if ((!defined && definedness == DEFINED_ONLY) || (defined && definedness == UNDEFINED_ONLY)) {
type_mismatch = 1;
break;
}
}
}
if (type_mismatch) {
cur_candidate++;
continue;
}
/* If we get here, it's an admissable candidate; add to list. */
possibles[possibles_count] = *cur_candidate;
possibles_count++;
cur_candidate++;
}
/* Cache the result if there's a single chosen one. */
if (possibles_count == 1) {
/* XXX TODO: Cache entry. */
}
/* Need a unique candidate. */
if (possibles_count == 1) {
PMC *result = possibles[0]->sub;
mem_sys_free(possibles);
return result;
}
else if (possibles_count == 0) {
/* Get signatures of all possible candidates. We dump them in the
* order in which we search for them. */
STRING *signatures = Parrot_str_new(interp, "", 0);
cur_candidate = candidates;
while (1) {
if (!cur_candidate[0] && !cur_candidate[1])
break;
/* XXX TODO: add sig dumping.
if (cur_candidate[0])
signatures = dump_signature(interp, signatures, (*cur_candidate)->sub); */
cur_candidate++;
}
mem_sys_free(possibles);
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"No applicable candidates found to dispatch to for '%Ss'. Available candidates are:\n%Ss",
VTABLE_get_string(interp, candidates[0]->sub),
signatures);
}
else {
/* Get signatures of ambiguous candidates. */
STRING *signatures = Parrot_str_new(interp, "", 0);
INTVAL i;
/* XXX TODO: sig dumping
for (i = 0; i < possibles_count; i++)
signatures = dump_signature(interp, signatures, possibles[i]->sub); */
mem_sys_free(possibles);
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"Ambiguous dispatch to multi '%Ss'. Ambiguous candidates had signatures:\n%Ss",
VTABLE_get_string(interp, candidates[0]->sub), signatures);
}
}
/* Binds a single argument into the lexpad, after doing any checks that are
* needed. Also handles any type captures. If there is a sub signature, then
* re-enters the binder. Returns one of the BIND_RESULT_* codes. */
static INTVAL
Rakudo_binding_bind_one_param(PARROT_INTERP, PMC *lexpad, PMC *llsig, llsig_element *sig_info,
PMC *value, INTVAL no_nom_type_check, STRING **error) {
/* If we need to do a type check, do one. */
if (!no_nom_type_check) {
/* See if we get a hit in the type cache. */
INTVAL cache_matched = 0;
INTVAL value_type = VTABLE_type(interp, value);
if (value_type != 0) {
INTVAL i;
for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) {
if (sig_info->nom_type_cache[i] == value_type)
{
cache_matched = 1;
break;
}
}
}
/* If not, do the check. */
if (!cache_matched) {
PMC * const type_obj = sig_info->nominal_type;
PMC * accepts_meth = VTABLE_find_method(interp, type_obj, ACCEPTS);
PMC * result = PMCNULL;
Parrot_ext_call(interp, accepts_meth, "PiP->P", type_obj, value, &result);
if (VTABLE_get_bool(interp, result)) {
/* Cache if possible. */
if (value_type != 0 && value_type != p6r_id && value_type != p6o_id) {
INTVAL i;
for (i = 0; i < NOM_TYPE_CACHE_SIZE; i++) {
if (sig_info->nom_type_cache[i] == 0)
{
sig_info->nom_type_cache[i] = value_type;
PARROT_GC_WRITE_BARRIER(interp, llsig);
break;
}
}
}
}
else {
/* Type check failed. However, for language inter-op, we do some
* extra checks if the type is just Positional, Associative, or
* Callable and the thingy we have matches those enough. */
/* XXX TODO: Implement language interop checks. */
if (error) {
STRING * const perl = PERL_str;
PMC * perl_meth = VTABLE_find_method(interp, type_obj, perl);
PMC * how_meth = VTABLE_find_method(interp, value, HOW);
STRING * expected, * got;
PMC * value_how, * value_type;
Parrot_ext_call(interp, perl_meth, "Pi->S", type_obj, &expected);
Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how);
value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str);
got = VTABLE_get_string(interp, value_type);
*error = Parrot_sprintf_c(interp, "Nominal type check failed for parameter '%S'; expected %S but got %S instead",
sig_info->variable_name, expected, got);
}
if (VTABLE_isa(interp, value, JUNCTION_str))
return BIND_RESULT_JUNCTION;
else
return BIND_RESULT_FAIL;
}
}
}
/* Do we have any type captures to bind? */
if (!PMC_IS_NULL(sig_info->type_captures))
Rakudo_binding_bind_type_captures(interp, lexpad, sig_info, value);
/* Do a coercion, if one is needed. */
if (!STRING_IS_NULL(sig_info->coerce_to)) {
PMC *coerce_meth = VTABLE_find_method(interp, value, sig_info->coerce_to);
if (!PMC_IS_NULL(coerce_meth)) {
Parrot_ext_call(interp, coerce_meth, "Pi->P", value, &value);
}
else {
/* No coercion method availale; whine and fail to bind. */
if (error) {
PMC * how_meth = VTABLE_find_method(interp, value, HOW);
PMC * value_how, * value_type;
STRING * got;
Parrot_ext_call(interp, how_meth, "Pi->P", value, &value_how);
value_type = VTABLE_get_attr_str(interp, value_how, SHORTNAME_str);
got = VTABLE_get_string(interp, value_type);
*error = Parrot_sprintf_c(interp,
"Unable to coerce value for '%S' from %S to %S; no coercion method defined",
sig_info->variable_name, got, sig_info->coerce_to);
}
return BIND_RESULT_FAIL;
}
}
/* If it's not got attributive binding, we'll go about binding it into the
* lex pad. */
if (!(sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE)) {
/* Is it "is rw"? */
if (sig_info->flags & SIG_ELEM_IS_RW) {
/* XXX TODO Check if rw flag is set. */
if (!STRING_IS_NULL(sig_info->variable_name))
VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value);
}
else if (sig_info->flags & SIG_ELEM_IS_PARCEL) {
/* Just bind the thing as is into the lexpad. */
if (!STRING_IS_NULL(sig_info->variable_name))
VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, value);
}
else if (sig_info->flags & SIG_ELEM_IS_COPY) {
/* Place the value into a new container instead of binding to an existing one */
value = descalarref(interp, value);
if (!STRING_IS_NULL(sig_info->variable_name)) {
PMC *copy, *ref, *store_meth;
if (sig_info->flags & SIG_ELEM_ARRAY_SIGIL) {
copy = Rakudo_binding_create_positional(interp, PMCNULL, ARRAY_str);
store_meth = VTABLE_find_method(interp, copy, STORE_str);
Parrot_ext_call(interp, store_meth, "PiP", copy, value);
}
else if (sig_info->flags & SIG_ELEM_HASH_SIGIL) {
copy = Rakudo_binding_create_hash(interp, pmc_new(interp, enum_class_Hash));
store_meth = VTABLE_find_method(interp, copy, STORE_str);
Parrot_ext_call(interp, store_meth, "PiP", copy, value);
}
else {
copy = pmc_new_init(interp, p6s_id, value);
VTABLE_setprop(interp, copy, SCALAR_str, copy);
}
VTABLE_setprop(interp, copy, RW_str, copy);
VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, copy);
}
}
else {
/* Read only. Wrap it into a ObjectRef, mark readonly and bind it. */
if (!STRING_IS_NULL(sig_info->variable_name)) {
PMC *ref = pmc_new_init(interp, or_id, value);
if (!(sig_info->flags & (SIG_ELEM_ARRAY_SIGIL | SIG_ELEM_HASH_SIGIL)))
VTABLE_setprop(interp, ref, SCALAR_str, ref);
VTABLE_set_pmc_keyed_str(interp, lexpad, sig_info->variable_name, ref);
}
}
}
/* Is it the invocant? If so, also have to bind to self lexical. */
if (sig_info->flags & SIG_ELEM_INVOCANT)
VTABLE_set_pmc_keyed_str(interp, lexpad, SELF_str, value);
/* Handle any constraint types (note that they may refer to the parameter by
* name, so we need to have bound it already). */
if (!PMC_IS_NULL(sig_info->post_constraints)) {
PMC * const constraints = sig_info->post_constraints;
INTVAL num_constraints = VTABLE_elements(interp, constraints);
PMC * result = PMCNULL;
INTVAL i;
for (i = 0; i < num_constraints; i++) {
PMC *cons_type = VTABLE_get_pmc_keyed_int(interp, constraints, i);
PMC *accepts_meth = VTABLE_find_method(interp, cons_type, ACCEPTS);
if (VTABLE_isa(interp, cons_type, BLOCK_str))
Parrot_sub_capture_lex(interp,
VTABLE_get_attr_str(interp, cons_type, DO_str));
Parrot_ext_call(interp, accepts_meth, "PiP->P", cons_type, value, &result);
if (!VTABLE_get_bool(interp, result)) {
if (error)
*error = Parrot_sprintf_c(interp, "Constraint type check failed for parameter '%S'",
sig_info->variable_name);
return BIND_RESULT_FAIL;
}
}
}
/* If it's attributive, now we assign it. */
if (sig_info->flags & SIG_ELEM_BIND_ATTRIBUTIVE) {
INTVAL result = Rakudo_binding_assign_attributive(interp, lexpad, sig_info, value, error);
if (result != BIND_RESULT_OK)
return result;
}
/* If it has a sub-signature, bind that. */
if (!PMC_IS_NULL(sig_info->sub_llsig)) {
/* Turn value into a capture, unless we already have one. */
PMC *capture = PMCNULL;
INTVAL result;
if (sig_info->flags & SIG_ELEM_IS_CAPTURE) {
capture = value;
}
else {
PMC *meth = VTABLE_find_method(interp, value, Parrot_str_new(interp, "Capture", 0));
if (PMC_IS_NULL(meth)) {
if (error)
*error = Parrot_sprintf_c(interp, "Could not turn argument into capture");
return BIND_RESULT_FAIL;
}
Parrot_ext_call(interp, meth, "Pi->P", value, &capture);
}
/* Recurse into signature binder. */
result = Rakudo_binding_bind_llsig(interp, lexpad, sig_info->sub_llsig,
capture, no_nom_type_check, error);
if (result != BIND_RESULT_OK)
{
if (error) {
/* Note in the error message that we're in a sub-signature. */
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " in sub-signature", 0));
/* Have we a variable name? */
if (!STRING_IS_NULL(sig_info->variable_name)) {
*error = Parrot_str_concat(interp, *error,
Parrot_str_new(interp, " of parameter ", 0));
*error = Parrot_str_concat(interp, *error, sig_info->variable_name);
}
}
return result;
}
}
/* Binding of this parameter was thus successful - we're done. */
return BIND_RESULT_OK;
}
/* This works out an allocation strategy for the object. It takes care of
* "inlining" storage of attributes that are natively typed, as well as
* noting unbox targets. */
static void compute_allocation_strategy(PARROT_INTERP, PMC *WHAT, P6opaqueREPRData *repr_data) {
STRING *type_str = Parrot_str_new_constant(interp, "type");
STRING *box_target_str = Parrot_str_new_constant(interp, "box_target");
STRING *avcont_str = Parrot_str_new_constant(interp, "auto_viv_container");
PMC *flat_list;
/*
* We have to block GC mark here. Because "repr" is assotiated with some
* PMC which is not accessible in this function. And we have to write
* barrier this PMC because we are poking inside it guts directly. We
* do have WB in caller function, but it can be triggered too late is
* any of allocation will cause GC run.
*
* This is kind of minor evil until after I'll find better solution.
*/
Parrot_block_GC_mark(interp);
/* Compute index mapping table and get flat list of attributes. */
flat_list = index_mapping_and_flat_list(interp, WHAT, repr_data);
/* If we have no attributes in the index mapping, then just the header. */
if (repr_data->name_to_index_mapping[0].class_key == NULL) {
repr_data->allocation_size = sizeof(P6opaqueInstance);
}
/* Otherwise, we need to compute the allocation strategy. */
else {
/* We track the size of the body part, since that's what we want offsets into. */
INTVAL cur_size = 0;
/* Get number of attributes and set up various counters. */
INTVAL num_attrs = VTABLE_elements(interp, flat_list);
INTVAL info_alloc = num_attrs == 0 ? 1 : num_attrs;
INTVAL cur_pmc_attr = 0;
INTVAL cur_init_slot = 0;
INTVAL cur_mark_slot = 0;
INTVAL cur_cleanup_slot = 0;
INTVAL cur_unbox_slot = 0;
INTVAL i;
/* Allocate offset array and GC mark info arrays. */
repr_data->num_attributes = num_attrs;
repr_data->attribute_offsets = (INTVAL *) mem_sys_allocate(info_alloc * sizeof(INTVAL));
repr_data->flattened_stables = (STable **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *));
repr_data->unbox_int_slot = -1;
repr_data->unbox_num_slot = -1;
repr_data->unbox_str_slot = -1;
/* Go over the attributes and arrange their allocation. */
for (i = 0; i < num_attrs; i++) {
PMC *attr = VTABLE_get_pmc_keyed_int(interp, flat_list, i);
/* Fetch its type and box target flag, if available. */
PMC *type = accessor_call(interp, attr, type_str);
PMC *box_target = accessor_call(interp, attr, box_target_str);
PMC *av_cont = accessor_call(interp, attr, avcont_str);
/* Work out what unboxed type it is, if any. Default to a boxed. */
INTVAL unboxed_type = STORAGE_SPEC_BP_NONE;
INTVAL bits = sizeof(PMC *) * 8;
if (!PMC_IS_NULL(type)) {
/* Get the storage spec of the type and see what it wants. */
storage_spec spec = REPR(type)->get_storage_spec(interp, STABLE(type));
if (spec.inlineable == STORAGE_SPEC_INLINED) {
/* Yes, it's something we'll flatten. */
unboxed_type = spec.boxed_primitive;
bits = spec.bits;
repr_data->flattened_stables[i] = STABLE(type);
/* Does it need special initialization? */
if (REPR(type)->initialize) {
if (!repr_data->initialize_slots)
repr_data->initialize_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL));
repr_data->initialize_slots[cur_init_slot] = i;
cur_init_slot++;
}
/* Does it have special GC needs? */
if (REPR(type)->gc_mark) {
if (!repr_data->gc_mark_slots)
repr_data->gc_mark_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL));
repr_data->gc_mark_slots[cur_mark_slot] = i;
cur_mark_slot++;
}
if (REPR(type)->gc_cleanup) {
if (!repr_data->gc_cleanup_slots)
repr_data->gc_cleanup_slots = (INTVAL *) mem_sys_allocate_zeroed((info_alloc + 1) * sizeof(INTVAL));
repr_data->gc_cleanup_slots[cur_cleanup_slot] = i;
cur_cleanup_slot++;
}
/* Is it a target for box/unbox operations? */
if (!PMC_IS_NULL(box_target) && VTABLE_get_bool(interp, box_target)) {
/* If it boxes a primitive, note that. */
switch (unboxed_type) {
case STORAGE_SPEC_BP_INT:
if (repr_data->unbox_int_slot >= 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Duplicate box_target for native int");
repr_data->unbox_int_slot = i;
break;
case STORAGE_SPEC_BP_NUM:
if (repr_data->unbox_num_slot >= 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Duplicate box_target for native num");
repr_data->unbox_num_slot = i;
break;
case STORAGE_SPEC_BP_STR:
if (repr_data->unbox_str_slot >= 0)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Duplicate box_target for native str");
repr_data->unbox_str_slot = i;
break;
default:
/* nothing, just suppress 'missing default' warning */
break;
}
/* Also list in the by-repr unbox list. */
if (repr_data->unbox_slots == NULL)
repr_data->unbox_slots = (P6opaqueBoxedTypeMap *) mem_sys_allocate_zeroed(info_alloc * sizeof(P6opaqueBoxedTypeMap));
repr_data->unbox_slots[cur_unbox_slot].repr_id = REPR(type)->ID;
repr_data->unbox_slots[cur_unbox_slot].slot = i;
cur_unbox_slot++;
}
}
}
/* Handle PMC attributes, which need marking and may have auto-viv needs. */
if (unboxed_type == STORAGE_SPEC_BP_NONE) {
if (!repr_data->gc_pmc_mark_offsets)
repr_data->gc_pmc_mark_offsets = (INTVAL *) mem_sys_allocate_zeroed(info_alloc * sizeof(INTVAL));
repr_data->gc_pmc_mark_offsets[cur_pmc_attr] = cur_size;
cur_pmc_attr++;
if (!PMC_IS_NULL(av_cont)) {
if (!repr_data->auto_viv_values)
repr_data->auto_viv_values = (PMC **) mem_sys_allocate_zeroed(info_alloc * sizeof(PMC *));
repr_data->auto_viv_values[i] = av_cont;
}
}
/* Do allocation. */
/* XXX TODO Alignment! Important when we get int1, int8, etc. */
repr_data->attribute_offsets[i] = cur_size;
cur_size += bits / 8;
}
/* Finally, put computed allocation size in place; it's body size plus
* header size. Also number of markables and sentinels. */
repr_data->allocation_size = cur_size + sizeof(P6opaqueInstance);
repr_data->gc_pmc_mark_offsets_count = cur_pmc_attr;
if (repr_data->initialize_slots)
repr_data->initialize_slots[cur_init_slot] = -1;
if (repr_data->gc_mark_slots)
repr_data->gc_mark_slots[cur_mark_slot] = -1;
if (repr_data->gc_cleanup_slots)
repr_data->gc_cleanup_slots[cur_cleanup_slot] = -1;
}
Parrot_unblock_GC_mark(interp);
}
Takes an interpreter name and (optional) entry name.
Returns a pointer to the new entry.
Used by Parrot_hll_register_HLL.
=cut
*/
PARROT_CANNOT_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static PMC*
new_hll_entry(PARROT_INTERP, ARGIN(STRING *entry_name))
{
ASSERT_ARGS(new_hll_entry)
PMC * const hll_info = interp->HLL_info;
const INTVAL id = VTABLE_elements(interp, hll_info);
PMC *entry_id;
PMC * const entry = Parrot_pmc_new_constant_init_int(interp,
enum_class_FixedPMCArray, e_HLL_MAX);
if (entry_name && !STRING_IS_EMPTY(entry_name)) {
VTABLE_set_pmc_keyed_str(interp, hll_info, entry_name, entry);
}
else
VTABLE_push_pmc(interp, hll_info, entry);
entry_id = Parrot_pmc_new_constant_init_int(interp, enum_class_Integer, id);
VTABLE_set_pmc_keyed_int(interp, entry, e_HLL_id, entry_id);
PARROT_EXPORT
void
Parrot_lib_update_paths_from_config_hash(PARROT_INTERP)
{
ASSERT_ARGS(Parrot_lib_update_paths_from_config_hash)
STRING * versionlib = NULL;
STRING * entry = NULL;
STRING * builddir = NULL;
PMC * const lib_paths =
VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_LIB_PATHS);
PMC * const config_hash =
VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_CONFIG_HASH);
PMC * paths;
if (VTABLE_elements(interp, config_hash)) {
STRING * const libkey = CONST_STRING(interp, "libdir");
STRING * const verkey = CONST_STRING(interp, "versiondir");
STRING * const builddirkey = CONST_STRING(interp, "build_dir");
STRING * const installed = CONST_STRING(interp, "installed");
versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
entry = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
versionlib = Parrot_str_concat(interp, versionlib, entry);
if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed))
builddir = VTABLE_get_string_keyed_str(interp,
config_hash, builddirkey);
}
paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"));
VTABLE_push_string(interp, paths, entry);
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"));
VTABLE_push_string(interp, paths, entry);
}
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"));
VTABLE_push_string(interp, paths, entry);
}
paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"));
VTABLE_push_string(interp, paths, entry);
}
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/"));
VTABLE_push_string(interp, paths, entry);
}
paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"));
VTABLE_push_string(interp, paths, entry);
}
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/"));
VTABLE_push_string(interp, paths, entry);
}
paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT);
if (!STRING_IS_NULL(builddir)) {
entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"));
VTABLE_push_string(interp, paths, entry);
}
if (!STRING_IS_NULL(versionlib)) {
entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/"));
VTABLE_push_string(interp, paths, entry);
}
}
