src/pmc.c

   1 /*
   2 Copyright (C) 2001-2009, Parrot Foundation.
   3 $Id$
   4
   5 =head1 NAME
   6
   7 src/pmc.c - The base vtable calling functions
   8
   9 =head1 DESCRIPTION
  10
  11 =head2 Functions
  12
  13 =over 4
  14
  15 =cut
  16
  17 */
  18
  19 #include "parrot/parrot.h"
  20 #include "pmc.str"
  21 #include "pmc/pmc_class.h"
  22 #include "pmc/pmc_context.h"
  23
  24 /* HEADERIZER HFILE: include/parrot/pmc.h */
  25
  26 /* HEADERIZER BEGIN: static */
  27 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  28
  29 static void check_pmc_reuse_flags(PARROT_INTERP,
  30     UINTVAL srcflags,
  31     UINTVAL destflags)
  32         __attribute__nonnull__(1);
  33
  34 PARROT_WARN_UNUSED_RESULT
  35 PARROT_CANNOT_RETURN_NULL
  36 static PMC * create_class_pmc(PARROT_INTERP, INTVAL type)
  37         __attribute__nonnull__(1);
  38
  39 PARROT_WARN_UNUSED_RESULT
  40 PARROT_CANNOT_RETURN_NULL
  41 static PMC * get_new_pmc_header(PARROT_INTERP,
  42     INTVAL base_type,
  43     UINTVAL flags)
  44         __attribute__nonnull__(1);
  45
  46 PARROT_CANNOT_RETURN_NULL
  47 static PMC* pmc_reuse_no_init(PARROT_INTERP,
  48     ARGIN(PMC *pmc),
  49     INTVAL new_type,
  50     SHIM(UINTVAL flags))
  51         __attribute__nonnull__(1)
  52         __attribute__nonnull__(2);
  53
  54 #define ASSERT_ARGS_check_pmc_reuse_flags __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
  55        PARROT_ASSERT_ARG(interp))
  56 #define ASSERT_ARGS_create_class_pmc __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
  57        PARROT_ASSERT_ARG(interp))
  58 #define ASSERT_ARGS_get_new_pmc_header __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
  59        PARROT_ASSERT_ARG(interp))
  60 #define ASSERT_ARGS_pmc_reuse_no_init __attribute__unused__ int _ASSERT_ARGS_CHECK = (\
  61        PARROT_ASSERT_ARG(interp) \
  62     , PARROT_ASSERT_ARG(pmc))
  63 /* Don't modify between HEADERIZER BEGIN / HEADERIZER END.  Your changes will be lost. */
  64 /* HEADERIZER END: static */
  65
  66
  67 #if PARROT_CATCH_NULL
  68 PMC * PMCNULL;
  69 #endif
  70
  71 /*
  72
  73 =item C<INTVAL PMC_is_null(PARROT_INTERP, const PMC *pmc)>
  74
  75 Tests if the given pmc is null.
  76
  77 =cut
  78
  79 */
  80
  81 PARROT_EXPORT
  82 INTVAL
  83 PMC_is_null(SHIM_INTERP, ARGIN_NULLOK(const PMC *pmc))
  84 {
  85     ASSERT_ARGS(PMC_is_null)
  86 #if PARROT_CATCH_NULL
  87     return pmc == PMCNULL || pmc == NULL;
  88 #else
  89     return pmc == NULL;
  90 #endif
  91 }
  92
  93 /*
  94
  95 =item C<void Parrot_pmc_destroy(PARROT_INTERP, PMC *pmc)>
  96
  97 Destroy a PMC. Call his destroy vtable function if needed, and deallocate
  98 his attributes if they are automatically allocated.
  99
 100 For internal usage of the PMC handling functions and garbage collection
 101 subsystem.
 102
 103 =cut
 104
 105 */
 106
 107 PARROT_EXPORT
 108 void
 109 Parrot_pmc_destroy(PARROT_INTERP, ARGMOD(PMC *pmc))
 110 {
 111     ASSERT_ARGS(Parrot_pmc_destroy)
 112
 113     if (PObj_custom_destroy_TEST(pmc)) {
 114         VTABLE_destroy(interp, pmc);
 115         /* Prevent repeated calls. */
 116         PObj_custom_destroy_CLEAR(pmc);
 117     }
 118
 119     PObj_custom_mark_CLEAR(pmc);
 120     PObj_live_CLEAR(pmc);
 121
 122     if (PObj_is_PMC_shared_TEST(pmc) && PMC_sync(pmc))
 123         Parrot_gc_free_pmc_sync(interp, pmc);
 124
 125     if (pmc->vtable->attr_size)
 126         Parrot_gc_free_pmc_attributes(interp, pmc);
 127     else
 128         PMC_data(pmc) = NULL;
 129
 130 #ifndef NDEBUG
 131
 132     pmc->vtable      = (VTABLE  *)0xdeadbeef;
 133
 134 #endif
 135
 136 }
 137
 138 /*
 139
 140 =item C<PMC * pmc_new(PARROT_INTERP, INTVAL base_type)>
 141
 142 Creates a new PMC of type C<base_type> (which is an index into the list of PMC
 143 types declared in C<vtables> in F<include/parrot/pmc.h>). Once the PMC has been
 144 successfully created and its vtable pointer initialized, we call its C<init>
 145 method to perform any other necessary initialization.
 146
 147 =cut
 148
 149 */
 150
 151 PARROT_EXPORT
 152 PARROT_CANNOT_RETURN_NULL
 153 PARROT_WARN_UNUSED_RESULT
 154 PMC *
 155 pmc_new(PARROT_INTERP, INTVAL base_type)
 156 {
 157     ASSERT_ARGS(pmc_new)
 158     PARROT_ASSERT(interp->vtables[base_type]);
 159     {
 160         PMC *const classobj = interp->vtables[base_type]->pmc_class;
 161
 162         if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
 163             return VTABLE_instantiate(interp, classobj, PMCNULL);
 164         else {
 165             PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
 166             VTABLE_init(interp, pmc);
 167             return pmc;
 168         }
 169     }
 170 }
 171
 172 /*
 173
 174 =item C<PMC * pmc_reuse(PARROT_INTERP, PMC *pmc, INTVAL new_type, UINTVAL
 175 flags)>
 176
 177 Reuse an existing PMC, turning it into an empty PMC of the new type. Any
 178 required internal structure will be put in place (such as the extension area)
 179 and the PMC will be ready to go.
 180
 181 Cannot currently handle converting a non-Object PMC into an Object. Use
 182 C<pmc_reuse_by_class> for that.
 183
 184
 185 =cut
 186
 187 */
 188
 189 PARROT_EXPORT
 190 PARROT_CANNOT_RETURN_NULL
 191 PARROT_IGNORABLE_RESULT
 192 PMC *
 193 pmc_reuse(PARROT_INTERP, ARGIN(PMC *pmc), INTVAL new_type,
 194           UINTVAL flags)
 195 {
 196     ASSERT_ARGS(pmc_reuse)
 197     pmc = pmc_reuse_no_init(interp, pmc, new_type, flags);
 198
 199     /* Call the base init for the redone pmc. Warning, this should not
 200        be called on Object PMCs. */
 201     VTABLE_init(interp, pmc);
 202
 203     return pmc;
 204 }
 205
 206 /*
 207
 208 =item C<PMC * pmc_reuse_init(PARROT_INTERP, PMC *pmc, INTVAL new_type, PMC
 209 *init, UINTVAL flags)>
 210
 211 Reuse an existing PMC, turning it into an PMC of the new type. Any
 212 required internal structure will be put in place (such as the extension area)
 213 and the PMC will be inited.
 214
 215 Cannot currently handle converting a non-Object PMC into an Object. Use
 216 C<pmc_reuse_by_class> for that.
 217
 218
 219 =cut
 220
 221 */
 222
 223 PARROT_EXPORT
 224 PARROT_CANNOT_RETURN_NULL
 225 PARROT_IGNORABLE_RESULT
 226 PMC *
 227 pmc_reuse_init(PARROT_INTERP, ARGIN(PMC *pmc), INTVAL new_type, ARGIN(PMC *init),
 228           UINTVAL flags)
 229 {
 230     ASSERT_ARGS(pmc_reuse_init)
 231     pmc = pmc_reuse_no_init(interp, pmc, new_type, flags);
 232
 233     /* Call the base init for the redone pmc. Warning, this should not
 234        be called on Object PMCs. */
 235     VTABLE_init_pmc(interp, pmc, init);
 236
 237     return pmc;
 238 }
 239
 240 /*
 241
 242 =item C<static PMC* pmc_reuse_no_init(PARROT_INTERP, PMC *pmc, INTVAL new_type,
 243 UINTVAL flags)>
 244
 245 Prepare pmc for reuse. Do all scuffolding except initing.
 246
 247 =cut
 248
 249 */
 250 PARROT_CANNOT_RETURN_NULL
 251 static PMC*
 252 pmc_reuse_no_init(PARROT_INTERP, ARGIN(PMC *pmc), INTVAL new_type,
 253     SHIM(UINTVAL flags)) {
 254
 255     ASSERT_ARGS(pmc_reuse_no_init)
 256     VTABLE *new_vtable;
 257     INTVAL  has_ext, new_flags = 0;
 258
 259     if (pmc->vtable->base_type == new_type)
 260         return pmc;
 261
 262     new_vtable = interp->vtables[new_type];
 263
 264     /* Singleton/const PMCs/types are not eligible */
 265     check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
 266
 267     /* Free the old PMC resources. */
 268     Parrot_pmc_destroy(interp, pmc);
 269
 270     PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | new_flags);
 271
 272     /* Set the right vtable */
 273     pmc->vtable = new_vtable;
 274
 275     if (new_vtable->attr_size)
 276         Parrot_gc_allocate_pmc_attributes(interp, pmc);
 277
 278     else
 279         PMC_data(pmc) = NULL;
 280
 281     return pmc;
 282 }
 283
 284 /*
 285
 286 =item C<PMC * pmc_reuse_by_class(PARROT_INTERP, PMC *pmc, PMC *class_, UINTVAL
 287 flags)>
 288
 289 Reuse an existing PMC. Convert it to the type specified by the given Class
 290 PMC. At the moment, this means we can only use this function to reuse PMCs
 291 into types with Classes (not built-in PMCs). Use C<pmc_reuse> if you need
 292 to convert to a built-in PMC type.
 293
 294 =cut
 295
 296 */
 297
 298 PARROT_EXPORT
 299 PARROT_CANNOT_RETURN_NULL
 300 PARROT_IGNORABLE_RESULT
 301 PMC *
 302 pmc_reuse_by_class(PARROT_INTERP, ARGMOD(PMC *pmc), ARGIN(PMC *class_),
 303     UINTVAL flags)
 304 {
 305     ASSERT_ARGS(pmc_reuse_by_class)
 306     const INTVAL   new_type   = PARROT_CLASS(class_)->id;
 307     VTABLE * const new_vtable = interp->vtables[new_type];
 308     INTVAL         new_flags  = flags;
 309
 310     if (pmc->vtable->base_type == new_type)
 311         return pmc;
 312
 313     /* Singleton/const PMCs/types are not eligible */
 314     check_pmc_reuse_flags(interp, pmc->vtable->flags, new_vtable->flags);
 315
 316     Parrot_pmc_destroy(interp, pmc);
 317
 318     PObj_flags_SETTO(pmc, PObj_is_PMC_FLAG | new_flags);
 319
 320     /* Set the right vtable */
 321     pmc->vtable = new_vtable;
 322
 323     if (new_vtable->attr_size)
 324         Parrot_gc_allocate_pmc_attributes(interp, pmc);
 325     else
 326         PMC_data(pmc) = NULL;
 327
 328     return pmc;
 329 }
 330
 331
 332 /*
 333
 334 =item C<static void check_pmc_reuse_flags(PARROT_INTERP, UINTVAL srcflags,
 335 UINTVAL destflags)>
 336
 337 We're converting one PMC type to another, either in C<pmc_reuse> or
 338 C<pmc_reuse_by_class>. Check to make sure that neither the existing PMC
 339 or the intended target PMC type are singletons or constants. We throw an
 340 exception if we are attempting an illegal operation.
 341
 342 =cut
 343
 344 */
 345
 346 static void
 347 check_pmc_reuse_flags(PARROT_INTERP, UINTVAL srcflags, UINTVAL destflags)
 348 {
 349     ASSERT_ARGS(check_pmc_reuse_flags)
 350     if ((srcflags | destflags) & (VTABLE_PMC_IS_SINGLETON | VTABLE_IS_CONST_FLAG))
 351     {
 352         /* First, is the destination a singleton? No joy for us there */
 353         if (destflags & VTABLE_PMC_IS_SINGLETON)
 354             Parrot_ex_throw_from_c_args(interp, NULL,
 355                 EXCEPTION_ALLOCATION_ERROR,
 356                 "Parrot VM: Can't turn to a singleton type!\n");
 357
 358         /* Is the destination a constant? No joy for us there */
 359         if (destflags & VTABLE_IS_CONST_FLAG)
 360             Parrot_ex_throw_from_c_args(interp, NULL,
 361                 EXCEPTION_ALLOCATION_ERROR,
 362                 "Parrot VM: Can't turn to a constant type!\n");
 363
 364         /* Is the source a singleton? */
 365         if (srcflags & VTABLE_PMC_IS_SINGLETON)
 366             Parrot_ex_throw_from_c_args(interp, NULL,
 367                 EXCEPTION_ALLOCATION_ERROR,
 368                 "Parrot VM: Can't modify a singleton\n");
 369
 370         /* Is the source constant? */
 371         if (srcflags & VTABLE_IS_CONST_FLAG)
 372             Parrot_ex_throw_from_c_args(interp, NULL,
 373                 EXCEPTION_ALLOCATION_ERROR,
 374                 "Parrot VM: Can't modify a constant\n");
 375     }
 376 }
 377
 378 /*
 379
 380 =item C<static PMC * get_new_pmc_header(PARROT_INTERP, INTVAL base_type, UINTVAL
 381 flags)>
 382
 383 Gets a new PMC header of the given integer type. Initialize the pmc if
 384 necessary. In the case of singleton PMC types, get the existing singleton
 385 instead of allocating a new one.
 386
 387 =cut
 388
 389 */
 390
 391 PARROT_WARN_UNUSED_RESULT
 392 PARROT_CANNOT_RETURN_NULL
 393 static PMC *
 394 get_new_pmc_header(PARROT_INTERP, INTVAL base_type, UINTVAL flags)
 395 {
 396     ASSERT_ARGS(get_new_pmc_header)
 397     PMC    *pmc;
 398     VTABLE *vtable = interp->vtables[base_type];
 399     UINTVAL vtable_flags;
 400
 401     /* This is usually because you either didn't call init_world early enough,
 402      * you added a new PMC class without adding Parrot_(classname)_class_init
 403      * to init_world, or you forgot to run 'make realclean' after adding a new
 404      * PMC class.  */
 405     if (!vtable)
 406         PANIC(interp, "Null vtable used; did you add a new PMC?");
 407
 408     vtable_flags = vtable->flags;
 409
 410     /* we only have one global Env object, living in the interp */
 411     if (vtable_flags & VTABLE_PMC_IS_SINGLETON) {
 412         /*
 413          * singletons (monadic objects) exist only once
 414          * the interface * with the class is:
 415          * - get_pointer: return NULL or a pointer to the single instance
 416          * - set_pointer: set the only instance once
 417          *
 418          * - singletons are created in the constant pmc pool
 419          */
 420         PMC *pmc = (PMC *)(vtable->get_pointer)(interp, NULL);
 421
 422         /* LOCK */
 423         if (!pmc) {
 424             pmc = Parrot_gc_new_pmc_header(interp, PObj_constant_FLAG);
 425             PARROT_ASSERT(pmc);
 426
 427             pmc->vtable    = vtable;
 428             VTABLE_set_pointer(interp, pmc, pmc);
 429         }
 430
 431         return pmc;
 432     }
 433
 434     if (vtable_flags & VTABLE_IS_CONST_PMC_FLAG)
 435         flags |= PObj_constant_FLAG;
 436     else if (vtable_flags & VTABLE_IS_CONST_FLAG) {
 437         /* put the normal vtable in, so that the pmc can be initialized first
 438          * parrot or user code has to set the _ro property then,
 439          * to morph the PMC to the const variant
 440          * This assumes that a constant PMC enum is one bigger then
 441          * the normal one.
 442          */
 443
 444         /*
 445          * XXX not yet we can't assure that all contents in the
 446          * const PMC is const too
 447          * see e.g. t/pmc/sarray_13.pir
 448          */
 449 #if 0
 450         flags |= PObj_constant_FLAG;
 451 #endif
 452         --base_type;
 453         vtable = interp->vtables[base_type];
 454     }
 455
 456     if (vtable_flags & VTABLE_IS_SHARED_FLAG)
 457         flags |= PObj_is_PMC_shared_FLAG;
 458
 459     pmc            = Parrot_gc_new_pmc_header(interp, flags);
 460     pmc->vtable    = vtable;
 461
 462     if (vtable->attr_size)
 463         Parrot_gc_allocate_pmc_attributes(interp, pmc);
 464
 465 #if GC_VERBOSE
 466     if (Interp_flags_TEST(interp, PARROT_TRACE_FLAG)) {
 467         /* XXX make a more verbose trace flag */
 468         fprintf(stderr, "\t=> new %p type %d\n", pmc, (int)base_type);
 469     }
 470 #endif
 471
 472     return pmc;
 473 }
 474
 475
 476 /*
 477
 478 =item C<PMC * pmc_new_noinit(PARROT_INTERP, INTVAL base_type)>
 479
 480 Creates a new PMC of type C<base_type> (which is an index into the list of PMC
 481 types declared in C<vtables> in F<include/parrot/pmc.h>). Unlike C<pmc_new()>,
 482 C<pmc_new_noinit()> does not call its C<init> method.  This allows separate
 483 allocation and initialization for continuations.
 484
 485 =cut
 486
 487 */
 488
 489 PARROT_EXPORT
 490 PARROT_CANNOT_RETURN_NULL
 491 PMC *
 492 pmc_new_noinit(PARROT_INTERP, INTVAL base_type)
 493 {
 494     ASSERT_ARGS(pmc_new_noinit)
 495     PMC *const classobj = interp->vtables[base_type]->pmc_class;
 496
 497     if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
 498         return VTABLE_instantiate(interp, classobj, PMCNULL);
 499
 500     return get_new_pmc_header(interp, base_type, 0);
 501 }
 502
 503
 504 /*
 505
 506 =item C<PMC * constant_pmc_new_noinit(PARROT_INTERP, INTVAL base_type)>
 507
 508 Creates a new constant PMC of type C<base_type>.
 509
 510 =cut
 511
 512 */
 513
 514 PARROT_EXPORT
 515 PARROT_CANNOT_RETURN_NULL
 516 PMC *
 517 constant_pmc_new_noinit(PARROT_INTERP, INTVAL base_type)
 518 {
 519     ASSERT_ARGS(constant_pmc_new_noinit)
 520     return get_new_pmc_header(interp, base_type, PObj_constant_FLAG);
 521 }
 522
 523
 524 /*
 525
 526 =item C<PMC * constant_pmc_new(PARROT_INTERP, INTVAL base_type)>
 527
 528 Creates a new constant PMC of type C<base_type>, then calls its C<init>.
 529
 530 =cut
 531
 532 */
 533
 534 PARROT_EXPORT
 535 PARROT_CANNOT_RETURN_NULL
 536 PMC *
 537 constant_pmc_new(PARROT_INTERP, INTVAL base_type)
 538 {
 539     ASSERT_ARGS(constant_pmc_new)
 540     PMC * const pmc = get_new_pmc_header(interp, base_type, PObj_constant_FLAG);
 541     VTABLE_init(interp, pmc);
 542     return pmc;
 543 }
 544
 545
 546 /*
 547
 548 =item C<PMC * pmc_new_init(PARROT_INTERP, INTVAL base_type, PMC *init)>
 549
 550 As C<pmc_new()>, but passes C<init> to the PMC's C<init_pmc()> vtable entry.
 551
 552 =cut
 553
 554 */
 555
 556 PARROT_EXPORT
 557 PARROT_CANNOT_RETURN_NULL
 558 PMC *
 559 pmc_new_init(PARROT_INTERP, INTVAL base_type, ARGOUT(PMC *init))
 560 {
 561     ASSERT_ARGS(pmc_new_init)
 562     PMC *const classobj = interp->vtables[base_type]->pmc_class;
 563
 564     if (!PMC_IS_NULL(classobj) && PObj_is_class_TEST(classobj))
 565         return VTABLE_instantiate(interp, classobj, init);
 566     else {
 567         PMC * const pmc = get_new_pmc_header(interp, base_type, 0);
 568         VTABLE_init_pmc(interp, pmc, init);
 569         return pmc;
 570     }
 571 }
 572
 573
 574 /*
 575
 576 =item C<PMC * constant_pmc_new_init(PARROT_INTERP, INTVAL base_type, PMC *init)>
 577
 578 As C<constant_pmc_new>, but passes C<init> to the PMC's C<init_pmc> vtable
 579 entry.
 580
 581 =cut
 582
 583 */
 584
 585 PARROT_EXPORT
 586 PARROT_CANNOT_RETURN_NULL
 587 PMC *
 588 constant_pmc_new_init(PARROT_INTERP, INTVAL base_type, ARGIN_NULLOK(PMC *init))
 589 {
 590     ASSERT_ARGS(constant_pmc_new_init)
 591     PMC * const pmc = get_new_pmc_header(interp, base_type, PObj_constant_FLAG);
 592     VTABLE_init_pmc(interp, pmc, init);
 593     return pmc;
 594 }
 595
 596
 597 /*
 598
 599 =item C<PMC * temporary_pmc_new(PARROT_INTERP, INTVAL base_type)>
 600
 601 Creates a new temporary PMC of type C<base_type>, then call C<init>. Cannot
 602 be used to create PMC Objects which have been defined from PIR.
 603
 604 B<You> are responsible for freeing this PMC when it goes out of scope with
 605 C<free_temporary_pmc()>.  B<Do not> store this PMC in any other PMCs, or
 606 allow it to be stored.  B<Do not> store any regular PMC in this PMC, or
 607 allow the storage of any regular PMC in this PMC. Temporary PMCs do not
 608 participate in garbage collection, and mixing them with PMCs that are
 609 garbage-collected will cause bugs.
 610
 611 If you don't know what this means means, or you can't tell if either case
 612 will happen as the result of any call you make on or with this PMC,
 613 B<DO NOT> use this function, lest you cause weird crashes and memory errors.
 614 Use C<pmc_new()> instead.
 615
 616 (Why do these functions even exist?  Used judiciously, they can reduce GC
 617 pressure in hotspots tremendously.  If you haven't audited the code carefully
 618 -- including profiling and benchmarking -- then use C<pmc_new()> instead, and
 619 never B<ever> add C<PARROT_EXPORT> to either function.)
 620
 621 =cut
 622
 623 */
 624
 625 PARROT_CANNOT_RETURN_NULL
 626 PMC *
 627 temporary_pmc_new(PARROT_INTERP, INTVAL base_type)
 628 {
 629     ASSERT_ARGS(temporary_pmc_new)
 630     PMC * const pmc = get_new_pmc_header(interp, base_type, PObj_constant_FLAG);
 631     VTABLE_init(interp, pmc);
 632     return pmc;
 633 }
 634
 635
 636 /*
 637
 638 =item C<void temporary_pmc_free(PARROT_INTERP, PMC *pmc)>
 639
 640 Frees a new temporary PMC created by C<temporary_pmc_new()>.  Do not call
 641 this with any other type of PMC.  Do not forget to call this (or you'll leak
 642 PMCs). Read and I<understand> the warnings for C<temporary_pmc_new()> before
 643 you're tempted to use this.
 644
 645 =cut
 646
 647 */
 648
 649 void
 650 temporary_pmc_free(PARROT_INTERP, ARGMOD(PMC *pmc))
 651 {
 652     ASSERT_ARGS(temporary_pmc_free)
 653     Parrot_gc_free_pmc_header(interp, pmc);
 654 }
 655
 656
 657 /*
 658
 659 =item C<INTVAL get_new_vtable_index(PARROT_INTERP)>
 660
 661 Get a new unique identifier number and allocate a new vtable structure for a
 662 new PMC type.
 663
 664 =cut
 665
 666 */
 667
 668 INTVAL
 669 get_new_vtable_index(PARROT_INTERP)
 670 {
 671     ASSERT_ARGS(get_new_vtable_index)
 672     const INTVAL type_id = interp->n_vtable_max++;
 673
 674     /* Have we overflowed the table? */
 675     if (type_id >= interp->n_vtable_alloced)
 676         parrot_realloc_vtables(interp);
 677
 678     return type_id;
 679 }
 680
 681 /*
 682
 683 =item C<INTVAL pmc_register(PARROT_INTERP, STRING *name)>
 684
 685 Registers the name of a new PMC type with Parrot, returning the INTVAL
 686 representing that type.
 687
 688 =cut
 689
 690 */
 691
 692 PARROT_EXPORT
 693 INTVAL
 694 pmc_register(PARROT_INTERP, ARGIN(STRING *name))
 695 {
 696     ASSERT_ARGS(pmc_register)
 697     /* If they're looking to register an existing class, return that
 698        class' type number */
 699     INTVAL type = pmc_type(interp, name);
 700
 701     if (type > enum_type_undef)
 702         return type;
 703
 704     if (type < enum_type_undef)
 705         Parrot_ex_throw_from_c_args(interp, NULL, 1,
 706             "undefined type already exists - can't register PMC");
 707
 708     type = get_new_vtable_index(interp);
 709
 710     /* set entry in name->type hash */
 711     VTABLE_set_integer_keyed_str(interp, interp->class_hash, name, type);
 712
 713     return type;
 714 }
 715
 716
 717 /*
 718
 719 =item C<INTVAL pmc_type(PARROT_INTERP, STRING *name)>
 720
 721 Returns the PMC type for C<name>.
 722
 723 =cut
 724
 725 */
 726
 727 PARROT_EXPORT
 728 PARROT_WARN_UNUSED_RESULT
 729 INTVAL
 730 pmc_type(PARROT_INTERP, ARGIN_NULLOK(STRING *name))
 731 {
 732     ASSERT_ARGS(pmc_type)
 733     if (!name)
 734         return enum_type_undef;
 735     else {
 736         PMC * const classname_hash = interp->class_hash;
 737         PMC * const item           =
 738             (PMC *)VTABLE_get_pointer_keyed_str(interp, classname_hash, name);
 739
 740         if (!PMC_IS_NULL(item)) {
 741             /* nested namespace with same name */
 742             if (item->vtable->base_type == enum_class_NameSpace)
 743                 return enum_type_undef;
 744             else
 745                 return VTABLE_get_integer(interp, item);
 746         }
 747         else
 748             return Parrot_get_datatype_enum(interp, name);
 749     }
 750 }
 751
 752
 753 /*
 754
 755 =item C<INTVAL pmc_type_p(PARROT_INTERP, PMC *name)>
 756
 757 Returns the PMC type for C<name>.
 758
 759 =cut
 760
 761 */
 762
 763 PARROT_EXPORT
 764 INTVAL
 765 pmc_type_p(PARROT_INTERP, ARGIN(PMC *name))
 766 {
 767     ASSERT_ARGS(pmc_type_p)
 768     PMC * const classname_hash = interp->class_hash;
 769     PMC * item;
 770
 771     item = (PMC *)VTABLE_get_pointer_keyed(interp, classname_hash, name);
 772
 773     if (!PMC_IS_NULL(item))
 774         return VTABLE_get_integer(interp, item);
 775
 776     return 0;
 777 }
 778
 779
 780 /*
 781
 782 =item C<static PMC * create_class_pmc(PARROT_INTERP, INTVAL type)>
 783
 784 Create a class object for this interpreter.  Takes an interpreter name and type
 785 as arguments.  Returns a pointer to the class object.
 786
 787 =cut
 788
 789 */
 790
 791 PARROT_WARN_UNUSED_RESULT
 792 PARROT_CANNOT_RETURN_NULL
 793 static PMC *
 794 create_class_pmc(PARROT_INTERP, INTVAL type)
 795 {
 796     ASSERT_ARGS(create_class_pmc)
 797     /*
 798      * class interface - a PMC is its own class
 799      * put an instance of this PMC into class
 800      *
 801      * create a constant PMC
 802      */
 803     PMC * const _class = get_new_pmc_header(interp, type,
 804                                            PObj_constant_FLAG);
 805
 806     /* If we are a second thread, we may get the same object as the
 807      * original because we have a singleton. Just set the singleton to
 808      * be our class object, but don't mess with its vtable.  */
 809     if ((interp->vtables[type]->flags & VTABLE_PMC_IS_SINGLETON)
 810     &&  (_class == _class->vtable->pmc_class))
 811         interp->vtables[type]->pmc_class = _class;
 812     else {
 813         Parrot_gc_free_pmc_sync(interp, _class);
 814         gc_flag_CLEAR(is_special_PMC, _class);
 815         PObj_is_PMC_shared_CLEAR(_class);
 816         interp->vtables[type]->pmc_class = _class;
 817     }
 818
 819     return _class;
 820 }
 821
 822
 823 /*
 824
 825 =item C<void Parrot_create_mro(PARROT_INTERP, INTVAL type)>
 826
 827 Create the MRO (method resolution order) array for this type.
 828
 829 =cut
 830
 831 */
 832
 833 PARROT_EXPORT
 834 void
 835 Parrot_create_mro(PARROT_INTERP, INTVAL type)
 836 {
 837     ASSERT_ARGS(Parrot_create_mro)
 838     PMC    *_class, *mro;
 839     VTABLE *vtable   = interp->vtables[type];
 840     PMC    *mro_list = vtable->mro;
 841     INTVAL  i, count;
 842
 843     /* this should never be PMCNULL */
 844     PARROT_ASSERT(!PMC_IS_NULL(mro_list));
 845
 846     /* multithreaded: has already mro */
 847     if (mro_list->vtable->base_type != enum_class_ResizableStringArray)
 848         return;
 849
 850     mro         = pmc_new(interp, enum_class_ResizablePMCArray);
 851     vtable->mro = mro;
 852
 853     if (vtable->ro_variant_vtable)
 854         vtable->ro_variant_vtable->mro = mro;
 855
 856     count = VTABLE_elements(interp, mro_list);
 857
 858     for (i = 0; i < count; ++i) {
 859         STRING *class_name  = VTABLE_get_string_keyed_int(interp, mro_list, i);
 860         INTVAL  parent_type = pmc_type(interp, class_name);
 861
 862         /* abstract classes don't have a vtable */
 863         if (!parent_type)
 864             break;
 865
 866         vtable = interp->vtables[parent_type];
 867
 868         if (!vtable->_namespace) {
 869             /* need a namespace Hash, anchor at parent, name it */
 870             PMC * const ns     = pmc_new(interp,
 871                     Parrot_get_ctx_HLL_type(interp, enum_class_NameSpace));
 872             vtable->_namespace = ns;
 873
 874             /* anchor at parent, aka current_namespace, that is 'parrot' */
 875             VTABLE_set_pmc_keyed_str(interp,
 876                     Parrot_pcc_get_namespace(interp, CURRENT_CONTEXT(interp)), class_name, ns);
 877         }
 878
 879         _class = vtable->pmc_class;
 880         if (!_class)
 881             _class = create_class_pmc(interp, parent_type);
 882
 883         VTABLE_push_pmc(interp, mro, _class);
 884     }
 885 }
 886
 887
 888 /*
 889
 890 =back
 891
 892 =head2 GC registry interface
 893
 894 =over 4
 895
 896 =item C<void gc_register_pmc(PARROT_INTERP, PMC *pmc)>
 897
 898 Registers the PMC with the interpreter's GC registry.
 899
 900 =cut
 901
 902 */
 903
 904 PARROT_EXPORT
 905 void
 906 gc_register_pmc(PARROT_INTERP, ARGIN(PMC *pmc))
 907 {
 908     ASSERT_ARGS(gc_register_pmc)
 909     /* Better not trigger a GC run with a potentially unanchored PMC */
 910     Parrot_block_GC_mark(interp);
 911
 912     PARROT_ASSERT(interp->gc_registry);
 913
 914     VTABLE_set_pmc_keyed(interp, interp->gc_registry, pmc, PMCNULL);
 915     Parrot_unblock_GC_mark(interp);
 916 }
 917
 918
 919 /*
 920
 921 =item C<void gc_unregister_pmc(PARROT_INTERP, PMC *pmc)>
 922
 923 Unregisters the PMC from the interpreter's GC registry.
 924
 925 =cut
 926
 927 */
 928
 929 PARROT_EXPORT
 930 void
 931 gc_unregister_pmc(PARROT_INTERP, ARGIN(PMC *pmc))
 932 {
 933     ASSERT_ARGS(gc_unregister_pmc)
 934     PARROT_ASSERT(interp->gc_registry);
 935
 936     VTABLE_delete_keyed(interp, interp->gc_registry, pmc);
 937 }
 938
 939
 940 /*
 941
 942 =back
 943
 944 =head1 SEE ALSO
 945
 946 F<include/parrot/vtable.h>.
 947
 948 C<5.1.0.14.2.20011008152120.02158148@pop.sidhe.org>
 949 (http://www.nntp.perl.org/group/perl.perl6.internals/5516).
 950
 951 =head1 HISTORY
 952
 953 Initial version by Simon on 2001.10.20.
 954
 955 =cut
 956
 957 */
 958
 959
 960 /*
 961  * Local variables:
 962  *   c-file-style: "parrot"
 963  * End:
 964  * vim: expandtab shiftwidth=4:
 965  */