src/ops/object.ops

   1 /*
   2
   3 Copyright (C) 2001-2008, The Perl Foundation.
   4 $Id$
   5
   6 object.ops
   7
   8 */
   9
  10
  11 VERSION = PARROT_VERSION;
  12
  13 =head1 NAME
  14
  15 object.ops
  16
  17 =head1 DESCRIPTION
  18
  19 Parrot's library of object ops
  20
  21 =over 4
  22
  23 =cut
  24
  25 =item B<callmethodcc>(invar PMC, in STR)
  26
  27 Call method $2 with invocant $1 and generate a new return continuation.
  28 The invocant ($1) is used for method lookup. The object is passed as
  29 the first argument in B<set_args>.
  30
  31 Throws a Method_Not_Found_Exception for a non-existent method.
  32
  33 =item B<callmethodcc>(invar PMC, invar PMC)
  34
  35 Like above but use the Sub object $2 as method.
  36
  37 =item B<callmethod>(invar PMC, in STR, invar PMC)
  38
  39 =item B<callmethod>(invar PMC, invar PMC, invar PMC)
  40
  41 Like above, but use continuation $3 instead of creating a new continuation.
  42
  43 =cut
  44
  45 =item B<tailcallmethod>(invar PMC, in STR)
  46
  47 =item B<tailcallmethod>(invar PMC, invar PMC)
  48
  49 Make a tailcall to method $2 with invocant $1.
  50
  51 =cut
  52
  53 op callmethodcc(invar PMC, in STR) :object_base :flow {
  54   PMC      * const object     = $1;
  55   STRING   * const meth       = $2;
  56   opcode_t * const next       = expr NEXT();
  57
  58   /* a class-specific find_method can overwrite interp->current_args()! */
  59   opcode_t *current_args      = interp->current_args;
  60   PMC      * const method_pmc = VTABLE_find_method(interp, object, meth);
  61   opcode_t *dest              = NULL;
  62   interp->current_args        = current_args;
  63
  64   if (PMC_IS_NULL(method_pmc)) {
  65     PMC * const _class = VTABLE_get_class(interp, object);
  66
  67     if (PMC_IS_NULL(_class))
  68         real_exception(interp, next, METH_NOT_FOUND,
  69             "Method '%Ss' not found for non-object", meth);
  70     else
  71         real_exception(interp, next, METH_NOT_FOUND,
  72             "Method '%Ss' not found for invocant of class '%Ss'", meth,
  73             VTABLE_get_string(interp, _class));
  74   }
  75
  76   interp->current_object = object;
  77   interp->current_cont   = NEED_CONTINUATION;
  78   dest                   = VTABLE_invoke(interp, method_pmc, next);
  79   goto ADDRESS(dest);
  80 }
  81
  82 op callmethodcc(invar PMC, invar PMC) :object_base :flow {
  83   PMC      * const object     = $1;
  84   PMC      * const method_pmc = $2;
  85   opcode_t * const next       = expr NEXT();
  86   /* RT#42371 should we check if object.can(method) */
  87
  88   opcode_t *dest;
  89
  90   interp->current_object = object;
  91   interp->current_cont = NEED_CONTINUATION;
  92   dest = VTABLE_invoke(interp, method_pmc, next);
  93   goto ADDRESS(dest);
  94 }
  95
  96 op callmethod(invar PMC, in STR, invar PMC) :object_base :flow {
  97   PMC      * const object     = $1;
  98   STRING   * const meth       = $2;
  99   opcode_t * const next       = expr NEXT();
 100
 101   /* a class-specific find_method can overwrite interp->current_args()! */
 102   opcode_t *current_args      = interp->current_args;
 103   PMC      * const method_pmc = VTABLE_find_method(interp, object, meth);
 104   opcode_t *dest              = NULL;
 105   interp->current_args        = current_args;
 106
 107
 108   if (PMC_IS_NULL(method_pmc)) {
 109     real_exception(interp, next, METH_NOT_FOUND,
 110         "Method '%Ss' not found for invocant of class '%Ss'", meth,
 111         VTABLE_get_string(interp, VTABLE_get_class(interp, object)));
 112   }
 113   interp->current_object = object;
 114   interp->current_cont = $3;
 115   dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
 116   goto ADDRESS(dest);
 117 }
 118
 119 op callmethod(invar PMC, invar PMC, invar PMC) :object_base :flow {
 120   PMC      * const object     = $1;
 121   PMC      * const method_pmc = $2;
 122   opcode_t * const next       = expr NEXT();
 123
 124   opcode_t *dest;
 125
 126   interp->current_object = object;
 127   interp->current_cont = $3;
 128   dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
 129   goto ADDRESS(dest);
 130 }
 131
 132 op tailcallmethod(invar PMC, in STR) :object_base :flow {
 133   opcode_t * const next       = expr NEXT();
 134   PMC      * const object     = $1;
 135   STRING   * const meth       = $2;
 136   PMC      * const method_pmc = VTABLE_find_method(interp, object, meth);
 137
 138   opcode_t *dest;
 139
 140   if (PMC_IS_NULL(method_pmc)) {
 141     real_exception(interp, next, METH_NOT_FOUND,
 142         "Method '%Ss' not found for invocant of class '%Ss'", meth,
 143         VTABLE_get_string(interp, VTABLE_get_class(interp, object)));
 144   }
 145   interp->current_cont = CONTEXT(interp)->current_cont;
 146   PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
 147   interp->current_object = object;
 148   dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
 149   goto ADDRESS(dest);
 150 }
 151
 152 op tailcallmethod(invar PMC, invar PMC) :object_base :flow {
 153   opcode_t * const next       = expr NEXT();
 154   PMC      * const object     = $1;
 155   PMC      * const method_pmc = $2;
 156
 157   opcode_t *dest;
 158
 159   interp->current_cont = CONTEXT(interp)->current_cont;
 160   PObj_get_FLAGS(interp->current_cont) |= SUB_FLAG_TAILCALL;
 161   interp->current_object = object;
 162   dest = (opcode_t *)VTABLE_invoke(interp, method_pmc, next);
 163   goto ADDRESS(dest);
 164 }
 165
 166 =item B<addmethod>(invar PMC, in STR, invar PMC)
 167
 168 Adds $3 as a method named $2 to $1.
 169
 170 =cut
 171
 172 inline op addmethod(invar PMC, in STR, invar PMC) :object_classes {
 173   VTABLE_add_method(interp, $1, $2, $3);
 174 }
 175
 176
 177 =item B<can>(out INT, invar PMC, in STR)
 178
 179 Sets result $1 to the result of the "can" vtable function for PMC $2,
 180 given method $3.
 181
 182 =cut
 183
 184 inline op can(out INT, invar PMC, in STR) :object_base {
 185   $1 = VTABLE_can(interp, $2, $3);
 186 }
 187
 188
 189 =item B<does>(out INT, invar PMC, in STR)
 190
 191 Sets result $1 to the result of the "does" vtable function for PMC $2,
 192 given the role of name $3.
 193
 194 =cut
 195
 196 inline op does(out INT, invar PMC, in STR) :object_base {
 197   $1 = $3 ? VTABLE_does(interp, $2, $3) : 0;
 198 }
 199
 200 =item B<does>(out INT, invar PMC, in PMC)
 201
 202 Sets result $1 to the result of the "does" vtable function for PMC $2,
 203 given the role $3.
 204
 205 =cut
 206
 207 inline op does(out INT, invar PMC, in PMC) :object_base {
 208   $1 = $3 ? VTABLE_does_pmc(interp, $2, $3) : 0;
 209 }
 210
 211 =item B<isa>(out INT, invar PMC, in STR)
 212
 213 =item B<isa>(out INT, invar PMC, in PMC)
 214
 215 Sets result $1 to the result of the "isa" vtable function for PMC $2,
 216 given class $3.
 217
 218 =cut
 219
 220 inline op isa(out INT, invar PMC, in STR) :object_base {
 221   $1 = $3 ? VTABLE_isa(interp, $2, $3) : 0;
 222 }
 223
 224 inline op isa(out INT, invar PMC, in PMC) :object_base {
 225     $1 = $3 ? VTABLE_isa_pmc(interp, $2, $3) : 0;
 226 }
 227
 228 ###############################################################################
 229
 230 =item B<newclass>(out PMC, in STR)
 231
 232 Create a new Parrot-style class, named $2, and puts the new PMC for it
 233 into $1.
 234
 235 =item B<newclass>(out PMC, in PMC)
 236
 237 Create a new Parrot-style class, with the name given in $2 as a key,
 238 namespace, or string PMC.
 239
 240 =cut
 241
 242 inline op newclass(out PMC, in STR) :object_classes {
 243   PMC * const name = pmc_new(interp, enum_class_String);
 244   VTABLE_set_string_native(interp, name, $2);
 245   $1 = pmc_new_init(interp, enum_class_Class, name);
 246 }
 247
 248 inline op newclass(out PMC, in PMC) :object_classes {
 249     $1 = pmc_new_init(interp, enum_class_Class, $2);
 250 }
 251
 252 =item B<subclass>(out PMC, in PMC)
 253
 254 =item B<subclass>(out PMC, in PMC, in STR)
 255
 256 =item B<subclass>(out PMC, in PMC, in PMC)
 257
 258 Create a new class, put in $1, that is a subclass of $2.  $3, if available
 259 and not null, is the name of the new class--if not, the subclass is an
 260 anonymous subclass.
 261
 262 =cut
 263
 264 inline op subclass(out PMC, in PMC) :object_classes :flow {
 265     PMC      * const parent_class = Parrot_oo_get_class(interp, $2);
 266     opcode_t * const next         = expr NEXT();
 267
 268     if (PMC_IS_NULL(parent_class)) {
 269       real_exception(interp, next, NO_CLASS,
 270                   "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
 271     }
 272     $1 = pmc_new(interp, enum_class_Class);
 273     VTABLE_add_parent(interp, $1, parent_class);
 274     goto ADDRESS(next);
 275 }
 276
 277 inline op subclass(out PMC, in PMC, in STR) :object_classes :flow {
 278     PMC      * const parent_class = Parrot_oo_get_class(interp, $2);
 279     opcode_t * const next         = expr NEXT();
 280
 281     if (PMC_IS_NULL(parent_class)) {
 282       real_exception(interp, next, NO_CLASS,
 283                   "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
 284     }
 285     $1 = Parrot_oo_newclass_from_str(interp, $3);
 286     VTABLE_add_parent(interp, $1, parent_class);
 287     goto ADDRESS(next);
 288 }
 289
 290 inline op subclass(out PMC, in PMC, in PMC) :object_classes :flow {
 291     PMC      * const parent_class = Parrot_oo_get_class(interp, $2);
 292     opcode_t * const next         = expr NEXT();
 293
 294     if (PMC_IS_NULL(parent_class)) {
 295       real_exception(interp, next, NO_CLASS,
 296                   "Class '%Ss' doesn't exist", VTABLE_get_string(interp, $2));
 297     }
 298     $1 = pmc_new_init(interp, enum_class_Class, $3);
 299     VTABLE_add_parent(interp, $1, parent_class);
 300     goto ADDRESS(next);
 301 }
 302
 303 =item B<subclass>(out PMC, in STR)
 304
 305 =item B<subclass>(out PMC, in STR, in STR)
 306
 307 =item B<subclass>(out PMC, in STR, in PMC)
 308
 309 Create a new class, put in $1, that is a subclass of the class named $2.
 310 $3, if available and not null, is the name of the new class--if not, the
 311 subclass is an anonymous subclass.
 312
 313 =cut
 314
 315
 316 op subclass(out PMC, in STR) :object_classes :flow {
 317     PMC      * const parent_class = Parrot_oo_get_class_str(interp, $2);
 318     opcode_t * const next         = expr NEXT();
 319
 320     if (PMC_IS_NULL(parent_class)) {
 321       real_exception(interp, next, NO_CLASS,
 322                   "Class '%Ss' doesn't exist", $2);
 323     }
 324
 325     $1 = pmc_new(interp, enum_class_Class);
 326     VTABLE_add_parent(interp, $1, parent_class);
 327     goto ADDRESS(next);
 328 }
 329
 330 op subclass(out PMC, in STR, in STR) :object_classes :flow {
 331     PMC      * const parent_class = Parrot_oo_get_class_str(interp, $2);
 332     opcode_t * const next         = expr NEXT();
 333
 334     if (PMC_IS_NULL(parent_class)) {
 335       real_exception(interp, next, NO_CLASS,
 336                 "Class '%Ss' doesn't exist", $2);
 337     }
 338
 339     $1  = Parrot_oo_newclass_from_str(interp, $3);
 340     VTABLE_add_parent(interp, $1, parent_class);
 341     goto ADDRESS(next);
 342 }
 343
 344 op subclass(out PMC, in STR, in PMC) :object_classes :flow {
 345     PMC      * const parent_class = Parrot_oo_get_class_str(interp, $2);
 346     opcode_t * const next         = expr NEXT();
 347
 348     if (PMC_IS_NULL(parent_class)) {
 349       real_exception(interp, next, NO_CLASS,
 350                 "Class '%Ss' doesn't exist", $2);
 351     }
 352
 353     $1 = pmc_new_init(interp, enum_class_Class, $3);
 354     VTABLE_add_parent(interp, $1, parent_class);
 355     goto ADDRESS(next);
 356 }
 357
 358 ###############################################################################
 359
 360 =item B<getclass>(out PMC, in STR)
 361
 362 =item B<getclass>(out PMC, in PMC)
 363
 364 Find the PMC for a class, by name. Deprecated - works with the old class
 365 system.
 366
 367 =cut
 368
 369 inline op getclass(out PMC, in STR) :object_classes :flow :deprecated {
 370     PMC      * const _class = Parrot_class_lookup(interp, $2);
 371     opcode_t * const next   = expr NEXT();
 372
 373     if (PMC_IS_NULL(_class))
 374         real_exception(interp, next, NO_CLASS, "Class '%Ss' doesn't exist", $2);
 375
 376     $1 = _class;
 377
 378   goto ADDRESS(next);
 379 }
 380
 381 inline op getclass(out PMC, in PMC) :object_classes :flow :deprecated {
 382   PMC      * const _class = Parrot_class_lookup_p(interp, $2);
 383   opcode_t * const next   = expr NEXT();
 384
 385   if (PMC_IS_NULL(_class)) {
 386     STRING * const name = readable_name(interp, $2);
 387     real_exception(interp, next, NO_CLASS, "Class '%Ss' doesn't exist", name);
 388   }
 389   else
 390     $1 = _class;
 391   goto ADDRESS(next);
 392 }
 393
 394 ###############################################################################
 395
 396 =item B<get_class>(out PMC, in STR)
 397
 398 =item B<get_class>(out PMC, in PMC)
 399
 400 Find the PMC for a class, by string name or by key.
 401
 402 =cut
 403
 404 inline op get_class(out PMC, in STR) :object_classes {
 405   $1 = Parrot_oo_get_class_str(interp, $2);
 406 }
 407
 408 inline op get_class(out PMC, in PMC) :object_classes {
 409   $1 = Parrot_oo_get_class(interp, $2);
 410 }
 411
 412 ###############################################################################
 413
 414 =item B<class>(out PMC, invar PMC)
 415
 416 Get the class PMC for the object in $2 and put it in $1.
 417
 418 =cut
 419
 420 inline op class(out PMC, invar PMC) :object_classes {
 421     $1 = VTABLE_get_class(interp, $2);
 422 }
 423
 424 ##################################################
 425
 426
 427 =item B<addparent>(invar PMC, invar PMC)
 428
 429 Add class $2 to the list of parent classes for $1.
 430
 431 =cut
 432
 433 inline op addparent(invar PMC, invar PMC) :object_classes {
 434     VTABLE_add_parent(interp, $1, $2);
 435 }
 436
 437 =item B<removeparent>(invar PMC, invar PMC)
 438
 439 Remove class $2 from class $1's list of parents.
 440
 441 =cut
 442
 443 inline op removeparent(invar PMC, invar PMC) :object_classes {
 444     Parrot_remove_parent(interp, $2, $1);
 445 }
 446
 447 =item B<addrole>(invar PMC, invar PMC)
 448
 449 Compose the role $2 into $1.
 450
 451 =cut
 452
 453 inline op addrole(invar PMC, invar PMC) :object_classes {
 454     VTABLE_add_role(interp, $1, $2);
 455 }
 456
 457 =item B<addattribute>(invar PMC, in STR)
 458
 459 Add the attribute named $2 to the class $1.
 460
 461 =cut
 462
 463 inline op addattribute(invar PMC, in STR) :object_classes {
 464     STRING * const class_name  = string_from_literal(interp, "Class");
 465     STRING * const role_name   = string_from_literal(interp, "Role");
 466
 467     if (VTABLE_isa(interp, $1, class_name) || VTABLE_isa(interp, $1, role_name))
 468         VTABLE_add_attribute(interp, $1, $2, PMCNULL);
 469     else
 470         real_exception(interp, NULL, INVALID_OPERATION,
 471             "Cannot add attribute to non-class");
 472 }
 473
 474 =item B<removeattribute>(invar PMC, in STR) B<(unimplemented)>
 475
 476 =item B<removeattribute>(invar PMC, in INT) B<(unimplemented)>
 477
 478 Remove attribute $2 from class $1, specified either by name or offset.
 479
 480 =cut
 481
 482 op removeattribute(invar PMC, in STR) :flow {
 483     real_exception(interp, NULL, UNIMPLEMENTED, "removeattribute is not implemented");
 484 }
 485
 486 op removeattribute(invar PMC, in INT) :flow {
 487     real_exception(interp, NULL, UNIMPLEMENTED, "removeattribute is not implemented");
 488 }
 489
 490 =item B<getattribute>(out PMC, invar PMC, in STR)
 491
 492 Get the attribute $3 from object $2 and put the result in $1.
 493
 494 =item B<getattribute>(out PMC, invar PMC, in PMC, in STR)
 495
 496 Get the attribute $4 from the parent $3 of object $2 and put the
 497 result in $1. (This is useful for storing data for a parent class
 498 attribute that is overridden in a child class.) The parent $3 is a
 499 class name, namespace, or key PMC.
 500
 501 =cut
 502
 503 inline op getattribute(out PMC, invar PMC, in STR) :object_classes {
 504     $1 = VTABLE_get_attr_str(interp, $2, $3);
 505 }
 506
 507 inline op getattribute(out PMC, invar PMC, in PMC, in STR) :object_classes {
 508     $1 = VTABLE_get_attr_keyed(interp, $2, $3, $4);
 509 }
 510
 511 =item B<setattribute>(invar PMC, in STR, invar PMC)
 512
 513 Set attribute $2 of object $1 to $3.
 514
 515 =item B<setattribute>(invar PMC, in PMC, in STR, invar PMC)
 516
 517 Set attribute $3 of the parent $2 of object $1 to $4. (This is useful
 518 for storing data for a parent class attribute that is overridden in a
 519 child class.) The parent $2 is a class name, namespace, or key PMC.
 520
 521 =cut
 522
 523 inline op setattribute(invar PMC, in STR, invar PMC) :object_classes {
 524     VTABLE_set_attr_str(interp, $1, $2, $3);
 525 }
 526
 527 inline op setattribute(invar PMC, in PMC, in STR, invar PMC) :object_classes {
 528     VTABLE_set_attr_keyed(interp, $1, $2, $3, $4);
 529 }
 530
 531 ###############################################################################
 532
 533 =item B<inspect>(out PMC, in PMC)
 534
 535 Sets $1 to a PMC hash of all introspection data available for $2, keyed on
 536 name.
 537
 538 =item B<inspect>(out PMC, in PMC, in STR)
 539
 540 Sets $1 to a PMC Hash, Array, String, Integer, or Number value with
 541 introspection information corresponding to the requested string name.
 542
 543 =cut
 544
 545 inline op inspect(out PMC, in PMC) :object_classes {
 546   $1 = VTABLE_inspect(interp, $2);
 547 }
 548
 549 inline op inspect(out PMC, in PMC, in STR) :object_classes {
 550   $1 = VTABLE_inspect_str(interp, $2, $3);
 551 }
 552
 553 =back
 554
 555 =head1 COPYRIGHT
 556
 557 Copyright (C) 2001-2008, The Perl Foundation.
 558
 559 =head1 LICENSE
 560
 561 This program is free software. It is subject to the same license
 562 as the Parrot interpreter itself.
 563
 564 =cut
 565
 566 /*
 567  * Local variables:
 568  *   c-file-style: "parrot"
 569  * End:
 570  * vim: expandtab shiftwidth=4:
 571  */