/* 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; }
PARROT_EXPORT PARROT_CANNOT_RETURN_NULL PARROT_WARN_UNUSED_RESULT PMC* Parrot_make_cb(PARROT_INTERP, ARGMOD(PMC* sub), ARGIN(PMC* user_data), ARGIN(STRING *cb_signature)) { ASSERT_ARGS(Parrot_make_cb) PMC *cb, *cb_sig; int type = 0; STRING *sc; char * const signature = Parrot_str_to_cstring(interp, cb_signature); /* * we stuff all the information into the user_data PMC and pass that * on to the external sub */ PMC * const interp_pmc = VTABLE_get_pmc_keyed_int(interp, interp->iglobals, (INTVAL) IGLOBALS_INTERPRETER); /* be sure __LINE__ is consistent */ sc = CONST_STRING(interp, "_interpreter"); VTABLE_setprop(interp, user_data, sc, interp_pmc); sc = CONST_STRING(interp, "_sub"); VTABLE_setprop(interp, user_data, sc, sub); /* only ASCII signatures are supported */ if (strlen(signature) == 3) { /* Callback return type ignored */ if (signature[1] == 'U') { type = 'D'; } else { if (signature[2] == 'U') { type = 'C'; } } } Parrot_str_free_cstring(signature); if (type != 'C' && type != 'D') Parrot_ex_throw_from_c_args(interp, NULL, 1, "unhandled signature '%Ss' in make_cb", cb_signature); cb_sig = Parrot_pmc_new(interp, enum_class_String); VTABLE_set_string_native(interp, cb_sig, cb_signature); sc = CONST_STRING(interp, "_signature"); VTABLE_setprop(interp, user_data, sc, cb_sig); /* * We are going to be passing the user_data PMC to external code, but * it may go out of scope until the callback is called -- we don't know * for certain as we don't know when the callback will be called. * Therefore, to prevent the PMC from being destroyed by a GC sweep, * we need to anchor it. * */ Parrot_pmc_gc_register(interp, user_data); /* * Finally, the external lib awaits a function pointer. * Create a PMC that points to Parrot_callback_C (or _D); * it can be passed on with signature 'p'. */ cb = Parrot_pmc_new(interp, enum_class_UnManagedStruct); /* * Currently, we handle only 2 types: * _C ... user_data is 2nd parameter * _D ... user_data is 1st parameter */ if (type == 'C') VTABLE_set_pointer(interp, cb, F2DPTR(Parrot_callback_C)); else VTABLE_set_pointer(interp, cb, F2DPTR(Parrot_callback_D)); Parrot_pmc_gc_register(interp, cb); return cb; }