object.ops

/*

Copyright (C) 2001-2007, The Perl Foundation.
$Id$

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();
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (PMC_IS_NULL(method_pmc)) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  interp->current_object = object;
  interp->current_cont = NEED_CONTINUATION;
  dest = 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;
  /* RT#42371 should we check if object.can(method) */

  next = expr NEXT();
  interp->current_object = object;
  interp->current_cont = NEED_CONTINUATION;
  dest = 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();
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (PMC_IS_NULL(method_pmc)) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  interp->current_object = object;
  interp->current_cont = $3;
  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;
  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;
  method_pmc = VTABLE_find_method(interp, object, meth);
  if (PMC_IS_NULL(method_pmc)) {
    real_exception(interp, next, METH_NOT_FOUND,
        "Method '%Ss' not found", meth);
  }
  interp->current_cont = CONTEXT(interp->ctx)->current_cont;
  PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
  interp->current_object = object;
  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;
  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 result $1 to the result of the "can" vtable function for PMC $2,
given method $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 result $1 to the result of the "does" vtable function for PMC $2,
given interface $3.

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

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


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

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

Sets result $1 to the result of the "isa" vtable function for PMC $2,
given class $3.

=cut

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

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

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

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

Create 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 name given in $2 as a key,
namespace, or string PMC.

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

inline op newclass(out PMC, in PMC) :object_classes {
    $1 = pmc_new_init(interp, enum_class_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 PMC, in PMC)

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, in PMC) :object_classes {
    PMC *parent_class = Parrot_oo_get_class(interp, $2);
    opcode_t *next = expr NEXT();
    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                  "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
    }
    $1 = pmc_new(interp, enum_class_Class);
    VTABLE_add_parent(interp, $1, parent_class);
    goto ADDRESS(next);
}

inline op subclass(out PMC, in PMC, in STR) :object_classes {
    PMC *parent_class = Parrot_oo_get_class(interp, $2);
    opcode_t *next = expr NEXT();
    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                  "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
    }
    $1 = Parrot_oo_newclass_from_str(interp, $3);
    VTABLE_add_parent(interp, $1, parent_class);
    goto ADDRESS(next);
}

inline op subclass(out PMC, in PMC, in PMC) :object_classes {
    PMC *parent_class = Parrot_oo_get_class(interp, $2);
    opcode_t *next = expr NEXT();
    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                  "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
    }
    $1 = pmc_new_init(interp, enum_class_Class, $3);
    VTABLE_add_parent(interp, $1, parent_class);
    goto ADDRESS(next);
}

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

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, in STR) :object_classes {
    PMC *parent_class = Parrot_oo_get_class_str(interp, $2);
    opcode_t *next = expr NEXT();
    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                  "Class '%Ss' doesn't exist", $2);
    }

    $1 = pmc_new(interp, enum_class_Class);
    VTABLE_add_parent(interp, $1, parent_class);
    goto ADDRESS(next);
}

op subclass(out PMC, in STR, in STR) :object_classes {
    PMC *parent_class = Parrot_oo_get_class_str(interp, $2);
    opcode_t *next = expr NEXT();

    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", $2);
    }

    $1  = Parrot_oo_newclass_from_str(interp, $3);
    VTABLE_add_parent(interp, $1, parent_class);
    goto ADDRESS(next);
}

op subclass(out PMC, in STR, in PMC) :object_classes {
    PMC *parent_class = Parrot_oo_get_class_str(interp, $2);
    opcode_t *next   = expr NEXT();

    if (PMC_IS_NULL(parent_class)) {
      real_exception(interp, next, NO_CLASS,
                "Class '%Ss' doesn't exist", $2);
    }

    $1 = pmc_new_init(interp, enum_class_Class, $3);
    VTABLE_add_parent(interp, $1, parent_class);
    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. Deprecated - works with the old class
system.

=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)) {
        char *class_name = string_to_cstring(interp, $2);
        real_exception(interp, next, NO_CLASS, "Class '%s' doesn't exist",
                class_name);
    }
    else
        $1 = _class;

  goto ADDRESS(next);
/*  real_exception(interp, NULL, UNIMPLEMENTED,
        "The 'getclass' opcode has been deprecated, use 'get_class'. See RT #47972.");*/
}

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);
/*  real_exception(interp, NULL, UNIMPLEMENTED,
        "The 'getclass' opcode has been deprecated, use 'get_class'. See RT #47972.");*/
}

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

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

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

Find the PMC for a class, by string name or by key.

=cut

inline op get_class(out PMC, in STR) :object_classes {
  $1 = Parrot_oo_get_class_str(interp, $2);
  goto NEXT();
}

inline op get_class(out PMC, in PMC) :object_classes {
  $1 = Parrot_oo_get_class(interp, $2);
  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<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<addrole>(invar PMC, invar PMC)

Compose the role $2 into $1.

=cut

inline op addrole(invar PMC, invar PMC) :object_classes {
    VTABLE_add_role(interp, $1, $2);
    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 {
    STRING *class_name  = string_from_literal(interp, "Class");
    STRING *pclass_name = string_from_literal(interp, "ParrotClass");

    if (VTABLE_isa(interp, $1, class_name))
        VTABLE_add_attribute(interp, $1, $2, PMCNULL);
    else if (VTABLE_isa(interp, $1, pclass_name))
        Parrot_add_attribute(interp, $1, $2);
    else
        real_exception(interp, NULL, INVALID_OPERATION,
            "Cannot add attribute to non-class");

    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) {
    real_exception(interp, NULL, UNIMPLEMENTED, "removeattribute is not implemented");
}

op removeattribute(invar PMC, in INT) {
    real_exception(interp, NULL, UNIMPLEMENTED, "removeattribute is not implemented");
}

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

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

Get the attribute $3 from object $2 and put the result in $1.

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

Get the attribute $4 from the parent $3 of object $2 and put the
result in $1. (This is useful for storing data for a parent class
attribute that is overridden in a child class.) The parent $3 is a
class name, namespace, or key PMC.

=cut

inline op getattribute(out PMC, invar PMC, in INT) :object_classes {
    real_exception(interp, NULL, UNIMPLEMENTED,
            "Integer access to attributes has been deprecated, "
            "use named attribute access instead. See RT #48729");
}

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

inline op getattribute(out PMC, invar PMC, in PMC, in STR) :object_classes {
    $1 = VTABLE_get_attr_keyed(interp, $2, $3, $4);
    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.

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

Set attribute $3 of the parent $2 of object $1 to $4. (This is useful
for storing data for a parent class attribute that is overridden in a
child class.) The parent $2 is a class name, namespace, or key PMC.

=cut

inline op setattribute(invar PMC, in INT, invar PMC) :object_classes {
    real_exception(interp, NULL, UNIMPLEMENTED,
            "Integer access to attributes has been deprecated, "
            "use named attribute access instead. See RT #48729");
}

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

inline op setattribute(invar PMC, in PMC, in STR, invar PMC) :object_classes {
    VTABLE_set_attr_keyed(interp, $1, $2, $3, $4);
    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 {
    real_exception(interp, NULL, UNIMPLEMENTED,
            "The 'classoffset' opcode has been deprecated, "
            "use named attribute access instead. See RT #48727");
}


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

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

Sets $1 to a PMC hash of all introspection data available for $2, keyed on
name.

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

Sets $1 to a PMC Hash, Array, String, Integer, or Number value with
introspection information corresponding to the requested string name.

=cut

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

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

=back

=head1 COPYRIGHT

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