src/pmc.c

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