/*
** experimental.ops
*/

extern PMC* Parrot_NameSpace_get_name(Interp* interp, PMC* pmc);

VERSION = PARROT_VERSION;

=head1 NAME

experimental.ops - Experimental Operations

=cut

=head1 DESCRIPTION

This file contains operations that are in an experimental state. Do not
rely upon the existence of the ops in this file when writing production code.
No decision has yet been made as to whether they are accepted as regular
Parrot ops or not. They are included here for testing purposes only!

=cut

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

=head2 IO operations

=over 4

=cut

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

=item B<print_newline>()

Print a newline char to standard output.

=cut

op print_newline() :base_io {
  PMC * const io = PIO_STDOUT(interp);
  PIO_puts(interp, io, "\n");
  goto NEXT();
}

=item B<print_newline>(invar PMC)

Print a newline char to IO stream object $1.

=cut

op print_newline(invar PMC) :base_io {
  PMC * const io = $1;
  PIO_puts(interp, io, "\n");
  goto NEXT();
}

=back

=cut

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

=head2 Mathematical operations

Implementations of various mathematical operations

=over 4

=cut

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

=item B<gcd>(out INT, in NUM, in NUM)

Greatest Common divisor of $2 and $3.

=item B<gcd>(out INT, out INT, out INT, in INT, in INT)

Given $4 and $5, it calculates $1, $2 and $3 so that

$1 = gcd($4, $5) = $2 * $4 + $3 * $5 (d = gcd(a,b) = x*a + y*b)

=cut

inline op gcd(out INT, in NUM, in NUM) :advanced_math {

  FLOATVAL q = 0;
  FLOATVAL c = 0;
  FLOATVAL temp2 = $2 < 0.0 ? -$2 : $2;
  FLOATVAL temp3 = $3 < 0.0 ? -$3 : $3;
  while (temp3 != 0) {
    q = floor( (FLOATVAL)temp2/temp3 );
    c = temp2 - temp3*q;
    temp2 = temp3;
    temp3 = c;
  }
  $1 = (INTVAL)temp2;
  goto NEXT();
}

inline op gcd(out INT, out INT, out INT, in INT, in INT) :advanced_math {
  /* r0 = q1*r1 + r2 */
  INTVAL r0 = $4 < 0 ? -$4 : $4;
  INTVAL r1 = $5 < 0 ? -$5 : $5;
  INTVAL r2 = 0;
  INTVAL q1 = 0;

  INTVAL xkm1 = 1;
  INTVAL xk = 0;
  INTVAL xkp1 = 0;

  INTVAL ykm1 = 0;
  INTVAL yk = 1;
  INTVAL ykp1 = 0;

  INTVAL n = 1;

  INTVAL x;
  INTVAL y;

  while (1) {
    q1 = r0/r1;
    r2 = r0 - q1*r1;
    if (r2 == 0) {
      break;
    }
    r0 = r1;
    r1 = r2;

    xkp1 = q1*xk + xkm1;
    xkm1 = xk;
    xk = xkp1;

    ykp1 = q1*yk + ykm1;
    ykm1 = yk;
    yk = ykp1;
  }
  $1 = r1;
  $2 = (INTVAL)( xk * pow( -1, n ) );
  $3 = (INTVAL)( yk * pow( -1, n+1 ) );

  x = $2 * $4;
  y = $3 * $5;

  /* correct the sign (can be wrong because we used abs($4) and abs($5) */
  if ( x + y == r1 ) {
    /* no correction necessary */
  }
  else if ( x + y == -r1 ) {
    $2 = -$2;
    $3 = -$3;
  }
  else if ( x - y == r1 ) {
    $3 = -$3;
  }
  else if ( -x + y == r1 ) {
    $2 = -$2;
  }

  goto NEXT();
}

=back

=cut

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

=head2 Misc other ops

=over 4

=cut

=item B<splice>(invar PMC, invar PMC, in INT, in INT)

Replace $4 values at offset $3 in aggregate $1 with the PMCs in aggregate $2.
The values are put into the aggregate by a shallow copy. If the values would
be reused, they have to be B<clone>d.

=cut

inline op splice(invar PMC, invar PMC, in INT, in INT) {
    $1->vtable->splice(interp, $1, $2, $3, $4);
    goto NEXT();
}


=item B<slice>(out PMC, invar PMC, in KEY)

Return a new Iterator PMC $1 for aggregate $2 and Slice PMC $3.

=item B<slice>(out PMC, invar PMC, in KEY, inconst INT)

Return a new list PMC $1 for aggregate $2 and Slice PMC $3.

This is a Python opcode. Range is i <= k < j. $4 must be 1.
May change and move to python.ops.

=item B<iter>(out PMC, invar PMC)

Return a new Iterator PMC $1 for aggregate $2.

=cut

inline op slice (out PMC, invar PMC, in KEY) :base_core {
    $1 = $2->vtable->slice(interp, $2, $3, 0);
    goto NEXT();
}

inline op slice (out PMC, invar PMC, in KEY, inconst INT) :python {
    $1 = $2->vtable->slice(interp, $2, $3, $4);
    goto NEXT();
}

inline op iter (out PMC, invar PMC) :base_core {
    $1 = $2->vtable->get_iter(interp, $2);
    goto NEXT();
}

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

=item B<morph>(invar PMC, in INT)

Have $1 turn itself into a PMC of type $2.

=cut

inline op morph(invar PMC, in INT) {
  VTABLE_morph(interp, $1, $2);
  goto NEXT();
}

=item B<exec>(in STR)

Execute the passed-in command. Completely tosses the current process
image and replaces it with the command. Doesn't exit (the program
ends, after all), though it does throw an exception if something goes
wrong.

=cut

inline op exec(in STR) {
  Parrot_Exec_OS_Command(interp, $1);
  goto NEXT();
}


=item B<classname>(out PMC, invar PMC)

Get the class name for the class in $2 and put it in $1. Note that $1 will be
a Key PMC that you can use with "new", for example.

=cut

op classname(out PMC, invar PMC) :object_base {
    PMC *ns = Parrot_NameSpace_get_name(interp,
                                    VTABLE_namespace(interp, $2));
    if (PMC_IS_NULL(ns) || VTABLE_elements(interp, ns) < 2)
    {
        real_exception(interp, NULL, NO_CLASS,
            "Attempt to get class name of a non-class.");
    }
    else
    {
        PMC *key_tail, *key;
        STRING *tmp;
        int i, max;

        /* Need to turn list of strings into a key. Note that we are not
           including the first item in the array, since that is the HLL. */
        tmp = VTABLE_get_string_keyed_int(interp, ns, 1);
        $1 = key_tail = key_new_string(interp, tmp);
        max = VTABLE_elements(interp, ns);
        for (i = 2; i < max; i++)
        {
            tmp = VTABLE_get_string_keyed_int(interp, ns, i);
            key = key_new_string(interp, tmp);
            key_append(interp, key_tail, key);
            key_tail = key;
        }
    }
    goto NEXT();
}

=back

=head2 More Experimental Ops

=over 4

=item C<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>.

=cut

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

=item B<pow>(out NUM, in NUM, in INT)

Set $1 to $2 raised to the power $3.

=cut

inline op pow(out NUM, in NUM, in INT) :base_core {
    FLOATVAL n2 = $2;
    FLOATVAL res = 1.0;
    INTVAL   e  = $3;
    int s = 1;
    if (e != 0) {
        if (e < 0) {
            s = -1;
            e = -e;
        }
    }
    while (e) {
        if (e & 1) {
            res *= n2;
        }
        n2 *= n2;
        e >>= 1;
    }
    if (s < 0) {
        res = 1.0/res;
    }
    $1 = res;
    goto NEXT();
}

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

Return the class PMC of the type $2.

=cut

op getclass(out PMC, in INT) {
    int typ = $2;
    if (typ < 1 || typ >= interp->n_vtable_max)
        real_exception(interp, NULL, E_ValueError,
                "type number out of range");
    $1 = interp->vtables[typ]->class;
    goto NEXT();
}

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

Create a new PMC of the type $2 according to the PMCs string representation
in $3. See also B<instantiate> for a more general form.

BUT SINCE INSTANTIATE WILL PROBABLY DIE, DON'T USE THIS;
OR IF YOU NEED THIS (OR INSTANTIATE), TELL CHIP

=cut

op new(out PMC, in INT, in STR) {
  PMC *class;
  if ($2 <= 0 || $2 >= interp->n_vtable_max) {
    real_exception(interp, 0, NO_CLASS,
                   "Illegal PMC enum (%d) in new", (int)$2);
  }
  class = interp->vtables[$2]->class;
  $1 = VTABLE_new_from_string(interp, class, $3, 0);
  goto NEXT();
}

=item B<instantiate>(out PMC)

Create a new PMC of the type of class ARGS[0]. This is a classmethod.
Arguments are passed according to the calling conventions in
F<docs/pdds/pdd03_calling_conventions.pod> with the C<set_args> opcode.
See also the I<getclass> opcode to get a class PMC.
BUT SINCE INSTANTIATE WILL PROBABLY DIE, DON'T USE IT;
OR IF YOU NEED IT, TELL CHIP

=cut

op instantiate(out PMC) {
  opcode_t* arg_op;
  PMC *sig, *class;
  int typ;

  arg_op = interp->current_args;
  if (!arg_op) {
        real_exception(interp, NULL, NULL_REG_ACCESS,
            "No set_args with instantiate");
  }
  sig = CONTEXT(interp->ctx)->constants[arg_op[1]]->u.key;
  ASSERT_SIG_PMC(sig);
  if (!SIG_ELEMS(sig)) {
        real_exception(interp, NULL, E_ValueError,
            "Empty signature with instantiate");
  }
  switch (SIG_ITEM(sig, 0)) {
      case PARROT_ARG_IC:
          typ = arg_op[2];
          if (typ <= 1 || typ >= interp->n_vtable_max) {
              real_exception(interp, NULL, E_ValueError,
                      "Illegal PMC enum (%d) in instantiate", typ);
          }
          class = interp->vtables[typ]->class;
          break;
      case PARROT_ARG_P:
          class = REG_PMC(arg_op[2]);
          break;
      default:
          internal_exception(UNIMPLEMENTED,
                  "uninplement class argument in instantiate");
          class = NULL; /* just for cc */
          break;
  }
  $1 = VTABLE_instantiate(interp, class, sig);
  interp->current_args = NULL;
  goto NEXT();
}

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

Extract some information about PMC $2 and store it in $1.
Possible values for $3 are:

=over 4

=item .PMCINFO_FLAGS Get the PMC's flags.

=back

B<TODO> move/officalize this opcode at next op cleanup.

=cut

op pmcinfo(out INT, invar PMC, inconst INT) {
  switch ($3) {
    case PMCINFO_FLAGS:    $1 = PObj_get_FLAGS($2); break;
  }
  goto NEXT();
}

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

=item B<new>(out PMC, invar PMC)

=cut

inline op new(out PMC, invar PMC) :object_classes {
    INTVAL type;
    switch ($2->vtable->base_type) {
        case enum_class_String:
                type = pmc_type(interp, PMC_str_val($2));
            if (type <= 0)
                real_exception(interp, NULL, NO_CLASS,
                    "Class '%Ss' not found", PMC_str_val($2));
            $1 = pmc_new(interp, type);
            break;
        case enum_class_Key:
            type = pmc_type_p(interp, $2);
            if (type <= 0)
                real_exception(interp, NULL, NO_CLASS,
                    "Class '%Ss' not found", readable_name(interp, $2));
            $1 = pmc_new(interp, type);
            break;
        default:
            real_exception(interp, NULL, NO_CLASS,
                "Can only use a Key or String PMC with new");
    }
    goto NEXT();
}

=item B<add_io_event>(invar PMC, invar PMC, invar PMC, inconst INT)

Call the sub $2 for PIO $1 with user data $3 on ready state of $4. XXX The
only handled $4 = IO_THR_MSG_ADD_SELECT_RD aka 2 for now.

=cut

op add_io_event(invar PMC, invar PMC, invar PMC, inconst INT) {
    Parrot_event_add_io_event(interp, $1, $2, $3, $4);
    goto NEXT();
}

=item B<need_finalize>(invar PMC)

The ParrotObject $1 needs the __finalize method during GC.

=cut

op need_finalize(invar PMC) {
    PMC* pmc = $1;
    if (PObj_is_object_TEST(pmc)) {
        PObj_get_FLAGS(pmc) |= PObj_need_finalize_FLAG;
    }
    goto NEXT();
}


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

=item B<runinterp>(invar PMC, in PMC)

Invokes the PMC $2 using interp $1.

=cut

op runinterp(invar PMC, in PMC) {
    Interp * const new_interp = (Interp *)PMC_data($1);
    opcode_t *pc;
    Interp_flags_SET(new_interp, PARROT_EXTERN_CODE_FLAG);
    pc = VTABLE_invoke(new_interp, $2, NULL);
    Parrot_runops_fromc_args(new_interp, $2, "P");
    goto NEXT();
}

=back

=head1 COPYRIGHT

Copyright (C) 2001-2004, The Perl 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:
 */
