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