object.ops

/*
** object.ops
*/

#include "parrot/method_util.h"

VERSION = PARROT_VERSION;

=head1 NAME

object.ops

=head1 DESCRIPTION

Parrot's library of object ops

=over 4

=cut

=item B<callmethodcc>(in 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>(in PMC, in PMC)

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

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

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

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

=cut

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

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

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

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

Find the method $3 for object $2 and put it in $1.
Throws a Method_Not_Found_Exception for a non-existent method.
The returned PMC may be outdated, when the call is actually performed and
changes to the underlying classes where made.

=cut

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

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

op callmethodcc(in PMC, in 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();
  interpreter->current_object = object;
  interpreter->current_cont = NEED_CONTINUATION;
  interpreter->current_method = VTABLE_get_string(interpreter, method_pmc);
  dest = (opcode_t *)VTABLE_invoke(interpreter, method_pmc, next);
  goto ADDRESS(dest);
}

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

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

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

  object = $1;
  method_pmc = $2;

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

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

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

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

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

op fetchmethod(out PMC, in PMC, in STR) {
  opcode_t *next = expr NEXT();
  $1 = VTABLE_find_method(interpreter, $2, $3);
  if (!$1) {
    real_exception(interpreter, next, METH_NOT_FOUND,
        "Method '%Ss' not found", $3);
  }
  goto ADDRESS(next);
}

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

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

=cut

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

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

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

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

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

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

=cut

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

inline op isa(out INT, in PMC, in STR) :object_base {
  $1 = $2->vtable->isa(interpreter, $2, $3);
  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. (This is a real out--the contents of $1 are ignored and the
pointer for the new PMC is put in there).

=cut

inline op newclass(out PMC, in STR) :object_classes {
  PMC* class = $1 = pmc_new(interpreter, enum_class_ParrotClass);
  Parrot_new_class(interpreter, class, $2);
  goto NEXT();
}

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

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

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

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

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

$1 is replaced--a new PMC for the subclass is generated and put in it.

=cut

inline op subclass(out PMC, in PMC, in STR) :object_base {
  $1 = VTABLE_subclass(interpreter, $2, $3);
  goto NEXT();
}

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

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

op subclass(out PMC, in STR) :object_classes {
  PMC *class = Parrot_class_lookup(interpreter, $2);
  if (PMC_IS_NULL(class)) {
    internal_exception(NO_CLASS, "Class '%s' doesn't exist",
		string_to_cstring( interpreter, $2 ));
  }
  $1 = VTABLE_subclass(interpreter, class, NULL);
  goto NEXT();
}

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

Find the PMC for a class, by name. Note that this is a one-level hash, so for
classes that have some structure you need to impose that structure externally.

Parrot's conventions are that level separators are noted with the NULL
character, so Perl's Foo::Bar would be Foo\0Bar.

=cut

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

=item B<singleton>(in 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(in PMC) :object_classes {
  goto NEXT();
}

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

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

=cut

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

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

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

=cut

inline op classname(out STR, in PMC) :object_base {
  PMC* classname_pmc;

  if (!(PObj_get_FLAGS($2) & (PObj_is_class_FLAG|PObj_is_object_FLAG))) {
    $1 = VTABLE_name(interpreter, $2);
  }
  else {
    classname_pmc = get_attrib_num((Buffer *)PMC_data($2), PCD_CLASS_NAME);
    if (classname_pmc) {
      $1 = VTABLE_get_string(interpreter, classname_pmc);
    }
    else {
      internal_exception(NO_CLASS, "Class doesn't exist");
    }
  }
  goto NEXT();
}


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


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

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

=cut

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

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

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

=cut

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

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

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

=cut

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

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

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

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

=cut

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

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

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

=item B<getattribute>(out PMC, in 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, in PMC, in INT) :object_classes {
    $1 = VTABLE_get_attr(interpreter, $2, $3);
    goto NEXT();
}

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

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

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

Set attribute $2 of object $1 to $3

=cut

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

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

=item B<classoffset>(out INT, in 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, in PMC, in STR) :object_classes {
    INTVAL offset;
    offset = Parrot_class_offset(interpreter, $2, $3);
    if (offset < 0) {
        internal_exception(NO_CLASS, "Class not parent of object");
    }
    $1 = offset;
    goto NEXT();
}


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

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

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

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

=cut

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

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

=back

=head1 COPYRIGHT

Copyright (C) 2001-2004 The Perl Foundation.  All rights reserved.

=head1 LICENSE

This program is free software. It is subject to the same license
as the Parrot interpreter itself.

=cut