src/pmc.c

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