Пример #1
0
/*

=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;
}
Пример #2
0
void
IMCC_warning(ARGMOD(imc_info_t * imcc), ARGIN(const char *fmt), ...)
{
    ASSERT_ARGS(IMCC_warning)
    va_list ap;
    va_start(ap, fmt);
    imcc->error_message = Parrot_str_concat(imcc->interp,
                                            imcc->error_message,
                                            Parrot_vsprintf_c(imcc->interp, fmt, ap));
    va_end(ap);
}
Пример #3
0
PARROT_DOES_NOT_RETURN
void
IMCC_fataly(ARGMOD(imc_info_t * imcc), SHIM(int code), ARGIN(const char *fmt), ...)
{
    ASSERT_ARGS(IMCC_fataly)
    STRING * location;
    va_list ap;

    va_start(ap, fmt);
    location = IMCC_get_err_location(imcc);
    imcc->error_message = Parrot_str_concat(imcc->interp,
        imcc->error_message,
        Parrot_sprintf_c(imcc->interp, "error:imcc:%Ss\n\t%Ss",
        Parrot_vsprintf_c(imcc->interp, fmt, ap),
        location));
    va_end(ap);
    Parrot_ex_throw_from_c_args(imcc->interp, NULL, IMCC_FATALY_EXCEPTION,
        "%Ss", imcc->error_message);
}
Пример #4
0
static void
nums_dump(PARROT_INTERP, const PackFile_Segment *self)
{
    const STRING           *debug_name = Parrot_str_concat(interp, self->name,
            Parrot_str_new_constant(interp, "_DB"));
    const PackFile_Segment *debug      = PackFile_find_segment(interp,
                                            self->dir, debug_name, 1);

    opcode_t   * pc            = self->data;
    opcode_t   * debug_ops     = debug->data;
    op_info_t ** const op_info = interp->code->op_info_table;

    while (pc < self->data + self->size) {
        /* n can't be const; the ADD_OP_VAR_PART macro increments it */
        size_t n = (size_t)op_info[*pc]->op_count;

        Parrot_io_printf(interp, " %04x:  %s\n",
            *(debug_ops++), op_info[*pc]->full_name);

        ADD_OP_VAR_PART(interp, interp->code, pc, n);
        pc += n;
    }
}
Пример #5
0
/* 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;
}
Пример #6
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(PARROT_INTERP, PMC *lexpad, PMC *sig_pmc, PMC *capture,
                    INTVAL no_nom_type_check, STRING **error) {
    INTVAL            i, num_pos_args;
    INTVAL            bind_fail   = 0;
    INTVAL            cur_pos_arg = 0;
    Rakudo_Signature *sig         = (Rakudo_Signature *)PMC_data(sig_pmc);
    PMC              *params      = sig->params;
    INTVAL            num_params  = VTABLE_elements(interp, params);
    Rakudo_BindVal    cur_bv;

    /* If we do have some named args, we want to make a clone of the hash
     * to work on. We'll delete stuff from it as we bind, and what we have
     * left over can become the slurpy hash or - if we aren't meant to be
     * taking one - tell us we have a problem. */
    PMC *named_args_copy = PMCNULL;

    /* If we have a |$foo that's followed by slurpies, then we can suppress
     * any future arity checks. */
    INTVAL suppress_arity_fail = 0;
    
    /* If it's a Parrot capture, it may contain natively typed arguments.
     * NOTE: This is a really an encapsulation breakage; if Parrot folks
     * change stuff and this breaks, it's not Parrot's fault. */
    struct Pcc_cell * pc_positionals = NULL;

    /* Set up statics. */
    if (!smo_id)
        setup_binder_statics(interp);

    /* If we've got a CallContext, just has an attribute with list of named
     * parameter names. Otherwise, it's probably a Perl 6 Capture and we need
     * to extract its parts. */
    if (capture->vtable->base_type == enum_class_CallContext) {
        PMC *named_names = VTABLE_get_attr_str(interp, capture, NAMED_str);
        if (!PMC_IS_NULL(named_names)) {
            PMC *iter = VTABLE_get_iter(interp, named_names);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, name,
                        VTABLE_get_pmc_keyed_str(interp, capture, name));
            }
        }
        GETATTR_CallContext_positionals(interp, capture, pc_positionals);
    }
    else if (capture->vtable->base_type == smo_id &&
            STABLE(capture)->type_check(interp, capture, Rakudo_types_capture_get())) {
        PMC *captype   = Rakudo_types_capture_get();
        PMC *list_part = VTABLE_get_attr_keyed(interp, capture, captype, LIST_str);
        PMC *hash_part = VTABLE_get_attr_keyed(interp, capture, captype, HASH_str);
        capture = Rakudo_isnqplist(list_part) 
                    ?  list_part 
                    : Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
        if (hash_part->vtable->base_type == enum_class_Hash) {
            PMC *iter = VTABLE_get_iter(interp, hash_part);
            named_args_copy = Parrot_pmc_new(interp, enum_class_Hash);
            while (VTABLE_get_bool(interp, iter)) {
                STRING *arg_copy_name = VTABLE_shift_string(interp, iter);
                VTABLE_set_pmc_keyed_str(interp, named_args_copy, arg_copy_name,
                    VTABLE_get_pmc_keyed_str(interp, hash_part, arg_copy_name));
            }
        }
    }
    else {
        Parrot_ex_throw_from_c_args(interp, NULL, EXCEPTION_INVALID_OPERATION,
                "Internal Error: Rakudo_binding_bind passed invalid Capture");
    }

    /* Now we'll walk through the signature and go about binding things. */
    num_pos_args = VTABLE_elements(interp, capture);
    for (i = 0; i < num_params; i++) {
        Rakudo_Parameter *param = (Rakudo_Parameter *)PMC_data(
                VTABLE_get_pmc_keyed_int(interp, params, i));

        /* Is it looking for us to bind a capture here? */
        if (param->flags & SIG_ELEM_IS_CAPTURE) {
            /* Capture the arguments from this point forwards into a Capture.
             * Of course, if there's no variable name we can (cheaply) do pretty
             * much nothing. */
            if (STRING_IS_NULL(param->variable_name)) {
                bind_fail = BIND_RESULT_OK;
            }
            else {
                PMC *captype    = Rakudo_types_capture_get();
                PMC *capsnap    = REPR(captype)->allocate(interp, STABLE(captype));
                PMC *pos_args   = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                PMC *named_args = Parrot_pmc_new(interp, enum_class_Hash);
                INTVAL k;
                VTABLE_set_attr_keyed(interp, capsnap, captype, LIST_str, pos_args);
                VTABLE_set_attr_keyed(interp, capsnap, captype, HASH_str, named_args);
                for (k = cur_pos_arg; k < num_pos_args; k++) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, k);
                    VTABLE_push_pmc(interp, pos_args, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                }
                if (!PMC_IS_NULL(named_args_copy)) {
                    PMC *iter = VTABLE_get_iter(interp, named_args_copy);
                    while (VTABLE_get_bool(interp, iter)) {
                        STRING *name = VTABLE_shift_string(interp, iter);
                        VTABLE_set_pmc_keyed_str(interp, named_args, name,
                            VTABLE_get_pmc_keyed_str(interp, named_args_copy, name));
                    }
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = capsnap;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param, cur_bv,
                        no_nom_type_check, error);
            }
            if (bind_fail) {
                return bind_fail;
            }
            else if (i + 1 == num_params) {
                /* Since a capture acts as "the ultimate slurpy" in a sense, if
                 * this is the last parameter in the signature we can return
                 * success right off the bat. */
                return BIND_RESULT_OK;
            }
            else {
                Rakudo_Parameter *next_param = (Rakudo_Parameter *)PMC_data(
                    VTABLE_get_pmc_keyed_int(interp, params, i + 1));
                if (next_param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_NAMED))
                    suppress_arity_fail = 1;
            }
        }

        /* Could it be a named slurpy? */
        else if (param->flags & SIG_ELEM_SLURPY_NAMED) {
            /* Can cheat a bit if it's the default method %_.
             * We give the hash to the lexpad. */
            if (param->flags & SIG_ELEM_METHOD_SLURPY_NAMED && lexpad->vtable->base_type == p6l_id) {
                SETATTR_Perl6LexPad_default_named_slurpy(interp, lexpad, named_args_copy);
                PARROT_GC_WRITE_BARRIER(interp, lexpad);
            }
            else {
                /* We'll either take the current named arguments copy hash which
                 * will by definition contain all unbound named parameters and use
                 * that, or just create an empty one. */
                PMC *slurpy = PMC_IS_NULL(named_args_copy) ?
                        Parrot_pmc_new(interp, enum_class_Hash) :
                        named_args_copy;
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = Rakudo_binding_create_hash(interp, slurpy);
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, no_nom_type_check, error);
                if (bind_fail)
                    return bind_fail;
            }
            
            /* Nullify named arguments hash now we've consumed it, to mark all
             * is well. */
            named_args_copy = PMCNULL;
        }

        /* Otherwise, maybe it's a positional. */
        else if (PMC_IS_NULL(param->named_names)) {
            /* Slurpy or LoL-slurpy? */
            if (param->flags & (SIG_ELEM_SLURPY_POS | SIG_ELEM_SLURPY_LOL)) {
                /* Create Perl 6 array, create RPA of all remaining things, then
                 * store it. */
                PMC *temp = Parrot_pmc_new(interp, enum_class_ResizablePMCArray);
                while (cur_pos_arg < num_pos_args) {
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    VTABLE_push_pmc(interp, temp, cur_bv.type == BIND_VAL_OBJ ?
                        cur_bv.val.o :
                        create_box(interp, cur_bv));
                    cur_pos_arg++;
                }
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = param->flags & SIG_ELEM_SLURPY_POS ?
                    Rakudo_binding_create_positional(interp, temp) :
                    Rakudo_binding_create_lol(interp, temp);
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, no_nom_type_check, error);
                if (bind_fail)
                    return bind_fail;
            }

            /* Otherwise, a positional. */
            else {
                /* Do we have a value?. */
                if (cur_pos_arg < num_pos_args) {
                    /* Easy - just bind that. */
                    cur_bv = get_positional_bind_val(interp, pc_positionals, capture, cur_pos_arg);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, no_nom_type_check, error);
                    if (bind_fail)
                        return bind_fail;
                    cur_pos_arg++;
                }
                else {
                    /* No value. If it's optional, fetch a default and bind that;
                     * if not, we're screwed. Note that we never nominal type check
                     * an optional with no value passed. */
                    if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                        cur_bv.type = BIND_VAL_OBJ;
                        cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                        bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                                cur_bv, 0, error);
                        if (bind_fail)
                            return bind_fail;
                    }
                    else {
                        if (error)
                            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 0);
                        return BIND_RESULT_FAIL;
                    }
                }
            }
        }

        /* Else, it's a non-slurpy named. */
        else {
            /* Try and get hold of value. */
            PMC *value = PMCNULL;
            INTVAL num_names = VTABLE_elements(interp, param->named_names);
            INTVAL j;
            if (!PMC_IS_NULL(named_args_copy)) {
                for (j = 0; j < num_names; j++) {
                    STRING *name = VTABLE_get_string_keyed_int(interp, param->named_names, j);
                    value = VTABLE_get_pmc_keyed_str(interp, named_args_copy, name);
                    if (!PMC_IS_NULL(value)) {
                        /* Found a value. Delete entry from to-bind args and stop looking. */
                        VTABLE_delete_keyed_str(interp, named_args_copy, name);
                        break;
                    }
                }
            }

            /* Did we get one? */
            if (PMC_IS_NULL(value)) {
                /* Nope. We'd better hope this param was optional... */
                if (param->flags & SIG_ELEM_IS_OPTIONAL) {
                    cur_bv.type = BIND_VAL_OBJ;
                    cur_bv.val.o = Rakudo_binding_handle_optional(interp, param, lexpad);
                    bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                            cur_bv, 0, error);
                }
                else if (!suppress_arity_fail) {
                    if (error)
                        *error = Parrot_sprintf_c(interp, "Required named parameter '%S' not passed",
                                VTABLE_get_string_keyed_int(interp, param->named_names, 0));
                    return BIND_RESULT_FAIL;
                }
            }
            else {
                cur_bv.type = BIND_VAL_OBJ;
                cur_bv.val.o = value;
                bind_fail = Rakudo_binding_bind_one_param(interp, lexpad, sig, param,
                        cur_bv, 0, error);
            }

            /* If we got a binding failure, return it. */
            if (bind_fail)
                return bind_fail;
        }
    }

    /* Do we have any left-over args? */
    if (cur_pos_arg < num_pos_args && !suppress_arity_fail) {
        /* Oh noes, too many positionals passed. */
        if (error)
            *error = Rakudo_binding_arity_fail(interp, params, num_params, num_pos_args, 1);
        return BIND_RESULT_FAIL;
    }
    if (!PMC_IS_NULL(named_args_copy) && VTABLE_elements(interp, named_args_copy)) {
        /* Oh noes, unexpected named args. */
        if (error) {
            INTVAL num_extra = VTABLE_elements(interp, named_args_copy);
            PMC *iter        = VTABLE_get_iter(interp, named_args_copy);
            if (num_extra == 1) {
                *error = Parrot_sprintf_c(interp, "Unexpected named parameter '%S' passed",
                        VTABLE_shift_string(interp, iter));
            }
            else {
                INTVAL first  = 1;
                STRING *comma = Parrot_str_new(interp, ", ", 0);
                *error = Parrot_sprintf_c(interp, "%d unexpected named parameters passed (", num_extra);
                while (VTABLE_get_bool(interp, iter)) {
                    STRING *name = VTABLE_shift_string(interp, iter);
                    if (!first)
                        *error = Parrot_str_concat(interp, *error, comma);
                    else
                        first = 0;
                    *error = Parrot_str_concat(interp, *error, name);
                }
                *error = Parrot_str_concat(interp, *error, Parrot_str_new(interp, ")", 0));
            }
        }
        return BIND_RESULT_FAIL;
    }

    /* If we get here, we're done. */
    return BIND_RESULT_OK;
}
Пример #7
0
/* 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;
}
Пример #8
0
void
parrot_init_library_paths(PARROT_INTERP)
{
    ASSERT_ARGS(parrot_init_library_paths)
    PMC    *paths;
    STRING *entry;
    STRING *versionlib      = NULL;
    STRING *builddir        = NULL;
    PMC * const iglobals    = interp->iglobals;
    PMC * const config_hash = VTABLE_get_pmc_keyed_int(interp, iglobals,
                                (INTVAL)IGLOBALS_CONFIG_HASH);

    /* create the lib_paths array */
    PMC * const lib_paths   = Parrot_pmc_new_init_int(interp,
            enum_class_FixedPMCArray, PARROT_LIB_PATH_SIZE);
    VTABLE_set_pmc_keyed_int(interp, iglobals,
            IGLOBALS_LIB_PATHS, lib_paths);

    if (VTABLE_elements(interp, config_hash)) {
        STRING * const libkey      = CONST_STRING(interp, "libdir");
        STRING * const verkey      = CONST_STRING(interp, "versiondir");
        STRING * const builddirkey = CONST_STRING(interp, "build_dir");
        STRING * const installed   = CONST_STRING(interp, "installed");

        versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
        entry      = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
        versionlib = Parrot_str_concat(interp, versionlib, entry);

        if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed))
            builddir = VTABLE_get_string_keyed_str(interp,
                                config_hash, builddirkey);
    }

    /* each is an array of strings */
    /* define include paths */
    paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
    VTABLE_set_pmc_keyed_int(interp, lib_paths,
            PARROT_LIB_PATH_INCLUDE, paths);
    { /* EXPERIMENTAL: add include path from environment */
        const char *envvar = Parrot_getenv(interp,
                                           Parrot_str_new_constant(interp, "PARROT_INCLUDE"));
        if (envvar != NULL  && envvar[0]) {
            entry = Parrot_str_new(interp, envvar, 0);
            VTABLE_push_string(interp, paths, entry);
        }
    }
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"));
        VTABLE_push_string(interp, paths, entry);
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"));
        VTABLE_push_string(interp, paths, entry);
    }
    entry = CONST_STRING(interp, "./");
    VTABLE_push_string(interp, paths, entry);
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"));
        VTABLE_push_string(interp, paths, entry);
    }

    /* define library paths */
    paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
    VTABLE_set_pmc_keyed_int(interp, lib_paths,
            PARROT_LIB_PATH_LIBRARY, paths);
    { /* EXPERIMENTAL: add library path from environment */
        const char *envvar = Parrot_getenv(interp,
                                           Parrot_str_new_constant(interp, "PARROT_LIBRARY"));
        if (envvar != NULL && envvar[0]) {
            entry = Parrot_str_new(interp, envvar, 0);
            VTABLE_push_string(interp, paths, entry);
        }
    }
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"));
        VTABLE_push_string(interp, paths, entry);
    }
    entry = CONST_STRING(interp, "./");
    VTABLE_push_string(interp, paths, entry);
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/"));
        VTABLE_push_string(interp, paths, entry);
    }

    /* define languages paths */
    paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
    VTABLE_set_pmc_keyed_int(interp, lib_paths,
            PARROT_LIB_PATH_LANG, paths);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"));
        VTABLE_push_string(interp, paths, entry);
    }
    entry = CONST_STRING(interp, "./");
    VTABLE_push_string(interp, paths, entry);
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/"));
        VTABLE_push_string(interp, paths, entry);
    }

    /* define dynext paths */
    paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
    VTABLE_set_pmc_keyed_int(interp, lib_paths,
            PARROT_LIB_PATH_DYNEXT, paths);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"));
        VTABLE_push_string(interp, paths, entry);
    }
    entry = CONST_STRING(interp, "dynext/");
    VTABLE_push_string(interp, paths, entry);
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/"));
        VTABLE_push_string(interp, paths, entry);
    }

    /* shared exts */
    paths = Parrot_pmc_new(interp, enum_class_ResizableStringArray);
    VTABLE_set_pmc_keyed_int(interp, lib_paths,
            PARROT_LIB_DYN_EXTS, paths);
    /* no CONST_STRING here - the c2str.pl preprocessor needs "real strs" */
    entry = Parrot_str_new_constant(interp, PARROT_LOAD_EXT);
    VTABLE_push_string(interp, paths, entry);
    /* OS/X has .dylib and .bundle */
    if (!STREQ(PARROT_LOAD_EXT, PARROT_SHARE_EXT)) {
        entry = Parrot_str_new_constant(interp, PARROT_SHARE_EXT);
        VTABLE_push_string(interp, paths, entry);
    }

#ifdef PARROT_PLATFORM_LIB_PATH_INIT_HOOK
    PARROT_PLATFORM_LIB_PATH_INIT_HOOK(interp, lib_paths);
#endif
}
Пример #9
0
PARROT_EXPORT
void
Parrot_lib_update_paths_from_config_hash(PARROT_INTERP)
{
    ASSERT_ARGS(Parrot_lib_update_paths_from_config_hash)
    STRING * versionlib = NULL;
    STRING * entry = NULL;
    STRING * builddir = NULL;
    PMC * const lib_paths =
        VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_LIB_PATHS);
    PMC * const config_hash =
        VTABLE_get_pmc_keyed_int(interp, interp->iglobals, IGLOBALS_CONFIG_HASH);
    PMC * paths;

    if (VTABLE_elements(interp, config_hash)) {
        STRING * const libkey      = CONST_STRING(interp, "libdir");
        STRING * const verkey      = CONST_STRING(interp, "versiondir");
        STRING * const builddirkey = CONST_STRING(interp, "build_dir");
        STRING * const installed   = CONST_STRING(interp, "installed");

        versionlib = VTABLE_get_string_keyed_str(interp, config_hash, libkey);
        entry      = VTABLE_get_string_keyed_str(interp, config_hash, verkey);
        versionlib = Parrot_str_concat(interp, versionlib, entry);

        if (!VTABLE_get_integer_keyed_str(interp, config_hash, installed))
            builddir = VTABLE_get_string_keyed_str(interp,
                                config_hash, builddirkey);
    }

    paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_INCLUDE);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/"));
        VTABLE_push_string(interp, paths, entry);
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/include/"));
        VTABLE_push_string(interp, paths, entry);
    }
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/include/"));
        VTABLE_push_string(interp, paths, entry);
    }

    paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LIBRARY);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/library/"));
        VTABLE_push_string(interp, paths, entry);
    }
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/library/"));
        VTABLE_push_string(interp, paths, entry);
    }

    paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_LANG);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/languages/"));
        VTABLE_push_string(interp, paths, entry);
    }
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/languages/"));
        VTABLE_push_string(interp, paths, entry);
    }

    paths = VTABLE_get_pmc_keyed_int(interp, lib_paths, PARROT_LIB_PATH_DYNEXT);
    if (!STRING_IS_NULL(builddir)) {
        entry = Parrot_str_concat(interp, builddir, CONST_STRING(interp, "/runtime/parrot/dynext/"));
        VTABLE_push_string(interp, paths, entry);
    }
    if (!STRING_IS_NULL(versionlib)) {
        entry = Parrot_str_concat(interp, versionlib, CONST_STRING(interp, "/dynext/"));
        VTABLE_push_string(interp, paths, entry);
    }
}