# Copyright (C) 2004-2006, The Perl Foundation.
# $Id: Pmc2c.pm 16245 2006-12-25 22:15:39Z paultcochrane $

=head1 NAME

Parrot::Pmc2c - PMC to C Code Generation

=head1 SYNOPSIS

    use Parrot::Pmc2c;

=head1 DESCRIPTION

C<Parrot::Pmc2c> (and the L<subclasses|/SUBCLASSES> defined in this
file) is used by F<tools/build/pmc2c.pl> to generate C code from PMC files.

=head2 Functions

=over

=cut

package Parrot::Pmc2c;

use strict;
use warnings;

use Parrot::PMC qw(%pmc_types);

use base qw( Exporter );

our @EXPORT_OK = qw(count_newlines gen_ret dont_edit dynext_load_code);

use Text::Balanced 'extract_bracketed';

=item C<count_newlines($string)>

Returns the number of newlines (C<\n>) in C<$string>.

=cut

sub count_newlines {
    return scalar $_[0] =~ tr/\n//;
}

=item C<dont_edit($pmcfile)>

Returns the "DO NOT EDIT THIS FILE" warning text. C<$pmcfile> is the name
of the original source F<*.pmc> file.

=cut

sub dont_edit {
    my ($pmcfile) = @_;

    return <<"EOC";
/*
 * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 *
 * This file is generated automatically from '$pmcfile'
 * by $0.
 *
 * Any changes made here will be lost!
 *
 */

EOC
}

=item C<gen_ret($method, $body)>

Generate the C code for a C<return> statement, if the body is empty then
make a cast if needed.

This method is imported by subclasses.

=cut

sub gen_ret {
    my ( $method, $body ) = @_;

    my $ret;
    if ($body) {
        $ret = $method->{type} eq 'void' ? "$body;" : "return $body;";
    }
    else {
        $ret = $method->{type} eq 'void' ? "" : "return ($method->{type})0;";
    }
    $ret;
}

=item C<class_name($self, $class)>

Returns the appropriate C<Parrot::Pmc2c> subclass for the PMC
(C<< $self->{class} >>). C<$self> is the hash reference passed to
C<new()>, and C<$class> is C<Parrot::Pmc2c>.

=cut

my %special_class_name =
    map { ( $_, 1 ) } qw( STMRef Ref default Null delegate SharedRef deleg_pmc );

sub class_name {
    my ( $self, $class ) = @_;

    my $classname = $self->{class};
    my $nclass    = $class;

    # bless object into different classes inheriting from Parrot::Pmc2c
    if ( $special_class_name{$classname} ) {
        $nclass .= "::" . $classname;
    }
    else {
        $nclass .= "::Standard";
    }
    $nclass;
}

=item C<dynext_load_code($library_name, %classes)>

C<$library_name> is the name of the dynamic library to be created.

C<%classes> is a map from the PMC names for which code is to be generated,
to dump info (PMC metadata).

This function is exported.

=cut

sub dynext_load_code {
    my ( $libname, %classes ) = @_;

    my $lc_libname = lc $libname;
    my $cout;

    $cout .= <<"EOC";
/*
 * This load function will be called to do global (once) setup
 * whatever is needed to get this extension running
 */

EOC
    $cout .= <<"EOC";

PARROT_DYNEXT_EXPORT extern Parrot_PMC Parrot_lib_${lc_libname}_load(Parrot_INTERP interp); /* don't warn */
Parrot_PMC Parrot_lib_${lc_libname}_load(Parrot_INTERP interp)
{
    Parrot_STRING whoami;
    Parrot_PMC pmc;
EOC
    while ( my ( $class, $info ) = each %classes ) {
        next if $info->{flags}->{noinit};
        $cout .= <<"EOC";
    Parrot_Int type${class};
EOC
    }
    $cout .= <<"EOC";
    int pass;

    /*
     * create a library PMC
     */
    pmc = pmc_new(interp, enum_class_ParrotLibrary);
    /*
     * TODO stuff some info into this PMCs props
     */

    /*
     * for all PMCs we want to register:
     */
EOC
    while ( my ( $class, $info ) = each %classes ) {
        my $lhs = $info->{flags}->{noinit} ? "" : "type$class = ";
        $cout .= <<"EOC";
    whoami = const_string(interp, "$class");
    ${lhs}pmc_register(interp, whoami);
EOC
    }
    $cout .= <<"EOC";

    /* do class_init code */
    for (pass = 0; pass <= 1; ++pass) {
EOC
    while ( my ( $class, $info ) = each %classes ) {
        next if $info->{flags}->{noinit};
        $cout .= <<"EOC";
        Parrot_${class}_class_init(interp, type$class, pass);
EOC
    }
    $cout .= <<"EOC";
    }
    return pmc;
}

EOC
}

=back

=head2 Class Methods

=over

=item C<new($self, $opt)>

Returns C<$self> as a new instance.

C<$self> is a hash reference C<eval>-ed from a F<*.dump> file generated
by F<tools/build/pmc2c.pl> from a F<*.pmc> file. It is C<bless>-ed either into
C<Parrot::Pmc2c::::Standard>, or into one of the other I<special> PMCs:
F<default>, C<delegate>, C<Null>, C<Ref> or C<SharedRef>.

C<$opt> is a hash reference.

=cut

sub new {
    my $this = shift;
    my $self = shift;

    my $class = ref($this) || $this;
    $self->{opt} = shift;
    $class = class_name( $self, $class );
    bless $self, $class;
    $self->init($class);
    $self;
}

=back

=head2 Instance Methods

=over

=item C<does_write($method)>

Returns true if the vtable method C<$method> writes our value.

=cut

sub does_write {
    my ( $self, $method ) = @_;

    my $attrs;
    if ( $self->{has_method}{$method} ) {
        $attrs = $self->{methods}[ $self->{has_method}{$method} ]->{attrs};
    }
    elsif ( $self->{super}{$method} ) {
        $attrs = $self->{super_attrs}{$method};
    }

    return 1 if $attrs->{write};
    return 0 if $attrs->{read};

    return $self->{attrs}{$method}{write};
}

=item C<line_directive($self,$line,$file)>

Generates the C pre processor string for a #line directive, or an empty string
if C<$self->{opt}{nolines}> is true.

=cut

sub line_directive {
    my ( $self, $line, $file ) = @_;

    return '' if $self->{opt}{nolines};
    if ( defined $file ) {
        my $file_escaped = $file;
        $file_escaped =~ s|(\\)|$1$1|g;    # escape backslashes
        return qq{#line $line "$file_escaped"\n};
    }
    return qq{#line $line\n};
}

=item C<line_directive_here($self,$output,$file)>

Generates the C pre processor string for a #line directive to reset the
compiler's line number to the next physical line in the output.

=cut

sub line_directive_here {
    my ( $self, $output, $file ) = @_;

    # Compilers count lines from 1, and on the 1st line there are no preceding
    # newlines, so *this* line is (number of newlines plus one).
    # But that's the number for *this* line (the #line directive) and we're
    # about to set the number for the next line. So + 1 again.
    return $self->line_directive( 1 + 1 + count_newlines($output), $file );
}

=item C<get_vtable_section()>

Creates a hash of all the method names containing vtable section. Called
from C<init()>.

=cut

# XXX FIXME unused?
sub get_vtable_section {
    my $self = shift;

    #  make a hash of all method names containing vtable section
    my $vt = $self->{vtable};
    foreach my $entry ( @{ $vt->{methods} } ) {
        $self->{all}{ $entry->{meth} } = $entry->{section};
    }
}

=item C<get_vtable_attrs()>

Creates a hash of all the methods names correspdoning to their attributes.
Called from C<init()>

=cut

sub get_vtable_attrs {
    my $self = shift;

    my $vt = $self->{vtable};
    foreach my $entry ( @{ $vt->{methods} } ) {
        $self->{attrs}{ $entry->{meth} } = $entry->{attr};
    }
}

=item C<make_constlike($class, $type, $is_variant)>

Create a variant for Const or RO.

=cut

sub make_constlike {
    my ( $self, $class, $type, $prefix ) = @_;

    $prefix = "$type" unless defined $prefix;

    my $const = bless {}, ref($self) . "::$type";
    {

        # autogenerate for exotic types
        # (XXX is this appropriate or do we want them to each
        # be explicitly cleared to have the variant?)
        no strict 'refs';
        if ( !@{ ref($const) . '::ISA' } ) {
            @{ ref($const) . '::ISA' } = "Parrot::Pmc2c::Standard::\u$type";
        }
    }
    my @methods = @{ $self->{methods} };

    # copy super
    $const->{super} = { %{ $self->{super} } };
    my $i;

    # FIXME support getting implementations from central superclass instead
    # (e.g. some ro_fail pseudoclass that generates an exception)
    foreach my $entry ( @{ $self->{vtable}{methods} } ) {
        my $meth = $entry->{meth};
        if ( $self->does_write($meth) ) {
            $const->{has_method}{$meth} = $i++;
            push @{ $const->{methods} },
                {
                meth       => $meth,
                type       => $entry->{type},
                parameters => $entry->{parameters},
                loc        => 'vtable',
                };
        }
        else {
            if ( $self->implements($meth) ) {
                $const->{super}{$meth} = $self->{class};
            }
            else {
                $const->{super}{$meth} = $self->{super}{$meth};
            }
        }
    }

    # copy parent(s), prepend self as parrent
    $const->{parents} = [ $self->{class}, @{ $self->{parents} } ];

    # copy flags, set is_const
    $const->{flags} = { %{ $self->{flags} } };

    # set classname
    $const->{class} = $prefix . $self->{class};

    # and alias vtable
    $const->{vtable} = $self->{vtable};

    # set parentname
    $const->{parentname} = $self->{class};
    return $const;
}

=item C<make_const($class)>

If the PMC had its C<const_too> flag set then this method is called in
C<init()> to to create the read-only set methods.

=cut

sub make_const {
    my ( $self, $class ) = @_;
    my $const = $self->make_constlike( $class, 'Const' );
    $self->{const} = $const;
    $const->{flags}->{is_const} = 1;
    delete $const->{flags}{const_too};

    # set const in does
    $const->{flags}{does}{const} = 1;
}

=item C<make_ro($class)>

If the PMC doesn't have C<const_too> set (FIXME?) then this method is called
to create the read-only set methods and vtable variant.

=cut

sub make_ro {
    my ( $self, $class ) = @_;
    my $ro = $self->make_constlike( $class, 'RO', '' );
    $self->{flags}{has_ro} = 1;
    $self->{ro} = $ro;
    delete $ro->{flags}->{has_ro};
    $ro->{flags}->{is_ro} = 1;
    $ro->{variant} = '_ro';
}

=item C<init($class)>

Initializes the instance. C<$class> is its class.

=cut

sub init {
    my ( $self, $class ) = @_;

    $self->get_vtable_section();
    $self->get_vtable_attrs();
    $self->make_const($class) if $self->{flags}{const_too};
    $self->{flags}{no_ro} = 1
        if $self->{flags}{abstract}
        or $self->{flags}{singleton}
        or $self->{flags}{const_too};
    if ( !$self->{flags}{no_ro} ) {
        $self->make_ro;
    }

    if ( $self->{flags}{singleton} ) {

        # Since singletons are shared between interpreters, we need
        # to make special effort to use the right namespace for
        # method lookups. Note that this trick won't work if the
        # singleton inherits from something else (because the
        # MRO will still be shared).
        unless ( $self->implements('namespace')
            or $self->{super}{'namespace'} ne 'default' )
        {
            push @{ $self->{methods} }, {
                meth       => 'namespace',
                parameters => '',
                body       => '{
        return INTERP->vtables[SELF->vtable->base_type]->_namespace;
}',
                'loc'  => 'vtable',
                'mmds' => [],
                'type' => 'PMC*',
                'line' => 1,
                attrs  => {},
            };
            $self->{has_method}{namespace} = $#{ $self->{methods} };
        }
    }
}

=item C<decl($classname, $method, $for_header)>

Returns the C code for the PMC method declaration. C<$for_header>
indicates whether the code is for a header or implementation file.

=cut

sub decl {
    my ( $self, $classname, $method, $for_header ) = @_;

    my $ret     = $method->{type};
    my $meth    = $method->{meth};
    my $args    = $method->{parameters};
    my $variant = $self->{variant} || "";
    $args = ", $args" if $args =~ /\S/;
    my ( $export, $extern, $newl, $semi, $interp, $pmc );
    if ($for_header) {
        $export =
            $self->{flags}->{dynpmc}
            ? 'PARROT_DYNEXT_EXPORT '
            : 'PARROT_API ';
        $extern = "extern ";
        $newl   = " ";
        $semi   = ";";
        $interp = $pmc = "";
    }
    else {
        $export = "";
        $extern = "";
        $newl   = "\n";
        $semi   = "";
        $interp = 'interp';
        $pmc    = ' pmc';
    }
    return <<"EOC";
$export$extern$ret${newl}Parrot_${classname}${variant}_$meth(Interp *$interp, PMC*$pmc$args)$semi
EOC
}

=item C<includes()>

Returns the C C<#include> for the header file of each of the PMC's
superclasses.

=cut

sub includes {
    my $self = shift;

    my $cout = "";
    $cout .= <<"EOC";
#include "parrot/parrot.h"
#include "parrot/extend.h"
#include "parrot/dynext.h"
EOC
    foreach my $parents ( $self->{class}, @{ $self->{parents} } ) {
        my $name = lc $parents;
        $cout .= <<"EOC";
#include "pmc_$name.h"
EOC
    }
    if ( !$self->{flags}{dynpmc} ) {
        my $name = lc $self->{class};
        $cout .= <<"EOC";
#include "$name.str"
EOC
    }
    "$cout\n";
}

=item C<full_arguments($args)>

Prepends C<INTERP, SELF> to C<$args>.

=cut

sub full_arguments {
    my $args = shift;

    if ( $args =~ m/\S/ ) {
        return "INTERP, SELF, $args";
    }
    else {
        return "INTERP, SELF";
    }
}

=item C<proto($type,$parameters)>

Determines the prototype (argument signature) for a method body
(see F<src/call_list>).

=cut

my %calltype = (
    "char"     => "c",
    "short"    => "s",
    "char"     => "c",
    "short"    => "s",
    "int"      => "i",
    "INTVAL"   => "I",
    "float"    => "f",
    "FLOATVAL" => "N",
    "double"   => "d",
    "STRING*"  => "S",
    "char*"    => "t",
    "PMC*"     => "P",
    "short*"   => "2",
    "int*"     => "3",
    "long*"    => "4",
    "void"     => "v",
    "void*"    => "b",
    "void**"   => "B",

    #"BIGNUM*" => "???" # XXX
);

sub proto {
    my ( $type, $parameters ) = @_;

    # reduce to a comma separated set of types
    $parameters =~ s/\w+(,|$)/,/g;
    $parameters =~ s/ //g;

    # type method(interp, self, parameters...)
    my $ret = $calltype{ $type or "void" };
    $ret .= "JO";
    $ret .= join( '', map { $calltype{$_} or "?" } split( /,/, $parameters ) );

    # TODO
    # scan src/call_list.txt if the generated signature is available
    # TODO report errors for "?"
    # --leo

    return $ret;
}

=item C<rewrite_nci_method($class, $method, $super, $super_table)>

Rewrites the method body performing the various macro substitutions for
nci method bodies (see F<tools/build/pmc2c.pl>).

=cut

sub rewrite_nci_method {
    my ( $class, $method ) = @_;

    local $_ = $_[2];

    # Rewrite SELF -> pmc, INTERP -> interp
    s/\bSELF\b/pmc/g;
    s/\bINTERP\b/interp/g;

    return $_;
}

=item C<rewrite_vtable_method($class, $method, $super, $super_table)>

Rewrites the method body performing the various macro substitutions for
vtable method bodies (see F<tools/build/pmc2c.pl>).

=cut

sub rewrite_vtable_method {
    my ( $class, $method, $super, $super_table ) = @_;
    local $_ = $_[4];

    # Rewrite method body
    my $supertype = "enum_class_$super";
    die "$class defines unknown vtable method '$method'\n"
        unless defined $super_table->{$method};
    my $supermethod = "Parrot_" . $super_table->{$method} . "_$method";

    # Rewrite DYNSUPER(args)
    s/\bDYNSUPER\b          # Macro: DYNSUPER
      \(\s*(.*?)\)      # capture argument list
     /"interp->vtables[$supertype].$method(" . full_arguments($1) . ')'/xeg;

    # Rewrite OtherClass.SUPER(args...)
    s/(\w+)             # capture OtherClass
      \.SUPER\b           # Macro: SUPER
      \(\s*(.*?)\)      # capture argument list
     /"Parrot_${1}_$method(" . full_arguments($2) . ')'/xeg;

    # Rewrite SUPER(args...)
    s/\bSUPER\b             # Macro: SUPER
      \(\s*(.*?)\)      # capture argument list
     /"$supermethod(" . full_arguments($1) . ')'/xeg;

    # Rewrite DYNSELF.other_method(args...)
    s/\bDYNSELF\b           # Macro: DYNSELF
      \.(\w+)           # other_method
      \(\s*(.*?)\)      # capture argument list
     /"pmc->vtable->$1(" . full_arguments($2) . ')'/xeg;

    # Rewrite DYNSELF(args...). See comments above.
    s/\bDYNSELF\b           # Macro: DYNSELF
      \(\s*(.*?)\)      # capture argument list
     /"pmc->vtable->$method(" . full_arguments($1) . ')'/xeg;

    # Rewrite OtherClass.SELF.other_method(args...)
    s/(\w+)             # OtherClass
      \.\bSELF\b            # Macro SELF
      \.(\w+)           # other_method
      \(\s*(.*?)\)      # capture argument list
     /"Parrot_${1}_$2(" . full_arguments($3) . ')'/xeg;

    # Rewrite SELF.other_method(args...)
    s/\bSELF\b              # Macro SELF
      \.(\w+)           # other_method
      \(\s*(.*?)\)      # capture argument list
     /"Parrot_${class}_$1(".full_arguments($2).")"/xeg;

    # Rewrite SELF -> pmc, INTERP -> interp
    s/\bSELF\b/pmc/g;
    s/\bINTERP\b/interp/g;

    # now use macros for all rewritten stuff
    s/\b(?:\w+)->vtable->(\w+)\(/ VTABLE_$1(/g;

    return $_;
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $cout      = "";
    my $classname = $self->{class};
    my $meth      = $method->{meth};
    my $body      = $method->{body};
    $body =~ s/^\t/        /mg;
    $body =~ s/^[ ]{4}//mg;
    my $super = $self->{super}{$meth};

    my $total_body;
    if ( $method->{loc} eq 'vtable' ) {
        $total_body = rewrite_vtable_method( $classname, $meth, $super, $self->{super}, $body );
    }
    else {
        $total_body = rewrite_nci_method( $classname, $meth, $body );
    }

    # now split into MMD if necessary:
    my $additional_bodies = '';
    $total_body = substr $total_body, 1, -1;
    my $standard_body = $total_body;
    my $header_decls  = '';
    while ( $total_body =~ s/\bMMD_(\w+):\s*// ) {
        my $right_type = $1;
        my $body_part = extract_bracketed( $total_body, '{' );
        die "Empty MMD body near '$total_body'"
            if ( !$body_part );
        $body_part = substr( $body_part, 1, -1 );
        $body_part =~ s/\n(\s*)$//s;
        if ( $right_type eq 'DEFAULT' ) {
            $standard_body = $body_part;
        }
        else {
            my $sub_meth_decl = $self->decl( $classname, $method );
            my $sub_meth_decl_h = $self->decl( $classname, $method, 1 );
            $sub_meth_decl =~ /(\w+)\(/;
            my $sub_meth_name = $1;
            my $sub_meth      = $sub_meth_decl;    # no "static ." ...
            $sub_meth        =~ s/\(/_$right_type(/;
            $sub_meth_decl_h =~ s/\(/_$right_type(/;
            $self->{hdecls} .= <<EOH;
$sub_meth_decl_h
EOH
            $additional_bodies .= $sub_meth;
            $additional_bodies .= "{$body_part\n}";
            push @{ $self->{mmd_variants}{$meth} }, [ $right_type, $sub_meth_name ];
        }

    }
    ## $cout .= $header_decls;
    $cout .= $self->decl( $classname, $method, 0 );

    # This is the part that comes from the PMC file.
    $cout .= $self->line_directive( $method->{line}, $self->{file} );
    $cout .= "{$standard_body\n}\n";

    # We are back to generated code immediately here
    $cout .= $self->line_directive( 2 + $line + count_newlines($cout), $out_name );
    $cout .= $additional_bodies;
    $cout .= "\n\n";

    $cout =~ s/^\s+$//mg;
    return $cout;
}

=item C<methods($line, $out_name)>

Returns the C code for the vtable methods. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

=cut

sub methods {
    my ( $self, $line, $out_name ) = @_;

    my $cout = "";

    # vtable methods
    foreach my $method ( @{ $self->{vtable}{methods} } ) {
        my $meth = $method->{meth};
        next if $meth eq 'class_init';
        if ( $self->implements($meth) ) {
            my $ret = $self->body( $method, $line, $out_name );
            $line += count_newlines($ret);
            $cout .= $ret;
        }
    }

    # nci methods
    foreach my $method ( @{ $self->{methods} } ) {
        next unless $method->{loc} eq 'nci';
        my $ret = $self->body( $method, $line, $out_name );
        $line += count_newlines($ret);
        $cout .= $ret;
    }

    $cout =~ s/^\s+$//mg;
    return $cout;
}

=item C<lib_load_code()>

Returns the C code for loading a library.

=cut

sub lib_load_code {
    my $self = shift;

    my $classname = $self->{class};
    return dynext_load_code( $classname, $classname => {} );
}

=item C<pmc_is_dynpmc>

Determines if a given PMC type is dynamically loaded or not.

=cut

sub pmc_is_dynpmc {

    # surely core PMCs aren't dynamic
    return exists( $pmc_types{ $_[1] } ) ? 0 : 1;
}

# XXX quick hack - to get MMD variants
sub get_super_mmds {
    my ( $self, $meth, $right, $func ) = @_;
    ## use Data::Dumper;
    ## printf "******* $meth_name **********\n";
    ## print Dumper($self);
    ## exit 0;
    my ( @mmds, $found );
    for my $super_mmd ( @{ $self->{super_mmd} } ) {
        my ( $super, $variants );
        $found = 0;
        @mmds  = ();
        while ( ( $super, $variants ) = each %{$super_mmd} ) {
            if ( $super eq 'meth' && $variants eq $meth ) {
                $found = 1;
            }
            elsif ( ref($variants) eq 'ARRAY' ) {
                for my $class ( @{$variants} ) {
                    next if $class eq 'DEFAULT';
                    my $r =
                        $class eq 'DEFAULT'
                        ? 'enum_type_PMC'
                        : "enum_class_$class";
                    my $super_name = "Parrot_${super}_$meth";
                    $super_name .= "_$class" if $class ne 'DEFAULT';
                    push @mmds, [ $func, 0, $r, $super_name ];
                }
            }
        }
        last if $found;
    }
    return $found ? @mmds : ();
}

=item C<find_mmd_methods()>

Returns three values:

The first is an arrayref of <[ mmd_number, left, right, implementation_func]>
suitable for initializing the MMD list.

The second is a arrayref listing dynamic PMCs which will need to be looked up.

The third is a list of C<[index, dynamic PMC]> pairs of right entries
in the MMD table that will need to be resolved at runtime.

=cut

sub find_mmd_methods {
    my $self      = shift;
    my $classname = $self->{class};
    my ( @mmds, @init_mmds, %init_mmds );
    foreach my $method ( @{ $self->{vtable}{methods} } ) {
        my $meth = $method->{meth};
        my $meth_name;
        if ( !$self->implements($meth) ) {
            my $class = $self->{super}{$meth};
            next
                if $class =~ /^[A-Z]/
                or $class eq 'default'
                or $class eq 'delegate';
            $meth_name = "Parrot_${class}_$meth";
        }
        else {
            $meth_name = "Parrot_${classname}_$meth";
        }
        next unless $method->{mmd} =~ /MMD_/;
        my ( $func, $left, $right );
        $func = $method->{mmd};

        # dynamic PMCs need the runtime type
        # which is passed in entry to class_init
        $left  = 0;                 # set to 'entry' below in initialization loop.
        $right = 'enum_type_PMC';
        $right = 'enum_type_INTVAL' if ( $func =~ s/_INT$// );
        $right = 'enum_type_FLOATVAL' if ( $func =~ s/_FLOAT$// );
        $right = 'enum_type_STRING' if ( $func =~ s/_STR$// );
        if ( exists $self->{super}{$meth} ) {
            push @mmds, $self->get_super_mmds( $meth, $right, $func );
        }
        push @mmds, [ $func, $left, $right, $meth_name ];
        foreach my $variant ( @{ $self->{mmd_variants}{$meth} } ) {
            if ( $self->pmc_is_dynpmc( $variant->[0] ) ) {
                $right = 0;
                push @init_mmds, [ $#mmds + 1, $variant->[0] ];
                $init_mmds{ $variant->[0] } = 1;
            }
            else {
                $right = "enum_class_$variant->[0]";
            }
            $meth_name = $variant->[1] . '_' . $variant->[0];
            push @mmds, [ $func, $left, $right, $meth_name ];
        }
        $self->{mmds} = @mmds;    # XXX?
    }
    return ( \@mmds, \@init_mmds, [ keys %init_mmds ] );
}

=item C<find_vtable_methods()>

Returns an arrayref containing the vtable methods in the order
they appear in the vtable.

=cut

sub find_vtable_methods {
    my $self      = shift;
    my $classname = $self->{class};
    my $variant   = $self->{variant} || "";
    my ( @meths, @mmds, @init_mmds, %init_mmds );
    foreach my $method ( @{ $self->{vtable}{methods} } ) {
        my $meth = $method->{meth};
        my $meth_name;
        if ( $self->implements($meth) ) {
            $meth_name = "Parrot_${classname}${variant}_$meth";
        }
        elsif ( exists $self->{super}{$meth} ) {
            my $class = $self->{super}{$meth};
            $meth_name = "Parrot_${class}_$meth";
        }
        else {
            $meth_name = "Parrot_default_$meth";
        }

        # normal vtable method}
        unless ( $method->{mmd} =~ /MMD_/ ) {
            push @meths, $meth_name;
        }
    }
    return \@meths;
}

=item C<vtable_decl($name)>

Returns the C code for the declaration of a vtable temporary named
C<$name> with the functions for this class.
=cut

sub vtable_decl {
    my ( $self, $name ) = @_;

    my $methods = $self->find_vtable_methods();

    my $cout = "";
    return "" if exists $self->{flags}{noinit};

    # TODO gen C line comment
    my $classname = $self->{class};
    my $vtbl_flag =
          $self->{flags}{const_too} ? 'VTABLE_HAS_CONST_TOO'
        : $self->{flags}{is_const}  ? 'VTABLE_IS_CONST_FLAG'
        :                             0;
    if ( exists $self->{flags}{need_ext} ) {
        $vtbl_flag .= '|VTABLE_PMC_NEEDS_EXT';
    }
    if ( exists $self->{flags}{singleton} ) {
        $vtbl_flag .= '|VTABLE_PMC_IS_SINGLETON';
    }
    if ( exists $self->{flags}{is_shared} ) {
        $vtbl_flag .= '|VTABLE_IS_SHARED_FLAG';
    }
    if ( exists $self->{flags}{is_ro} ) {
        $vtbl_flag .= '|VTABLE_IS_READONLY_FLAG';
    }
    if ( exists $self->{flags}{has_ro} ) {
        $vtbl_flag .= '|VTABLE_HAS_READONLY_FLAG';
    }

    my $enum_name = $self->{flags}{dynpmc} ? -1 : "enum_class_$classname";
    my $methlist = join( ",\n        ", @$methods );
    $cout .= <<ENDOFCODE;
    const struct _vtable $name = {
        NULL, /* namespace */
        $enum_name, /* base_type */
        NULL, /* whoami */
        $vtbl_flag, /* flags */
        NULL,   /* does_str */
        NULL,   /* isa_str */
        NULL,   /* class */
        NULL,   /* mro */
        NULL,   /* ro_variant_vtable */
        $methlist
    };
ENDOFCODE
    return $cout;
}

=item C<init_func()>

Returns the C code for the PMC's initialization method, or an empty
string if the PMC has a C<no_init> flag.

=cut

sub init_func {
    my $self = shift;

    my $cout = "";
    return "" if exists $self->{flags}{noinit};
    my ( $mmds, $init_mmds, $dyn_mmds ) = $self->find_mmd_methods();
    my $vtable_decl = $self->vtable_decl('temp_base_vtable');

    my $classname = $self->{class};

    my $mmd_list = join(
        ",\n        ",
        map {
            "{ $_->[0], $_->[1], $_->[2],
                    (funcptr_t) $_->[3] }"
            } @$mmds
    );
    my $isa = join( " ", $classname, @{ $self->{parents} } );
    $isa =~ s/\s?default$//;
    my $does = join( " ", keys( %{ $self->{flags}{does} } ) );
    my $n = exists $self->{has_method}{class_init} ? $self->{has_method}{class_init} : -1;
    my $class_init_code = $n >= 0 ? $self->{methods}[$n]{body} : "";
    $class_init_code =~ s/INTERP/interp/g;
    my $enum_name = $self->{flags}{dynpmc} ? -1 : "enum_class_$classname";

    my %extra_vt;

    if ( $self->{ro} ) {
        $extra_vt{ro} = $self->{ro};
    }

    $cout .= <<"EOC";
void
Parrot_${classname}_class_init(Parrot_Interp interp, int entry, int pass)
{
$vtable_decl
EOC

    for my $k ( keys %extra_vt ) {
        $cout .= $extra_vt{$k}->vtable_decl("temp_${k}_vtable");
    }

    my $const = ( $self->{flags}{dynpmc} ) ? " " : " const ";
    if ( scalar @$mmds ) {
        $cout .= <<"EOC";

   $const MMD_init _temp_mmd_init[] = {
        $mmd_list
    };
    /*  Dynamic PMCs need the runtime type
    which is passed in entry to class_init.
    */
EOC
    }

    $cout .= <<"EOC";
    if (pass == 0) {
EOC
    $cout .= <<"EOC";
        /*
         * create vtable - clone it - we have to set a few items
         */
        struct _vtable *vt_clone =
            Parrot_clone_vtable(interp, &temp_base_vtable);
EOC
    for my $k ( keys %extra_vt ) {
        $cout .= <<"EOC";
        struct _vtable *vt_${k}_clone =
            Parrot_clone_vtable(interp, &temp_${k}_vtable);
EOC
    }

    # init vtable slot
    if ( $self->{flags}{dynpmc} ) {
        $cout .= <<"EOC";
        vt_clone->base_type = entry;
        vt_clone->whoami = string_make(interp,
            "$classname", @{[length($classname)]}, "ascii",
            PObj_constant_FLAG|PObj_external_FLAG);
        vt_clone->isa_str = string_make(interp,
            "$isa", @{[length($isa)]}, "ascii",
            PObj_constant_FLAG|PObj_external_FLAG);
        vt_clone->does_str = string_make(interp,
            "$does", @{[length($does)]}, "ascii",
            PObj_constant_FLAG|PObj_external_FLAG);
EOC
    }
    else {
        $cout .= <<"EOC";
        vt_clone->whoami = CONST_STRING(interp, "$classname");
        vt_clone->isa_str = CONST_STRING(interp, "$isa");
        vt_clone->does_str = CONST_STRING(interp, "$does");
EOC
    }
    for my $k ( keys %extra_vt ) {
        $cout .= <<"EOC";
        vt_${k}_clone->base_type = entry;
        vt_${k}_clone->whoami = vt_clone->whoami;
        vt_${k}_clone->isa_str = vt_clone->isa_str;
        vt_${k}_clone->does_str = vt_clone->does_str;
EOC
    }

    if ( $extra_vt{ro} ) {
        $cout .= <<"EOC";
        vt_clone->ro_variant_vtable = vt_ro_clone;
        vt_ro_clone->ro_variant_vtable = vt_clone;
EOC
    }

    $cout .= <<"EOC";
        interp->vtables[entry] = vt_clone;
EOC
    $cout .= <<"EOC";
    }
    else { /* pass */
EOC

    # To make use of the .HLL directive, register any mapping...
    if ( $self->{flags}{hll} && $self->{flags}{maps} ) {

        my $hll  = ( keys %{ $self->{flags}{hll} } )[0];
        my $maps = ( keys %{ $self->{flags}{maps} } )[0];
        $cout .= <<"EOC";

        {
            /* Register this PMC as a HLL mapping */
            INTVAL pmc_id = Parrot_get_HLL_id(
                interp, const_string(interp, "$hll")
            );
            if (pmc_id > 0)
                Parrot_register_HLL_type(
                    interp, pmc_id, enum_class_$maps, entry
                );
        } /* Register */
EOC
    }

    $cout .= <<"EOC";
        /* setup MRO and _namespace */
        Parrot_create_mro(interp, entry);
EOC

    # declare each nci method for this class
    foreach my $method ( @{ $self->{methods} } ) {
        next unless $method->{loc} eq 'nci';
        my $proto = proto( $method->{type}, $method->{parameters} );
        $cout .= <<"EOC";
        enter_nci_method(interp, entry,
                F2DPTR(Parrot_${classname}_$method->{meth}),
                "$method->{meth}", "$proto");
EOC
        if ( $method->{attrs}{write} ) {
            $cout .= <<"EOC";
        Parrot_mark_method_writes(interp, entry, "$method->{meth}");
EOC
        }
    }

    # include any class specific init code from the .pmc file
    $cout .= <<"EOC";
        /* class_init */
EOC
    $cout .= "    $class_init_code\n" if $class_init_code;

    $cout .= <<"EOC";
        {
EOC

    # declare auxiliary variables for dyncpmc IDs
    foreach my $dynpmc (@$dyn_mmds) {
        next if $dynpmc eq $classname;
        $cout .= <<"EOC";
            int my_enum_class_$dynpmc = pmc_type(interp, string_from_const_cstring(interp, "$dynpmc", 0));
EOC
    }

    # init MMD "right" slots with the dynpmc types
    foreach my $entry (@$init_mmds) {
        if ( $entry->[1] eq $classname ) {
            $cout .= <<"EOC";
            _temp_mmd_init[$entry->[0]].right = entry;
EOC
        }
        else {
            $cout .= <<"EOC";
            _temp_mmd_init[$entry->[0]].right = my_enum_class_$entry->[1];
EOC
        }
    }

    # just to be safe
    foreach my $dynpmc (@$dyn_mmds) {
        next if $dynpmc eq $classname;
        $cout .= <<"EOC";
            assert(my_enum_class_$dynpmc != enum_class_default);
EOC
    }
    if ( scalar @$mmds ) {
        $cout .= <<"EOC";
#define N_MMD_INIT (sizeof(_temp_mmd_init)/sizeof(_temp_mmd_init[0]))
            Parrot_mmd_register_table(interp, entry,
                _temp_mmd_init, N_MMD_INIT);
EOC
    }

    $cout .= <<"EOC";
        }
    } /* pass */
} /* Parrot_${classname}_class_init */
EOC
    if ( $self->{flags}{dynpmc} ) {
        $cout .= $self->lib_load_code();
    }
    $cout;
}

=item C<gen_c($out_name)>

Generates the C implementation file code for the PMC. C<$out_name> is the name
of the output file we are generating.

=cut

sub gen_c {
    my ( $self, $out_name ) = @_;

    my $cout = dont_edit( $self->{file} );
    if ( $self->{flags}{dynpmc} ) {
        $cout .= "#define PARROT_IN_EXTENSION\n";
    }
    $cout .= $self->line_directive( 1, $self->{file} ) . $self->{pre};
    $cout .= $self->line_directive_here( $cout, $out_name ) . $self->includes;
    my $l = count_newlines($cout);
    $cout .= $self->methods( $l, $out_name );
    if ( $self->{ro} ) {
        $cout .= $self->{ro}->methods( $l, $out_name );
    }
    $cout .= $self->init_func;
    if ( $self->{const} ) {
        $cout .= $self->{const}->methods( $l, $out_name );
        $cout .= $self->{const}->init_func;
    }
    $cout .= $self->{post};
    $cout;
}

=item C<hdecls()>

Returns the C code function declarations for all the methods for inclusion
in the PMC's C header file.

TODO include MMD variants.

=cut

sub hdecls {
    my $self = shift;

    my $hout;
    my $classname = $self->{class};

    # generat decls for all methods in this file
    foreach my $meth ( @{ $self->{vtable}{methods} } ) {
        if ( $self->implements( $meth->{meth} ) ) {
            $hout .= $self->decl( $classname, $meth, 1 );
        }
    }
    foreach my $method ( @{ $self->{methods} } ) {
        next unless $method->{loc} eq 'nci';
        $hout .= $self->decl( $classname, $method, 1 );
    }

    # class init decl
    if ( $self->{flags}->{dynpmc} ) {
        $hout .= 'PARROT_DYNEXT_EXPORT ';
    }
    $hout .= <<"EOC";
void Parrot_${classname}_class_init(Parrot_Interp, int, int);
EOC
    $self->{hdecls} .= $hout;
    $self->{hdecls};
}

=item C<gen_h($out_name)>

Generates the C header file code for the PMC. C<$out_name> is the name
of the output file we are generating.

=cut

sub gen_h {
    my ( $self, $out_name ) = @_;

    my $hout = dont_edit( $self->{file} );
    my $name = uc $self->{class};
    $hout .= <<"EOH";

#ifndef PARROT_PMC_${name}_H_GUARD
#define PARROT_PMC_${name}_H_GUARD

EOH

    if ( $self->{flags}{dynpmc} ) {
        $hout .= "#define PARROT_IN_EXTENSION\n";
    }

    $hout .= $self->hdecls();
    if ( $self->{const} ) {
        $hout .= $self->{const}->hdecls();
    }
    if ( $self->{ro} ) {
        $hout .= $self->{ro}->hdecls();
    }
    $hout .= <<"EOH";

#endif

EOH
    $hout .= $self->c_code_coda();
    $hout;
}

=item C<c_code_coda()>

Returns the Parrot C code coda (PDD07)

=cut

sub c_code_coda {
    return <<'EOC';
/*
 * Local variables:
 *   c-file-style: "parrot"
 * End:
 * vim: expandtab shiftwidth=4:
 */

EOC
}

=item C<implements($method)>

True if this class generates code for the method C<$method>.

=cut

sub implements {
    my ( $self, $meth ) = @_;

    return 0 unless exists $self->{has_method}{$meth};
    my $n = $self->{has_method}{$meth};
    return $self->{methods}[$n]{'loc'} ne 'nci';
}

=item C<implements_vtable($method)>

True if this class generates code for VTABLE method C<$method>.

=cut

sub implements_vtable {
    my ( $self, $meth ) = @_;
    return 1 if exists $self->{has_method}{$meth};
    my $n = $self->{vtable}{has_method}{$meth};
    return $self->{vtable}{methods}[$n]{mmd} =~ /MMD/ ? 0 : 1;
}

=back

=head1 SUBCLASSES

=head2 Parrot::Pmc2c::Standard Instance Methods

Standard behavior.

=over 4

=cut

package Parrot::Pmc2c::Standard;
use base 'Parrot::Pmc2c';

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};
    my $n    = $self->{has_method}{$meth};
    return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
}

=back

=head2 Parrot::Pmc2c::Standard::Const Instance Methods

Returns the C code for the method body.

=over 4

=cut

package Parrot::Pmc2c::Standard::Const;
use base 'Parrot::Pmc2c::Standard';
import Parrot::Pmc2c qw( gen_ret );

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    my $decl       = $self->decl( $self->{class}, $method, 0 );
    my $classname  = $self->{class};
    my $parentname = $self->{parentname};
    my $ret        = gen_ret($method);
    my $cout       = <<"EOC";
$decl {
EOC
    if ( $meth eq 'morph' ) {
        $cout .= <<EOC;
    if (1 || Parrot_is_const_pmc(interp, pmc))
        internal_exception(WRITE_TO_CONSTCLASS, "$meth() in $classname");
    else
        Parrot_${parentname}_$meth(interp, pmc, type);
EOC
    }
    else {
        $cout .= <<EOC;
        internal_exception(WRITE_TO_CONSTCLASS, "$meth() in $classname");
EOC
        $cout .= "    $ret\n" if $ret;
    }
    $cout .= <<"EOC";
}

EOC
    $cout;
}

=back

=head2 Parrot::Pmc2c::Standard::RO Instance Methods

Returns the C code for the method body.

=over 4

=cut

package Parrot::Pmc2c::Standard::RO;
use base 'Parrot::Pmc2c::Standard';
import Parrot::Pmc2c qw( gen_ret );

=item C<implements($method)>

Returns true if we implement C<$method>. This is true in the special
case of C<find_method> and for all read-only methods.

=cut

sub implements {
    my ( $self, $method ) = @_;
    return 1 if $method eq 'find_method';
    return $self->SUPER::implements($method);
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth       = $method->{meth};
    my $decl       = $self->decl( $self->{class}, $method, 0 );
    my $classname  = $self->{class};
    my $parentname = $self->{parentname};
    my $ret        = gen_ret($method);
    my $cout;

    if ( $meth eq 'find_method' ) {
        my $real_findmethod = 'Parrot_' . $self->{super}{find_method} . '_find_method';
        $cout = <<"EOC";
$decl {
    PMC *const method = $real_findmethod(interp, pmc, method_name);
    if (!PMC_IS_NULL(VTABLE_getprop(interp, method, const_string(interp, "write"))))
        return PMCNULL;
    else
        return method;
}
EOC
    }
    else {
        $cout = <<"EOC";
$decl {
    internal_exception(WRITE_TO_CONSTCLASS,
            "$meth() in read-only instance of $classname");
EOC
        $cout .= "    $ret\n" if $ret;
        $cout .= <<"EOC";
}
EOC
    }
    $cout;
}

=back

=head2 Parrot::Pmc2c::Ref Instance Methods

=over 4

=cut

package Parrot::Pmc2c::Ref;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

=item C<implements($method)>

Always true for vtables.

=cut

sub implements {
    my ( $self, $meth ) = @_;
    return $self->implements_vtable($meth);
}

=item C<prederef($method)>

Returns C code to be executed before executing a delegated method.
Default versions always returns an empty string.

=cut

sub prederef {
    return '';
}

=item C<postderef($method)>

Returns C code to be executed after executing a delegated method
through this reference. Default version returns an empty string.

=cut

sub postderef {
    return '';
}

=item C<raw_deref($method)>

Returns C code that can be used to access the underlying PMC in the
delegated methods. Defualt is PMC_pmc_val(pmc)

=cut

sub raw_deref {
    my ( $self, $method ) = @_;
    return 'PMC_pmc_val(pmc)';
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

Overrides the default implementation to direct all unknown methods to
the thing referred to.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    # existing methods get emitted
    if ( $self->SUPER::implements($meth) ) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
    }
    my $is_mmd     = $method->{mmd} ne "-1";
    my $parameters = $method->{parameters};
    my $n          = 0;
    my @args       = grep { $n++ & 1 ? $_ : 0 } split / /, $parameters;
    my $arg        = '';
    $arg = ", " . join( ' ', @args ) if @args;
    $parameters = ", $parameters" if $parameters;
    my $body;
    my $pre        = $self->prederef($method);
    my $post       = $self->postderef($method);
    my $deref      = $self->raw_deref($method);
    my $ret_def    = '';
    my $ret_assign = '';
    my $ret        = '';

    if ( $method->{type} ne 'void' ) {
        $ret_def    = $method->{type} . ' ret_val;';
        $ret_assign = 'ret_val = ';
        $ret        = gen_ret( $method, 'ret_val' );
    }
    $body = <<EOC;
    $pre
    $ret_assign VTABLE_$meth(interp, $deref$arg);
    $post
EOC
    my $decl = $self->decl( $self->{class}, $method, 0 );

    # I think that these will be out by one - NWC
    my $l = $self->line_directive( $line, "\L$self->{class}.c" );
    return <<EOC;
$l
$decl {
    $ret_def
$body
    $ret
}

EOC
}

=back

=cut

package Parrot::Pmc2c::STMRef;
use base 'Parrot::Pmc2c::Ref';

=head2 Parrot::Pmc2c::STMRef Instance Methods

=over 4

=cut

sub prederef {
    my ( $self, $method ) = @_;
    my $name = $method->{meth};
    my $code = '';
    $code .= <<'EOC';
    PMC *real_pmc;
    Parrot_STM_PMC_handle handle;

    assert(pmc->vtable->class != pmc);

    handle = PMC_struct_val(pmc);
EOC
    if ( $self->does_write($name) ) {    # XXX is this good enough?
        $code .= <<'EOC';
    real_pmc = Parrot_STM_begin_update(interp, handle);
EOC
    }
    else {
        $code .= <<'EOC';
    real_pmc = Parrot_STM_read(interp, handle);
EOC
    }
}

sub raw_deref {
    return 'real_pmc';
}

=back

=head2 Parrot::Pmc2c::SharedRef Instance Methods

=over 4

=cut

package Parrot::Pmc2c::SharedRef;
use base 'Parrot::Pmc2c::Ref';

=item C<prederef($method)>

Returns code that will lock the PMC for calling the underlying
implementation of $method.

=cut

sub prederef {
    my ( $self, $method ) = @_;
    return 'LOCK_PMC(interp, pmc);';
}

=item C<postderef($method)>

Returns the unlocking code.

=cut

sub postderef {
    my ( $self, $method ) = @_;
    return 'UNLOCK_PMC(interp, pmc);';
}

=back

=head2 Parrot::Pmc2c::default Instance Methods

=over 4

=cut

package Parrot::Pmc2c::default;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

=item C<implements($method)>

Always true.

=cut

sub implements {
    return 1;
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

Overrides the default implementation to throw an execption for unknown
methods.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    # existing methods get emitted
    if ( $self->SUPER::implements($meth) ) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
    }
    my $decl = $self->decl( $self->{class}, $method, 0 );
    my $ret = "";
    if ( $method->{type} ne 'void' ) {

        # This cheats, assuming that all return types can be cast from zero.
        $ret = "return ($method->{type})0;";
    }

    # I think that these will be out by one - NWC
    my $l = $self->line_directive( $line, "default.c" );
    my $cout = <<EOC;
$l
${decl}\{
    cant_do_method(interp, pmc, "$meth");
EOC

    $cout .= "    $ret\n" if $ret;
    $cout .= <<EOC;
}

EOC
    return $cout;
}

=back

=head2 Parrot::Pmc2c::Null Instance Methods

=over 4

=cut

package Parrot::Pmc2c::Null;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

=item C<implements($method)>

True for vtable methods.

=cut

sub implements {

    my ( $self, $meth ) = @_;
    $self->implements_vtable($meth);
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

The C<Null> PMC throws an execption for all methods.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    # existing methods get emitted
    if ( $self->SUPER::implements($meth) ) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
    }
    my $decl = $self->decl( $self->{class}, $method, 0 );
    my $ret = gen_ret($method);

    # I think that these will be out by one - NWC
    my $l = $self->line_directive( $line, "null.c" );
    my $output = <<EOC;
$l
${decl} {
    real_exception(interp, NULL, NULL_REG_ACCESS,
        "Null PMC access in $meth()");
EOC

    $output .= $ret if $ret;
    return $output .= "\n}\n";
}

=back

=head2 Parrot::Pmc2c::delegate Instance Methods

=over 4

=cut

package Parrot::Pmc2c::delegate;
use base 'Parrot::Pmc2c';

=item C<implements($method)>

True for vtables.

=cut

sub implements {
    my ( $self, $meth ) = @_;
    $self->implements_vtable($meth);
}

=item C<trans($type)>

Used in C<signature()> to normalize argument types.

=cut

sub trans {
    my ( $self, $type ) = @_;

    my $char = substr $type, 0, 1;
    return $1 if ( $char =~ /([ISP])/ );
    return 'N' if ( $char eq 'F' );
    return 'v' if ( $type eq 'void' );
    return '?';
}

=item C<signature($params)>

Returns the method signature for C<$params>.

=cut

sub signature {
    my ( $self, $params ) = @_;

    my $n = 1;
    my @types = grep { $n++ & 1 ? $_ : 0 } split / /, $params;
    @types = map { $self->trans($_) } @types;
    return join '', @types;
}

=item C<gen_ret($type)>

Generate the C code for a C<return> statement.

=cut

sub gen_ret {
    my ( $self, $type ) = @_;

    #return "ret_val = *($1*) " if ($type =~ /((?:INT|FLOAT)VAL)/);
    return "ret_val = ($type) ";
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

The C<delegate> PMC redirects all methods to bytecode.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    # existing methods get emitted
    if ( $self->SUPER::implements($meth) ) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
    }
    my $decl       = $self->decl( $self->{class}, $method, 0 );
    my $parameters = $method->{parameters};
    my $n          = 0;
    my @args       = grep { $n++ & 1 ? $_ : 0 } split / /, $parameters;
    my $arg        = '';
    $arg = ", " . join( ' ', @args ) if @args;
    my $sig = $self->signature($parameters);
    $sig = $self->trans( $method->{type} ) . $sig;
    my $ret      = '';
    my $ret_def  = '';
    my $func_ret = '(void) ';
    my $ret_type = '';

    if ( $method->{type} ne 'void' ) {
        my $type = $method->{type};
        $ret_def  = "$type ret_val;";
        $func_ret = $self->gen_ret( $method->{type} );
        $ret      = "return ret_val;";
        if ( $type !~ /\*/ ) {
            $ret_type = "_ret" . lc substr $type, 0, 1;
            $ret_type = "_reti" if $ret_type eq '_retu';
        }
    }
    my $umeth         = uc $meth;
    my $delegate_meth = "PARROT_VTABLE_${umeth}_METHNAME";

    # I think that these will be out by one - NWC
    my $l = $self->line_directive( $line, "delegate.c" );
    my $cout = <<EOC;
$l
${decl} {
EOC
    $cout .= "    $ret_def\n" if $ret_def;
    $cout .= <<EOC;
    STRING *meth = CONST_STRING(interp, "__$meth");
    STRING *meth_v = CONST_STRING(interp, "$meth");
    PMC *sub = find_vtable_meth(interp, pmc, meth_v);
    if (PMC_IS_NULL(sub))
        sub = find_or_die(interp, pmc, meth);
    ${func_ret}Parrot_run_meth_fromc_args$ret_type(interp, sub,
        pmc, meth, "$sig"$arg);
EOC
    $cout .= "    $ret\n" if $ret;
    $cout .= <<EOC;
}

EOC
    return $cout;
}

package Parrot::Pmc2c::deleg_pmc;
use base 'Parrot::Pmc2c';
import Parrot::Pmc2c qw( gen_ret );

=item C<implements($method)>

Always true for vtables.

=cut

sub implements {
    my ( $self, $meth ) = @_;
    $self->implements_vtable($meth);
}

=item C<body($method, $line, $out_name)>

Returns the C code for the method body. C<$line> is used to accumulate
the number of lines, C<$out_name> is the name of the output file we are
generating.

Overrides the default implementation to direct all unknown methods to
the PMC in the first attribute slot.

=cut

sub body {
    my ( $self, $method, $line, $out_name ) = @_;

    my $meth = $method->{meth};

    # existing methods get emitted
    if ( $self->SUPER::implements($meth) ) {
        my $n = $self->{has_method}{$meth};
        return $self->SUPER::body( $self->{methods}[$n], $line, $out_name );
    }
    my $parameters = $method->{parameters};
    my $n          = 0;
    my @args       = grep { $n++ & 1 ? $_ : 0 } split / /, $parameters;
    my $arg        = '';
    $arg = ", " . join( ' ', @args ) if @args;
    $parameters = ", $parameters" if $parameters;
    my $body = "VTABLE_$meth(interp, attr$arg)";
    my $ret  = gen_ret( $method, $body );
    my $decl = $self->decl( $self->{class}, $method, 0 );

    # I think that these will be out by one - NWC
    my $l = $self->line_directive( $line, "ref.c" );
    return <<EOC;
$l
$decl {
    SLOTTYPE *attrib_array = PMC_data(pmc);
    PMC *attr = get_attrib_num(attrib_array, 0);
    $ret
}

EOC
}

=back

=cut

1;

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
