# Copyright (C) 2001-2007, The Perl Foundation.
# $Id: Vtable.pm 23914 2007-12-15 08:14:49Z petdance $
=head1 NAME
Parrot::Vtable - Functions for manipulating vtables
=head1 SYNOPSIS
use Parrot::Vtable;
=head1 DESCRIPTION
C<Parrot::Vtable> provides a collection of functions for manipulating
PMC vtables. It is used by F<tools/build/jit2c.pl>, F<tools/build/pmc2c.pl>,
F<tools/build/vtable_h.pl>, F<tools/dev/gen_class.pl>, and
F<src/pmc/null.pl>.
=head2 Functions
The following functions are exported:
=over 4
=cut
package Parrot::Vtable;
use strict;
use warnings;
use base qw( Exporter );
use FileHandle;
our @EXPORT = qw(parse_vtable vtbl_defs vtbl_struct vtbl_macros vtbl_embed);
sub make_re {
my $re = shift;
my $comp_re = qr/$re/;
return ( defined $comp_re )
? $comp_re
: "(?:$re)";
}
my $ident_re = make_re('[A-Za-z_][A-Za-z0-9_]*');
my $type_re = make_re( '(?:(?:struct\s+)|(?:union\s+))?' . $ident_re . '\**' );
my $const_re = make_re( '(?:const\s+)?' );
my $param_re = make_re( $const_re . $type_re . '\s+' . $ident_re );
my $arglist_re = make_re( '(?:' . $param_re . '(?:\s*,\s*' . $param_re . ')*)?' );
my $method_re =
make_re( '^\s*(' . $type_re . ')\s+(' . $ident_re . ')\s*\((' . $arglist_re . ')\)\s*$' );
my $attrs_re = make_re('(?::(\w+)\s*)*');
my $attr_re = make_re(':(\w+)\s*');
sub parse_attrs {
my $attrs = shift;
my $default = shift || {};
my $result = {%$default};
$result->{$1} = 1 while $attrs =~ /$attr_re/g;
return $result;
}
=item C<parse_vtable($file)>
Returns a reference to an array containing
[ return_type method_name parameters section MMD_type attributes ]
for each vtable method defined in C<$file>. If C<$file> is unspecified it
defaults to F<vtable.tbl>. If it is not an MMD method, C<MMD_type> is -1.
=cut
sub parse_vtable {
my $file = defined $_[0] ? shift() : 'vtable.tbl';
my $vtable = [];
my $mmd = [];
my $fh = FileHandle->new( $file, O_RDONLY ) or die "Can't open $file for reading: $!\n";
my $section = 'MAIN';
my $default_attrs = {};
while (<$fh>) {
chomp;
s/\s+$//;
next if /^\s*#/ or /^$/;
if (/^\[(\w+)\]\s*($attrs_re)/) {
$section = $1;
$default_attrs = parse_attrs($2);
}
elsif (
m/^\s*
($type_re)\s+
($ident_re)\s*
\(($arglist_re)\)
(?:\s+(MMD_\w+))?\s*($attrs_re)$/x
)
{
my $mmdop = defined $4 ? $4 : -1;
my $entry = [ $1, $2, $3, $section, $mmdop, parse_attrs( $5, $default_attrs ) ];
if ( defined $4 ) {
push @{$mmd}, $entry;
}
else {
push @{$vtable}, $entry;
}
}
else {
die "Syntax error at $file line " . $fh->input_line_number() . "\n";
}
}
# We probably should sort on insert, but this is easier for now. And it's
# compile time, so it's not all that important.
return [ @{$mmd}, sort { $a->[1] cmp $b->[1] } @{$vtable} ];
}
=item C<vtbl_defs($vtable)>
Returns the C C<typedef> definitions for the elements in the referenced
vtable array.
=cut
sub vtbl_defs {
my $vtable = shift;
my $defs = q{};
my $entry;
for $entry ( @{$vtable} ) {
next if ( $entry->[4] =~ /MMD_/ );
my $args = join( ", ", 'PARROT_INTERP', 'PMC* pmc', split( /\s*,\s*/, $entry->[2] ) );
$defs .= "typedef $entry->[0] (*$entry->[1]_method_t)($args);\n";
}
return $defs;
}
=item C<vtbl_struct($vtable)>
Returns the C C<struct> definitions for the elements in the referenced
vtable array.
=cut
sub vtbl_struct {
my $vtable = shift;
my $struct = q{};
my $entry;
$struct = <<"EOF";
typedef enum {
VTABLE_IS_CONST_FLAG = 0x001,
VTABLE_HAS_CONST_TOO = 0x002,
VTABLE_PMC_NEEDS_EXT = 0x004,
VTABLE_DATA_IS_PMC = 0x008,
VTABLE_PMC_IS_SINGLETON = 0x010,
VTABLE_IS_SHARED_FLAG = 0x020,
VTABLE_IS_CONST_PMC_FLAG = 0x040,
VTABLE_HAS_READONLY_FLAG = 0x080,
VTABLE_IS_READONLY_FLAG = 0x100
} vtable_flags_t;
typedef struct _vtable {
PMC *_namespace; /* Pointer to namespace for this class */
INTVAL base_type; /* 'type' value for MMD */
STRING *whoami; /* Name of class this vtable is for */
UINTVAL flags; /* Flags. Duh */
STRING *does_str; /* space-separated list of interfaces */
STRING *isa_str; /* space-separated list of classes */
PMC *pmc_class; /* for PMCs: a PMC of that type
for objects: the class PMC */
PMC *mro; /* array PMC of [class, parents ... ] */
struct _vtable *ro_variant_vtable; /* A variant of this vtable with the
opposite IS_READONLY flag */
/* Vtable Functions */
EOF
for $entry ( @{$vtable} ) {
next if ( $entry->[4] =~ /MMD_/ );
$struct .= " $entry->[1]_method_t $entry->[1];\n";
}
$struct .= "} _vtable;\n";
return $struct;
}
=item C<vtbl_macros($vtable)>
Returns the C C<#define> definitions for the elements in the referenced
vtable array.
=cut
sub vtbl_macros {
my $vtable = shift;
my $macros = <<"EOM";
/*
* vtable accessor macros
* as vtable methods might get moved around internally
* these macros hide the details
*/
EOM
for my $entry ( @{$vtable} ) {
next if ( $entry->[4] =~ /MMD_/ );
my @args = split /,\s*/, $entry->[2];
unshift @args, "i interp", "p pmc";
my $args = join ', ', map { ( split / /, $args[$_] )[-1] } ( 0 .. $#args );
$macros .= <<"EOM";
#define VTABLE_$entry->[1]($args) \\
(pmc)->vtable->$entry->[1]($args)
EOM
}
$macros .= <<"EOM";
/*
* vtable method name defines for delegate
*/
/* &gen_from_def(vtable_methods.pasm) */
EOM
for my $entry ( @{$vtable} ) {
my $uc_meth = uc $entry->[1];
$macros .= <<"EOM";
#define PARROT_VTABLE_${uc_meth}_METHNAME \"__$entry->[1]\"
EOM
}
$macros .= <<"EOM";
/* &end_gen */
EOM
# finally the name mapping
$macros .= <<"EOM";
/*
* vtable slot names
*/
#ifdef PARROT_IN_OBJECTS_C
#define PARROT_VTABLE_LOW 9
static const char * const Parrot_vtable_slot_names[] = {
"", /* Pointer to namespace for this class */
"", /* 'type' value for MMD */
"", /* Name of class this vtable is for */
"", /* Flags. Duh */
"", /* space-separated list of interfaces */
"", /* space-separated list of classes */
"", /* class */
"", /* mro */
"", /* ro_variant_vtable */
/* Vtable Functions */
EOM
my $num_vtable_funcs = 0;
for my $entry ( @{$vtable} ) {
next if ( $entry->[4] =~ /MMD_/ );
$num_vtable_funcs++;
$macros .= <<"EOM";
\"__$entry->[1]\",
EOM
}
$macros .= <<"EOM";
NULL
};
#define NUM_VTABLE_FUNCTIONS $num_vtable_funcs
#endif /* PARROT_IN_OBJECTS_C */
/* Need this for add, subtract, multiply, divide, mod, cmod, bitwise
(and, or, xor, lshift, rshift), concat, logical (and, or, xor),
repeat, eq, cmp */
/* &gen_from_enum(mmd.pasm) */
typedef enum {
EOM
for my $entry ( @{$vtable} ) {
next unless ( $entry->[4] =~ /MMD_/ );
next if ( $entry->[4] =~ /_INT$/ );
next if ( $entry->[4] =~ /_STR$/ );
next if ( $entry->[4] =~ /_FLOAT$/ );
$macros .= <<"EOM";
$entry->[4],
EOM
}
$macros .= <<"EOM";
MMD_USER_FIRST
} parrot_mmd_func_enum;
/* &end_gen */
#ifdef PARROT_IN_OBJECTS_C
static const char * const Parrot_mmd_func_names[] = {
EOM
for my $entry ( @{$vtable} ) {
next unless ( $entry->[4] =~ /MMD_/ );
next if ( $entry->[4] =~ /_INT$/ );
next if ( $entry->[4] =~ /_STR$/ );
next if ( $entry->[4] =~ /_FLOAT$/ );
$macros .= <<"EOM";
\"__$entry->[1]\",
EOM
}
$macros .= <<"EOM";
NULL
};
#endif /* PARROT_IN_OBJECTS_C */
EOM
$macros;
}
=item C<vtbl_embed($vtable)>
Returns the C function definitions to call the vtable methods on a PMC for the
elements in the referenced vtable array.
=cut
sub vtbl_embed {
my $vtable = shift;
my $funcs = q{};
my $protos = q{};
for my $entry (@$vtable) {
my ( $return_type, $name, $params, $section, $mmd ) = @$entry;
next unless $mmd eq '-1';
my @params = parse_params($params);
my @sig = ( 'PARROT_INTERP', 'Parrot_PMC pmc' );
my @args = ( 'interp', 'pmc' );
while ( my ( $type, $name ) = splice( @params, 0, 2 ) ) {
eval {
push @sig, find_type($type) . ' ' . $name;
push @args, $name;
};
}
next if $@;
my $signature = join( ', ', @sig );
my $arguments = join( ', ', @args );
my $ret_type = find_type($return_type);
$protos .= sprintf "extern PARROT_API %s Parrot_PMC_%s( %s );\n", $ret_type, $name,
$signature;
$funcs .= sprintf "/*
=item C<%s
%s(%s)>
=cut
*/
PARROT_API %s
Parrot_PMC_%s( %s )
{
", ( $ret_type, $name, $signature ) x 2;
$funcs .= " $ret_type retval;\n" unless $ret_type eq 'void';
$funcs .= " PARROT_CALLIN_START( interp );\n ";
$funcs .= "retval = " unless $ret_type eq 'void';
$funcs .= "VTABLE_$name( $arguments );
PARROT_CALLIN_END( interp );
return";
$funcs .= " retval" unless $ret_type eq 'void';
$funcs .= ";\n}\n\n";
}
return ( $funcs, $protos );
}
sub find_type {
my $type = shift;
my %typemap = (
'STRING*' => 'Parrot_String',
'void*' => 'void*',
'INTVAL' => 'Parrot_Int',
'PMC*' => 'Parrot_PMC',
'FLOATVAL' => 'Parrot_Float',
'void' => 'void',
'UINTVAL' => 'Parrot_Int',
'size_t' => 'size_t',
'opcode_t*' => 'Parrot_Opcode*',
);
die "Unknown type $type\n" unless exists $typemap{$type};
return $typemap{$type};
}
sub parse_params {
my $params = shift;
my @params;
while ( $params =~ m/(\w+\*?) (\w+)/g ) {
push @params, $1, $2;
}
return @params;
}
=back
=head1 SEE ALSO
=over 4
=item F<tools/build/jit2c.pl>
=item F<tools/build/pmc2c.pl>
=item F<tools/build/vtable_h.pl>
=item F<tools/dev/gen_class.pl>
=item F<src/pmc/null.pl>
=cut
1;
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
# vim: expandtab shiftwidth=4:
syntax highlighted by Code2HTML, v. 0.9.1