/*
** object.ops
*/


VERSION = PARROT_VERSION;

=head1 NAME

object.ops

=head1 DESCRIPTION

Parrot's library of object ops

=over 4

=cut

=item B<callmethodcc>(invar PMC, in STR)

Call method $2 with invocant $1 and generate a new return continuation.
The invocant ($1) is used for method lookup. The object is passed as
the first argument in B<set_args>.

Throws a Method_Not_Found_Exception for a non-existent method.

=item B<callmethodcc>(invar PMC, invar PMC)

Like above but use the Sub object $2 as method.

=item B<callmethod>(invar PMC, in STR, invar PMC)

=item B<callmethod>(invar PMC, invar PMC, invar PMC)

Like above, but use continuation $3 instead of creating a new continuation.

=cut

=item B<tailcallmethod>(invar PMC, in STR)

=item B<tailcallmethod>(invar PMC, invar PMC)

Make a tailcall to method $2 with invocant $1.

=cut

op callmethodcc(invar PMC, in STR) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next;
  STRING *meth;

  object = $1;
  meth = $2;
  next = expr NEXT();
  interp->current_object = object;
  interp->current_cont = NEED_CONTINUATION;
  interp->current_method = meth;
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (!method_pmc) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

op callmethodcc(invar PMC, invar PMC) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next;

  object = $1;
  method_pmc = $2;
  /* XXX should we check if object.can(method) */

  next = expr NEXT();
  interp->current_object = object;
  interp->current_cont = NEED_CONTINUATION;
  interp->current_method = VTABLE_get_string(interp, method_pmc);
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

op callmethod(invar PMC, in STR, invar PMC) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next;
  STRING *meth;

  object = $1;
  meth = $2;
  next = expr NEXT();
  interp->current_object = object;
  interp->current_cont = $3;
  interp->current_method = meth;
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (!method_pmc) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

op callmethod(invar PMC, invar PMC, invar PMC) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next;

  object = $1;
  method_pmc = $2;

  next = expr NEXT();
  interp->current_object = object;
  interp->current_cont = $3;
  interp->current_method = VTABLE_get_string(interp, method_pmc);
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

op tailcallmethod(invar PMC, in STR) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next = expr NEXT();
  STRING *meth;

  object = $1;
  meth = $2;
  interp->current_cont = CONTEXT(interp->ctx)->current_cont;
  PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
  interp->current_object = object;
  interp->current_method = meth;
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (!method_pmc) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

op tailcallmethod(invar PMC, invar PMC) :object_base {
  opcode_t *dest;
  PMC *method_pmc, *object;
  opcode_t *next = expr NEXT();

  object = $1;
  method_pmc = $2;
  interp->current_cont = CONTEXT(interp->ctx)->current_cont;
  PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
  interp->current_object = object;
  interp->current_method = VTABLE_get_string(interp, method_pmc);
  dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
  goto ADDRESS(dest);
}

=item B<addmethod>(invar PMC, in STR, invar PMC)

Adds $3 as a method named $2 to $1.

=cut

inline op addmethod(invar PMC, in STR, invar PMC) :object_classes {
  VTABLE_add_method(interp, $1, $2, $3);
  goto NEXT();
}

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

Sets $1 to true or false, depending on whether $2 ->can the method in $3.

=cut

inline op can(out INT, invar PMC, in STR) :object_base {
  $1 = $2->vtable->can(interp, $2, $3);
  goto NEXT();
}

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

Sets $1 to true or false, depending on whether $2 ->does the interface in $3.

See L<tools/build/pmc2c.pl> for a list of available interfaces.

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

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

Sets $1 to true or false, depending on whether $2 isa $3.

=cut

inline op does(out INT, invar PMC, in STR) :object_base {
  $1 = $2->vtable->does(interp, $2, $3);
  goto NEXT();
}

inline op isa(out INT, invar PMC, in STR) :object_base {
  $1 = $2->vtable->isa(interp, $2, $3);
  goto NEXT();
}

inline op isa(out INT, invar PMC, in PMC) :object_base {
    PMC *class = Parrot_class_lookup_p(interp, $3);
    $1 = Parrot_object_isa(interp, $2, class);
    goto NEXT();
}

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

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

Creates a new Parrot-style class, named $2, and puts the new PMC for it
into $1.

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

Create a new Parrot-style class, with the hierarchical name given in $2.

=cut

inline op newclass(out PMC, in STR) :object_classes {
  PMC *name = pmc_new(interp, enum_class_String);
  VTABLE_set_string_native(interp, name, $2);
  $1 = pmc_new_init(interp, enum_class_ParrotClass, name);
  goto NEXT();
}

inline op newclass(out PMC, in PMC) :object_classes {
    $1 = pmc_new_init(interp, enum_class_ParrotClass, $2);
    goto NEXT();
}

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

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

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

KLUDGE ALERT - OPCODE NAME SHOULD DIFFER FROM BELOW - XXX FIXME

Create a new class, put in $1, that is a subclass of $2.  $3, if available
and not null, is the name of the new class--if not, the subclass is an
anonymous subclass.

=cut

inline op subclass(out PMC, invar PMC) :object_classes {
  $1 = VTABLE_subclass(interp, $2, PMCNULL);
  goto NEXT();
}

inline op subclass(out PMC, invar PMC, in STR) :object_classes {
  PMC *name = pmc_new(interp, enum_class_String);
  VTABLE_set_string_native(interp, name, $3);
  $1 = VTABLE_subclass(interp, $2, name);
  goto NEXT();
}

inline op subclass(out PMC, invar PMC, in PMC) :object_classes {
  $1 = VTABLE_subclass(interp, $2, $3);
  goto NEXT();
}

=item B<subclass>(out PMC, inconst PMC)

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

=item B<subclass>(out PMC, inconst PMC, in PMC)

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

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

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

KLUDGE ALERT - OPCODE NAME SHOULD DIFFER FROM ABOVE - XXX FIXME

Create a new class, put in $1, that is a subclass of the class named $2.
$3, if available and not null, is the name of the new class--if not, the
subclass is an anonymous subclass.

=cut

op subclass(out PMC, inconst PMC) :object_classes {
  PMC *class = Parrot_class_lookup_p(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    STRING *name = readable_name(interp, $2);
    real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", name);
  }
  $1 = VTABLE_subclass(interp, class, PMCNULL);
  goto ADDRESS(next);
}

op subclass(out PMC, in STR) :object_classes {
  PMC *class = Parrot_class_lookup(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", $2);
  }
  $1 = VTABLE_subclass(interp, class, PMCNULL);
  goto ADDRESS(next);
}


op subclass(out PMC, inconst PMC, in STR) :object_classes {
  PMC *class = Parrot_class_lookup_p(interp, $2);
  PMC *subname_p;
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    STRING *name = readable_name(interp, $2);
    real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", name);
  }
  subname_p = pmc_new(interp, enum_class_String);
  VTABLE_set_string_native(interp, subname_p, $3);
  $1 = VTABLE_subclass(interp, class, subname_p);
  goto NEXT();
}

op subclass(out PMC, in STR, in STR) :object_classes {
  PMC *class = Parrot_class_lookup(interp, $2);
  PMC *subname_p;
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", $2);
  }
  subname_p = pmc_new(interp, enum_class_String);
  VTABLE_set_string_native(interp, subname_p, $3);
  $1 = VTABLE_subclass(interp, class, subname_p);
  goto ADDRESS(next);
}


op subclass(out PMC, inconst PMC, in PMC) :object_classes {
  PMC *class = Parrot_class_lookup_p(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    STRING *name = readable_name(interp, $2);
    real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", name);
  }
  $1 = VTABLE_subclass(interp, class, $3);
  goto ADDRESS(next);
}

op subclass(out PMC, in STR, in PMC) :object_classes {
  PMC *class = Parrot_class_lookup(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    real_exception(interp, next, NO_CLASS, "Class '%s' doesn't exist",
                string_to_cstring( interp, $2 ));
  }
  $1 = VTABLE_subclass(interp, class, $3);
  goto ADDRESS(next);
}

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

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

Find the PMC for a class, by name.

=cut

inline op getclass(out PMC, in STR) :object_classes {
  PMC *class = Parrot_class_lookup(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    real_exception(interp, next, NO_CLASS, "Class '%s' doesn't exist",
                string_to_cstring( interp, $2 ));
  }
  else
    $1 = class;
  goto ADDRESS(next);
}

inline op getclass(out PMC, in PMC) :object_classes {
  PMC *class = Parrot_class_lookup_p(interp, $2);
  opcode_t *next = expr NEXT();
  if (PMC_IS_NULL(class)) {
    STRING *name = readable_name(interp, $2);
    real_exception(interp, next, NO_CLASS,
         "Class '%Ss' doesn't exist", name);
  }
  else
    $1 = class;
  goto ADDRESS(next);
}

=item B<singleton>(invar PMC)  B<(unimplemented)>

Take the object in $1 and put it into its own singleton class, which is
an anonymous subclass of the object's current class.

=cut

inline op singleton(invar PMC) :object_classes {
  goto NEXT();
}

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

Get the class PMC for the object in $2 and put it in $1.

=cut

inline op class(out PMC, invar PMC) :object_classes {
    $1 = VTABLE_get_class(interp, $2);
    goto NEXT();
}

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

Get the class name for the class in $2 and put it in $1.

=cut

inline op classname(out STR, invar PMC) :object_base {
    $1 = VTABLE_name(interp, $2);
    goto NEXT();
}


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


=item B<addparent>(invar PMC, invar PMC)

Add class $2 to the list of parent classes for $1.

=cut

inline op addparent(invar PMC, invar PMC) :object_classes {
    VTABLE_add_parent(interp, $1, $2);
    goto NEXT();
}

=item B<removeparent>(invar PMC, invar PMC)

Remove class $2 from class $1's list of parents.

=cut

inline op removeparent(invar PMC, invar PMC) :object_classes {
    Parrot_remove_parent(interp, $2, $1);
    goto NEXT();
}

=item B<addattribute>(invar PMC, in STR)

Add the attribute named $2 to the class $1.

=cut

inline op addattribute(invar PMC, in STR) :object_classes {
    Parrot_add_attribute(interp, $1, $2);
    goto NEXT();
}

=item B<removeattribute>(invar PMC, in STR) B<(unimplemented)>

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

Remove attribute $2 from class $1, specified either by name or offset.

=cut

op removeattribute(invar PMC, in STR) {
    internal_exception(UNIMPLEMENTED, "removeattribute is not implemented");
    goto NEXT();
}

op removeattribute(invar PMC, in INT) {
    internal_exception(UNIMPLEMENTED, "removeattribute is not implemented");
    goto NEXT();
}

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

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

Get attribute number $3 from object $2 and put the result in $1.
String attribute names have to be fully qualified.

=cut

inline op getattribute(out PMC, invar PMC, in INT) :object_classes {
    $1 = VTABLE_get_attr(interp, $2, $3);
    goto NEXT();
}

inline op getattribute(out PMC, invar PMC, in STR) :object_classes {
    $1 = VTABLE_get_attr_str(interp, $2, $3);
    goto NEXT();
}

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

=item B<setattribute>(invar PMC, in STR, invar PMC)

Set attribute $2 of object $1 to $3

=cut

inline op setattribute(invar PMC, in INT, invar PMC) :object_classes {
    VTABLE_set_attr(interp, $1, $2, $3);
    goto NEXT();
}

inline op setattribute(invar PMC, in STR, invar PMC) :object_classes {
    VTABLE_set_attr_str(interp, $1, $2, $3);
    goto NEXT();
}

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

Returns the offset of the first attribute for class $3 in object $2.
Throws an exception if $3 isn't in $2's hierarchy.

=cut

op classoffset(out INT, invar PMC, in STR) :object_classes {
    opcode_t *next = expr NEXT();
    INTVAL offset;
    offset = Parrot_class_offset(interp, $2, $3);
    if (offset < 0) {
        real_exception(interp, next, NO_CLASS,
            "Class not parent of object");
    }
    $1 = offset;
    goto ADDRESS(next);
}


=item B<adddoes>(invar PMC, in STR) B<(unimplemented)>

Add $2 to the list of interfaces that this class claims to implement.

=item B<removedoes>(invar PMC, in STR) B<(unimplemented)>

Remove $2 from the list of interfaces that this class claims to
implement.

=cut

op adddoes(invar PMC, in STR) :object_classes {
    internal_exception(UNIMPLEMENTED, "removedoes is not implemented");
    goto NEXT();
}

op removedoes(invar PMC, in STR) :object_classes {
    internal_exception(UNIMPLEMENTED, "removedoes is not implemented");
    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 interpreter itself.

=cut

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