Author: leo
Date: Thu Apr 21 04:07:13 2005
New Revision: 7900
Modified:
trunk/build_tools/pmc2c.pl
trunk/classes/float.pmc
trunk/dynclasses/tclfloat.pmc
trunk/lib/Parrot/Pmc2c.pm
trunk/lib/Parrot/Pmc2c/Library.pm
trunk/src/mmd.c
trunk/t/pmc/mmd.t
Log:
MMD 30 - inheritance of abstract functions
* add MMD variants to pmc dumps
* create MMD_init entries for statically inherited functions
* remove hacks in float.pmc
* fix typo in tclfloat
* better MMD distance sorting
Modified: trunk/build_tools/pmc2c.pl
==============================================================================
--- trunk/build_tools/pmc2c.pl (original)
+++ trunk/build_tools/pmc2c.pl Thu Apr 21 04:07:13 2005
@@ -257,12 +257,12 @@
main();
-#
+#
# my $path = find_file( [$dir1, $dir2], $file, $die_unless_found_flag );
-#
+#
# Return the full path to $file (search in the given directories).
# Optionally, die with an error message if that file cannot be found.
-#
+#
sub find_file {
my ($include, $file, $die_unless_found) = @_;
@@ -277,21 +277,21 @@
undef;
}
-#
+#
# dump_default();
-#
+#
# Create a .dump file for the default vtable (from which all PMCs
# inherit).
-#
+#
sub dump_default {
my $file = "$FindBin::Bin/../vtable.tbl";
my $default = parse_vtable($file);
my $dump = $file;
$dump =~ s/\.\w+$/\.dump/;
-
+
print "Writing $dump\n" if $opt{verbose};
open VTD, ">", $dump or die "Can't write '$dump'";
-
+
my %vtable = (
flags => {},
pre => '',
@@ -311,25 +311,25 @@
};
}
$vtable{'has_method'} = \%meth_hash;
-
+
my $Dumper = Data::Dumper->new([\%vtable], ['class']);
$Dumper->Indent(3);
print VTD $Dumper->Dump();
close VTD;
}
-#
+#
# my ($balanced, $remaining) = extract_balanced($code);
-#
+#
# Remove a balanced {} construct from the beginning of $code.
# Return it and the remaining code.
-#
+#
sub extract_balanced {
my $code = shift;
my $balance = 0;
-
+
$code =~ s/^\s+//;
-
+
# create a copy and remove strings and comments so that
# unbalanced {} can be used in them in PMCs, being careful to
# preserve string length.
@@ -340,9 +340,9 @@
| /\* .*? \*/ ) # remove C comments
]
[ "-" x length $1 ]sexg;
-
+
/^\{/ or die "bad block open: ", substr($code,0,10), "...";
-
+
while (/ (\{) | (\}) /gx) {
if($1) {
$balance++;
@@ -355,20 +355,20 @@
die "Badly balanced" if $balance;
}
-#
+#
# my ($pre, $class_name, $flags) = parse_flags(\$code);
-#
+#
# Extract a class signature from the code ref and return (a) the
# code found before the signature, (b) the name of the class, and
# (c) a hash ref containing the flags associated with the class
# (such as 'extends' and 'does').
-#
+#
sub parse_flags {
my $c = shift;
$$c =~ s/^(.*?^\s*)pmclass ([\w]*)//ms;
my ($pre, $classname) = ($1, $2);
-
+
# flags that have values passed with them
my %has_value = map { $_ => 1 } qw(does extends group lib);
@@ -379,7 +379,7 @@
if ($has_value{$flag}) {
$$c =~ s/^\s+(\w+)//s
or die "Parser error: no value for '$flag'";
-
+
$flags{$flag}{$1} =
$flag eq 'extends' ? ++$parent_nr : 1;
}
@@ -387,22 +387,22 @@
$flags{$flag} = 1;
}
}
-
+
# setup some defaults
if ($classname ne 'default') {
$flags{extends}{default} = 1 unless $flags{extends};
$flags{does}{scalar} = 1 unless $flags{does};
}
-
+
return $pre, $classname, \%flags;
}
-#
+#
# my ($name, $attributes) = parse_pmc($code);
-#
+#
# Parse PMC code and return the class name and a hash ref of
# attributes.
-#
+#
sub parse_pmc {
my $code = shift;
@@ -414,7 +414,7 @@
)*
(METHOD\s+)? #method flag
-
+
(\w+\**) #type
\s+
(\w+) #method name
@@ -424,7 +424,7 @@
my ($pre, $classname, $flags) = parse_flags(\$code);
my ($classblock, $post) = extract_balanced($code);
-
+
my $lineno = 1 + count_newlines($pre);
$classblock = substr($classblock, 1,-1); # trim out the { }
@@ -434,7 +434,7 @@
$lineno += count_newlines($1);
my ($flag, $type, $methodname, $parameters) = ($2,$3,$4,$5);
my ($methodblock, $rema) =
extract_balanced($classblock);
-
+
$methodblock = "" if $opt{nobody};
if ($methodname eq 'class_init') {
$class_init = {
@@ -449,6 +449,7 @@
else {
# name => method idx mapping
$meth_hash{$methodname} = scalar @methods;
+ my @mmds = ($methodblock =~ /MMD_(\w+):/g);
push @methods,
{
meth => $methodname,
@@ -456,13 +457,14 @@
line => $lineno,
type => $type,
parameters => $parameters,
- loc => $flag ? "nci" : "vtable"
+ loc => $flag ? "nci" : "vtable",
+ mmds => [ @mmds ],
};
}
$classblock = $rema;
$lineno += count_newlines($methodblock);
}
-
+
if ($class_init) {
$meth_hash{'class_init'} = scalar @methods;
push @methods, $class_init;
@@ -480,33 +482,33 @@
};
}
-#
+#
# gen_parent_list( [$dir1, $dir2], $class, $classes );
-#
+#
# Generate an ordered list of parent classes to put in the
# $classes->{class}->{parents} array, using the given directories
# to find parents.
-#
+#
sub gen_parent_list {
my ($include, $this, $all) = @_;
my @todo = ($this);
my $class = $all->{$this};
-
+
while (@todo) {
my $n = shift @todo;
my $sub = $all->{$n};
next if $n eq 'default';
-
+
my %parent_hash = %{$sub->{flags}{extends}};
my @parents = sort { $parent_hash{$a} <=> $parent_hash{$b} }
keys %parent_hash;
for my $parent (@parents) {
next if exists $class->{has_parent}{$parent};
-
+
$all->{$parent} = read_dump($include, lc("$parent.pmc"))
if not $all->{$parent};
-
+
$class->{has_parent}{$parent} = { %{$all->{$parent}{has_method} }};
push @todo, $parent;
push @{ $class->{parents} }, $parent;
@@ -515,15 +517,15 @@
}
-#
+#
# my $class = dump_1_pmc($file);
-#
+#
# Generate the class structure from $file for a .dump file.
-#
+#
sub dump_1_pmc {
my $file = shift;
$file =~ s/\.\w+$/.pmc/;
-
+
print "Reading $file\n" if $opt{verbose};
open my $fh, "<", $file
or die "Can't read '$file'";
@@ -531,22 +533,30 @@
return parse_pmc($contents);
}
-#
+#
# gen_super_meths($class, $vtable)
-#
+#
# Generate a list of inherited methods for $class by searching the
# inheritence tree. The method list is found in $vtable.
-#
+#
sub gen_super_meths {
- my ($self, $vt) = @_;
+ my ($self, $vt, $all) = @_;
# look through all meths in class and locate the nearest parent
foreach my $entry (@{ $vt->{methods} } ) {
my $meth = $entry->{meth};
next if exists $self->{super}{$meth};
foreach my $pname (@{ $self->{parents} } ) {
- if (exists $self->{has_parent}{$pname}{$meth} ) {
+ if (exists ($self->{has_parent}{$pname}{$meth} )) {
$self->{super}{$meth} = $pname;
+ my $n = $self->{has_parent}{$pname}{$meth};
+ my $super_mmd = $all->{$pname}{methods}[$n]{mmds};
+ if ($super_mmd && scalar @{ $super_mmd }) {
+ ##print "** @{ $super_mmd } **\n";
+ push @{ $self->{super_mmd} },
+ { $pname => $super_mmd,
+ 'meth' => $meth};
+ }
last;
}
}
@@ -569,13 +579,13 @@
}
}
-#
+#
# add_defaulted($class_structure, $vtable);
-#
+#
# Add methods to the class structure for each method found in the
# vtable. This is used to determine all of the 'default' methods
# from the vtable.dump.
-#
+#
sub add_defaulted {
my ($class, $vt) = @_;
@@ -585,30 +595,30 @@
}
}
-#
+#
# my $newer = dump_is_newer($file);
-#
+#
# Return whether the dump of a file is newer than the PMC file.
# (If it's not, then the PMC file has changed and the dump has
# not been updated.)
-#
+#
sub dump_is_newer {
my $pmc = my $file = shift;
$pmc =~ s/\.\w+$/.pmc/;
-
+
my $pmc_dt = (stat $pmc)[9];
my $dump_dt = (stat $file)[9];
-
+
return $dump_dt > $pmc_dt;
}
-#
+#
# dump_pmc( [$dir1, $dir2], $file1, $file2, ... );
-#
+#
# Create a .dump file for each of the passed files (which can be
# found in the given directories). A '*.pmc' glob may also be passed
# to emulate a proper shell in the presence of a dump one.
-#
+#
sub dump_pmc {
my ($include, @files) = @_;
# help these dumb 'shells' that are no shells
@@ -623,25 +633,25 @@
$all{default} = read_dump($include, "classes/default.pmc")
if not $all{default};
-
+
my $vt = read_dump($include, "vtable.pmc");
add_defaulted($all{default}, $vt);
foreach my $name (keys %all) {
my $file = $all{$name}->{file};
$file =~ s/\.\w+$/\.dump/;
-
+
# XXX write default.dump only once
my $existing = find_file($include, $file);
next if $existing && -e $existing && dump_is_newer($existing);
-
+
my $class = $all{$name};
gen_parent_list($include, $name, \%all);
- gen_super_meths($class, $vt);
-
+ gen_super_meths($class, $vt, \%all);
+
my $Dumper = Data::Dumper->new([$class], ['class']);
$Dumper->Indent(1);
-
+
print "Writing $file\n" if $opt{verbose};
open my $fh, ">", $file or die "Can't write '$file'";
print $fh $Dumper->Dump;
@@ -649,25 +659,25 @@
}
}
-#
+#
# my $class = read_dump( [$dir1, $dir2], $file );
-#
+#
# Read in the class definition found in $file (which is found in one
# of the given directories) and recreate the data structure.
-#
+#
sub read_dump {
my ($include, $file) = @_;
-
+
$file =~ s/\.\w+$/.dump/;
$file = find_file($include, $file, 1);
-
+
print "Reading $file\n" if $opt{verbose};
open my $fh, "<", $file or die "Can't read '$file'";
-
+
my $class;
eval do { local $/; <$fh> };
die $@ if $@;
-
+
close $fh;
$class;
}
@@ -679,45 +689,45 @@
# given directories to search for all of correct PMCs. The middle
# argument is the display depth, which is used for the recursive
# definition of this function.
-#
+#
sub print_tree {
my ($include,$depth, @files) = @_;
for my $file (@files) {
my $class = read_dump($include, $file);
-
+
print " " x $depth, $class->{class}, "\n";
print_tree($include, $depth + 1, lc("$_.pmc"))
for keys %{$class->{flags}{extends}};
}
}
-#
+#
# gen_c( [$dir1, $dir2], $file1, $file2, ... );
-#
+#
# Generate the c source code file for each of the files passed in,
# using the directories passed in to search for the PMC dump files.
-#
+#
sub gen_c {
my ($include, @files) = @_;
my %pmcs = map { $_, read_dump($include, $_) } @files;
-
+
Parrot::Pmc2c::Library
->new( \%opt, read_dump($include, "vtable.pmc"), %pmcs )
->write_all_files;
}
-#
+#
# main()
-#
+#
# Get and set the correct options and execute the runmode
# specified in @ARGS.
-#
+#
sub main {
my ($default, $dump, $gen_c, $tree, @include);
# initialization to prevent warnings
%opt = map { $_ => 0 } qw(nobody nolines debug verbose);
-
+
my $result = GetOptions(
"vtable" => \$default,
"dump" => \$dump,
Modified: trunk/classes/float.pmc
==============================================================================
--- trunk/classes/float.pmc (original)
+++ trunk/classes/float.pmc Thu Apr 21 04:07:13 2005
@@ -20,9 +20,6 @@
#include "parrot/parrot.h"
-PMC* Parrot_scalar_subtract_Complex(Interp* , PMC* pmc, PMC* value, PMC* dest);
-void Parrot_scalar_i_subtract_Complex(Interp* , PMC* pmc, PMC* value);
-
pmclass Float extends scalar {
/*
@@ -209,47 +206,10 @@
*/
void morph (INTVAL type) {
- if (SELF->vtable->base_type == type)
- return;
- if (type == enum_class_String) {
- /*
- * if we morph to a string, first clear str_val
- * so that after changing the vtable a parallel
- * reader doesn't get a garbage pointer
- */
- PMC_str_val(SELF) = NULL;
- PObj_custom_mark_SET(SELF);
- SELF->vtable = Parrot_base_vtables[type];
- return;
- }
- if (type == enum_class_BigInt || type == enum_class_Complex) {
- PMC_str_val(SELF) = NULL;
- SELF->vtable = Parrot_base_vtables[type];
- DYNSELF.init();
- return;
- }
- SELF->vtable = Parrot_base_vtables[type];
+ pmc_reuse(INTERP, SELF, type, 0);
}
- PMC* subtract (PMC* value, PMC* dest) {
-MMD_Complex: {
- return Parrot_scalar_subtract_Complex(interpreter,
- SELF, value, dest); /* XXX inheritance problem */
- }
-MMD_DEFAULT: {
- return SUPER(value, dest); /* XXX inheritance problem */
- }
- }
-
- void i_subtract (PMC* value) {
-MMD_Complex: {
- Parrot_scalar_i_subtract_Complex(interpreter, SELF, value);
- }
-MMD_DEFAULT: {
- SUPER(value); /* XXX inheritance problem */
- }
- }
/*
Modified: trunk/dynclasses/tclfloat.pmc
==============================================================================
--- trunk/dynclasses/tclfloat.pmc (original)
+++ trunk/dynclasses/tclfloat.pmc Thu Apr 21 04:07:13 2005
@@ -23,7 +23,7 @@
-pmclass TclFloat extends TclObject extend Float dynpmc group tcl_group {
+pmclass TclFloat extends TclObject extends Float dynpmc group tcl_group {
void init () {
PMC_num_val(SELF) = 0.0;
Modified: trunk/lib/Parrot/Pmc2c.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c.pm (original)
+++ trunk/lib/Parrot/Pmc2c.pm Thu Apr 21 04:07:13 2005
@@ -206,19 +206,6 @@
}
$cout .= <<"EOC";
}
-
- /*
- * force rebuilding of the static MMD_table
- * TODO only for classes that have mmds
- */
-EOC
- while (my ($class, $info) = each %classes) {
- next if $info->{flags}->{noinit};
- $cout .= <<"EOC";
- Parrot_mmd_rebuild_table(interpreter, type$class, -1);
-EOC
- }
- $cout .= <<"EOC";
return pmc;
}
@@ -637,8 +624,10 @@
my $sub_meth_name = $1;
my $sub_meth = $sub_meth_decl; # no "static ." ...
$sub_meth =~ s/\(/_$right_type(/;
- $header_decls .= <<EOH;
-$sub_meth;
+ $sub_meth_decl = $sub_meth;
+ $sub_meth_decl =~ s/\n/ /g;
+ $self->{hdecls} .= <<EOH;
+$sub_meth_decl;
EOH
$additional_bodies .= $sub_meth;
$additional_bodies .= "{$body_part\n}";
@@ -647,7 +636,7 @@
}
}
- $cout .= $header_decls;
+ ## $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});
@@ -718,6 +707,38 @@
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<init_func()>
Returns the C code for the PMC's initialization method, or an empty
@@ -780,6 +801,9 @@
$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])) {
@@ -793,6 +817,7 @@
$meth_name = $variant->[1] . '_' .$variant->[0];
push @mmds, [ $func, $left, $right, $meth_name];
}
+ $self->{mmds} = @mmds;
}
}
my $methlist = join(",\n ", @meths);
@@ -1008,7 +1033,8 @@
$hout .= <<"EOC";
void Parrot_${classname}_class_init(Parrot_Interp, int, int);
EOC
- $hout;
+ $self->{hdecls} .= $hout;
+ $self->{hdecls};
}
=item C<gen_h($out_name)>
Modified: trunk/lib/Parrot/Pmc2c/Library.pm
==============================================================================
--- trunk/lib/Parrot/Pmc2c/Library.pm (original)
+++ trunk/lib/Parrot/Pmc2c/Library.pm Thu Apr 21 04:07:13 2005
@@ -58,18 +58,18 @@
local (*H, *C);
print Data::Dumper->Dump([$generator]) if $opt->{debug} > 1;
- my $hout = $generator->gen_h($h_name);
- print $hout if $opt->{debug};
- print "Writing $h_name\n" if $opt->{verbose};
- open H, ">$h_name" or die "Can't write '$h_name";
- print H $hout;
- close H;
my $cout = $generator->gen_c($c_name);
print $cout if $opt->{debug};
print "Writing $c_name\n" if $opt->{verbose};
open C, ">$c_name" or die "Can't write '$c_name";
print C $cout;
close C;
+ my $hout = $generator->gen_h($h_name);
+ print $hout if $opt->{debug};
+ print "Writing $h_name\n" if $opt->{verbose};
+ open H, ">$h_name" or die "Can't write '$h_name";
+ print H $hout;
+ close H;
}
=item C<write_all_files()>
Modified: trunk/src/mmd.c
==============================================================================
--- trunk/src/mmd.c (original)
+++ trunk/src/mmd.c Thu Apr 21 04:07:13 2005
@@ -1252,6 +1252,14 @@
{
short da = (short)a & 0xffff;
short db = (short)b & 0xffff;
+ /* sort first by distance */
+ if (da > db)
+ return 1;
+ if (da < db)
+ return -1;
+ /* end then by index in candidate list */
+ da = a >> 16;
+ db = b >> 16;
return da > db ? 1 : da < db ? -1 : 0;
}
@@ -1385,6 +1393,8 @@
* create a helper structure:
* bits 0..15 = distance
* bits 16..31 = idx in candidate list
+ *
+ * TODO use half of available INTVAL bits
*/
sort = pmc_new(interpreter, enum_class_FixedIntegerArray);
VTABLE_set_integer_native(interpreter, sort, n);
Modified: trunk/t/pmc/mmd.t
==============================================================================
--- trunk/t/pmc/mmd.t (original)
+++ trunk/t/pmc/mmd.t Thu Apr 21 04:07:13 2005
@@ -305,7 +305,6 @@
pir_output_is(<<'CODE', <<'OUT', "first dynamic MMD call");
-.namespace ["Main"]
.sub main @MAIN
.local pmc F, B, f, b, m, s
newclass F, "Foo"
@@ -313,27 +312,25 @@
newclass B, "Bar"
b = B."instantiate"()
# create a multi the hard way
- m = new MultiSub
- s = find_global "Foo", "foo"
- push m, s
- s = find_global "Bar", "foo"
- push m, s
- global "foo" = m
+ ## m = new MultiSub
+ ## s = find_global "Foo", "foo"
+ ## push m, s
+ ## s = find_global "Bar", "foo"
+ ## push m, s
+ ## global "foo" = m
print "calling foo(f, b)\n"
foo(f, b)
print "calling foo(b, f)\n"
foo(b, f)
.end
-.namespace ["Foo"]
-.sub foo method
+.sub foo method, @MULTI(Foo, Bar)
.param pmc x
.param pmc y
print " Foo::foo\n"
.end
-.namespace ["Bar"]
-.sub foo method
+.sub foo method, @MULTI(Bar, Foo)
.param pmc x
.param pmc y
print " Bar::foo\n"
@@ -815,7 +812,6 @@
open P, ">$temp" or die "can't write $temp";
print P <<'EOF';
-.namespace ["__parrot_core"]
.sub __add @MULTI(Integer, Integer)
.param pmc l
.param pmc r
