lib/Parrot/Pmc2c/PMCEmitter.pm

   1 # Copyright (C) 2007-2008, The Perl Foundation.
   2 # $Id$
   3
   4 =head1 NAME
   5
   6 Parrot::Pmc2c::PMCEmitter - PMC to C Code Generation
   7
   8 =head1 SYNOPSIS
   9
  10     use Parrot::Pmc2c::PMCEmitter;
  11
  12 =head1 DESCRIPTION
  13
  14 C<Parrot::Pmc2c::PMCEmitter> is used by F<tools/build/pmc2c.pl> to generate C code from PMC files.
  15
  16 =head2 Functions
  17
  18 =over
  19
  20 =cut
  21
  22 package Parrot::Pmc2c::PMC;
  23 use strict;
  24 use warnings;
  25 use Parrot::Pmc2c::Emitter;
  26 use Parrot::Pmc2c::Method;
  27 use Parrot::Pmc2c::MethodEmitter;
  28 use Parrot::Pmc2c::UtilFunctions
  29     qw( gen_ret dont_edit count_newlines dynext_load_code c_code_coda );
  30 use Text::Balanced 'extract_bracketed';
  31 use Parrot::Pmc2c::PCCMETHOD;
  32 use Parrot::Pmc2c::PMC::RO;
  33 use Parrot::Pmc2c::PMC::ParrotClass;
  34
  35 sub prep_for_emit {
  36     my ( $this, $pmc, $vtable_dump ) = @_;
  37
  38     $pmc->vtable($vtable_dump);
  39     $pmc->init();
  40
  41     return $pmc;
  42 }
  43
  44 sub generate {
  45     my ($self) = @_;
  46     my $emitter = $self->{emitter} =
  47         Parrot::Pmc2c::Emitter->new( $self->filename(".c") );
  48
  49     $self->generate_c_file;
  50     $emitter->write_to_file;
  51
  52     $emitter = $self->{emitter} =
  53         Parrot::Pmc2c::Emitter->new( $self->filename(".h") );
  54
  55     $self->generate_h_file;
  56     $emitter->write_to_file;
  57 }
  58
  59 =item C<generate_c_file()>
  60
  61 Generates the C implementation file code for the PMC.
  62
  63 =cut
  64
  65 sub generate_c_file {
  66     my ($self) = @_;
  67     my $c      = $self->{emitter};
  68
  69     $c->emit( dont_edit( $self->filename ) );
  70     if ($self->is_dynamic) {
  71         $c->emit("#define PARROT_IN_EXTENSION\n");
  72         $c->emit("#define CONST_STRING(i, s) const_string((i), s)\n");
  73         $c->emit("#define CONST_STRING_GEN(i, s) const_string((i), s)\n");
  74     }
  75
  76     $self->gen_includes;
  77
  78     $c->emit( $self->preamble );
  79
  80     $self->gen_methods;
  81
  82     my $ro = $self->ro;
  83     if ($ro) {
  84         $ro->{emitter} = $self->{emitter};
  85         $ro->gen_methods;
  86     }
  87
  88     $c->emit("#include \"pmc_default.h\"\n");
  89
  90     $c->emit( $self->init_func );
  91     $c->emit( $self->postamble );
  92
  93     return 1;
  94 }
  95
  96 =item C<generate_h_file()>
  97
  98 Generates the C header file code for the PMC.
  99
 100 =cut
 101
 102 sub generate_h_file {
 103     my ($self) = @_;
 104     my $h      = $self->{emitter};
 105     my $name   = uc $self->name;
 106
 107     $h->emit( dont_edit( $self->filename ) );
 108     $h->emit(<<"EOH");
 109
 110 #ifndef PARROT_PMC_${name}_H_GUARD
 111 #define PARROT_PMC_${name}_H_GUARD
 112
 113 EOH
 114
 115     $h->emit("#define PARROT_IN_EXTENSION\n") if ( $self->is_dynamic );
 116     $h->emit( $self->hdecls );
 117     $h->emit( $self->{ro}->hdecls ) if ( $self->{ro} );
 118     $self->gen_attributes;
 119     $h->emit(<<"EOH");
 120
 121 #endif /* PARROT_PMC_${name}_H_GUARD */
 122
 123 EOH
 124     $h->emit( c_code_coda() );
 125     return 1;
 126 }
 127
 128 =item C<hdecls()>
 129
 130 Returns the C code function declarations for all the methods for inclusion
 131 in the PMC's C header file.
 132
 133 TODO include MMD variants.
 134
 135 =cut
 136
 137 sub hdecls {
 138     my ($self) = @_;
 139
 140     my $hout;
 141     my $name = $self->name;
 142
 143     # generate decls for all vtable methods in this PMC
 144     foreach my $vt_method_name ( @{ $self->vtable->names } ) {
 145         if ( $self->implements_vtable($vt_method_name) ) {
 146             $hout .=
 147                 $self->get_method($vt_method_name)->generate_headers($self);
 148         }
 149     }
 150
 151     # generate decls for all nci methods in this PMC
 152     foreach my $method ( @{ $self->{methods} } ) {
 153         next if $method->is_vtable;
 154         $hout .= $method->generate_headers($self);
 155     }
 156
 157     # class init decl
 158     $hout .= 'PARROT_DYNEXT_EXPORT ' if ( $self->is_dynamic );
 159     $hout .= "void Parrot_${name}_class_init(PARROT_INTERP, int, int);\n";
 160     $self->{hdecls} .= $hout;
 161
 162     return $self->{hdecls};
 163 }
 164
 165 =back
 166
 167 =head2 Instance Methods
 168
 169 =over
 170
 171 =item C<init()>
 172
 173 Initializes the instance.
 174
 175 =cut
 176
 177 sub init {
 178     my ($self) = @_;
 179
 180     $self->fixup_singleton if $self->singleton;
 181
 182     #!( singleton or abstract ) everything else gets readonly version of
 183     # methods too.
 184
 185     $self->ro( Parrot::Pmc2c::PMC::RO->new($self) )
 186         unless $self->abstract or $self->singleton;
 187 }
 188
 189 sub fixup_singleton {
 190     my ($self) = @_;
 191
 192     # Because singletons are shared between interpreters, we need to make
 193     # special effort to use the right namespace for method lookups.
 194     #
 195     # Note that this trick won't work if the singleton inherits from something
 196     # else (because the MRO will still be shared).
 197
 198     unless ( $self->implements_vtable('get_namespace')
 199         or $self->super_method('get_namespace') ne 'default' )
 200     {
 201         my $body =
 202             Parrot::Pmc2c::Emitter->text(
 203             "  return INTERP->vtables[SELF->vtable->base_type]->_namespace;\n");
 204         $self->add_method(
 205             Parrot::Pmc2c::Method->new(
 206                 {
 207                     name        => 'get_namespace',
 208                     parent_name => $self->name,
 209                     parameters  => '',
 210                     body        => $body,
 211                     type        => Parrot::Pmc2c::Method::VTABLE,
 212                     mmds        => [],
 213                     return_type => 'PMC*',
 214                     attrs       => {},
 215                 }
 216             )
 217         );
 218     }
 219 }
 220
 221 =item C<gen_includes()>
 222
 223 Returns the C C<#include> for the header file of each of the PMC's superclasses.
 224
 225 =cut
 226
 227 sub gen_includes {
 228     my ($self) = @_;
 229     my $c      = $self->{emitter};
 230
 231     $c->emit(<<"EOC");
 232 #include "parrot/parrot.h"
 233 #include "parrot/extend.h"
 234 #include "parrot/dynext.h"
 235 EOC
 236
 237     $c->emit(qq{#include "pmc_fixedintegerarray.h"\n})
 238         if $self->flag('need_fia_header');
 239
 240     foreach my $parent_name ( $self->name, @{ $self->parents } ) {
 241         $c->emit( '#include "pmc_' . lc $parent_name . ".h\"\n" );
 242     }
 243
 244     foreach my $mixin_name ( @{ $self->mixins } ) {
 245         $c->emit( '#include "pmc_' . lc $mixin_name . ".h\"\n" );
 246     }
 247
 248     $c->emit( '#include "' . lc $self->name . ".str\"\n" )
 249         unless $self->is_dynamic;
 250 }
 251
 252 =item C<proto($type,$parameters)>
 253
 254 Determines the prototype (argument signature) for a method body
 255 (see F<src/call_list>).
 256
 257 =cut
 258
 259 my %calltype = (
 260     "char"     => "c",
 261     "short"    => "s",
 262     "char"     => "c",
 263     "short"    => "s",
 264     "int"      => "i",
 265     "INTVAL"   => "I",
 266     "float"    => "f",
 267     "FLOATVAL" => "N",
 268     "double"   => "d",
 269     "STRING*"  => "S",
 270     "char*"    => "t",
 271     "PMC*"     => "P",
 272     "short*"   => "2",
 273     "int*"     => "3",
 274     "long*"    => "4",
 275     "void"     => "v",
 276     "void*"    => "b",
 277     "void**"   => "B",
 278
 279     #"BIGNUM*" => "???" # RT#43731
 280 );
 281
 282 sub proto {
 283     my ( $type, $parameters ) = @_;
 284
 285     # reduce to a comma separated set of types
 286     $parameters =~ s/\w+(,|$)/,/g;
 287     $parameters =~ s/ //g;
 288
 289     # flatten whitespace before "*" in return value
 290     $type =~ s/\s+\*$/\*/ if defined $type;
 291
 292     # type method(interp, self, parameters...)
 293     my $ret = $calltype{ $type or "void" }
 294         . "JO"
 295         . join( '', map { $calltype{$_} or "?" } split( /,/, $parameters ) );
 296
 297     # RT #43733
 298     # scan src/call_list.txt if the generated signature is available
 299
 300     # RT #43735 report errors for "?"
 301     # --leo
 302
 303     return $ret;
 304 }
 305
 306 sub pre_method_gen {
 307 }
 308
 309 =item C<gen_methods()>
 310
 311 Returns the C code for the pmc methods.
 312
 313 =cut
 314
 315 sub gen_methods {
 316     my ($self) = @_;
 317
 318     # vtable methods
 319     foreach my $method ( @{ $self->vtable->methods } ) {
 320         my $vt_method_name = $method->name;
 321         next if $vt_method_name eq 'class_init';
 322
 323         if ( $self->implements_vtable($vt_method_name) ) {
 324             $self->get_method($vt_method_name)->generate_body($self);
 325         }
 326     }
 327
 328     # non-vtable methods
 329     foreach my $method ( @{ $self->methods } ) {
 330         next if $method->is_vtable;
 331         $method->generate_body($self);
 332     }
 333 }
 334
 335 =item C<gen_attributes()>
 336
 337 Returns the C code for the attribute struct definition.
 338
 339 =cut
 340
 341 sub gen_attributes {
 342     my ($self)     = @_;
 343     my $attributes = $self->attributes;
 344
 345     if ( @$attributes ) {
 346
 347         Parrot::Pmc2c::Attribute::generate_start( $attributes->[0], $self );
 348
 349         foreach my $attribute ( @$attributes ) {
 350             $attribute->generate_declaration($self);
 351         }
 352
 353         Parrot::Pmc2c::Attribute::generate_end( $attributes->[0], $self );
 354
 355         foreach my $attribute ( @$attributes ) {
 356             $attribute->generate_accessor($self);
 357         }
 358     }
 359
 360 }
 361
 362 # RT #43737 quick hack - to get MMD variants
 363 sub get_super_mmds {
 364     my ( $self, $vt_method_name, $right, $mmd_prefix ) = @_;
 365     my @mmds;
 366
 367     my $super_mmd_rights = $self->{super_mmd_rights}{$vt_method_name};
 368     if ($super_mmd_rights) {
 369         while ( my ( $super_pmc_name, $mmd_rights ) = each %$super_mmd_rights )
 370         {
 371             for my $x ( @{$mmd_rights} ) {
 372                 next if $x eq "DEFAULT";
 373                 my $right      = "enum_class_$x";
 374                 my $super_name =
 375                     "Parrot_${super_pmc_name}_${vt_method_name}_$x";
 376                 push @mmds, [ $mmd_prefix, 0, $right, $super_name ];
 377             }
 378         }
 379     }
 380
 381     return @mmds;
 382 }
 383
 384 =item C<find_mmd_methods()>
 385
 386 Returns three values:
 387
 388 The first is an arrayref of <[ mmd_number, left, right, implementation_func]>
 389 suitable for initializing the MMD list.
 390
 391 The second is a arrayref listing dynamic PMCs which will need to be looked up.
 392
 393 The third is a list of C<[index, dynamic PMC]> pairs of right entries
 394 in the MMD table that will need to be resolved at runtime.
 395
 396 =cut
 397
 398 sub find_mmd_methods {
 399     my ($self)  = @_;
 400     my $pmcname = $self->name;
 401
 402     my ( @mmds, @init_mmds, %init_mmds );
 403
 404     foreach my $vt_method ( @{ $self->vtable->methods } ) {
 405         my $vt_method_name = $vt_method->name;
 406         next unless $vt_method->is_mmd;
 407
 408         my $implementor;
 409         if ( $self->implements_vtable($vt_method_name) ) {
 410             $implementor = $pmcname;
 411         }
 412         else {
 413             my $class = $self->{super}{$vt_method_name};
 414             next
 415                 if $class =~ /^[A-Z]/
 416                 or $class eq 'default'
 417                 or $class eq 'delegate';
 418             $implementor = $class;
 419         }
 420
 421         my ( $mmd_method_name, $func, $left, $right );
 422         $mmd_method_name = "Parrot_${implementor}_$vt_method_name";
 423         $func            = $vt_method->mmd_prefix;
 424
 425         # dynamic PMCs need the runtime type which is passed in entry to
 426         # class_init
 427
 428         # set to 'entry' below in initialization loop.
 429         $left  = 0;
 430         $right = $vt_method->right;
 431
 432         if ( exists $self->{super}{$vt_method_name} ) {
 433             push @mmds, $self->get_super_mmds( $vt_method_name, $right, $func );
 434         }
 435
 436         push @mmds, [ $func, $left, $right, $mmd_method_name ];
 437
 438         my $pmc_method = $self->get_method($vt_method_name);
 439         if ($pmc_method) {
 440             foreach my $mmd ( @{ $pmc_method->mmds } ) {
 441                 my $right = $mmd->right;
 442                 if ( $self->is_dynamic($right) ) {
 443                     $right = 0;
 444                     push @init_mmds, [ scalar @mmds, $mmd->right ];
 445                     $init_mmds{ $mmd->right } = 1;
 446                 }
 447                 else {
 448                     $right = "enum_class_$right";
 449                 }
 450                 $mmd_method_name = "Parrot_" . $self->name . "_" . $mmd->name;
 451                 push @mmds, [ $func, $left, $right, $mmd_method_name ];
 452             }
 453
 454             #$self->{mmds} = @mmds;    # RT#43739
 455         }
 456     }
 457     return ( \@mmds, \@init_mmds, [ keys %init_mmds ] );
 458 }
 459
 460 sub build_full_c_vt_method_name {
 461     my ( $self, $vt_method_name ) = @_;
 462
 463     my $implementor;
 464     if ( $self->implements_vtable($vt_method_name) ) {
 465         return $self->get_method($vt_method_name)
 466             ->full_method_name( $self->name . $self->{variant} );
 467     }
 468     elsif ( $self->{super}{$vt_method_name} ) {
 469         $implementor = $self->{super}{$vt_method_name};
 470     }
 471     else {
 472         $implementor = "default";
 473     }
 474
 475     return "Parrot_${implementor}_$vt_method_name";
 476 }
 477
 478 =item C<vtable_decl($name)>
 479
 480 Returns the C code for the declaration of a vtable temporary named
 481 C<$name> with the functions for this class.
 482
 483 =cut
 484
 485 sub vtable_decl {
 486     my ( $self, $temp_struct_name, $enum_name ) = @_;
 487
 488     # gen vtable flags
 489     my $vtbl_flag = 0;
 490     $vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT'     if $self->flag('need_ext');
 491     $vtbl_flag .= '|VTABLE_PMC_IS_SINGLETON'  if $self->flag('singleton');
 492     $vtbl_flag .= '|VTABLE_IS_SHARED_FLAG'    if $self->flag('is_shared');
 493     $vtbl_flag .= '|VTABLE_IS_READONLY_FLAG'  if $self->flag('is_ro');
 494     $vtbl_flag .= '|VTABLE_HAS_READONLY_FLAG' if $self->flag('has_ro');
 495
 496     my @vt_methods;
 497     foreach my $vt_method ( @{ $self->vtable->methods } ) {
 498         next if $vt_method->is_mmd;
 499         push @vt_methods,
 500             $self->build_full_c_vt_method_name( $vt_method->name );
 501     }
 502
 503     my $methlist = join( ",\n        ", @vt_methods );
 504
 505     my $cout = <<ENDOFCODE;
 506     const VTABLE $temp_struct_name = {
 507         NULL,       /* namespace */
 508         $enum_name, /* base_type */
 509         NULL,       /* whoami */
 510         $vtbl_flag, /* flags */
 511         NULL,       /* provides_str */
 512         NULL,       /* isa_hash */
 513         NULL,       /* class */
 514         NULL,       /* mro */
 515         NULL,       /* ro_variant_vtable */
 516         $methlist
 517     };
 518 ENDOFCODE
 519     return $cout;
 520 }
 521
 522 =item C<init_func()>
 523
 524 Returns the C code for the PMC's initialization method, or an empty
 525 string if the PMC has a C<no_init> flag.
 526
 527 =cut
 528
 529 sub init_func {
 530     my ($self) = @_;
 531     return "" if $self->no_init;
 532
 533     my $cout      = "";
 534     my $classname = $self->name;
 535
 536     my ( $mmds, $init_mmds, $dyn_mmds ) = $self->find_mmd_methods();
 537
 538     my $enum_name   = $self->is_dynamic ? -1 : "enum_class_$classname";
 539     my $vtable_decl = $self->vtable_decl( 'temp_base_vtable', $enum_name );
 540
 541     my $mmd_list = join( ",\n        ",
 542         map { "{ $_->[0], $_->[1], $_->[2], (funcptr_t) $_->[3] }" } @$mmds );
 543
 544     my @isa = grep { $_ ne 'default' } @{ $self->parents };
 545
 546     my $provides        = join( " ", keys( %{ $self->{flags}{provides} } ) );
 547     my $class_init_code = "";
 548
 549     if ($self->has_method('class_init')) {
 550         $class_init_code    = $self->get_method('class_init')->body;
 551
 552         $class_init_code =~ s/INTERP/interp/g;
 553
 554         # fix indenting
 555         $class_init_code =~ s/^/        /mg;
 556     }
 557
 558     my %extra_vt;
 559     $extra_vt{ro} = $self->{ro} if $self->{ro};
 560
 561     $cout .= <<"EOC";
 562 void
 563 Parrot_${classname}_class_init(PARROT_INTERP, int entry, int pass)
 564 {
 565 $vtable_decl
 566 EOC
 567
 568     for my $k ( keys %extra_vt ) {
 569         $cout .= $extra_vt{$k}->vtable_decl( "temp_${k}_vtable", $enum_name );
 570     }
 571
 572     my $const = ( $self->{flags}{dynpmc} ) ? " " : " const ";
 573     if ( @$mmds ) {
 574         $cout .= <<"EOC";
 575
 576    $const MMD_init _temp_mmd_init[] = {
 577         $mmd_list
 578     };
 579     /* Dynamic PMCs need the runtime type which is passed in entry to class_init. */
 580 EOC
 581     }
 582
 583     $cout .= <<"EOC";
 584     if (pass == 0) {
 585 EOC
 586     $cout .= <<"EOC";
 587         Hash          *isa_hash;
 588         /* create vtable - clone it - we have to set a few items */
 589         VTABLE * const vt_clone        = Parrot_clone_vtable(interp,
 590                                              &temp_base_vtable);
 591 EOC
 592     for my $k ( keys %extra_vt ) {
 593         $cout .= <<"EOC";
 594         VTABLE * const vt_${k}_clone     = Parrot_clone_vtable(interp,
 595                                              &temp_${k}_vtable);
 596 EOC
 597     }
 598
 599     # init vtable slot
 600     if ( $self->is_dynamic ) {
 601         $cout .= <<"EOC";
 602         vt_clone->base_type    = entry;
 603         vt_clone->whoami       = string_make(interp, "$classname", @{[length($classname)]}, "ascii",
 604             PObj_constant_FLAG|PObj_external_FLAG);
 605         vt_clone->provides_str = string_append(interp, vt_clone->provides_str,
 606             string_make(interp, " $provides", @{[length($provides) + 1]}, "ascii",
 607             PObj_constant_FLAG|PObj_external_FLAG));
 608
 609         /* set up isa hash */
 610         parrot_new_hash(interp, &isa_hash);
 611         vt_clone->isa_hash     = isa_hash;
 612 EOC
 613     }
 614     else {
 615         $cout .= <<"EOC";
 616         vt_clone->whoami       = CONST_STRING_GEN(interp, "$classname");
 617         vt_clone->provides_str = CONST_STRING_GEN(interp, "$provides");
 618
 619         /* set up isa hash */
 620         parrot_new_hash(interp, &isa_hash);
 621         vt_clone->isa_hash     = isa_hash;
 622 EOC
 623     }
 624
 625     for my $k ( keys %extra_vt ) {
 626         $cout .= <<"EOC";
 627         vt_${k}_clone->base_type    = entry;
 628         vt_${k}_clone->whoami       = vt_clone->whoami;
 629         vt_${k}_clone->provides_str = vt_clone->provides_str;
 630 EOC
 631     }
 632
 633     if ( $extra_vt{ro} ) {
 634         $cout .= <<"EOC";
 635         vt_clone->ro_variant_vtable    = vt_ro_clone;
 636         vt_ro_clone->ro_variant_vtable = vt_clone;
 637         vt_ro_clone->isa_hash          = isa_hash;
 638 EOC
 639     }
 640
 641     $cout .= <<"EOC";
 642         interp->vtables[entry]         = vt_clone;
 643 EOC
 644
 645     for my $isa ($classname, @isa) {
 646         $cout .= <<"EOC";
 647         parrot_hash_put(interp, isa_hash, (void *)(CONST_STRING_GEN(interp, "$isa")), PMCNULL);
 648 EOC
 649     }
 650
 651     $cout .= <<"EOC";
 652     }
 653     else { /* pass */
 654 EOC
 655
 656     # To make use of the .HLL directive, register any mapping...
 657     if ( $self->{flags}{hll} && $self->{flags}{maps} ) {
 658
 659         my $hll = $self->{flags}{hll};
 660         $cout .= <<"EOC";
 661
 662         {
 663             /* Register this PMC as a HLL mapping */
 664             const INTVAL pmc_id = Parrot_get_HLL_id( interp, CONST_STRING_GEN(interp, "$hll")
 665             );
 666             if (pmc_id > 0) {
 667 EOC
 668         foreach my $maps ( sort keys %{ $self->{flags}{maps} } ) {
 669             $cout .= <<"EOC";
 670                 Parrot_register_HLL_type( interp, pmc_id, enum_class_$maps, entry);
 671 EOC
 672         }
 673         $cout .= <<"EOC";
 674             }
 675         } /* Register */
 676 EOC
 677     }
 678
 679         $cout .= <<"EOC";
 680         {
 681             PMC           *mro      = pmc_new(interp, enum_class_ResizableStringArray);
 682             VTABLE * const vt_clone = interp->vtables[entry];
 683
 684             vt_clone->mro = mro;
 685
 686             if (vt_clone->ro_variant_vtable)
 687                 vt_clone->ro_variant_vtable->mro = mro;
 688
 689 EOC
 690
 691     for my $isa ($classname, @isa) {
 692         $cout .= <<"EOC";
 693             VTABLE_push_string(interp, mro, CONST_STRING_GEN(interp, "$isa"));
 694 EOC
 695     }
 696
 697     $cout .= <<"EOC";
 698         }
 699
 700         /* setup MRO and _namespace */
 701         Parrot_create_mro(interp, entry);
 702 EOC
 703
 704     # declare each nci method for this class
 705     foreach my $method ( @{ $self->{methods} } ) {
 706         next unless $method->type eq Parrot::Pmc2c::Method::NON_VTABLE;
 707
 708         my $proto       = proto( $method->return_type, $method->parameters );
 709         my $method_name = $method->name;
 710         my $symbol_name =
 711             defined $method->symbol ? $method->symbol : $method->name;
 712
 713         if ( exists $method->{PCCMETHOD} ) {
 714             $cout .= <<"EOC";
 715         register_raw_nci_method_in_ns(interp, entry,
 716             F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name");
 717 EOC
 718         }
 719         else {
 720             $cout .= <<"EOC";
 721         register_nci_method(interp, entry,
 722                 F2DPTR(Parrot_${classname}_${method_name}), "$symbol_name", "$proto");
 723 EOC
 724         }
 725         if ( $method->{attrs}{write} ) {
 726             $cout .= <<"EOC";
 727         Parrot_mark_method_writes(interp, entry, "$symbol_name");
 728 EOC
 729         }
 730     }
 731
 732     # include any class specific init code from the .pmc file
 733     $cout .= <<"EOC" if $class_init_code;
 734         /* class_init */
 735         {
 736 $class_init_code
 737         }
 738 EOC
 739
 740     $cout .= <<"EOC";
 741         {
 742 EOC
 743
 744     # declare auxiliary variables for dyncpmc IDs
 745     foreach my $dynpmc (@$dyn_mmds) {
 746         next if $dynpmc eq $classname;
 747         $cout .= <<"EOC";
 748             const int my_enum_class_$dynpmc = pmc_type(interp, string_from_literal(interp, "$dynpmc"));
 749 EOC
 750     }
 751
 752     # init MMD "right" slots with the dynpmc types
 753     foreach my $entry (@$init_mmds) {
 754         if ( $entry->[1] eq $classname ) {
 755             $cout .= <<"EOC";
 756             _temp_mmd_init[$entry->[0]].right = entry;
 757 EOC
 758         }
 759         else {
 760             $cout .= <<"EOC";
 761             _temp_mmd_init[$entry->[0]].right = my_enum_class_$entry->[1];
 762 EOC
 763         }
 764     }
 765
 766     # just to be safe
 767     foreach my $dynpmc (@$dyn_mmds) {
 768         next if $dynpmc eq $classname;
 769         $cout .= <<"EOC";
 770             PARROT_ASSERT(my_enum_class_$dynpmc != enum_class_default);
 771 EOC
 772     }
 773
 774     if ( @$mmds ) {
 775         $cout .= <<"EOC";
 776 #define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
 777             Parrot_mmd_register_table(interp, entry,
 778                 _temp_mmd_init, N_MMD_INIT);
 779 EOC
 780     }
 781
 782     $cout .= <<"EOC";
 783         }
 784     } /* pass */
 785 } /* Parrot_${classname}_class_init */
 786 EOC
 787     if ( $self->is_dynamic ) {
 788         $cout .= dynext_load_code( $classname, $classname => {} );
 789     }
 790
 791     $cout;
 792 }
 793
 794 sub is_vtable_method {
 795     my ( $self, $vt_method_name ) = @_;
 796     return 1 if $self->vtable->has_method($vt_method_name);
 797     return 0;
 798 }
 799
 800 sub vtable {
 801     my ( $self, $value ) = @_;
 802     $self->{vtable} = $value if $value;
 803     return $self->{vtable};
 804 }
 805
 806 1;
 807
 808 # Local Variables:
 809 #   mode: cperl
 810 #   cperl-indent-level: 4
 811 #   fill-column: 100
 812 # End:
 813 # vim: expandtab shiftwidth=4: