Hi all,
Here is a patch I promised Nicholas a while ago to generate
src/extends.c automatically. It's not complete and it's not perfect,
but it's a good first step that someone (including potentially myself)
can refine as we see where and how it fails.
-- c
Index: lib/Parrot/Vtable.pm
===================================================================
--- lib/Parrot/Vtable.pm (revision 8971)
+++ lib/Parrot/Vtable.pm (working copy)
@@ -26,13 +26,14 @@
package Parrot::Vtable;
-use FileHandle;
+use strict;
use Exporter;
-use strict;
+use FileHandle;
[EMAIL PROTECTED]::Vtable::ISA = qw(Exporter);
[EMAIL PROTECTED]::Vtable::EXPORT = qw(parse_vtable vtbl_defs vtbl_struct vtbl_macros);
[EMAIL PROTECTED]::Vtable::ISA = qw(Exporter);
[EMAIL PROTECTED]::Vtable::EXPORT =
+ qw( parse_vtable vtbl_defs vtbl_struct vtbl_macros vtbl_extend );
sub make_re {
my $re = shift;
@@ -53,10 +54,10 @@
Returns a reference to an array containing
- [ return_type method_name parameters section ]
+ [ return_type method_name parameters section MMD_type ]
-for each vtable method defined in C<$file>. If C<$file> is unspecified
-it defaults to F<vtable.tbl>.
+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
@@ -64,7 +65,7 @@
my $file = defined $_[0] ? shift() : 'vtable.tbl';
my $vtable = [];
- my $fh = new FileHandle ($file, O_RDONLY) or
+ my $fh = FileHandle->new($file, O_RDONLY) or
die "Can't open $file for reading: $!\n";
my $section = 'MAIN';
@@ -74,15 +75,15 @@
next if /^\s*#/ or /^\s*$/;
- if (/^\[(\w+)\]/) {
- $section = $1;
- }
+ if (/^\[(\w+)\]/) {
+ $section = $1;
+ }
elsif (m/^\s*
- ($type_re)\s+
- ($ident_re)\s*
- \(($arglist_re)\)
- (?:\s+(MMD_\w+))?\s*$/x) {
- my $mmd = defined $4 ? $4 : -1;
+ ($type_re)\s+
+ ($ident_re)\s*
+ \(($arglist_re)\)
+ (?:\s+(MMD_\w+))?\s*$/x) {
+ my $mmd = defined $4 ? $4 : -1;
push @{$vtable}, [ $1, $2, $3, $section, $mmd ];
} else {
die "Syntax error at $file line ".$fh->input_line_number()."\n";
@@ -105,7 +106,7 @@
my $entry;
for $entry (@{$vtable}) {
- next if ($entry->[4] =~ /MMD_/);
+ next if ($entry->[4] =~ /MMD_/);
my $args = join(", ", 'Interp* interpreter', 'PMC* pmc', split(/\s*,\s*/, $entry->[2]));
$defs .= "typedef $entry->[0] (*$entry->[1]_method_t)($args);\n";
}
@@ -140,8 +141,8 @@
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 */
+ STRING* does_str; /* space separated list of interfaces */
+ STRING* isa_str; /* space separated list of classes */
PMC *class; /* for PMCs: a PMC of that type
for objects: the class PMC */
PMC *mro; /* array PMC of [class, parents ... ] */
@@ -149,7 +150,7 @@
EOF
for $entry (@{$vtable}) {
- next if ($entry->[4] =~ /MMD_/);
+ next if ($entry->[4] =~ /MMD_/);
$struct .= " $entry->[1]_method_t $entry->[1];\n";
}
@@ -177,11 +178,11 @@
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";
+ 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
@@ -195,8 +196,8 @@
/* &gen_from_def(vtable_methods.pasm) */
EOM
for my $entry (@{$vtable}) {
- my $uc_meth = uc $entry->[1];
- $macros .= <<"EOM";
+ my $uc_meth = uc $entry->[1];
+ $macros .= <<"EOM";
#define PARROT_VTABLE_${uc_meth}_METHNAME \"__$entry->[1]\"
EOM
@@ -217,16 +218,16 @@
"", /* 'type' value for MMD */
"", /* Name of class this vtable is for */
"", /* Flags. Duh */
- "", /* space separated list of interfaces */
- "", /* space separated list of classes */
+ "", /* space separated list of interfaces */
+ "", /* space separated list of classes */
"", /* class */
- "", /* mro */
+ "", /* mro */
/* Vtable Functions */
EOM
for my $entry (@{$vtable}) {
- next if ($entry->[4] =~ /MMD_/);
- $macros .= <<"EOM";
+ next if ($entry->[4] =~ /MMD_/);
+ $macros .= <<"EOM";
\"__$entry->[1]\",
EOM
}
@@ -245,11 +246,11 @@
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";
+ 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
}
@@ -264,11 +265,11 @@
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";
+ 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
}
@@ -282,6 +283,84 @@
$macros;
}
+=item C<vtbl_extend($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;
+
+ 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 interp', 'Parrot_PMC pmc' );
+ my @args = ( 'interp', 'pmc' );
+
+ while (my ($type, $name) = splice( @params, 0, 2 ))
+ {
+ push @sig, find_type( $type ) . ' ' . $name;
+ push @args, $name;
+ }
+
+ my $signature = join( ', ', @sig );
+ my $arguments = join( ', ', @args );
+
+ my $ret_type = find_type( $return_type );
+
+ printf
+"%s Parrot_PMC_%s( %s )
+{
+ %s retval;
+ PARROT_CALLIN_START( interp );
+ retval = VTABLE_%s( %s );
+ PARROT_CALLIN_END( interp );
+ return retval;
+}\n\n", $ret_type, $name, $signature, $ret_type, $name, $arguments;
+
+ }
+}
+
+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',
+ );
+
+ 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
@@ -301,4 +380,3 @@
=back
1;
-
