experimental.ops

/*
 * $Id$
** experimental.ops
*/

=head1 NAME

experimental.ops - Experimental Opcodes

=cut

=head1 DESCRIPTION

This file contains experimental opcodes.

These opcodes should be considered implicitly deprecated - that is, they
may be removed in any release.

If you rely on any of these opcodes, please open a
Trac ticket at L<https://trac.parrot.org/>.


=cut

###############################################################################

=head2 More Experimental Ops

=over 4

=item B<trap>()

Break into debugger. Implementation notes:

 - x86/gcc ... works with gdb
 - ppc/gcc ... works with gdb, to proceed: gdb> p $pc = $pc + 4
 - TODO

For other architectures, this is a C<noop>.

=back

=cut

op trap() :deprecated {
#if defined(__GNUC__) && defined(i386)
    __asm__("int3");       /* opcode 0xcc */
#endif
#if defined(__GNUC__) && defined(PPC)
    __asm__("trap");       /* opcode tr 31, 0, 0 */
#endif
}

=over 4

=item B<set_label>(invar PMC, inconst LABEL)

Sets the opcode_t* label value for the given PMC. This is basically only
useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives

=item B<get_label>(out INT, invar PMC)

Gets the opcode_t* label value from the given PMC. This is basically only
useful for PMCs such as Sub, Continuation, ExceptionHandler and derivatives

=back

=cut

inline op set_label(invar PMC, inconst LABEL) {
    VTABLE_set_pointer(interp, $1, (CUR_OPCODE + $2));
}

inline op get_label(out INT, invar PMC) {
    void * const ptr = VTABLE_get_pointer(interp, $2);
    $1 =  PTR2INTVAL(ptr);
}

=over 4

=item B<fetch>(out PMC, in PMC, in PMC, in PMC)

Fetches a value from $2, keyed by $3 into $1.  If the resulting PMC is PMCNULL,
uses the type in $4 to create and return a new PMC.

=item B<fetch>(out PMC, in PMC, in INT, in PMC)

=item B<fetch>(out PMC, in PMC, in STR, in PMC)

=back

=cut

inline op fetch(out PMC, in PMC, in PMC, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed(interp, $2, $3);
    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);
        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }
    }
}

inline op fetch(out PMC, in PMC, in INT, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3);
    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);
        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }
    }
}

inline op fetch(out PMC, in PMC, in STR, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3);
    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);
        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }
    }
}

=over 4

=item B<vivify>(out PMC, in PMC, in PMC, in PMC)

Fetches a value from $2, keyed by $3 into $1.  If the resulting PMC is PMCNULL,
uses the type in $4 to create and return a new PMC.

=item B<vivify>(out PMC, in PMC, in INT, in PMC)

=item B<vivify>(out PMC, in PMC, in STR, in PMC)

=back

=cut

inline op vivify(out PMC, in PMC, in PMC, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);

        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }
        VTABLE_set_pmc_keyed(interp, $2, $3, $1);
    }
}

inline op vivify(out PMC, in PMC, in INT, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_int(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);
        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }

        VTABLE_set_pmc_keyed_int(interp, $2, $3, $1);
    }
}

inline op vivify(out PMC, in PMC, in STR, in PMC) :base_core {
    $1 = VTABLE_get_pmc_keyed_str(interp, $2, $3);

    if (PMC_IS_NULL($1)) {
        PMC * const classobj = Parrot_oo_get_class(interp, $4);
        if (!PMC_IS_NULL(classobj))
            $1 = VTABLE_instantiate(interp, classobj, PMCNULL);
        else {
            const INTVAL type = Parrot_pmc_get_type(interp, $4);
            if (type <= 0) {
                opcode_t *dest = Parrot_ex_throw_from_op_args(
                    interp, expr NEXT(), EXCEPTION_NO_CLASS,
                    "Class '%Ss' not found", VTABLE_get_repr(interp, $4));
                goto ADDRESS(dest);
            }

            $1 = Parrot_pmc_new(interp, type);
        }

        VTABLE_set_pmc_keyed_str(interp, $2, $3, $1);
    }
}

=over 4

=item B<new>(out PMC, in STR, in INT)

=item B<new>(out PMC, in PMC, in INT)

=back

=cut


op new(out PMC, in STR, in INT) {
    STRING * const name   = $2;
    PMC    * const _class = Parrot_pcc_get_HLL(interp, CURRENT_CONTEXT(interp))
                          ? Parrot_oo_get_class_str(interp, name)
                          : PMCNULL;

    if (!PMC_IS_NULL(_class)) {
        PMC *initial = Parrot_pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_Integer));
        VTABLE_set_integer_native(interp, initial, $3);
        $1 = VTABLE_instantiate(interp, _class, initial);
    }
    else {
        const INTVAL type = Parrot_pmc_get_type_str(interp, name);
        if (type <= 0) {
            opcode_t *dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
                EXCEPTION_NO_CLASS,
                "Class '%Ss' not found", name);
            goto ADDRESS(dest);
        }
        $1 = Parrot_pmc_new_init_int(interp, type, $3);
    }
}


op new(out PMC, in PMC, in INT) {
    PMC * const  name_key = $2;

    /* get_class() returns a PMCProxy for core types, so check for core PMCs */
    const INTVAL type = Parrot_pmc_get_type(interp, name_key);

    /* if it's clearly a PIR-level PMC */
    if (type > enum_class_core_max) {
        PMC * const _class = Parrot_oo_get_class(interp, name_key);
        if (!PMC_IS_NULL(_class)) {
            PMC *initial = Parrot_pmc_new(interp,
                Parrot_get_ctx_HLL_type(interp, enum_class_Integer));
            VTABLE_set_integer_native(interp, initial, $3);
            $1 = VTABLE_instantiate(interp, _class, initial);
        }
    }

    /* if it's a core PMC */
    else if (type > enum_class_default)
        $1 = Parrot_pmc_new_init_int(interp, type, $3);

    /* it's a typo */
    else {
        opcode_t *dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
            EXCEPTION_NO_CLASS,
            "Class '%Ss' not found", VTABLE_get_repr(interp, name_key));
        goto ADDRESS(dest);
    }
}

=over 4

=item B<root_new>(out PMC, in PMC, in INT)

=back

=cut

op root_new(out PMC, in PMC, in INT) {
    PMC * const  name_key = $2;

    /* get_class() returns a PMCProxy for core types, so check for core PMCs */
    const INTVAL type = Parrot_pmc_get_type(interp, name_key);

    /* if it's clearly a PIR-level PMC */
    if (type > enum_class_core_max) {
        PMC * const root_ns  = interp->root_namespace;
        PMC * const ns       = Parrot_get_namespace_keyed(interp, root_ns, name_key);
        PMC * const _class   = Parrot_oo_get_class(interp, ns);
        if (!PMC_IS_NULL(_class)) {
            PMC *initial = Parrot_pmc_new(interp,
                Parrot_get_ctx_HLL_type(interp, enum_class_Integer));
            VTABLE_set_integer_native(interp, initial, $3);
            $1 = VTABLE_instantiate(interp, _class, initial);
        }
    }

    /* if it's a core PMC */
    else if (type > enum_class_default)
        $1 = Parrot_pmc_new_init_int(interp, type, $3);

    /* it's a typo */
    else {
        opcode_t *dest = Parrot_ex_throw_from_op_args(interp, expr NEXT(),
            EXCEPTION_NO_CLASS,
            "Class '%Ss' not found", VTABLE_get_repr(interp, name_key));
        goto ADDRESS(dest);
    }
}

=head1 COPYRIGHT

Copyright (C) 2001-2010, Parrot Foundation.

=head1 LICENSE

This program is free software. It is subject to the same license
as the Parrot interp itself.

=cut

/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */