src/pmc/object.pmc

   1 /*
   2 Copyright (C) 2001-2008, The Perl Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/pmc/object.pmc - An instance of a class
   8
   9 =head1 DESCRIPTION
  10
  11 Implements an instance of a class.
  12
  13 =head2 Functions
  14
  15 =over 4
  16
  17 =cut
  18
  19 */
  20
  21 #include "parrot/parrot.h"
  22 #include "parrot/oo_private.h"
  23 #include "pmc_class.h"
  24
  25 /* This finds the index of an attribute in an object's attribute store and
  26  * returns it. Returns -1 if the attribute does not exist. */
  27 static INTVAL
  28 get_attrib_index(PARROT_INTERP, PMC *self, STRING *name)
  29 {
  30     Parrot_Class * const _class = PARROT_CLASS(self);
  31     int                  num_classes, i;
  32
  33     /* First see if we can find it in the cache. */
  34     if (VTABLE_exists_keyed_str(interp, _class->attrib_cache, name))
  35         return VTABLE_get_integer_keyed_str(interp, _class->attrib_cache, name);
  36
  37     /* No hit. We need to walk up the list of parents to try and find the
  38      * attribute. */
  39     num_classes = VTABLE_elements(interp, _class->all_parents);
  40
  41     for (i = 0; i < num_classes; i++) {
  42         /* Get the class and its attribute metadata hash. */
  43         PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp,
  44             _class->all_parents, i);
  45
  46         /* Build a string representing the fully qualified attribute name. */
  47         STRING *fq_name = VTABLE_get_string(interp, cur_class);
  48         fq_name         = string_append(interp, fq_name, name);
  49
  50         /* Look up. */
  51         if (VTABLE_exists_keyed_str(interp, _class->attrib_index, fq_name)) {
  52             /* Found it. Get value, cache it and we're done. */
  53             const INTVAL index = VTABLE_get_integer_keyed_str(interp,
  54                 _class->attrib_index, fq_name);
  55             VTABLE_set_integer_keyed_str(interp, _class->attrib_cache, name,
  56                 index);
  57
  58             return index;
  59         }
  60     }
  61
  62     return -1;
  63 }
  64
  65 /* This variation bypasses the cache and finds the index of a particular
  66  * parent's attribute in an object's attribute store and returns it. Returns -1
  67  * if the attribute does not exist. */
  68
  69 static INTVAL
  70 get_attrib_index_keyed(PARROT_INTERP, PMC *self, PMC *key, STRING *name)
  71 {
  72     Parrot_Class * const _class       = PARROT_CLASS(self);
  73     PMC          * const class_cache  = VTABLE_get_pmc_keyed_str(interp,
  74                     _class->attrib_cache, VTABLE_get_string(interp, key));
  75     PMC                 *parent_class;
  76     STRING              *fq_name;
  77
  78     if (!PMC_IS_NULL(class_cache))
  79         if (VTABLE_exists_keyed_str(interp, class_cache, name))
  80             return VTABLE_get_integer_keyed_str(interp, class_cache, name);
  81
  82     /* Build a string representing the fully qualified attribute name. */
  83     parent_class = Parrot_oo_get_class(interp, key);
  84     fq_name      = VTABLE_get_string(interp, parent_class);
  85     fq_name      = string_append(interp, fq_name, name);
  86
  87     /* Look up. */
  88     if (VTABLE_exists_keyed_str(interp, _class->attrib_index, fq_name)) {
  89         /* Found it. Get value and we're done. */
  90         const INTVAL index = VTABLE_get_integer_keyed_str(interp,
  91             _class->attrib_index, fq_name);
  92         return index;
  93     }
  94
  95     return -1;
  96 }
  97
  98 pmclass Object need_ext {
  99     ATTR PMC *_class;       /* The class this is an instance of. */
 100     ATTR PMC *attrib_store; /* The attributes store - a resizable PMC array. */
 101
 102 /*
 103
 104 =item C<void init()>
 105
 106 Raises an exception; you can only instantiate objects from a class.
 107
 108 =cut
 109
 110 */
 111
 112     VTABLE void init() {
 113         real_exception(interp, NULL, INVALID_OPERATION,
 114                 "Object must be created by a class.");
 115     }
 116
 117 /*
 118
 119
 120 =item C<void init_pmc(PMC *class)>
 121
 122 Raises an exception; you can only instantiate objects from a class.
 123
 124 =cut
 125
 126 */
 127
 128     VTABLE void init_pmc(PMC *worreva) {
 129         real_exception(interp, NULL, INVALID_OPERATION,
 130                 "Object must be created by a class.");
 131     }
 132
 133 /*
 134
 135 =item C<void destroy()>
 136
 137 Free the object's underlying struct.
 138
 139 =cut
 140
 141 */
 142     VTABLE void destroy() {
 143         mem_sys_free(PMC_data(SELF));
 144     }
 145
 146 /*
 147
 148 =item C<STRING *name()>
 149
 150 Returns the fully qualified name of the object's class.
 151
 152 =cut
 153
 154 */
 155
 156     VTABLE STRING *name() {
 157         PMC    * const _class     = VTABLE_get_class(interp, SELF);
 158         STRING * const name       = CONST_STRING(interp, "name");
 159
 160         /* If there's a vtable override for 'name' run that instead. */
 161         PMC * const method = Parrot_oo_find_vtable_override(interp, _class, name);
 162
 163         if (!PMC_IS_NULL(method))
 164             return (STRING *)Parrot_run_meth_fromc_args(interp, method, SELF, name, "S");
 165         else
 166             return VTABLE_get_string(interp, _class);
 167     }
 168
 169 /*
 170
 171 =item C<void mark()>
 172
 173 Mark any referenced strings and PMCs.
 174
 175 =cut
 176
 177 */
 178     VTABLE void mark() {
 179         if (PARROT_OBJECT(SELF)) {
 180             Parrot_Object * const obj = PARROT_OBJECT(SELF);
 181
 182             if (obj->_class)
 183                 pobject_lives(interp, (PObj*)obj->_class);
 184             if (obj->attrib_store)
 185                 pobject_lives(interp, (PObj*)obj->attrib_store);
 186         }
 187     }
 188
 189 /*
 190
 191 =item C<PMC *get_attr_str(STRING *name)>
 192
 193 Gets the value of an attribute for this object. Will find the first attribute
 194 of the given name walking up the inheritance tree.
 195
 196 =cut
 197
 198 */
 199     VTABLE PMC *get_attr_str(STRING *name) {
 200         Parrot_Object * const obj      = PARROT_OBJECT(SELF);
 201         STRING        * const get_attr = CONST_STRING(interp, "get_attr_str");
 202         INTVAL index;
 203
 204         /* If there's a vtable override for 'get_attr_str' run that first. */
 205         PMC * const method = Parrot_oo_find_vtable_override(interp,
 206                 VTABLE_get_class(interp, SELF), get_attr);
 207
 208         if (!PMC_IS_NULL(method))
 209             return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
 210                     get_attr, "PS", name);
 211
 212         /* Look up the index. */
 213         index = get_attrib_index(interp, obj->_class, name);
 214
 215         /* If lookup failed, exception. */
 216         if (index == -1)
 217             real_exception(interp, NULL, ATTRIB_NOT_FOUND,
 218                 "No such attribute '%S'", name);
 219
 220         return VTABLE_get_pmc_keyed_int(interp, obj->attrib_store, index);
 221     }
 222
 223 /*
 224
 225 =item C<PMC *get_attr_keyed(PMC *key, STRING *name)>
 226
 227 Gets the value of an attribute for this object. Will only look for attributes
 228 defined in the parent identified by the given key.
 229
 230 =cut
 231
 232 */
 233     VTABLE PMC *get_attr_keyed(PMC *key, STRING *name) {
 234         Parrot_Object * const obj = PARROT_OBJECT(SELF);
 235
 236         /* Look up the index. */
 237         const INTVAL index = get_attrib_index_keyed(interp, obj->_class, key, name);
 238
 239         /* If lookup failed, exception. */
 240         if (index == -1)
 241             real_exception(interp, NULL, ATTRIB_NOT_FOUND,
 242                 "No such attribute '%S' in class '%S'", name,
 243                 VTABLE_get_string(interp, key));
 244
 245         return VTABLE_get_pmc_keyed_int(interp, obj->attrib_store, index);
 246     }
 247
 248 /*
 249
 250 =item C<void set_attr_str(STRING *name, PMC *value)>
 251
 252 Sets the value of an attribute for this object. Will set the first attribute
 253 of the given name walking up the inheritance tree.
 254
 255 =cut
 256
 257 */
 258     VTABLE void set_attr_str(STRING *name, PMC *value) {
 259         Parrot_Object * const obj       = PARROT_OBJECT(SELF);
 260         STRING        *vtable_meth_name = CONST_STRING(interp, "set_attr_str");
 261         INTVAL         index;
 262
 263         /* If there's a vtable override for 'set_attr_str' run that first. */
 264         PMC * const method = Parrot_oo_find_vtable_override(interp,
 265                 VTABLE_get_class(interp, SELF), vtable_meth_name);
 266         if (!PMC_IS_NULL(method)) {
 267             PMC *unused = (PMC *)Parrot_run_meth_fromc_args(interp, method,
 268                 SELF, vtable_meth_name, "vSP", name, value);
 269             UNUSED(unused);
 270             return;
 271         }
 272
 273         index = get_attrib_index(interp, obj->_class, name);
 274
 275         /* If lookup failed, exception. */
 276         if (index == -1)
 277             real_exception(interp, NULL, ATTRIB_NOT_FOUND,
 278                 "No such attribute '%S'", name);
 279
 280         VTABLE_set_pmc_keyed_int(interp, obj->attrib_store, index, value);
 281     }
 282
 283 /*
 284
 285 =item C<void set_attr_keyed(PMC *key, STRING *name, PMC *value)>
 286
 287 Sets the value of an attribute for this object. Will only set attributes
 288 defined in the parent identified by the given key.
 289
 290 =cut
 291
 292 */
 293     VTABLE void set_attr_keyed(PMC *key, STRING *name, PMC *value) {
 294         Parrot_Object * const obj = PARROT_OBJECT(SELF);
 295         const INTVAL index        = get_attrib_index_keyed(interp, obj->_class, key, name);
 296
 297         /* If lookup failed, exception. */
 298         if (index == -1)
 299             real_exception(interp, NULL, ATTRIB_NOT_FOUND,
 300                 "No such attribute '%S' in class '%S'", name,
 301                 VTABLE_get_string(interp, key));
 302
 303         VTABLE_set_pmc_keyed_int(interp, obj->attrib_store, index, value);
 304     }
 305
 306 /*
 307
 308 =item C<PMC *find_method(STRING *name)>
 309
 310 Queries this object's class to find the method with the given name.
 311
 312 =cut
 313
 314 */
 315     VTABLE PMC *find_method(STRING *name) {
 316         Parrot_Object * const obj    = PARROT_OBJECT(SELF);
 317         Parrot_Class  * const _class = PARROT_CLASS(obj->_class);
 318         PMC           *method        = PMCNULL;
 319         STRING        *find_method   = CONST_STRING(interp, "find_method");
 320
 321         /* Walk and search. One day, we'll use the cache first. */
 322         const int num_classes        = VTABLE_elements(interp,
 323                                                       _class->all_parents);
 324         const int all_in_universe    = !CLASS_has_alien_parents_TEST(obj->_class);
 325         int       alien_parents_pos  = VTABLE_elements(interp,
 326                                                       _class->attrib_metadata);
 327         int i;
 328
 329         for (i = 0; i < num_classes; i++) {
 330             /* Get the class. */
 331             PMC * const cur_class =
 332                 VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
 333
 334             /* If there's a vtable override for 'find_method' in the current
 335              * class, run that first. */
 336             method = Parrot_oo_find_vtable_override_for_class(interp, cur_class,
 337                     find_method);
 338
 339             if (!PMC_IS_NULL(method))
 340                 return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
 341                         find_method, "PS", name);
 342
 343             /* If it's from this universe or the class doesn't inherit from
 344              * anything outside of it... */
 345             if (all_in_universe || VTABLE_isa(interp, cur_class, CONST_STRING(interp, "Class"))) {
 346                 const Parrot_Class * const class_info = PARROT_CLASS(cur_class);
 347                 if (VTABLE_exists_keyed_str(interp, class_info->methods, name)) {
 348                     /* Found it! */
 349                     method = VTABLE_get_pmc_keyed_str(interp, class_info->methods, name);
 350                     break;
 351                 }
 352             }
 353             else {
 354                 /* Delegate the lookup to the class. */
 355                 PMC * const del_class = VTABLE_get_pmc_keyed_int(interp, obj->attrib_store,
 356                     alien_parents_pos);
 357                 method = VTABLE_find_method(interp, del_class, name);
 358
 359                 if (!PMC_IS_NULL(method)) {
 360                     /* Found it. However, if we just hand this back and it's
 361                      * an NCI and we call it, we will get the wrong invocant
 362                      * passed. Therefore, we need to close the NCI and make it
 363                      * into a BoundNCI. */
 364                     if (method->vtable->base_type == enum_class_NCI) {
 365                         method         = VTABLE_clone(interp, method);
 366                         method->vtable = interp->vtables[enum_class_Bound_NCI];
 367                         VTABLE_set_pmc(interp, method, del_class);
 368                     }
 369
 370                     /* Found a method, so we're done. */
 371                     break;
 372                 }
 373
 374                 alien_parents_pos++;
 375             }
 376         }
 377
 378         return method;
 379     }
 380
 381 /*
 382
 383 =item C<PMC *get_class()>
 384
 385 Get the class PMC representing the class that this object is an instance of.
 386
 387 =cut
 388
 389 */
 390     VTABLE PMC *get_class() {
 391         PMC    * const classobj = PARROT_OBJECT(SELF)->_class;
 392         STRING *get_class       = CONST_STRING(interp, "get_class");
 393         /* If there's a vtable override for 'get_class' run that instead. */
 394         PMC * const method = Parrot_oo_find_vtable_override(interp,
 395                 classobj, get_class);
 396
 397         if (!PMC_IS_NULL(method))
 398             return (PMC *)Parrot_run_meth_fromc_args(interp, method, SELF,
 399                     get_class, "P");
 400
 401         return classobj;
 402     }
 403
 404 /*
 405
 406 =item C<INTVAL can(STRING *method_name)>
 407
 408 Returns 0 if the class does not have a method with the given name and a
 409 non-zero value if it does.
 410
 411 =cut
 412
 413 */
 414     VTABLE INTVAL can(STRING *method_name) {
 415         /* Just use find_method and see it if finds anything. */
 416         const PMC * const method = VTABLE_find_method(interp, SELF, method_name);
 417         return !PMC_IS_NULL(method);
 418     }
 419
 420 /*
 421
 422 =item C<INTVAL isa_pmc(PMC *classname)>
 423
 424 Returns whether the object's class is or inherits from C<*classname>.
 425
 426 =cut
 427
 428 */
 429
 430     VTABLE INTVAL isa_pmc(PMC *lookup) {
 431         if (PMC_IS_NULL(lookup))
 432             return 0;
 433
 434         if (SUPER(lookup))
 435             return 1;
 436
 437         /* Dispatch isa to the object's class */
 438         return VTABLE_isa_pmc(interp, VTABLE_get_class(interp, SELF), lookup);
 439     }
 440
 441 /*
 442
 443 =item C<INTVAL isa(STRING *classname)>
 444
 445 Returns whether the class is or inherits from C<*classname>.
 446
 447 =cut
 448
 449 */
 450
 451     VTABLE INTVAL isa(STRING *classname) {
 452         PMC   *_class;
 453
 454         if (SUPER(classname))
 455             return 1;
 456
 457         _class = VTABLE_get_class(interp, SELF);
 458         return VTABLE_isa(interp, _class, classname);
 459     }
 460
 461 /*
 462
 463 =item C<INTVAL does(STRING *role_name)>
 464
 465 Returns whether the object's class does the role with name C<*role_name>.
 466
 467 =cut
 468
 469 */
 470
 471     VTABLE INTVAL does(STRING *role_name) {
 472         if (!role_name)
 473             return 0;
 474
 475         /* Dispatch to the object's class */
 476         return VTABLE_does(interp, VTABLE_get_class(interp, SELF), role_name);
 477     }
 478
 479 /*
 480
 481 =item C<INTVAL does_pmc(PMC *role)>
 482
 483 Returns whether the object's class does C<*role>.
 484
 485 =cut
 486
 487 */
 488
 489     VTABLE INTVAL does_pmc(PMC *role) {
 490         if (PMC_IS_NULL(role))
 491             return 0;
 492
 493         if (SUPER(role))
 494             return 1;
 495
 496         /* Dispatch to the object's class */
 497         return VTABLE_does_pmc(interp, VTABLE_get_class(interp, SELF), role);
 498     }
 499
 500 /*
 501
 502 =item C<opcode_t *invoke(void *next)>
 503
 504 Invokes the object (if this vtable function is overridden).
 505
 506 =cut
 507
 508 */
 509
 510     opcode_t * invoke(void *next) {
 511         Parrot_Object * const obj    = PARROT_OBJECT(pmc);
 512         Parrot_Class  * const _class = PARROT_CLASS(obj->_class);
 513
 514         /* Walk and search for the vtable method. */
 515         const int num_classes = VTABLE_elements(interp, _class->all_parents);
 516         int i;
 517
 518         for (i = 0; i < num_classes; i++) {
 519             /* Get the class. */
 520             STRING *meth_name     = CONST_STRING(interp, "invoke");
 521             STRING *proxy         = CONST_STRING(interp, "proxy");
 522             PMC * const cur_class =
 523                 VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
 524
 525             PMC * const meth =
 526                 Parrot_oo_find_vtable_override_for_class(interp, cur_class,
 527                                                          meth_name);
 528             if (!PMC_IS_NULL(meth))
 529                 return VTABLE_invoke(interp, meth, next);
 530
 531             if (cur_class->vtable->base_type == enum_class_PMCProxy) {
 532                 /* Get the PMC instance and call the vtable method on that. */
 533                 PMC * const del_object =
 534                     VTABLE_get_attr_keyed(interp, pmc, cur_class, proxy);
 535
 536                 if (!PMC_IS_NULL(del_object))
 537                     return VTABLE_invoke(interp, del_object, next);
 538             }
 539         }
 540
 541         return (opcode_t *)Parrot_default_invoke(interp, pmc, next);
 542     }
 543
 544 /*
 545
 546 =item C<INTVAL type()>
 547
 548 Returns the integer type of the object's class.
 549
 550 =cut
 551
 552 */
 553
 554     VTABLE INTVAL type() {
 555         PMC *_class = VTABLE_get_class(interp, SELF);
 556         return VTABLE_type(interp, _class);
 557     }
 558
 559 /*
 560
 561 =item C<PMC * clone()>
 562
 563 Creates a clone of the object.
 564
 565 =cut
 566
 567 */
 568
 569     VTABLE PMC * clone() {
 570         Parrot_Object * const obj       = PARROT_OBJECT(pmc);
 571         Parrot_Class  * const _class    = PARROT_CLASS(obj->_class);
 572         STRING        * const meth_name = CONST_STRING(interp, "clone");
 573         PMC           * cloned;
 574         Parrot_Object * cloned_guts;
 575
 576         /* See if we have a custom override of the method first. */
 577         const int num_classes = VTABLE_elements(interp, _class->all_parents);
 578         int i;
 579         for (i = 0; i < num_classes; i++) {
 580             /* Get the class. */
 581             PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
 582
 583             /* Look for a method and run it if we find one. */
 584             PMC * const meth =
 585                 Parrot_oo_find_vtable_override_for_class(interp, cur_class, meth_name);
 586             if (!PMC_IS_NULL(meth))
 587                 return (PMC*)Parrot_run_meth_fromc_args(interp, meth, pmc, meth_name, "P");
 588         }
 589
 590         /* If we get here, no custom clone. Create a new object PMC. */
 591         cloned = pmc_new_noinit(interp, enum_class_Object);
 592
 593         /* Set custom DOD mark and destroy on the object. */
 594         PObj_custom_mark_SET(cloned);
 595         PObj_active_destroy_SET(cloned);
 596
 597         /* Flag that it is an object */
 598         PObj_is_object_SET(cloned);
 599
 600         /* Now create the underlying structure, and clone attributes list.class. */
 601         cloned_guts               = mem_allocate_zeroed_typed(Parrot_Object);
 602         cloned_guts->_class       = obj->_class;
 603         cloned_guts->attrib_store = VTABLE_clone(INTERP, obj->attrib_store);
 604         PMC_data(cloned)          = cloned_guts;
 605
 606         /* Some of the attributes may have been the PMCs providing storage for any
 607          * PMCs we inherited from; also need to clone those. */
 608         if (CLASS_has_alien_parents_TEST(obj->_class)) {
 609             /* Locate any PMC parents. */
 610             for (i = 0; i < num_classes; i++) {
 611                 PMC * const cur_class = VTABLE_get_pmc_keyed_int(interp, _class->all_parents, i);
 612                 if (cur_class->vtable->base_type == enum_class_PMCProxy) {
 613                     /* Clone this PMC too. */
 614                     STRING *proxy         = CONST_STRING(interp, "proxy");
 615                     VTABLE_set_attr_keyed(interp, cloned, cur_class, proxy,
 616                         VTABLE_clone(interp,
 617                             VTABLE_get_attr_keyed(interp, pmc, cur_class, proxy)));
 618                 }
 619             }
 620         }
 621
 622         /* And we have ourselves a clone. */
 623         return cloned;
 624     }
 625
 626 /*
 627
 628 =item C<void visit(visit_info *info)>
 629
 630 This is used by freeze/thaw to visit the contents of the object.
 631
 632 C<*info> is the visit info, (see F<include/parrot/pmc_freeze.h>).
 633
 634 =cut
 635
 636 */
 637
 638     VTABLE void visit(visit_info *info) {
 639         Parrot_Object * const obj_data = PARROT_OBJECT(SELF);
 640         PMC **pos;
 641
 642         /* 1) visit class */
 643         pos            = &obj_data->_class;
 644         info->thaw_ptr = pos;
 645         (info->visit_pmc_now)(INTERP, *pos, info);
 646
 647         /* 2) visit the attributes */
 648         pos      = &obj_data->attrib_store;
 649         info->thaw_ptr = pos;
 650         (info->visit_pmc_now)(INTERP, *pos, info);
 651     }
 652
 653 /*
 654
 655 =item C<void thaw(visit_info *info)>
 656
 657 Used to unarchive the object.
 658
 659 =cut
 660
 661 */
 662
 663     VTABLE void thaw(visit_info *info) {
 664         if (info->extra_flags == EXTRA_IS_PROP_HASH) {
 665             SUPER(info);
 666         }
 667         else if (info->extra_flags == EXTRA_IS_NULL) {
 668             /* Allocate the object's core data struct */
 669             PMC_data(SELF) = mem_allocate_zeroed_typed(Parrot_Object);
 670         }
 671     }
 672
 673 /*
 674
 675 =item C<void thawfinish(visit_info *info)>
 676
 677 Called after the object has been thawed.
 678
 679 =cut
 680
 681 */
 682
 683     void thawfinish(visit_info *info) {
 684         /* Set custom DOD mark and destroy on the object. */
 685         PObj_custom_mark_SET(SELF);
 686         PObj_active_destroy_SET(SELF);
 687
 688         /* Flag that it is an object */
 689         PObj_is_object_SET(SELF);
 690     }
 691
 692 /*
 693
 694 =item C<PMC * share_ro()>
 695
 696 Used to mark a PMC as read-only shared.
 697
 698 =cut
 699
 700 */
 701     VTABLE PMC *share_ro() {
 702         PMC   *ret, *_true, *data;
 703         INTVAL i, n;
 704         PMC *classobj;
 705         Parrot_Interp  master;
 706         INTVAL         type_num;
 707         PMC           *vtable_cache = PMCNULL;
 708
 709         if (PObj_is_PMC_shared_TEST(SELF))
 710             return SELF;
 711
 712         master = interpreter_array[0];
 713         classobj = VTABLE_get_class(INTERP, SELF);
 714         type_num = SELF->vtable->base_type;
 715
 716         /* keep the original vtable from going away... */
 717         vtable_cache = PARROT_CLASS(classobj)->vtable_cache;
 718         if (PMC_IS_NULL(vtable_cache)) {
 719             vtable_cache = pmc_new(INTERP, enum_class_VtableCache);
 720             PMC_struct_val(vtable_cache) = INTERP->vtables[type_num];
 721             PARROT_CLASS(classobj)->vtable_cache = vtable_cache;
 722         }
 723
 724         add_pmc_sync(INTERP, vtable_cache);
 725         PObj_is_PMC_shared_SET(vtable_cache);
 726
 727         /* make sure metadata doesn't go away unexpectedly */
 728         if (PMC_metadata(pmc))
 729             PMC_metadata(pmc) = pt_shared_fixup(interp, PMC_metadata(pmc));
 730
 731         PARROT_ASSERT(master->vtables[type_num]->pmc_class);
 732         /* don't want the referenced class disappearing on us */
 733         LOCK_INTERPRETER(master);
 734         SELF->vtable->pmc_class = master->vtables[type_num]->pmc_class;
 735         UNLOCK_INTERPRETER(master);
 736
 737         ret = SELF;
 738         _true = pmc_new(INTERP, enum_class_Integer);
 739
 740         /* Setting the '_ro' property switches to the read-only vtable */
 741         VTABLE_set_integer_native(INTERP, _true, 1);
 742         VTABLE_setprop(INTERP, ret, CONST_STRING(interp, "_ro"), _true);
 743         SELF->vtable->pmc_class = master->vtables[type_num]->pmc_class;
 744         add_pmc_sync(INTERP, ret);
 745         PObj_is_PMC_shared_SET(ret);
 746
 747         data = PARROT_CLASS(classobj)->parents;
 748         n    = VTABLE_elements(INTERP, data);
 749
 750         for (i = 0; i < n; ++i) {
 751             PMC * cur_class = VTABLE_get_pmc_keyed_int(INTERP, data, i);
 752             VTABLE_set_pmc_keyed_int(INTERP, data, i, VTABLE_share_ro(INTERP, cur_class));
 753         }
 754
 755         /* XXX This is perhaps not the best way to fix this up, but we
 756          * need to ensure that the class object won't go away when
 757          * this interpreter dies.
 758          */
 759         PARROT_ASSERT(ret->vtable->pmc_class);
 760         PARROT_ASSERT(ret->vtable->share_ro == Parrot_Object_share_ro);
 761
 762         return ret;
 763     }
 764
 765 /*
 766
 767 =item C<void morph(INTVAL type)>
 768
 769 Changes the PMC to a PMC of a new type
 770
 771 =cut
 772
 773 */
 774
 775     VTABLE void morph(INTVAL type) {
 776         SUPER(type);
 777     }
 778 }
 779
 780 /*
 781
 782 =back
 783
 784 =head1 SEE ALSO
 785
 786 F<docs/pdds/pdd15_objects.pod>.
 787
 788 =cut
 789
 790 */
 791
 792 /*
 793  * Local variables:
 794  *   c-file-style: "parrot"
 795  * End:
 796  * vim: expandtab shiftwidth=4:
 797  */