/*
 * $Id: experimental.ops 47678 2010-06-18 00:29:10Z whiteknight $
** experimental.ops
*/

BEGIN_OPS_PREAMBLE

#if PARROT_HAS_ICU
#  include <unicode/uchar.h>
#endif

END_OPS_PREAMBLE

=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/>.

When making changes to any ops file, run C<make bootstrap-ops> to regenerate
all generated ops files.

=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)

=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_ns_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);
    }
}

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

Set $1 to the codepoint with the name given in $2, or -1 if there is none.
Requires ICU lib, otherwise exception is thrown.

=cut

op find_codepoint(out INT, in STR) {
#if PARROT_HAS_ICU
    UErrorCode   err       = U_ZERO_ERROR;
    char * const cstr      = Parrot_str_to_cstring(interp, $2);
    UChar32      codepoint = u_charFromName(U_EXTENDED_CHAR_NAME, cstr, &err);
    Parrot_str_free_cstring(cstr);
    $1 = U_SUCCESS(err) ? (INTVAL) codepoint : -1;
#else
    opcode_t * const dest = expr NEXT();
    Parrot_ex_throw_from_op_args(interp, dest, EXCEPTION_LIBRARY_ERROR,
        "no ICU lib loaded");
#endif
}

=item B<finalize>(in PMC)

Finalize exception handling, freeing any information needed to resume
the handled exception, like inner runloops.
$1 is the Exception handled or the ExceptionHandler that is handling it.
EXPERIMENTAL. Handle with care.

=cut

op finalize(in PMC) {
    /* Go to the next op after loop unrolling */
    opcode_t * const dest = expr NEXT();
    PMC *eh = PMCNULL;
    if (!PMC_IS_NULL($1)) {
        /* If isa ExceptionHandler, use it. If isa Exception, get its active handler */
        if (VTABLE_isa(interp, $1, Parrot_str_new_constant(interp, "ExceptionHandler")))
            eh = $1;
        else if (VTABLE_isa(interp, $1, Parrot_str_new_constant(interp, "Exception"))) {
            PMC *iter = VTABLE_get_attr_str(interp,
                                            $1, Parrot_str_new_constant(interp, "handler_iter"));
            if (!PMC_IS_NULL(iter))
                eh = VTABLE_get_pmc_keyed_int(interp, iter, -1);
        }
    }
    if (!PMC_IS_NULL(eh)) {
        /* Get the runloop_id from the continuation and jump to it. */
        Parrot_runloop *rl = interp->current_runloop;
        INTVAL rid;
        Parrot_pcc_invoke_method_from_c_args(interp,
                                             eh, Parrot_str_new_constant(interp, "rid"),
                                             "->I", &rid);
        while (rl && rl->id != rid)
            rl = rl->prev;
        if (rl) {
            if (rl != interp->current_runloop) {
                rl->handler_start = dest;
                longjmp(rl->resume, 3);
            }
        }
        else
            Parrot_ex_throw_from_c_args(interp, NULL,
                    EXCEPTION_INVALID_OPERATION, "missing runloop");
    }
}


=back

=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:
 */
