/*
=item C<static STRING* dump_signature(PARROT_INTERP, STRING *so_far, PMC *sub)>
Utility for getting hold of the signature dump for a sub, which aids us in
producing awesomer errors.
=cut
*/
static STRING* dump_signature(PARROT_INTERP, STRING *so_far, PMC *sub) {
STRING * const sig_name = Parrot_str_new(interp, "signature", 0);
STRING * const perl_name = Parrot_str_new(interp, "perl", 0);
STRING * const newline = Parrot_str_new(interp, "\n", 0);
PMC * sig_meth, *sig_obj, *perl_meth, * sig_perl;
sig_meth = VTABLE_find_method(interp, sub, sig_name);
Parrot_ext_call(interp, sig_meth, "Pi->P", sub, &sig_obj);
perl_meth = VTABLE_find_method(interp, sig_obj, perl_name);
Parrot_ext_call(interp, perl_meth, "Pi->P", sig_obj, &sig_perl);
so_far = Parrot_str_concat(interp, so_far,
REPR(sig_perl)->box_funcs->get_str(interp, STABLE(sig_perl), OBJECT_BODY(sig_perl)));
so_far = Parrot_str_concat(interp, so_far, newline);
return so_far;
}
static STRING *get_str(PARROT_INTERP, STable *st, void *data) {
CStrBody *body = (CStrBody *) data;
PMC *old_ctx, *cappy, *meth, *enc_pmc;
STRING *enc;
STR_VTABLE *encoding;
if (!body->cstr)
return (STRING *) NULL;
/* Look up "encoding" method. */
meth = VTABLE_find_method(interp, st->WHAT,
Parrot_str_new_constant(interp, "encoding"));
if (PMC_IS_NULL(meth))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStr representation expects an 'encoding' method, specifying the encoding");
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, st->WHAT);
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
enc_pmc = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0));
enc = REPR(enc_pmc)->box_funcs->get_str(interp, STABLE(enc_pmc), OBJECT_BODY(enc_pmc));
return new_from_cstring(interp, body->cstr, enc);
}
/* Creates a Perl 6 Hash. */
static PMC *
Rakudo_binding_create_hash(PARROT_INTERP, PMC *storage) {
PMC *result = PMCNULL;
PMC *create = PMCNULL;
if (!HashPunned) {
/* We cache the punned Hash role class so we can very quickly call
* CREATE - critical as we have slurpy hashes for all methods. */
PMC *root_ns = Parrot_get_ctx_HLL_namespace(interp);
PMC *hash_role = VTABLE_get_pmc_keyed_str(interp, root_ns, HASH_str);
PMC *meth = VTABLE_find_method(interp, hash_role, SELECT_str);
Parrot_ext_call(interp, meth, "P->P", hash_role, &hash_role);
meth = VTABLE_find_method(interp, hash_role, PUN_str);
Parrot_ext_call(interp, meth, "P->P", hash_role, &HashPunned);
}
create = VTABLE_find_method(interp, HashPunned, CREATE_str);
Parrot_ext_call(interp, create, "P->P", HashPunned, &result);
VTABLE_set_attr_str(interp, result, STORAGE_str, storage);
return result;
}
/* Assigns an attributive parameter to the desired attribute. */
static INTVAL
Rakudo_binding_assign_attributive(PARROT_INTERP, PMC *lexpad, Rakudo_Parameter *param,
Rakudo_BindVal value, PMC *decont_value, STRING **error) {
PMC *assignee = PMCNULL;
PMC *assigner;
/* Find self. */
PMC *self = VTABLE_get_pmc_keyed_str(interp, lexpad,
Parrot_str_new(interp, "self", 0));
if (PMC_IS_NULL(self)) {
if (error)
*error = Parrot_sprintf_c(interp,
"Unable to bind attributive parameter '%S' - could not find self",
param->variable_name);
return BIND_RESULT_FAIL;
}
/* Ensure it's not native; NYI. */
if (value.type != BIND_VAL_OBJ) {
*error = Parrot_sprintf_c(interp,
"Binding to natively typed attributive parameter '%S' not supported",
param->variable_name);
return BIND_RESULT_FAIL;
}
/* If it's private, just need to fetch the attribute. */
if (param->flags & SIG_ELEM_BIND_PRIVATE_ATTR) {
assignee = VTABLE_get_attr_keyed(interp, self, param->attr_package,
param->variable_name);
}
/* Otherwise if it's public, do a method call to get the assignee. */
else {
PMC *meth = VTABLE_find_method(interp, self, param->variable_name);
if (PMC_IS_NULL(meth)) {
if (error)
*error = Parrot_sprintf_c(interp,
"Unable to bind attributive parameter '$.%S' - could not find method '%S'",
param->variable_name,
param->variable_name);
return BIND_RESULT_FAIL;
}
Parrot_ext_call(interp, meth, "Pi->P", self, &assignee);
}
Rakudo_cont_store(interp, assignee, decont_value, 1, 1);
return BIND_RESULT_OK;
}
/* Binds any type captures a variable has. */
static void
Rakudo_binding_bind_type_captures(PARROT_INTERP, PMC *lexpad, llsig_element *sig_info, PMC *value) {
/* Obtain type object. */
PMC * meta_obj = PMCNULL;
PMC * type_obj = PMCNULL;
PMC * iter;
STRING * const HOW = Parrot_str_new(interp, "HOW", 0);
PMC * const how_meth = VTABLE_find_method(interp, value, HOW);
Parrot_ext_call(interp, how_meth, "Pi->P", value, &meta_obj);
type_obj = VTABLE_get_attr_str(interp, meta_obj, Parrot_str_new(interp, "protoobject", 0));
/* Iterate over symbols we need to bind this to, and bind 'em. */
iter = VTABLE_get_iter(interp, sig_info->type_captures);
while (VTABLE_get_bool(interp, iter)) {
STRING *name = VTABLE_shift_string(interp, iter);
VTABLE_set_pmc_keyed_str(interp, lexpad, name, type_obj);
}
}
/* Assigns an attributive parameter to the desired attribute. */
static INTVAL
Rakudo_binding_assign_attributive(PARROT_INTERP, PMC *lexpad, llsig_element *sig_info,
PMC *value, STRING **error) {
PMC *assignee = PMCNULL;
PMC *assigner;
/* Find self. */
PMC *self = VTABLE_get_pmc_keyed_str(interp, lexpad,
Parrot_str_new(interp, "self", 0));
if (PMC_IS_NULL(self)) {
if (error)
*error = Parrot_sprintf_c(interp,
"Unable to bind attributive parameter '%S' - could not find self",
sig_info->variable_name);
return BIND_RESULT_FAIL;
}
/* If it's private, just need to fetch the attribute. */
if (sig_info->flags & SIG_ELEM_BIND_PRIVATE_ATTR) {
assignee = VTABLE_get_attr_str(interp, self, sig_info->variable_name);
}
/* Otherwise if it's public, do a method call to get the assignee. */
else {
PMC *meth = VTABLE_find_method(interp, self, sig_info->variable_name);
if (PMC_IS_NULL(meth)) {
if (error)
*error = Parrot_sprintf_c(interp,
"Unable to bind attributive parameter '$.%S' - could not find method '%S'",
sig_info->variable_name,
sig_info->variable_name);
return BIND_RESULT_FAIL;
}
Parrot_ext_call(interp, meth, "Pi->P", self, &assignee);
}
/* Now look up infix:<=> and do the assignment. */
assigner = VTABLE_get_pmc_keyed_str(interp, Parrot_get_ctx_HLL_namespace(interp),
Parrot_str_new(interp, "!only_infix:=", 0));
Parrot_ext_call(interp, assigner, "PP", assignee, value);
return BIND_RESULT_OK;
}
PARROT_EXPORT
void
Parrot_pcc_invoke_method_from_c_args(PARROT_INTERP, ARGIN(PMC* pmc),
ARGMOD(STRING *method_name),
ARGIN(const char *signature), ...)
{
ASSERT_ARGS(Parrot_pcc_invoke_method_from_c_args)
PMC *call_obj;
PMC *sub_obj;
va_list args;
const char *arg_sig, *ret_sig;
PMC *arg_flags;
PMC * const old_call_obj =
Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_split_signature_string(signature, &arg_sig, &ret_sig);
va_start(args, signature);
call_obj = Parrot_pcc_build_call_from_varargs(interp, PMCNULL, arg_sig, &args);
/* inlined version of pcc_add_invocant */
arg_flags = PARROT_CALLCONTEXT(call_obj)->arg_flags;
VTABLE_unshift_integer(interp, arg_flags, PARROT_ARG_PMC | PARROT_ARG_INVOCANT);
Parrot_CallContext_unshift_pmc(interp, call_obj, pmc);
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), call_obj);
/* Find the subroutine object as a named method on pmc */
sub_obj = VTABLE_find_method(interp, pmc, method_name);
if (UNLIKELY(PMC_IS_NULL(sub_obj)))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_METHOD_NOT_FOUND,
"Method '%Ss' not found", method_name);
/* Invoke the subroutine object with the given CallContext object */
Parrot_pcc_invoke_from_sig_object(interp, sub_obj, call_obj);
call_obj = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_fill_params_from_varargs(interp, call_obj, ret_sig, &args,
PARROT_ERRORS_RESULT_COUNT_FLAG);
va_end(args);
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_call_obj);
}
/* Helper to make an accessor call. */
static PMC * accessor_call(PARROT_INTERP, PMC *obj, STRING *name) {
PMC *old_ctx, *cappy;
/* Look up method; if there is none hand back a null. */
PMC *meth = VTABLE_find_method(interp, obj, name);
if (PMC_IS_NULL(meth))
return meth;
/* Set up call capture. */
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, obj);
/* Call. */
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
/* Grab result. */
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
return VTABLE_get_pmc_keyed_int(interp, cappy, 0);
}
static void set_str(PARROT_INTERP, STable *st, void *data, STRING *value) {
CStrBody *body = (CStrBody *) data;
PMC *old_ctx, *cappy, *meth, *enc_pmc;
STRING *enc;
STR_VTABLE *encoding;
if(body->cstr)
mem_sys_free(body->cstr);
/* Look up "encoding" method. */
meth = VTABLE_find_method(interp, st->WHAT,
Parrot_str_new_constant(interp, "encoding"));
if (PMC_IS_NULL(meth))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"CStr representation expects an 'encoding' method, specifying the encoding");
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, st->WHAT);
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
enc_pmc = decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, cappy, 0));
enc = REPR(enc_pmc)->box_funcs->get_str(interp, STABLE(enc_pmc), OBJECT_BODY(enc_pmc));
if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "utf8")))
encoding = Parrot_utf8_encoding_ptr;
else if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "utf16")))
encoding = Parrot_utf16_encoding_ptr;
else if (STRING_equal(interp, enc, Parrot_str_new_constant(interp, "ascii")))
encoding = Parrot_ascii_encoding_ptr;
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Unknown encoding passed to CStr representation");
body->cstr = Parrot_str_to_encoded_cstring(interp, value, encoding);
}
/* Helper to make an introspection call, possibly with :local. */
static PMC * introspection_call(PARROT_INTERP, PMC *WHAT, PMC *HOW, STRING *name, INTVAL local) {
PMC *old_ctx, *cappy;
/* Look up method; if there is none hand back a null. */
PMC *meth = VTABLE_find_method(interp, HOW, name);
if (PMC_IS_NULL(meth))
return meth;
/* Set up call capture. */
old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, HOW);
VTABLE_push_pmc(interp, cappy, WHAT);
if (local)
VTABLE_set_integer_keyed_str(interp, cappy, Parrot_str_new_constant(interp, "local"), 1);
/* Call. */
Parrot_pcc_invoke_from_sig_object(interp, meth, cappy);
/* Grab result. */
cappy = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
Parrot_pcc_set_signature(interp, CURRENT_CONTEXT(interp), old_ctx);
return VTABLE_get_pmc_keyed_int(interp, cappy, 0);
}
/* 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));
}
}
/* 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;
}
/* 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;
}