Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: 9bd6a5cd5d
Fetching contributors…

Cannot retrieve contributors at this time

226 lines (161 sloc) 6.598 kB
/*
* Copyright (C) 2006-2008, The Parrot Foundation.
*/
BEGIN_OPS_PREAMBLE
#include "parrot/parrot.h"
#include "parrot/string_funcs.h"
#include "parrot/exceptions.h"
#include "src/binary.h"
END_OPS_PREAMBLE
=head1 NAME
tcl.ops
=cut
=head1 DESCRIPTION
A dynamic opcode library for tcl on parrot that provides a few opcodes
that simplify PIR generation for tcl.
BUGS: pull out the TCL_ constants, as well as the code slot(#9)
=cut
=head1 C<[binary]> opcodes
=over 4
=item B<tcl_binary_scan>(out PMC, in STR, in STR)
Scan $2 for the fields specified in $3 and return their values in $1.
=cut
inline op tcl_binary_scan(out PMC, in STR, in STR) {
$1 = ParTcl_binary_scan(interp, $2, $3);
}
=item B<tcl_binary_format>(out STR, in STR, in PMC)
Format the values in $3 into a string $1 according to the format in $2.
=cut
inline op tcl_binary_format(out STR, in STR, in PMC) {
$1 = ParTcl_binary_format(interp, $2, $3);
}
=back
=head1 Flow control opcodes
These opcodes are used to generate exception return values. (Anything that
isn't a TCL_OK).
=over 4
=item B<tcl_error>(in STR, in PMC, in PMC)
Generate a TCL_ERROR with $1 as the value, set $errorInfo to $2,
and $errorCode to $3
=item B<tcl_error>(in STR, in PMC)
Generate a TCL_ERROR with $1 as the value, and set $errorInfo $2,
use $errorCode of C<NONE>.
=item B<tcl_error>(in STR)
Generate a TCL_ERROR with $1 as the message, use $errorCode of C<NONE>,
and $errorInfo of C<''>.
=cut
inline op tcl_error(in STR, in PMC, in PMC) :flow {
PMC *errorCode, *errorInfo, *ns;
PMC *const root_ns = interp->root_namespace;
PMC *tcl_key = pmc_new(interp, enum_class_Key);
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_ERROR, $1);
opcode_t * const ret = expr NEXT();
opcode_t * dest;
/* Set the globals */
VTABLE_set_string_native(interp, tcl_key, string_from_literal(interp, "tcl"));
ns = Parrot_ns_get_namespace_keyed(interp, root_ns, tcl_key);
errorInfo = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorInfo"));
VTABLE_assign_pmc(interp, errorInfo, $2);
errorCode = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorCode"));
VTABLE_assign_pmc(interp, errorCode, $3);
/* Throw the exception */
dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
inline op tcl_error(in STR, in PMC) :flow {
PMC *errorCode, *errorInfo, *ns;
PMC *const root_ns = interp->root_namespace;
PMC *tcl_key = pmc_new(interp, enum_class_Key);
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_ERROR, $1);
opcode_t * const ret = expr NEXT();
opcode_t * dest;
PMC *newEC;
/* Set the globals */
VTABLE_set_string_native(interp, tcl_key, string_from_literal(interp, "tcl"));
ns = Parrot_ns_get_namespace_keyed(interp, root_ns, tcl_key);
errorInfo = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorInfo"));
VTABLE_assign_pmc(interp, errorInfo, $2);
errorCode = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorCode"));
newEC = pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String));
VTABLE_set_string_native(interp, newEC, string_from_literal(interp, "NONE"));
VTABLE_assign_pmc(interp, errorCode, newEC);
/* Throw the exception */
dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
inline op tcl_error(in STR) :flow {
PMC *errorCode, *errorInfo, *ns;
PMC *const root_ns = interp->root_namespace;
PMC *tcl_key = pmc_new(interp, enum_class_Key);
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_ERROR, $1);
opcode_t * const ret = expr NEXT();
opcode_t * dest;
PMC *newEC, *newEI;
/* Set the globals */
VTABLE_set_string_native(interp, tcl_key, string_from_literal(interp, "tcl"));
ns = Parrot_ns_get_namespace_keyed(interp, root_ns, tcl_key);
errorInfo = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorCode"));
newEI = pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String));
VTABLE_set_string_native(interp, newEI, string_from_literal(interp, ""));
VTABLE_assign_pmc(interp, errorInfo, newEI);
errorCode = Parrot_ns_find_namespace_global(interp, ns, string_from_literal(interp, "$errorCode"));
newEC = pmc_new(interp, Parrot_get_ctx_HLL_type(interp, enum_class_String));
VTABLE_set_string_native(interp, newEC, string_from_literal(interp, "NONE"));
VTABLE_assign_pmc(interp, errorCode, newEC);
/* Throw the exception */
dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
=item B<tcl_return>(in PMC)
=item B<tcl_return>(in STR)
Generate a TCL_RETURN, returning the specified value
=cut
inline op tcl_return(in PMC) :flow {
opcode_t * const ret = expr NEXT();
STRING *msg = PMC_IS_NULL($1)
? NULL : VTABLE_get_string(interp, $1);
PMC *exception =
Parrot_ex_build_exception(interp, EXCEPT_error, CONTROL_RETURN, msg);
opcode_t *dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
inline op tcl_return(in STR) :flow {
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_RETURN, $1);
opcode_t * const ret = expr NEXT();
opcode_t * const dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
=item B<tcl_break>()
Generate a TCL_BREAK
=cut
inline op tcl_break() :flow {
STRING *empty = Parrot_str_new_noinit(interp, 0);
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_BREAK, empty);
opcode_t * const ret = expr NEXT();
opcode_t * const dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
=item B<tcl_continue>()
Generate a TCL_CONTINUE
=cut
inline op tcl_continue() :flow {
STRING *empty = Parrot_str_new_noinit(interp, 0);
PMC *exception = Parrot_ex_build_exception(interp, EXCEPT_error,
CONTROL_CONTINUE, empty);
opcode_t * const ret = expr NEXT();
opcode_t * const dest = Parrot_ex_throw_from_op(interp, exception, ret);
goto ADDRESS(dest);
}
=back
=cut
/*
* Local variables:
* c-file-style: "parrot"
* End:
* vim: expandtab shiftwidth=4:
*/
Jump to Line
Something went wrong with that request. Please try again.