/*
** tcl.ops
*/

#include "parrot/parrot.h"
#include "parrot/string_funcs.h"

#include "../binary.h"

VERSION = PARROT_VERSION;

=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 tclPIR generation for tcl

BUGS: pull out the TCL_ constants, as well as the code slot (#9) and the
message slot (#0)

=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);
    goto NEXT();
}

=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);
    goto NEXT();
}

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

=item B<tcl_error>(in STR)

Generate a TCL_ERROR with $1 as the value.

=item B<tcl_error>(in STR, in PMC)

Generate a TCL_ERROR with $1 as the value, and set $errorCode to $2

=item B<tcl_error>(in INT, in PMC)

Generate a $1 with $2 as the value.

=cut

inline op tcl_error(in PMC) {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_ERROR = 1;
  PMC* exception = pmc_new(interp, enum_class_Exception);

  VTABLE_set_pmc_keyed_int(interp, exception, (INTVAL)0, $1);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_ERROR);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

inline op tcl_error(in STR) {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_ERROR = 1;
  PMC* exception = pmc_new(interp, enum_class_Exception);

  VTABLE_set_string_keyed_int(interp, exception, 0, $1);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_ERROR);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

inline op tcl_error(in STR, in PMC) {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_ERROR = 1;
  PMC* errorCode, *ns;
  PMC* const root_ns = interp->root_namespace;
  PMC* exception = pmc_new(interp, enum_class_Exception);
  PMC* tcl_key = pmc_new(interp, enum_class_Key);

  VTABLE_set_string_native(interp, tcl_key, string_from_const_cstring(interp,"tcl",0));
  ns = Parrot_get_namespace_keyed(interp, root_ns, tcl_key);

  errorCode = Parrot_find_global_n(interp, ns, string_from_const_cstring(interp,"$errorCode",0));
  VTABLE_assign_pmc(interp, errorCode, $2);

  VTABLE_set_string_keyed_int(interp, exception, 0, $1);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_ERROR);

  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

inline op tcl_error(in INT, in PMC) {
  opcode_t * ret;
  opcode_t * dest;
  PMC* exception = pmc_new(interp, enum_class_Exception);

  VTABLE_set_pmc_keyed_int(interp, exception, 0, $2);
  VTABLE_set_integer_keyed_int(interp, exception, 9, $1);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(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) {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_RETURN = 2;
  PMC* exception = pmc_new(interp, enum_class_Exception);

  VTABLE_set_pmc_keyed_int(interp, exception, 0, $1);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_RETURN);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

inline op tcl_return(in STR) {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_RETURN = 2;
  PMC* exception = pmc_new(interp, enum_class_Exception);

  VTABLE_set_string_keyed_int(interp, exception, 0, $1);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_RETURN);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

=item B<tcl_break>()

Generate a TCL_BREAK

=cut

inline op tcl_break() {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_BREAK = 3;
  PMC* exception = pmc_new(interp, enum_class_Exception);
  STRING* empty = string_make_empty(interp, enum_stringrep_one, 0);

  VTABLE_set_string_keyed_int(interp, exception, 0, empty);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_BREAK);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

=item B<tcl_continue>()

Generate a TCL_CONTINUE

=cut

inline op tcl_continue() {
  opcode_t * ret;
  opcode_t * dest;
  INTVAL TCL_CONTINUE = 4;
  PMC* exception = pmc_new(interp, enum_class_Exception);
  STRING* empty = string_make_empty(interp, enum_stringrep_one, 0);

  VTABLE_set_string_keyed_int(interp, exception, 0, empty);
  VTABLE_set_integer_keyed_int(interp, exception, 9, TCL_CONTINUE);
  ret = expr NEXT();
  dest = (opcode_t *)
      throw_exception(interp, exception, ret);
  goto ADDRESS(dest);
}

=back

=cut

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