Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: e29b2f1866
Fetching contributors…

Cannot retrieve contributors at this time

1813 lines (1370 sloc) 51.0 kb
/*
* Copyright (C) 2008-2012, The Perl Foundation.
*/
BEGIN_OPS_PREAMBLE
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "parrot/dynext.h"
#include "pmc_object.h"
#include "pmc_class.h"
#include "pmc_callcontext.h"
#include "pmc_sub.h"
#include "pmc_continuation.h"
#include "pmc_exception.h"
#include "../binder/bind.h"
#include "../binder/multidispatch.h"
#include "../binder/container.h"
#include "../binder/types.h"
#include "../binder/sixmodelobject.h"
#if PARROT_HAS_ICU
# include <unicode/uchar.h>
#endif
/* Cache some stuff for fast access. */
static INTVAL smo_id = 0;
/* The current dispatcher, for the next thing that wants one to take. */
static PMC *current_dispatcher = NULL;
static PMC *build_sig_object(PARROT_INTERP, ARGIN_NULLOK(PMC *signature), ARGIN(const char *sig), ...)
{
PMC *sig_obj;
va_list args;
va_start(args, sig);
/* sigh, Parrot_pcc_build_sig_object_from_varargs does not have a signature arg */
sig_obj = Parrot_pcc_build_sig_object_from_varargs(interp, PMCNULL, sig, args);
va_end(args);
return sig_obj;
}
static INTVAL should_run_phaser(PARROT_INTERP, PMC *phaser, PMC *all_phasers, PMC *result) {
PMC *keep_list, *undo_list;
INTVAL i, elems;
/* Check if the phaser is in the keep or undo list. */
INTVAL in_keep_list = 0;
INTVAL in_undo_list = 0;
phaser = Rakudo_cont_decontainerize(interp, phaser);
keep_list = VTABLE_get_pmc_keyed_str(interp, all_phasers, Parrot_str_new_constant(interp, "KEEP"));
if (!PMC_IS_NULL(keep_list)) {
elems = VTABLE_elements(interp, keep_list);
for (i = 0; i < elems; i++)
if (Rakudo_cont_decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, keep_list, i)) == phaser)
{
in_keep_list = 1;
break;
}
}
if (!in_keep_list) {
undo_list = VTABLE_get_pmc_keyed_str(interp, all_phasers, Parrot_str_new_constant(interp, "UNDO"));
if (!PMC_IS_NULL(undo_list)) {
elems = VTABLE_elements(interp, undo_list);
for (i = 0; i < elems; i++)
if (Rakudo_cont_decontainerize(interp, VTABLE_get_pmc_keyed_int(interp, undo_list, i)) == phaser)
{
in_undo_list = 1;
break;
}
}
}
/* If it's in neither list, it's just a plain old LEAVE. */
if (!in_keep_list && !in_undo_list)
return 1;
/* If it's NULL, we're unwinding, which means we only UNDO. */
if (PMC_IS_NULL(result))
return in_undo_list;
/* Otherwise, need to consider the definedness of the return value. */
if (IS_CONCRETE(result))
return in_keep_list;
else
return in_undo_list;
}
static PMC *run_leave_phasers(PARROT_INTERP, PMC *ctx, PMC *perl6_code, PMC *result, PMC *exceptions)
{
Rakudo_Code *code;
PMC *phasers, *leave_phasers;
PMC *oldctx;
int i, n;
Parrot_runloop jump_point;
if (PMC_IS_NULL(perl6_code))
return PMCNULL;
code = (Rakudo_Code *)PMC_data(perl6_code);
phasers = code->phasers;
if (PMC_IS_NULL(phasers))
return PMCNULL;
leave_phasers = VTABLE_get_pmc_keyed_str(interp, phasers, Parrot_str_new_constant(interp, "!LEAVE-ORDER"));
if (PMC_IS_NULL(leave_phasers))
return PMCNULL;
n = VTABLE_elements(interp, leave_phasers);
if (!n)
return PMCNULL;
oldctx = CURRENT_CONTEXT(interp);
Parrot_pcc_set_context(interp, ctx);
for (i = 0; i < n; i++) {
int runloop_id = interp->current_runloop_id;
if (setjmp(jump_point.resume)) {
if (PMC_IS_NULL(exceptions)) {
exceptions = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
}
VTABLE_push_pmc(interp, exceptions, jump_point.exception);
/* grrr */
while (interp->current_runloop && interp->current_runloop_id != runloop_id)
free_runloop_jump_point(interp);
} else {
PMC *phaser = VTABLE_get_pmc_keyed_int(interp, leave_phasers, i);
Parrot_ex_add_c_handler(interp, &jump_point);
if (should_run_phaser(interp, phaser, phasers, result))
Parrot_pcc_invoke_sub_from_c_args(interp, phaser, "->");
}
Parrot_cx_delete_handler_local(interp, STRINGNULL);
}
Parrot_pcc_set_context(interp, oldctx);
return exceptions;
}
static void rethrow_phaser_exceptions(PARROT_INTERP, PMC *exceptions)
{
int i, n;
if (PMC_IS_NULL(exceptions))
return;
n = VTABLE_elements(interp, exceptions);
if (!n)
return;
for (i = 0; i < n; i++) {
Parrot_ex_rethrow_from_c(interp, VTABLE_get_pmc_keyed_int(interp, exceptions, i));
}
}
static void rewind_to_ctx(PARROT_INTERP, ARGIN_NULLOK(PMC *ctx), ARGIN_NULLOK(PMC *basectx), ARGIN_NULLOK(PMC *result))
{
PMC *parrot_sub;
PMC *perl6_code;
PMC *exceptions = PMCNULL;
while (!PMC_IS_NULL(ctx) && ctx != basectx) {
parrot_sub = Parrot_pcc_get_sub(interp, ctx);
if (!PMC_IS_NULL(parrot_sub)) {
GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
if (!PMC_IS_NULL(perl6_code) && perl6_code->vtable->base_type == smo_id &&
STABLE(perl6_code)->WHAT != Rakudo_types_code_get()) {
exceptions = run_leave_phasers(interp, ctx, perl6_code, result, exceptions);
}
}
ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
}
if (!PMC_IS_NULL(exceptions)) {
Parrot_pcc_set_context(interp, basectx);
rethrow_phaser_exceptions(interp, exceptions);
}
}
static PMC *find_common_ctx(PARROT_INTERP, ARGIN_NULLOK(PMC *ctx1), ARGIN_NULLOK(PMC *ctx2))
{
int depth1 = 0;
int depth2 = 0;
PMC *ctx;
for (ctx = ctx1; !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx), depth1++)
if (ctx == ctx2)
return ctx;
for (ctx = ctx2; !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx), depth2++)
if (ctx == ctx1)
return ctx;
for (; depth1 > depth2; depth2++)
ctx1 = Parrot_pcc_get_caller_ctx(interp, ctx1);
for (; depth2 > depth1; depth1++)
ctx2 = Parrot_pcc_get_caller_ctx(interp, ctx2);
while (ctx1 != ctx2) {
ctx1 = Parrot_pcc_get_caller_ctx(interp, ctx1);
ctx2 = Parrot_pcc_get_caller_ctx(interp, ctx2);
}
return ctx1;
}
PARROT_CAN_RETURN_NULL
PARROT_WARN_UNUSED_RESULT
static PMC* sub_find_pad(PARROT_INTERP, ARGIN(STRING *lex_name), ARGIN(PMC *ctx))
{
ASSERT_ARGS(Parrot_sub_find_pad)
while (1) {
PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, ctx);
PMC * outer = Parrot_pcc_get_outer_ctx(interp, ctx);
if (PMC_IS_NULL(outer))
return lex_pad;
PARROT_ASSERT(outer->vtable->base_type == enum_class_CallContext);
if (!PMC_IS_NULL(lex_pad))
if (VTABLE_exists_keyed_str(interp, lex_pad, lex_name))
return lex_pad;
ctx = outer;
}
}
END_OPS_PREAMBLE
/*
=item rakudo_dynop_setup()
Does various setup tasks on behalf of all of the other dynops.
=cut
*/
inline op rakudo_dynop_setup() :base_core {
/* Get 6model object type ID. */
smo_id = Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "SixModelObject", 0));
}
/*
=item find_lex_skip_current(out PMC, in STR)
Finds the lexical named $2 and returns it. However, unlike find_lex this op
skips the current sub and starts looking immediately at its outers.
=cut
*/
inline op find_lex_skip_current(out PMC, in STR) :base_core {
PMC *ctx = CURRENT_CONTEXT(interp);
$1 = PMCNULL;
while (Parrot_pcc_get_outer_ctx(interp, ctx)) {
PMC * const outer = Parrot_pcc_get_outer_ctx(interp, ctx);
PMC * const lex_pad = Parrot_pcc_get_lex_pad(interp, outer);
if (!PMC_IS_NULL(lex_pad) && VTABLE_exists_keyed_str(interp, lex_pad, $2)) {
$1 = VTABLE_get_pmc_keyed_str(interp, lex_pad, $2);
break;
}
ctx = outer;
}
}
/*
=item inline op x_is_uprop(out INT, in STR, in STR, in INT)
Sets a true value in $1 if character $4 in string $3 has the unicode property
named $2.
=cut
*/
inline op x_is_uprop(out INT, in STR, in STR, in INT) :base_core {
#if PARROT_HAS_ICU
char *cstr;
INTVAL ord;
int32_t strwhich, ordwhich;
UProperty strprop;
opcode_t *handler;
if ($4 > 0 && (UINTVAL)$4 == ($3->strlen)) {
$1 = 0;
goto NEXT();
}
ord = Parrot_str_indexed(interp, $3, $4);
cstr = Parrot_str_to_cstring(interp, $2);
/* try block tests */
if (strncmp(cstr, "In", 2) == 0) {
strwhich = u_getPropertyValueEnum(UCHAR_BLOCK, cstr+2);
ordwhich = u_getIntPropertyValue(ord, UCHAR_BLOCK);
if (strwhich != UCHAR_INVALID_CODE) {
$1 = (strwhich == ordwhich);
Parrot_str_free_cstring(cstr);
goto NEXT();
}
}
/* try bidi tests */
if (strncmp(cstr, "Bidi", 4) == 0) {
strwhich = u_getPropertyValueEnum(UCHAR_BIDI_CLASS, cstr+4);
ordwhich = u_getIntPropertyValue(ord, UCHAR_BIDI_CLASS);
if (strwhich != UCHAR_INVALID_CODE) {
$1 = (strwhich == ordwhich);
Parrot_str_free_cstring(cstr);
goto NEXT();
}
}
/* try property value aliases */
strwhich = u_getPropertyValueEnum(UCHAR_GENERAL_CATEGORY_MASK, cstr);
if (strwhich != UCHAR_INVALID_CODE) {
ordwhich = u_getIntPropertyValue(ord, UCHAR_GENERAL_CATEGORY_MASK);
$1 = ((strwhich & ordwhich) != 0);
Parrot_str_free_cstring(cstr);
goto NEXT();
}
/* try property */
strprop = u_getPropertyEnum(cstr);
if (strprop != UCHAR_INVALID_CODE) {
$1 = (u_hasBinaryProperty(ord, strprop) != 0);
Parrot_str_free_cstring(cstr);
goto NEXT();
}
/* try script aliases */
strwhich = u_getPropertyValueEnum(UCHAR_SCRIPT, cstr);
if (strwhich != UCHAR_INVALID_CODE) {
ordwhich = u_getIntPropertyValue(ord, UCHAR_SCRIPT);
$1 = (strwhich == ordwhich);
Parrot_str_free_cstring(cstr);
goto NEXT();
}
/* unrecognized property name */
Parrot_str_free_cstring(cstr);
handler = Parrot_ex_throw_from_op_args(interp, NULL,
EXCEPTION_ICU_ERROR,
"Unicode property '%Ss' not found", $2);
goto ADDRESS(handler);
#else
opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
EXCEPTION_ICU_ERROR,
"ICU not loaded", $2);
goto ADDRESS(handler);
#endif
}
/*
=item bind_signature()
This is emitted into a sub to cause it's Perl 6 signature to be bound.
=cut
*/
inline op bind_signature() :base_core {
/* Need to make sure some stuff doesn't get destroyed. */
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const saved_ccont = interp->current_cont;
PMC * const saved_sig = Parrot_pcc_get_signature(interp, ctx);
opcode_t * const current_pc = Parrot_pcc_get_pc(interp, ctx);
/* Obtain lexpad and other settings. */
PMC * const lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
const INTVAL noms_checked = PObj_flag_TEST(P6BINDER_ALREADY_CHECKED, ctx);
STRING * error = STRINGNULL;
INTVAL bind_error;
/* Look up signature to bind. */
PMC * const parrot_sub = Parrot_pcc_get_sub(interp, ctx);
PMC *perl6_code, *signature;
GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
if (PMC_IS_NULL(perl6_code))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Could not locate Perl 6 code object");
signature = ((Rakudo_Code *)PMC_data(perl6_code))->signature;
/* Call signature binder. */
bind_error = Rakudo_binding_bind(interp, lexpad, signature, ctx,
noms_checked, &error);
/* Bind ok? */
if (!bind_error) {
/* Re-instate anything we may have damaged. */
CURRENT_CONTEXT(interp) = ctx;
interp->current_cont = saved_ccont;
Parrot_pcc_set_signature(interp, ctx, saved_sig);
Parrot_pcc_set_pc(interp, ctx, current_pc);
goto NEXT();
}
else {
/* Maybe we need to auto-thread... */
if (bind_error == BIND_RESULT_JUNCTION) {
/* Find dispatcher and call it. */
PMC * const dispatcher = Rakudo_types_junction_threader_get();
PMC * const sub = Parrot_pcc_get_sub(interp, ctx);
PMC * call_ctx = VTABLE_clone(interp, ctx);
PMC * ret_cont = Parrot_pcc_get_continuation(interp, ctx);
PMC * p6sub;
opcode_t *next;
GETATTR_Sub_multi_signature(interp, sub, p6sub);
VTABLE_unshift_pmc(interp, call_ctx, p6sub);
Parrot_pcc_invoke_from_sig_object(interp, dispatcher, call_ctx);
/* Invoke the original return continuation, to return junction result. */
next = VTABLE_invoke(interp, ret_cont, expr NEXT());
goto ADDRESS(next);
}
else {
/* Nope, just normal fail... */
opcode_t * const handler = Parrot_ex_throw_from_op_args(interp, NULL,
EXCEPTION_INVALID_OPERATION, "%Ss", error);
goto ADDRESS(handler);
}
}
}
/*
=item perl6_trial_bind_ct()
Sees if we could potentially bind a signature.
$0 is a flag indicating the outcome. 0 means could not decide, 1 means
decided that we will be able to bind, -1 means that it'd never work
$1 is the signature object
$2 is the argument array
$3 is a set of flags for native types. 0 = object, 1 = native int,
2 = native num, 3 = native str.
=cut
*/
inline op perl6_trial_bind_ct(out INT, in PMC, in PMC, in PMC) :base_core {
/* Build up a capture with sample arguments. */
PMC *capture = Parrot_pmc_new(interp, enum_class_CallContext);
INTVAL num_args = VTABLE_elements(interp, $3);
INTVAL args_ok = 1;
INTVAL i;
for (i = 0; i < num_args; i++) {
INTVAL native = VTABLE_get_integer_keyed_int(interp, $4, i);
PMC *obj;
switch (native) {
case BIND_VAL_INT:
VTABLE_push_integer(interp, capture, 0);
break;
case BIND_VAL_NUM:
VTABLE_push_float(interp, capture, 0.0);
break;
case BIND_VAL_STR:
VTABLE_push_string(interp, capture, STRINGNULL);
break;
default:
obj = VTABLE_get_pmc_keyed_int(interp, $3, i);
if (obj->vtable->base_type == smo_id) {
VTABLE_push_pmc(interp, capture, obj);
}
else {
args_ok = 0;
break;
}
}
}
/* Do trial bind. */
$1 = Rakudo_binding_trial_bind(interp, $2, capture);
}
/*
=item perl6_set_types_mu_any(in PMC, in PMC)
Sets the top type.
=cut
*/
inline op perl6_set_types_mu_any(in PMC, in PMC) :base_core {
Rakudo_types_mu_set($1);
Rakudo_types_any_set($2);
}
/*
=item perl6_setup_junction_autothreading(in PMC)
Sets the junction type and auto-threader.
=cut
*/
inline op perl6_setup_junction_autothreading(in PMC, in PMC) :base_core {
Rakudo_types_junction_set($1);
Rakudo_types_junction_threader_set($2);
}
/*
=item perl6_set_types_ins(in PMC, in PMC, in PMC)
Sets the Int/Num/Str types.
=cut
*/
inline op perl6_set_types_ins(in PMC, in PMC, in PMC) :base_core {
Rakudo_types_int_set($1);
Rakudo_types_num_set($2);
Rakudo_types_str_set($3);
}
/*
=item perl6_set_types_list_array_lol(in PMC, in PMC, in PMC, in PMC, in PMC)
Sets the List, ListIter, Array and LoL types.
=cut
*/
inline op perl6_set_types_list_array_lol(in PMC, in PMC, in PMC, in PMC, in PMC) :base_core {
Rakudo_types_list_set($1);
Rakudo_types_listiter_set($2);
Rakudo_types_array_set($3);
Rakudo_types_lol_set($4);
Rakudo_types_parcel_set($5);
}
/*
=item perl6_set_types_enummap_hash(in PMC, in PMC)
Sets the EnumMap and Hash types.
=cut
*/
inline op perl6_set_types_enummap_hash(in PMC, in PMC) :base_core {
Rakudo_types_enummap_set($1);
Rakudo_types_hash_set($2);
}
/*
=item perl6_set_type_capture(in PMC)
Sets the Capture type.
=cut
*/
inline op perl6_set_type_capture(in PMC) :base_core {
Rakudo_types_capture_set($1);
}
/*
=item perl6_set_type_code(in PMC)
Sets the Code type.
=cut
*/
inline op perl6_set_type_code(in PMC) :base_core {
Rakudo_types_code_set($1);
}
/*
=item perl6_set_type_packagehow(in PMC)
Sets the package type.
=cut
*/
inline op perl6_set_type_packagehow(in PMC) :base_core {
Rakudo_types_packagehow_set($1);
}
/*
=item perl6_booleanize(out PMC, in INT)
If $2 is non-zero, puts Bool::True in $1. Otherwise puts Bool::False
in.
=cut
*/
inline op perl6_booleanize(out PMC, in INT) :base_core {
$1 = $2 == 0 ? Rakudo_types_bool_false_get() : Rakudo_types_bool_true_get();
}
/*
=item perl6_set_bools(in PMC, in PMC)
Sets and caches the False ($1) and True ($2) values to booleanize to.
=cut
*/
inline op perl6_set_bools(in PMC, in PMC) :base_core {
Rakudo_types_bool_false_set($1);
Rakudo_types_bool_true_set($2);
}
/*
=item perl6_box_str()
Box a native string to a Perl 6 Str.
=cut
*/
inline op perl6_box_str(out PMC, in STR) :base_core {
PMC *type = Rakudo_types_str_get();
$1 = REPR(type)->allocate(interp, STABLE(type));
REPR($1)->box_funcs->set_str(interp, STABLE($1), OBJECT_BODY($1), $2);
PARROT_GC_WRITE_BARRIER(interp, $1);
}
/*
=item perl6_box_int()
Box a native int to a Perl 6 Int.
=cut
*/
inline op perl6_box_int(out PMC, in INT) :base_core {
PMC *type = Rakudo_types_int_get();
$1 = REPR(type)->allocate(interp, STABLE(type));
REPR($1)->box_funcs->set_int(interp, STABLE($1), OBJECT_BODY($1), $2);
}
/*
=item perl6_box_num()
Box a native floating point number to a Perl 6 Num.
=cut
*/
inline op perl6_box_num(out PMC, in NUM) :base_core {
PMC *type = Rakudo_types_num_get();
$1 = REPR(type)->allocate(interp, STABLE(type));
REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), $2);
}
/*
=item perl6_box_bigint(out PMC, in NUM)
Return a Perl 6 Int if $2 will fit, otherwise return a Perl 6 Num.
=cut
*/
inline op perl6_box_bigint(out PMC, in NUM) :base_core {
if ((INTVAL)$2 == $2) {
PMC *type = Rakudo_types_int_get();
$1 = REPR(type)->allocate(interp, STABLE(type));
REPR($1)->box_funcs->set_int(interp, STABLE($1), OBJECT_BODY($1), $2);
}
else {
PMC *type = Rakudo_types_num_get();
$1 = REPR(type)->allocate(interp, STABLE(type));
REPR($1)->box_funcs->set_num(interp, STABLE($1), OBJECT_BODY($1), $2);
}
}
/*
=item perl6ize_type(out PMC, in PMC)
Looks for Parrot-y types sneaking into Perl 6 land and maps them
into Perl 6 types.
=cut
*/
inline op perl6ize_type(out PMC, in PMC) :base_core {
if ($2->vtable->base_type == smo_id)
$1 = $2;
else
$1 = Rakudo_types_parrot_map(interp, $2);
}
/*
=item set_scalar_container_type(in PMC)
Sets the scalar container type.
=cut
*/
inline op set_scalar_container_type(in PMC) :base_core {
Rakudo_cont_set_scalar_type($1);
}
/*
=item perl6_decontainerize(out PMC, in PMC)
Strips away any outer container, if one exists. Otherwise, no-op.
=cut
*/
inline op perl6_decontainerize(out PMC, in PMC) :base_core {
$1 = $2->vtable->base_type == smo_id ?
Rakudo_cont_decontainerize(interp, $2) :
$2;
}
/*
=item perl6_recontainerize_to_ro()
If the passed value is an rw scalar, re-wrap it. Otherwise, just
hand it on back.
=cut
*/
inline op perl6_recontainerize_to_ro(out PMC, in PMC) :base_core {
if ($2->vtable->base_type == smo_id && Rakudo_cont_is_rw_scalar(interp, $2))
$1 = Rakudo_cont_scalar_with_value_no_descriptor(interp,
Rakudo_cont_decontainerize(interp, $2));
else
$1 = $2;
}
/*
=item perl6_container_store(in PMC, in PMC)
Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method.
=cut
*/
inline op perl6_container_store(in PMC, in PMC) :base_core {
Rakudo_cont_store(interp, $1, $2, 1, 1);
}
/*
=item perl6_container_store_unchecked(in PMC, in PMC)
Stores a value in a container. If it's Scalar, there's a fast path;
otherwise, calls the .STORE method. In the fast path case, with this
op no rw or type checking is done (assumes that the compiler has
already decided that it's safe).
=cut
*/
inline op perl6_container_store_unchecked(in PMC, in PMC) :base_core {
Rakudo_cont_store(interp, $1, $2, 0, 0);
}
/*
=item perl6_create_container_descriptor
Creates a container descriptor and puts in in $1. $2 is the type of the
descriptor to create. $3 is the 'of' type, $4 is the rw flag and $5 is
the name.
=cut
*/
inline op perl6_create_container_descriptor(out PMC, in PMC, in PMC, in INT, in STR) :base_core {
$1 = Rakudo_create_container_descriptor(interp, $2, $3, $4, $5);
}
/*
=item perl6_assert_bind_ok(in PMC, in PMC)
Takes a potential value to bind in $1 and a container descriptor in $2
and asserts that the bind is allowed to take place.
=cut
*/
inline op perl6_assert_bind_ok(in PMC, in PMC) :base_core {
if ($2->vtable->base_type == smo_id) {
PMC *type = $2;
if (type != Rakudo_types_mu_get()) {
INTVAL ok = 0;
if ($1->vtable->base_type == smo_id) {
PMC *value = Rakudo_cont_decontainerize(interp, $1);
ok = STABLE(value)->type_check(interp, value, type);
}
if (!ok)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Type check failed in binding");
}
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_assert_bind_ok on a SixModelObject");
}
}
/*
=item perl6_var(in PMC, in PMC)
The .VAR operation. Wraps in an outer Scalar container so we can actually
operate on the underlying Scalar, if we have a container. Otherwise, $1
is just $2.
=cut
*/
inline op perl6_var(out PMC, in PMC) :base_core {
if ($2->vtable->base_type == smo_id && STABLE($2)->container_spec != NULL) {
$1 = Rakudo_cont_scalar_with_value_no_descriptor(interp, $2);
}
else {
$1 = $2;
}
}
/*
=item perl6_repr_name
Takes an object and returns a string containing the name of its representation.
=cut
*/
inline op perl6_repr_name(out PMC, in PMC) :base_core {
PMC *val = Rakudo_cont_decontainerize(interp, $2);
if (val->vtable->base_type == smo_id) {
PMC *type = Rakudo_types_str_get();
STRING *name = REPR(val)->name;
PMC *res = REPR(type)->allocate(interp, STABLE(type));
REPR(res)->box_funcs->set_str(interp, STABLE(res), OBJECT_BODY(res), name);
PARROT_GC_WRITE_BARRIER(interp, res);
$1 = res;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_repr_name with a SixModelObject");
}
}
/*
=item perl6_definite
Takes an object and returns a boolean determining whether it is concrete.
=cut
*/
inline op perl6_definite(out PMC, in PMC) :base_core {
PMC *val = Rakudo_cont_decontainerize(interp, $2);
$1 = IS_CONCRETE(val) ?
Rakudo_types_bool_true_get() :
Rakudo_types_bool_false_get();
}
/*
=item find_method_null_ok(out PMC, in PMC, in STR)
Like Parrot's find_method, but returns PMCNULL in $1 if $2 doesn't have a
method named $3 instead of throwing an exception.
=cut
*/
inline op find_method_null_ok(out PMC, in PMC, in STR) :base_core {
$1 = VTABLE_find_method(interp, $2, $3);
}
/*
=item perl6_associate_sub_code_object()
Takes a Parrot Sub in $1 and a code object in $2 and associates the two.
Actually, it uses a field in the Parrot Sub PMC that Rakudo never makes
use of. Evil, but saves a prophash for every single code object.
=cut
*/
inline op perl6_associate_sub_code_object(in PMC, in PMC) :base_core {
if ($1->vtable->base_type == enum_class_Sub
|| $1->vtable->base_type == enum_class_Coroutine) {
SETATTR_Sub_multi_signature(interp, $1, $2);
PARROT_GC_WRITE_BARRIER(interp, $1);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_associate_sub_code_object if first operand is a Sub.");
}
}
/*
=item perl6_code_object_from_parrot_sub()
Takes a Parrot Sub PMC and gets the Perl 6 code object associated with it.
=cut
*/
inline op perl6_code_object_from_parrot_sub(out PMC, in PMC) :base_core {
if ($2->vtable->base_type == enum_class_Sub
|| $2->vtable->base_type == enum_class_Coroutine) {
PMC *p6sub;
GETATTR_Sub_multi_signature(interp, $2, p6sub);
$1 = PMC_IS_NULL(p6sub) ? Rakudo_types_mu_get() : p6sub;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_code_object_from_parrot_sub if second operand is a Parrot Sub.");
}
}
/*
=item perl6_decontainerize_return_value()
If the sub is not rw, decontainerizes the return value.
=cut
*/
inline op perl6_decontainerize_return_value(out PMC, in PMC) :base_core {
if ($2->vtable->base_type == smo_id && Rakudo_cont_is_rw_scalar(interp, $2)) {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
PMC *parrot_sub = Parrot_pcc_get_sub(interp, cur_ctx);
PMC *p6sub;
Rakudo_Code *code;
GETATTR_Sub_multi_signature(interp, parrot_sub, p6sub);
code = (Rakudo_Code *)PMC_data(p6sub);
$1 = code->rw ? $2 : Rakudo_cont_scalar_with_value_no_descriptor(interp,
Rakudo_cont_decontainerize(interp, $2));
}
else {
$1 = $2;
}
}
/*
=item perl6_type_check_return_value()
Gets the return type for a sub and type checks it.
=cut
*/
inline op perl6_type_check_return_value(in PMC) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
PMC *parrot_sub = Parrot_pcc_get_sub(interp, cur_ctx);
PMC *p6sub;
PMC *sig_pmc;
PMC *rtype;
GETATTR_Sub_multi_signature(interp, parrot_sub, p6sub);
sig_pmc = ((Rakudo_Code *)PMC_data(p6sub))->signature;
rtype = ((Rakudo_Signature *)PMC_data(sig_pmc))->rtype;
if (!PMC_IS_NULL(rtype)) {
PMC *decont_value = Rakudo_cont_decontainerize(interp, $1);
if (!STABLE(decont_value)->type_check(interp, decont_value, rtype)) {
/* XXX Awesomize. */
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Type check failed for return value");
}
}
}
/*
=item perl6_enter_multi_dispatch_from_onlystar_block()
Entry point to multi-dispatch over the dispatchee list in the specified
candidate.
=cut
*/
inline op perl6_enter_multi_dispatch_from_onlystar_block(out PMC) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
PMC *orig_caller = Parrot_pcc_get_caller_ctx(interp, cur_ctx);
PMC *parrot_sub = Parrot_pcc_get_sub(interp, cur_ctx);
PMC *perl6_code, *chosen;
GETATTR_Sub_multi_signature(interp, parrot_sub, perl6_code);
if (PMC_IS_NULL(perl6_code))
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Could not locate Perl 6 code object");
chosen = Rakudo_md_dispatch(interp, perl6_code, cur_ctx, NULL);
if (!PMC_IS_NULL(chosen)) {
/* Invoke the chosen candidate; we use the existing call frame
* and don't make a nested runloop. */
opcode_t *addr;
Parrot_pcc_set_signature(interp, cur_ctx, cur_ctx);
interp->current_cont = Parrot_pcc_get_continuation(interp, cur_ctx);
addr = VTABLE_invoke(interp, chosen, expr NEXT());
Parrot_pcc_set_caller_ctx(interp, cur_ctx, orig_caller);
PObj_flag_SET(P6BINDER_ALREADY_CHECKED, cur_ctx);
goto ADDRESS(addr);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Internal error: multiple dispatcher returned a null candidate");
}
}
/*
=item perl6_multi_dispatch_thunk()
Creates a multi-dispatch thunk for the specified onlystar dispatcher.
=cut
*/
inline op perl6_multi_dispatch_thunk(out PMC, in PMC) :base_core {
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data($2);
if (PMC_IS_NULL(code_obj->md_thunk)) {
code_obj->md_thunk = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "MDThunk", 0)));
PARROT_GC_WRITE_BARRIER(interp, $2);
VTABLE_set_pointer(interp, code_obj->md_thunk, &Rakudo_md_dispatch);
VTABLE_set_pmc(interp, code_obj->md_thunk, $2);
}
$1 = code_obj->md_thunk;
}
/*
=item perl6_multi_dispatch_cand_thunk()
Creates a multi-dispatch thunk for calling the candidate at the specified
index in the dispatchee list (for when we decided the candidate at compile
time). Also implies that we won't re-do the type check in the binder.
=cut
*/
inline op perl6_multi_dispatch_cand_thunk(out PMC, in PMC, in INT) :base_core {
Rakudo_Code *disp_obj = (Rakudo_Code *)PMC_data($2);
PMC *chosen = VTABLE_get_pmc_keyed_int(interp, disp_obj->dispatchees, $3);
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(chosen);
if (PMC_IS_NULL(code_obj->md_thunk)) {
code_obj->md_thunk = Parrot_pmc_new(interp, Parrot_pmc_get_type_str(interp, Parrot_str_new(interp, "CTMThunk", 0)));
PARROT_GC_WRITE_BARRIER(interp, chosen);
VTABLE_set_pmc(interp, code_obj->md_thunk, chosen);
}
$1 = code_obj->md_thunk;
}
/*
=item perl6_get_matching_multis()
Gets the multi dispatcher to find all candidates under the control of
the dispatcher in $2 that are applicable for capture $3. Puts an RPA
of them in $1.
=cut
*/
inline op perl6_get_matching_multis(out PMC, in PMC, in PMC) :base_core {
$1 = Rakudo_md_get_all_matches(interp, $2, $3);
}
/*
=item perl6_multi_dispatch_ct(out PMC, in PMC, in PMC, in PMC)
Does a "compile time" multi-dispatch. Used by the optimizer to try to
decide some multiple dispatches at compile time.
$0 is an array of two elements. The first is a flag indicating the
outcome. 0 means could not decide, 1 means decided on a candidate,
-1 means that the dispatch is doomed to fail.
$1 is the dispatcher
$2 is the argument array
$3 is a set of flags for native types. 0 = object, 1 = native int,
2 = native num, 3 = native str.
=cut
*/
inline op perl6_multi_dispatch_ct(out PMC, in PMC, in PMC, in PMC) :base_core {
/* Build up a capture with sample arguments. */
PMC *result = PMCNULL;
PMC *capture = Parrot_pmc_new(interp, enum_class_CallContext);
INTVAL num_args = VTABLE_elements(interp, $3);
INTVAL args_ok = 1;
INTVAL i;
for (i = 0; i < num_args; i++) {
INTVAL native = VTABLE_get_integer_keyed_int(interp, $4, i);
PMC *obj;
switch (native) {
case BIND_VAL_INT:
VTABLE_push_integer(interp, capture, 0);
break;
case BIND_VAL_NUM:
VTABLE_push_float(interp, capture, 0.0);
break;
case BIND_VAL_STR:
VTABLE_push_string(interp, capture, STRINGNULL);
break;
default:
obj = VTABLE_get_pmc_keyed_int(interp, $3, i);
if (obj->vtable->base_type == smo_id) {
VTABLE_push_pmc(interp, capture, obj);
}
else {
args_ok = 0;
break;
}
}
}
/* Use the capture to do a compile time trial dispatch. */
$1 = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
if (args_ok) {
VTABLE_set_integer_keyed_int(interp, $1, 0,
Rakudo_md_ct_dispatch(interp, $2, capture, &result));
VTABLE_set_pmc_keyed_int(interp, $1, 1, result);
}
else {
VTABLE_set_integer_keyed_int(interp, $1, 0, MD_CT_NOT_SURE);
}
}
/*
=item perl6_get_package_through_who
Takes a type object and uses its associated symbol table (in .WHO)
to look for a package within it. It will auto-vivify the package if
non exists.
=cut
*/
inline op perl6_get_package_through_who(out PMC, in PMC, in STR) :base_core {
if ($2->vtable->base_type == smo_id) {
PMC *who = STABLE($2)->WHO;
PMC *pkg = VTABLE_get_pmc_keyed_str(interp, who, $3);
if (PMC_IS_NULL(pkg)) {
/* Create the package object. This is just like a call:
* pkg = PackageHOW.new_type(:name($3))
*/
PMC *pkg_how = Rakudo_types_packagehow_get();
PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *meth = VTABLE_find_method(interp, pkg_how, Parrot_str_new(interp, "new_type", 0));
PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
VTABLE_push_pmc(interp, cappy, pkg_how);
VTABLE_set_string_keyed_str(interp, cappy, Parrot_str_new(interp, "name", 0), $3);
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);
pkg = VTABLE_get_pmc_keyed_int(interp, cappy, 0);
/* Install it in the outer package's .WHO. */
VTABLE_set_pmc_keyed_str(interp, who, $3, pkg);
}
$1 = pkg;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_get_package_through_who with a SixModelObject");
}
}
/*
=item perl6_set_dispatcher_for_callee(in PMC)
Sets the dispatcher that the next thing we call that is interested
in one will take.
=cut
*/
inline op perl6_set_dispatcher_for_callee(in PMC) :base_core {
current_dispatcher = $1;
}
/*
=item perl6_take_dispatcher()
Takes the dispatcher that was set, if any, and store it in the current
lexpad's $*DISPATCHER. Also clears the current set dispatcher so that
nothing else can take it by accident. If there's no current set dispatcher
then this is a no-op.
=cut
*/
inline op perl6_take_dispatcher() :base_core {
if (current_dispatcher) {
PMC *lexpad = Parrot_pcc_get_lex_pad(interp, CURRENT_CONTEXT(interp));
VTABLE_set_pmc_keyed_str(interp, lexpad, Parrot_str_new_constant(interp, "$*DISPATCHER"),
current_dispatcher);
current_dispatcher = NULL;
}
}
/*
=item perl6_find_dispatcher(out PMC)
Locates the nearest dispatcher $*DISPATCHER, vivifying it if required,
and returns it.
=cut
*/
inline op perl6_find_dispatcher(out PMC, in STR) :base_core {
PMC *ctx = CURRENT_CONTEXT(interp);
STRING *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
PMC *dispatcher = NULL;
while (!PMC_IS_NULL(ctx)) {
/* Do we have a dispatcher here? */
PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
PMC *maybe_dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
if (!PMC_IS_NULL(maybe_dispatcher)) {
dispatcher = maybe_dispatcher;
if (!PMC_IS_NULL(dispatcher) && !IS_CONCRETE(dispatcher)) {
/* Need to vivify it. */
PMC *old_ctx = Parrot_pcc_get_signature(interp, CURRENT_CONTEXT(interp));
PMC *meth = VTABLE_find_method(interp, dispatcher, Parrot_str_new_constant(interp, "vivify_for"));
PMC *cappy = Parrot_pmc_new(interp, enum_class_CallContext);
PMC *sub = Parrot_pcc_get_sub(interp, ctx);
PMC *p6sub;
VTABLE_push_pmc(interp, cappy, dispatcher);
GETATTR_Sub_multi_signature(interp, sub, p6sub);
VTABLE_push_pmc(interp, cappy, p6sub);
VTABLE_push_pmc(interp, cappy, lexpad);
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);
dispatcher = VTABLE_get_pmc_keyed_int(interp, cappy, 0);
VTABLE_set_pmc_keyed_str(interp, lexpad, dispatcher_str, dispatcher);
}
break;
}
}
/* Follow dynamic chain. */
ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
}
if (!dispatcher)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"%Ss is not in the dynamic scope of a dispatcher", $2);
$1 = dispatcher;
}
/*
=item perl6_args_for_dispatcher(out PMC, in PMC)
Locates the callframe with the $*DISPATCHER passed and returns it.
=cut
*/
inline op perl6_args_for_dispatcher(out PMC, in PMC) :base_core {
PMC *ctx = CURRENT_CONTEXT(interp);
STRING *dispatcher_str = Parrot_str_new_constant(interp, "$*DISPATCHER");
PMC *result = NULL;
while (!PMC_IS_NULL(ctx)) {
/* Do we have a dispatcher here? */
PMC *lexpad = Parrot_pcc_get_lex_pad(interp, ctx);
if (!PMC_IS_NULL(lexpad) && VTABLE_exists_keyed_str(interp, lexpad, dispatcher_str)) {
PMC *dispatcher = VTABLE_get_pmc_keyed_str(interp, lexpad, dispatcher_str);
if (dispatcher == $2) {
result = ctx;
break;
}
}
ctx = Parrot_pcc_get_caller_ctx(interp, ctx);
}
if (!result)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Could not find arguments for dispatcher");
$1 = result;
}
/*
=item perl6_current_args_rpa(out PMC)
Gets a ResizablePMCArray containing the positional arguments passed to the
current block.
=cut
*/
inline op perl6_current_args_rpa(out PMC) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
PMC *result = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
INTVAL args = VTABLE_elements(interp, cur_ctx);
INTVAL i;
for (i = 0; i < args; i++)
VTABLE_set_pmc_keyed_int(interp, result, i,
VTABLE_get_pmc_keyed_int(interp, cur_ctx, i));
$1 = result;
}
/*
=item perl6_state_needs_init(out INT)
Returns a non-zero value if state variables need their initialization
and START blocks should run.
=cut
*/
inline op perl6_state_needs_init(out INT) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
$1 = PObj_flag_TEST(P6LEXPAD_STATE_INIT, cur_ctx)
}
/*
=item perl6_set_block_first_flag(in PMC)
Flags that the next execution of a block should run the FIRST block.
=cut
*/
inline op perl6_set_block_first_flag(in PMC) :base_core {
Rakudo_Code * code = (Rakudo_Code *)PMC_data($1);
PObj_flag_SET(SUB_FIRST, code->_do);
}
/*
=item perl6_take_block_first_flag(out INT)
Checks the flag for if FIRST blocks should be run for this invocation, and
clears it.
=cut
*/
inline op perl6_take_block_first_flag(out INT) :base_core {
PMC * const ctx = CURRENT_CONTEXT(interp);
PMC * const cur_sub = Parrot_pcc_get_sub(interp, ctx);
$1 = PObj_flag_TEST(SUB_FIRST, cur_sub);
PObj_flag_CLEAR(SUB_FIRST, cur_sub);
}
/*
=item perl6_is_list(out INT, in PMC)
Checks if the passed object is a RPA.
=cut
*/
inline op perl6_is_list(out INT, in PMC) :base_core {
$1 = $2->vtable->base_type == enum_class_ResizablePMCArray;
}
/*
=item perl6_is_hash(out INT, in PMC)
Checks if the passed object is a (VM) hash.
=cut
*/
inline op perl6_is_hash(out INT, in PMC) :base_core {
$1 = $2->vtable->base_type == enum_class_Hash;
}
/*
=item perl6_parcel_from_rpa(out PMC, in PMC, in PMC)
Creates a Perl 6 Parcel object from the RPA in $2, replacing
any PMCNULL elements with $3.
=cut
*/
inline op perl6_parcel_from_rpa(out PMC, in PMC, in PMC) :base_core {
$1 = Rakudo_binding_parcel_from_rpa(interp, $2, $3);
}
/*
=item perl6_iter_from_rpa(out PMC, in PMC, in PMC)
Creates a lazy Perl 6 ListIter object from the RPA in $2
and iterates into the List at $3.
=cut
*/
inline op perl6_iter_from_rpa(out PMC, in PMC, in PMC) :base_core {
$1 = Rakudo_binding_iter_from_rpa(interp, $2, $3);
}
/*
=item perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC)
Creates a lazy Perl 6 List object of type $3 from the RPA
in $2 and with flattening $4.
=cut
*/
inline op perl6_list_from_rpa(out PMC, in PMC, in PMC, in PMC) :base_core {
$1 = Rakudo_binding_list_from_rpa(interp, $2, $3, $4);
}
/*
=item perl6_rpa_find_type(out INT, in PMC, in PMC, int INT, in INT)
Find the first element of RPA $2 that has type $3, starting at
index $4 and up through (but not including) index $5. Sets $1
to be the index of the first element matching type, otherwise
$1 is set to the highest index searched.
Containerized elements are automatically skipped.
=cut
*/
inline op perl6_rpa_find_type(out INT, in PMC, in PMC, in INT, in INT)
{
PMC *rpa = $2;
PMC *type = Rakudo_cont_decontainerize(interp, $3);
INTVAL elems = VTABLE_elements(interp, rpa);
INTVAL last = $5;
INTVAL index;
if (elems < last) last = elems;
for (index = $4; index < last; index++) {
PMC *val = VTABLE_get_pmc_keyed_int(interp, rpa, index);
if (val->vtable->base_type == smo_id
&& !STABLE(val)->container_spec
&& STABLE(val)->type_check(interp, val, type)) break;
}
$1 = index;
}
/*
=item perl6_shiftpush(inout PMC, in PMC, in INT)
Shifts up to $3 elements from $2, pushing each shifted onto $1.
$1 can be PMCNULL, in which case the shifted elements are
simply discarded.
*/
inline op perl6_shiftpush(inout PMC, in PMC, in INT) :base_core {
INTVAL count = $3;
INTVAL elems = VTABLE_elements(interp, $2);
if (count > elems) count = elems;
if (!PMC_IS_NULL($1) && $3 > 0) {
INTVAL get_pos = 0;
INTVAL set_pos = VTABLE_elements(interp, $1);
VTABLE_set_integer_native(interp, $1, set_pos + count);
while (count > 0) {
VTABLE_set_pmc_keyed_int(interp, $1, set_pos,
VTABLE_get_pmc_keyed_int(interp, $2, get_pos));
count--;
get_pos++;
set_pos++;
}
}
if ($3 > 0)
VTABLE_splice(interp, $2, Parrot_pmc_new(interp, enum_class_ResizablePMCArray), 0, $3);
}
/*
=item perl6_caller_location(out INT)
Gets a unique ID representing the place the current routine was
called from. Used for implementing flip-flops.
=cut
*/
inline op perl6_callerid(out INT) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
PMC *caller_ctx = Parrot_pcc_get_caller_ctx(interp, cur_ctx);
$1 = Parrot_pcc_get_pc(interp, caller_ctx);
}
/*
=item capture_all_outers(in PMC)
Takes a list of Code objects that map to closures, finds those closures outers
can captures those contexts.
=cut
*/
inline op capture_all_outers(in PMC) :base_core {
PMC *cur_ctx = CURRENT_CONTEXT(interp);
INTVAL elems = VTABLE_elements(interp, $1);
INTVAL i;
for (i = 0; i < elems; i++) {
PMC *code_obj = VTABLE_get_pmc_keyed_int(interp, $1, i);
PMC *closure = ((Rakudo_Code *)PMC_data(code_obj))->_do;
PMC *ctx_to_diddle = PARROT_SUB(closure)->outer_ctx;
Parrot_pcc_set_outer_ctx_func(interp, ctx_to_diddle, cur_ctx);
}
}
/*
=item encodelocaltime(out INT, in PMC)
The inverse of C<decodelocaltime>.
=cut
*/
inline op encodelocaltime(out INT, in PMC) :base_core {
struct tm tm;
tm.tm_sec = VTABLE_get_integer_keyed_int(interp, $2, 0);
tm.tm_min = VTABLE_get_integer_keyed_int(interp, $2, 1);
tm.tm_hour = VTABLE_get_integer_keyed_int(interp, $2, 2);
tm.tm_mday = VTABLE_get_integer_keyed_int(interp, $2, 3);
tm.tm_mon = VTABLE_get_integer_keyed_int(interp, $2, 4) - 1;
tm.tm_year = VTABLE_get_integer_keyed_int(interp, $2, 5) - 1900;
/* We needn't bother setting tm_wday or tm_yday, since mktime
is required to ignore them. */
tm.tm_isdst = VTABLE_get_integer_keyed_int(interp, $2, 8);
$1 = mktime(&tm);
}
/*
=item perl6_based_rethrow(in PMC, in PMC)
Rethrow an exception, but instead of starting the search for a
matching ExceptionHandler in the current context, use another
exception as base for the rethrow.
=cut
*/
inline op perl6_based_rethrow(in PMC, in PMC) :base_core {
PMC *except = $1;
PMC *base = $2;
opcode_t *dest;
STRING *handlers_left_str = Parrot_str_new_constant(interp, "handlers_left");
PMC *base_ctx = (PMC *)VTABLE_get_pointer(interp, base);
INTVAL base_handlers_left = VTABLE_get_integer_keyed_str(interp, base, handlers_left_str);
VTABLE_set_pointer(interp, except, base_ctx);
VTABLE_set_integer_keyed_str(interp, except, handlers_left_str, base_handlers_left);
dest = Parrot_ex_rethrow_from_op(interp, except);
goto ADDRESS(dest);
}
/*
=item perl6_skip_handlers_in_rethrow(in PMC, in INT)
=cut
*/
inline op perl6_skip_handlers_in_rethrow(in PMC, in INT) :base_core {
PMC *except = $1;
STRING *handlers_left_str = Parrot_str_new_constant(interp, "handlers_left");
INTVAL handlers_left = VTABLE_get_integer_keyed_str(interp, except, handlers_left_str);
handlers_left -= $2
if (handlers_left < 0)
handlers_left = 0;
VTABLE_set_integer_keyed_str(interp, except, handlers_left_str, handlers_left);
}
/*
=item perl6_invoke_catchhandler(invar PMC, in PMC)
Works like invoke, but takes a parrot exception as second argument.
The perl6 spec says that the catchhandler's call chain must include
the callframes from the exception, so we do some context fiddling
here. When the catchhandler returns, it uses the continuation that
points to the original callchain.
Note that exceptions in the catchhandler must be caught and
possibly rethrown with perl6_based_rethrow, otherwise the handlers
from the exception will pick them up.
=cut
*/
inline op perl6_invoke_catchhandler(invar PMC, in PMC) :flow {
PMC * p = $1;
PMC * ctx = CURRENT_CONTEXT(interp);
opcode_t * dest = expr NEXT();
PMC * call_obj = Parrot_pcc_build_call_from_c_args(interp, PMCNULL, "P", $2);
PMC * cont = Parrot_pmc_new(interp, enum_class_Continuation);
PMC * ectx = PMCNULL;
VTABLE_set_pointer(interp, cont, dest);
Parrot_pcc_set_pc(interp, ctx, dest);
/* now the tricky part, restore exception context */
GETATTR_Exception_thrower(interp, $2, ectx);
if (PMC_IS_NULL(ectx))
ectx = ctx;
if (ectx != ctx)
Parrot_pcc_set_context(interp, ectx);
if (PMC_IS_NULL(p)) {
/* no function provided, return immediately */
PMC *basectx = find_common_ctx(interp, ctx, ectx);
rewind_to_ctx(interp, ectx, basectx, PMCNULL);
Parrot_pcc_set_context(interp, ctx);
goto NEXT();
} else {
interp->current_cont = cont;
Parrot_pcc_set_signature(interp, ectx, call_obj);
dest = VTABLE_invoke(interp, p, dest);
goto ADDRESS(dest);
}
}
inline op perl6_return_from_routine(in PMC) :flow {
PMC * ctx = CURRENT_CONTEXT(interp);
PMC * cont = PMCNULL;
opcode_t * dest = expr NEXT();
PMC * cctx;
PMC * basectx;
PMC * call_sig = build_sig_object(interp, PMCNULL, "P", $1);
STRING * lex_name = Parrot_str_new_constant(interp, "RETURN");
for (ctx = Parrot_pcc_get_caller_ctx(interp, ctx); !PMC_IS_NULL(ctx); ctx = Parrot_pcc_get_caller_ctx(interp, ctx)) {
PMC * const lex_pad = sub_find_pad(interp, lex_name, ctx);
if (!PMC_IS_NULL(lex_pad)) {
cont = VTABLE_get_pmc_keyed_str(interp, lex_pad, lex_name);
if (!PMC_IS_NULL(cont))
break;
}
}
if (PMC_IS_NULL(cont)) {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Attempt to return outside of any Routine");
}
ctx = CURRENT_CONTEXT(interp);
GETATTR_Continuation_to_ctx(interp, cont, cctx);
basectx = find_common_ctx(interp, ctx, cctx);
rewind_to_ctx(interp, ctx, basectx, $1);
Parrot_pcc_set_signature(interp, ctx, call_sig);
dest = VTABLE_invoke(interp, cont, dest);
goto ADDRESS(dest);
}
inline op perl6_returncc(in PMC) :flow {
PMC * ctx = CURRENT_CONTEXT(interp);
PMC * cont = Parrot_pcc_get_continuation(interp, ctx);
opcode_t * dest = expr NEXT();
PMC * cctx;
PMC * basectx;
PMC * call_sig = build_sig_object(interp, PMCNULL, "P", $1);
GETATTR_Continuation_to_ctx(interp, cont, cctx);
basectx = find_common_ctx(interp, ctx, cctx);
rewind_to_ctx(interp, ctx, basectx, $1);
Parrot_pcc_set_signature(interp, ctx, call_sig);
dest = VTABLE_invoke(interp, cont, dest);
goto ADDRESS(dest);
}
/*
=item perl6_capture_lex
Does a lexical capture, but based on a Perl 6 code object.
=cut
*/
inline op perl6_capture_lex(in PMC) {
if ($1->vtable->base_type == smo_id) {
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data($1);
Parrot_sub_capture_lex(interp, code_obj->_do);
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_capture_lex with a SixModelObject");
}
}
/*
=item perl6_get_outer_ctx
Returns the OUTER context of a Perl 6 code object. Needed for the fixups
that macros do.
=cut
*/
inline op perl6_get_outer_ctx(out PMC, in PMC) {
if ($2->vtable->base_type == smo_id) {
Rakudo_Code *code_obj = (Rakudo_Code *)PMC_data(Rakudo_cont_decontainerize(interp, $2));
if (code_obj->_do->vtable->base_type != enum_class_Sub)
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"perl6_get_outer_ctx did not get a Parrot Sub as expected, got %Ss",
VTABLE_name(interp, VTABLE_get_class(interp, $2)));
$1 = PARROT_SUB(code_obj->_do)->outer_ctx;
}
else {
Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
"Can only use perl6_get_outer_ctx with a SixModelObject");
}
}
/*
* Local variables:
* c-file-style: "parrot"
* End:
* vim: expandtab shiftwidth=4:
*/
Jump to Line
Something went wrong with that request. Please try again.