/* This function gets shared with perl6.ops for the perl6_iter_from_rpa op. */
PMC *
Rakudo_binding_iter_from_rpa(PARROT_INTERP, PMC *rpa, PMC *list) {
PMC *type = Rakudo_types_listiter_get();
PMC *iter = REPR(type)->allocate(interp, STABLE(type));
VTABLE_set_attr_keyed(interp, iter, type, REST_str, rpa);
VTABLE_set_attr_keyed(interp, iter, type, LIST_str, list);
return iter;
}
/* This function gets shared with perl6.ops for the perl6_list_from_rpa op. */
PMC *
Rakudo_binding_list_from_rpa(PARROT_INTERP, PMC *rpa, PMC *type, PMC *flattens) {
PMC *list = REPR(type)->allocate(interp, STABLE(type));
PMC *List = Rakudo_types_list_get();
if (!PMC_IS_NULL(rpa))
VTABLE_set_attr_keyed(interp, list, List, NEXTITER_str,
Rakudo_binding_iter_from_rpa(interp, rpa, list));
VTABLE_set_attr_keyed(interp, list, List, FLATTENS_str, flattens);
return list;
}
/* Creates a Perl 6 Hash. */
static PMC *
Rakudo_binding_create_hash(PARROT_INTERP, PMC *storage) {
PMC *type = Rakudo_types_hash_get();
PMC *hash = REPR(type)->allocate(interp, STABLE(type));
VTABLE_set_attr_keyed(interp, hash, Rakudo_types_enummap_get(), STORAGE_str, storage);
return hash;
}
/* 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;
}
/* 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;
}
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;
}