/* Binds the given value to the specified attribute. */
static void bind_attribute_boxed(PARROT_INTERP, STable *st, void *data, PMC *class_handle, STRING *name, INTVAL hint, PMC *value) {
P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
INTVAL slot;
/* Try the slot allocation first. */
slot = hint >= 0 && !(repr_data->mi) ? hint :
try_get_slot(interp, repr_data, class_handle, name);
if (slot >= 0) {
STable *st = repr_data->flattened_stables[slot];
if (st) {
if (value->vtable->base_type == smo_id && st == STABLE(value))
st->REPR->copy_to(interp, st, OBJECT_BODY(value),
(char *)data + repr_data->attribute_offsets[slot]);
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Type mismatch when storing value to attribute '%Ss' on class '%Ss'",
name, VTABLE_get_string(interp, introspection_call(interp,
class_handle, STABLE(class_handle)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
else {
set_pmc_at_offset(data, repr_data->attribute_offsets[slot], value);
}
}
else {
/* Otherwise, complain that the attribute doesn't exist. */
no_such_attribute(interp, "bind", class_handle, name);
}
}
/* Helper for finding a slot number. */
static INTVAL try_get_slot(PARROT_INTERP, P6opaqueREPRData *repr_data, PMC *class_key, STRING *name) {
INTVAL slot = -1;
if (repr_data->name_to_index_mapping) {
P6opaqueNameMap *cur_map_entry = repr_data->name_to_index_mapping;
while (cur_map_entry->class_key != NULL) {
if (cur_map_entry->class_key == class_key) {
if (!PMC_IS_NULL(cur_map_entry->name_map)) {
PMC *slot_pmc = VTABLE_get_pmc_keyed_str(interp, cur_map_entry->name_map, name);
if (!PMC_IS_NULL(slot_pmc))
slot = VTABLE_get_integer(interp, slot_pmc);
break;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Null attribute map for P6opaque in class '%Ss'",
VTABLE_get_string(interp, introspection_call(interp,
class_key, STABLE(class_key)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
}
cur_map_entry++;
}
}
return slot;
}
/* Helper for complaining about attrbiute access errors. */
static void no_such_attribute(PARROT_INTERP, char *action, PMC *class_handle, STRING *name) {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can not %s non-existant attribute '%Ss' on class '%Ss'",
action, name, VTABLE_get_string(interp, introspection_call(interp,
class_handle, STABLE(class_handle)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
PARROT_EXPORT
PARROT_CAN_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
PMC *
Parrot_oo_get_class(PARROT_INTERP, ARGIN(PMC *key))
{
ASSERT_ARGS(Parrot_oo_get_class)
PMC *classobj = PMCNULL;
if (PMC_IS_NULL(key))
return PMCNULL;
if (PObj_is_class_TEST(key))
classobj = key;
else {
/* Fast select of behavior based on type of the lookup key */
switch (key->vtable->base_type) {
case enum_class_NameSpace:
classobj = VTABLE_get_class(interp, key);
break;
case enum_class_String:
case enum_class_Key:
case enum_class_ResizableStringArray:
{
PMC * const hll_ns = VTABLE_get_pmc_keyed_int(interp,
interp->HLL_namespace,
Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp)));
PMC * const ns = Parrot_ns_get_namespace_keyed(interp,
hll_ns, key);
if (!PMC_IS_NULL(ns))
classobj = VTABLE_get_class(interp, ns);
}
default:
break;
}
}
/* If the PMCProxy doesn't exist yet for the given key, we look up the
type ID here and create a new one */
if (PMC_IS_NULL(classobj)) {
INTVAL type;
const INTVAL base_type = key->vtable->base_type;
/* This is a hack! All PMCs should be able to be handled through
a single codepath, and all of them should be able to avoid
stringification because it's so imprecise. */
if (base_type == enum_class_Key
|| base_type == enum_class_ResizableStringArray
|| base_type == enum_class_String)
type = Parrot_pmc_get_type(interp, key);
else
type = Parrot_pmc_get_type_str(interp, VTABLE_get_string(interp, key));
classobj = get_pmc_proxy(interp, type);
}
return classobj;
}
/* Helper for complaining about attribute access errors. */
PARROT_DOES_NOT_RETURN
static void no_such_attribute(PARROT_INTERP, const char *action, PMC *class_handle, STRING *name) {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can not %s attribute '%Ss' declared in class '%Ss' with this object",
action, name, VTABLE_get_string(interp, introspection_call(interp,
class_handle, STABLE(class_handle)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
/* Given an SC, looks up the index of a code ref that is in its root set. */
INTVAL SC_find_code_idx(PARROT_INTERP, PMC *sc, PMC *obj) {
PMC *to_search;
INTVAL i, count;
GETATTR_SerializationContext_root_codes(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,
"Code ref '%Ss' does not exist in serialization context",
VTABLE_get_string(interp, obj));
}
PARROT_WARN_UNUSED_RESULT
PARROT_CANNOT_RETURN_NULL
static STRING*
trace_class_name(PARROT_INTERP, ARGIN(const PMC* pmc))
{
ASSERT_ARGS(trace_class_name)
STRING *class_name;
if (PObj_is_class_TEST(pmc)) {
SLOTTYPE * const class_array = (SLOTTYPE *)PMC_data(pmc);
PMC * const class_name_pmc = get_attrib_num(class_array,
PCD_CLASS_NAME);
class_name = VTABLE_get_string(interp, class_name_pmc);
}
else
class_name = pmc->vtable->whoami;
return class_name;
}
static void
debug_trace_find_meth(PARROT_INTERP, ARGIN(const PMC *_class),
ARGIN(const STRING *name), ARGIN_NULLOK(const PMC *sub))
{
ASSERT_ARGS(debug_trace_find_meth)
STRING *class_name;
const char *result;
Interp *tracer;
if (!Interp_trace_TEST(interp, PARROT_TRACE_FIND_METH_FLAG))
return;
if (PObj_is_class_TEST(_class)) {
SLOTTYPE * const class_array = PMC_data_typed(_class, SLOTTYPE *);
PMC * const class_name_pmc = get_attrib_num(class_array, PCD_CLASS_NAME);
class_name = VTABLE_get_string(interp, class_name_pmc);
}
else
static void bind_attribute_ref(PARROT_INTERP, STable *st, void *data, PMC *class_handle, STRING *name, INTVAL hint, void *value) {
P6opaqueREPRData *repr_data = (P6opaqueREPRData *)st->REPR_data;
INTVAL slot;
/* Try to find the slot. */
slot = hint >= 0 && !(repr_data->mi) ? hint :
try_get_slot(interp, repr_data, class_handle, name);
if (slot >= 0) {
STable *st = repr_data->flattened_stables[slot];
if (st)
st->REPR->copy_to(interp, st, value, (char *)data + repr_data->attribute_offsets[slot]);
else
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can not bind by reference to non-flattened attribute '%Ss' on class '%Ss'",
name, VTABLE_get_string(interp, introspection_call(interp,
class_handle, STABLE(class_handle)->HOW,
Parrot_str_new_constant(interp, "name"), 0)));
}
else {
/* Otherwise, complain that the attribute doesn't exist. */
no_such_attribute(interp, "bind", class_handle, name);
}
}
PARROT_API
Parrot_Int
Parrot_api_get_result(Parrot_PMC interp_pmc, ARGOUT(Parrot_Int *is_error),
ARGOUT(Parrot_PMC *exception), ARGOUT(Parrot_Int *exit_code),
ARGOUT(Parrot_String *errmsg))
{
ASSERT_ARGS(Parrot_api_get_result)
EMBED_API_CALLIN(interp_pmc, interp)
*exit_code = interp->exit_code;
*exception = interp->final_exception;
if (PMC_IS_NULL(*exception)) {
*is_error = 0;
*errmsg = STRINGNULL;
}
else {
STRING * const severity_str = Parrot_str_new(interp, "severity", 0);
const INTVAL severity = VTABLE_get_integer_keyed_str(interp, *exception, severity_str);
*is_error = (severity != EXCEPT_exit);
*errmsg = VTABLE_get_string(interp, *exception);
}
interp->final_exception = PMCNULL;
interp->exit_code = 0;
EMBED_API_CALLOUT(interp_pmc, interp)
}
/* 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;
}
/* 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;
}
/* 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);
}
}
PARROT_EXPORT
void
Parrot_run_callback(PARROT_INTERP,
ARGMOD(PMC* user_data), ARGIN(void* external_data))
{
ASSERT_ARGS(Parrot_run_callback)
PMC *signature;
PMC *sub;
STRING *sig_str;
INTVAL ch;
char pasm_sig[5];
INTVAL i_param;
PMC *p_param;
void *param = NULL; /* avoid -Ox warning */
STRING *sc;
sc = CONST_STRING(interp, "_sub");
sub = Parrot_pmc_getprop(interp, user_data, sc);
sc = CONST_STRING(interp, "_signature");
signature = Parrot_pmc_getprop(interp, user_data, sc);
sig_str = VTABLE_get_string(interp, signature);
pasm_sig[0] = 'P';
ch = STRING_ord(interp, sig_str, 1);
if (ch == 'U') /* user_data Z in pdd16 */
ch = STRING_ord(interp, sig_str, 2); /* ch is now type of external data */
switch (ch) {
case 'v':
pasm_sig[1] = 'v';
break;
case 'l':
/* FIXME: issue #742 */
i_param = (INTVAL)(long)(INTVAL) external_data;
goto case_I;
case 'i':
/* FIXME: issue #742 */
i_param = (INTVAL)(int)(INTVAL) external_data;
goto case_I;
case 's':
/* FIXME: issue #742 */
i_param = (INTVAL)(short)(INTVAL) external_data;
goto case_I;
case 'c':
/* FIXME: issue #742 */
i_param = (INTVAL)(char)(INTVAL) external_data;
case_I:
pasm_sig[1] = 'I';
param = (void*) i_param;
break;
case 'p':
/* created a UnManagedStruct */
p_param = Parrot_pmc_new(interp, enum_class_UnManagedStruct);
VTABLE_set_pointer(interp, p_param, external_data);
pasm_sig[1] = 'P';
param = (void*) p_param;
break;
case 't':
pasm_sig[1] = 'S';
param = Parrot_str_new(interp, (const char*)external_data, 0);
break;
default:
Parrot_ex_throw_from_c_args(interp, NULL, 1,
"unhandled signature char '%c' in run_cb", ch);
}
pasm_sig[2] = '-';
pasm_sig[3] = '>'; /* no return value supported yet */
pasm_sig[4] = '\0';
Parrot_ext_call(interp, sub, pasm_sig, user_data, param);
}
=cut
*/
PARROT_DOES_NOT_RETURN
PARROT_COLD
void
die_from_exception(PARROT_INTERP, ARGIN(PMC *exception))
{
ASSERT_ARGS(die_from_exception)
/* Avoid anything that can throw if we are already throwing from
* a previous call to this function */
static int already_dying = 0;
STRING * const message = already_dying ? STRINGNULL :
VTABLE_get_string(interp, exception);
const INTVAL severity = already_dying ? (INTVAL)EXCEPT_fatal :
VTABLE_get_integer_keyed_str(interp, exception, CONST_STRING(interp, "severity"));
if (already_dying)
Parrot_x_jump_out(interp, 1);
else {
/* In some cases we have a fatal exception before the IO system
* is completely initialized. Do some attempt to output the
* message to stderr, to help diagnosing. */
const int use_perr = !PMC_IS_NULL(Parrot_io_STDERR(interp));
already_dying = 1;
interp->final_exception = exception;
interp->exit_code = 1;
/* flush interpreter output to get things printed in order */
static void
PackFile_Constant_dump(PARROT_INTERP, ARGIN(const PackFile_ConstTable *ct),
ARGIN(const PackFile_Constant *self))
{
ASSERT_ARGS(PackFile_Constant_dump)
PMC *key;
size_t i;
switch (self->type) {
case PFC_NUMBER:
Parrot_io_printf(interp, " [ 'PFC_NUMBER', %g ],\n", self->u.number);
break;
case PFC_STRING:
Parrot_io_printf(interp, " [ 'PFC_STRING', {\n");
pobj_flag_dump(interp, (long)PObj_get_FLAGS(self->u.string));
Parrot_io_printf(interp, " CHARSET => %ld,\n",
self->u.string->charset);
i = self->u.string->bufused;
Parrot_io_printf(interp, " SIZE => %ld,\n",
(long)i);
Parrot_io_printf(interp, " DATA => \"%Ss\"\n",
Parrot_str_escape(interp, self->u.string));
Parrot_io_printf(interp, " } ],\n");
break;
case PFC_KEY:
for (i = 0, key = self->u.key; key; i++) {
GETATTR_Key_next_key(interp, key, key);
}
/* number of key components */
Parrot_io_printf(interp, " [ 'PFC_KEY' (%ld items)\n", i);
/* and now type / value per component */
for (key = self->u.key; key;) {
opcode_t type = PObj_get_FLAGS(key);
Parrot_io_printf(interp, " {\n");
type &= KEY_type_FLAGS;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(key));
switch (type) {
case KEY_integer_FLAG:
Parrot_io_printf(interp, " TYPE => INTEGER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => NUMBER\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_NUMBER);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => %ld\n", detail->u.number);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_string_FLAG:
{
const PackFile_Constant *detail;
size_t ct_index;
Parrot_io_printf(interp, " TYPE => STRING\n");
ct_index = PackFile_find_in_const(interp, ct, key, PFC_STRING);
Parrot_io_printf(interp, " PFC_OFFSET => %ld\n", ct_index);
detail = ct->constants[ct_index];
Parrot_io_printf(interp, " DATA => '%Ss'\n",
detail->u.string);
Parrot_io_printf(interp, " },\n");
}
break;
case KEY_integer_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => I REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_number_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => N REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_string_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => S REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
case KEY_pmc_FLAG | KEY_register_FLAG:
Parrot_io_printf(interp, " TYPE => P REGISTER\n");
Parrot_io_printf(interp, " DATA => %ld\n",
VTABLE_get_integer(interp, key));
Parrot_io_printf(interp, " },\n");
break;
default:
Parrot_io_eprintf(NULL, "PackFile_Constant_pack: "
"unsupported constant type\n");
Parrot_exit(interp, 1);
}
GETATTR_Key_next_key(interp, key, key);
}
Parrot_io_printf(interp, " ],\n");
break;
case PFC_PMC:
Parrot_io_printf(interp, " [ 'PFC_PMC', {\n");
{
PMC * const pmc = self->u.key;
Parrot_Sub_attributes *sub;
STRING * const null = Parrot_str_new_constant(interp, "(null)");
STRING *namespace_description;
pobj_flag_dump(interp, (long)PObj_get_FLAGS(pmc));
switch (pmc->vtable->base_type) {
case enum_class_FixedBooleanArray:
case enum_class_FixedFloatArray:
case enum_class_FixedPMCArray:
case enum_class_FixedStringArray:
case enum_class_ResizableBooleanArray:
case enum_class_ResizableIntegerArray:
case enum_class_ResizableFloatArray:
case enum_class_ResizablePMCArray:
case enum_class_ResizableStringArray:
{
const int n = VTABLE_get_integer(interp, pmc);
STRING* const out_buffer = VTABLE_get_repr(interp, pmc);
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\telement count => %d,\n"
"\telements => %Ss,\n",
pmc->vtable->whoami,
n,
out_buffer);
}
break;
case enum_class_Sub:
case enum_class_Coroutine:
PMC_get_sub(interp, pmc, sub);
if (sub->namespace_name) {
switch (sub->namespace_name->vtable->base_type) {
case enum_class_String:
namespace_description = Parrot_str_new(interp, "'", 1);
namespace_description = Parrot_str_append(interp,
namespace_description,
VTABLE_get_string(interp, sub->namespace_name));
namespace_description = Parrot_str_append(interp,
namespace_description,
Parrot_str_new(interp, "'", 1));
break;
case enum_class_Key:
namespace_description =
key_set_to_string(interp, sub->namespace_name);
break;
default:
namespace_description = sub->namespace_name->vtable->whoami;
}
}
else {
namespace_description = null;
}
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\tstart_offs => %d,\n"
"\tend_offs => %d,\n"
"\tname => '%Ss',\n"
"\tsubid => '%Ss',\n"
"\tmethod => '%Ss',\n"
"\tnsentry => '%Ss',\n"
"\tnamespace => %Ss\n"
"\tHLL_id => %d,\n",
pmc->vtable->whoami,
sub->start_offs,
sub->end_offs,
sub->name,
sub->subid,
sub->method_name,
sub->ns_entry_name,
namespace_description,
sub->HLL_id);
break;
case enum_class_FixedIntegerArray:
Parrot_io_printf(interp,
"\tclass => %Ss,\n"
"\trepr => '%Ss'\n",
pmc->vtable->whoami,
VTABLE_get_repr(interp, pmc));
break;
default:
Parrot_io_printf(interp, "\tno dump info for PMC %ld %Ss\n",
pmc->vtable->base_type, pmc->vtable->whoami);
Parrot_io_printf(interp, "\tclass => %Ss,\n", pmc->vtable->whoami);
}
}
Parrot_io_printf(interp, " } ],\n");
break;
default:
Parrot_io_printf(interp, " [ 'PFC_\?\?\?', type '0x%x' ],\n",
self->type);
break;
}
}
/* 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;
}
/*
=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");
}
