Author: tewk
Date: Wed May 30 06:30:14 2007
New Revision: 18685
Modified:
branches/pmc2c/lib/Parrot/Pmc2c/Emitter.pm
branches/pmc2c/lib/Parrot/Pmc2c/Method.pm
branches/pmc2c/lib/Parrot/Pmc2c/MethodEmitter.pm
branches/pmc2c/lib/Parrot/Pmc2c/PCCMETHOD.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMC.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMC/RO.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Null.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Ref.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/default.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/deleg_pmc.pm
branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/delegate.pm
branches/pmc2c/lib/Parrot/Pmc2c/Parser.pm
branches/pmc2c/lib/Parrot/Pmc2c/VTable.pm
branches/pmc2c/src/pmc/class.pmc
branches/pmc2c/src/pmc/exporter.pmc
branches/pmc2c/src/pmc/parrotlibrary.pmc
branches/pmc2c/src/pmc/sarray.pmc
Log:
[Pmc2c Branch] checkpoint
Modified: branches/pmc2c/lib/Parrot/Pmc2c/Emitter.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/Emitter.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/Emitter.pm Wed May 30 06:30:14 2007
@@ -5,24 +5,147 @@
use warnings;
use base qw( Exporter );
our @EXPORT_OK = qw();
-use Parrot::Pmc2c::UtilFunctions qw(spew);
+use Parrot::Pmc2c::UtilFunctions qw(count_newlines spew);
+use overload '""' => \&stringify;
+use overload 'bool' => \&boolify;
+use Data::Dumper;
sub new {
- my ( $class, $filename, $parent) = @_;
+ my ( $class, $filename ) = @_;
my $self = {
filename => $filename,
- parent => $parent,
};
bless $self, (ref($class) || $class);
$self;
}
+sub text {
+ my ( $class, $data, $filename, $bline) = @_;
+ $filename ||= "";
+ $bline ||= -1;
+ my $self = {
+ data => $data,
+ filename => $filename,
+ bline => $bline,
+ eline => $bline + count_newlines($data),
+ };
+ bless $self, ref($class) || $class;
+ $self;
+}
+
+sub find {
+ my ( $self, $regex ) = @_;
+ if ( $self->{items} ) {
+ for my $x ( @{ $self->{items} } ) {
+ my $matched = $x->find($regex);
+ return $matched if $matched;
+ }
+ }
+ else {
+ return $self if ($self->{data} =~ /$regex/);
+ }
+ return 0;
+}
+
+sub subst {
+ my ( $self, $regex, $replacement ) = @_;
+ if ( $self->{items} ) {
+ for my $x ( @{ $self->{items} } ) {
+ $x->subst($regex, $replacement);
+ }
+ }
+ else {
+ while ( $self->{data} =~ m/$regex/ ) {
+ my $result = $replacement->();
+ $self->{data} =~ s/$regex/$result/x;
+ }
+ }
+ return 1;
+}
+
+sub replace {
+ my ( $self, $regex, $replacement ) = @_;
+ my $m = $self->{data} =~ /((.*)\Q$regex\E)(.*)/s;
+ $self->emit($2, $self->filename, $self->{bline});
+ $self->add_fragment($replacement);
+ $self->emit($3, $self->filename, $self->{bline} + count_newlines($1));
+ for my $x qw( data filename bline eline) {
+ delete $self->{data};
+ }
+ return 1;
+}
+
+sub stringify {
+ my ( $self ) = @_;
+ my $out = "";
+
+ if ( $self->{items} ) {
+ for my $x ( @{ $self->{items} } ) {
+ $out .= $x->stringify;
+ }
+ }
+ else {
+ $out .= $self->{data};
+ }
+ return $out;
+}
+
+sub boolify {
+ my ( $self ) = @_;
+ return $self;
+}
+
+sub annotate {
+ my ( $self ) = @_;
+ $self->{output} = "";
+ $self->{current_file} = $self->filename;
+ $self->{current_line} = 1;
+
+ $self->annotate_worker($self);
+
+ my $output = $self->{output};
+
+ for my $x qw( output current_line current_file ) {
+ delete $self->{$x};
+ }
+
+ return $output;
+}
+
+sub annotate_worker {
+ my ( $self, $it ) = @_;
+
+ if ( $it->{items} ) {
+ for my $x ( @{ $it->{items} } ) {
+ $self->annotate_worker($x);
+ }
+ }
+ else {
+ my $data;
+ my $filename = $it->{filename} || $self->filename;
+ my $line = $it->{bline};
+
+ #no need to emit uneccessary #line directive
+ if ( $line == -1 and $self->filename eq $self->{current_file} ) {
+ $data = $it->{data};
+ }
+ else {
+ $line = $self->{current_line} if $line == -1;;
+ #$data .= "#line $line \"$filename\" \n";
+ $data .= $it->{data};
+ }
+ $self->{output} .= $data;
+ $self->{current_file} = $filename;
+ $self->{current_line} += count_newlines($data);
+ }
+}
+
sub emit {
my ( $self, $item, $file, $line ) = @_;
- unless ( ref($item) eq 'Parrot::Pmc2c::CodeFragment' ) {
- $file = $self->filename unless $file;
- $line = -1 unless $line;
- $item = Parrot::Pmc2c::CodeFragment->new($item, $file, $line)
+ unless ( ref($item) eq 'Parrot::Pmc2c::Emitter' ) {
+ $file ||= $self->filename;
+ $line ||= -1;
+ $item = $self->text($item, $file, $line)
}
$self->add_fragment($item);
}
@@ -40,17 +163,7 @@
sub write_to_file {
my ( $self) = @_;
- my $items = $self->{items};
- my $output = "";
- my $lines = 1;
-
- for my $item ( @$items ) {
- my ( $item_output, $item_lines ) = $item->annotate( $lines );
- $output .= $item_output;
- $lines += $item_lines;
- }
-
- spew($self->filename, $output);
+ spew($self->filename, $self->annotate);
}
1;
Modified: branches/pmc2c/lib/Parrot/Pmc2c/Method.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/Method.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/Method.pm Wed May 30 06:30:14 2007
@@ -45,12 +45,12 @@
}
#getters/setters
-for my $x qw( name type body return_type mmds symbol mmd_prefix mmd_table
mmd_name right
+for my $x qw( name type return_type body mmds symbol mmd_prefix mmd_table
mmd_name right
attrs parameters ) {
my $code = <<'EOC';
sub REPLACE {
my ( $self, $value ) = @_;
- $self->{REPLACE} = $value if $value;
+ $self->{REPLACE} = $value if defined $value;
return $self->{REPLACE}
}
EOC
Modified: branches/pmc2c/lib/Parrot/Pmc2c/MethodEmitter.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/MethodEmitter.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/MethodEmitter.pm Wed May 30 06:30:14 2007
@@ -42,41 +42,29 @@
sub generate_body {
my ( $self, $pmc ) = @_;
+ my $emit = sub { $pmc->{emitter}->emit(@_) };
+
+ Parrot::Pmc2c::PCCMETHOD::rewrite_pccinvoke( $self, $pmc );
- my $cout = "";
- my $pmcname = $pmc->name;
- my $meth = $self->name;
my $body = $self->body;
- $body =~ s/^[ ]{4}//mg;
- my $super = $pmc->{super}{$meth};
if ( $self->is_vtable ) {
- $body = $self->rewrite_vtable_method( $pmc, $super, $pmc->{super},
$body );
+ $self->rewrite_vtable_method( $pmc );
}
else {
- $body = $self->rewrite_nci_method( $pmc );
+ $self->rewrite_nci_method( $pmc );
}
- Parrot::Pmc2c::PCCMETHOD::rewrite_pccinvoke( $self, \$body );
-
- $cout .= $self->decl( $pmc, 'CFILE' );
- if ( exists $self->{pre_block} ) {
- $cout .= $self->{pre_block};
- $cout .= $body;
- $cout .= $self->{post_block};
- $cout .= "\n}\n";
- }
- else {
- $cout .= "{$body\n}\n";
- }
+ $emit->($self->decl( $pmc, 'CFILE' ));
+ $emit->("{\n");
+ $emit->($body);
+ $emit->("}\n\n");
for my $mmd ( @{ $self->mmds } ) {
- $cout .= $mmd->generate_body($pmc);
+ $mmd->generate_body($pmc);
}
- #remove trailing whitespace
- $cout =~ s/^\s+$//mg;
- return $cout;
+ return 1;
}
sub generate_headers {
@@ -129,20 +117,6 @@
EOC
}
-=item C<full_arguments($args)>
-
-Prepends C<INTERP, SELF> to C<$args>.
-
-=cut
-
-sub full_arguments {
- my $args = shift;
- my $obj = shift || 'SELF';
-
- return "INTERP, $obj, $args" if ( $args =~ m/\S/ );
- return "INTERP, $obj";
-}
-
=item C<proto($type,$parameters)>
Determines the prototype (argument signature) for a method body
@@ -202,27 +176,30 @@
sub rewrite_nci_method {
my ( $self, $pmc ) = @_;
my $pmcname = $pmc->name;
-
- local $_ = $self->body;
-
+ my $body = $self->body;
+
# Rewrite DYNSELF.other_method(args...)
- s/\bDYNSELF\b # Macro: DYNSELF
+ $body->subst( qr{
+ \bDYNSELF\b # Macro: DYNSELF
\.(\w+) # other_method
\(\s*(.*?)\) # capture argument list
- /"pmc->vtable->$1(" . full_arguments($2) . ')'/xeg;
+ }x,
+ sub { "pmc->vtable->$1(" . full_arguments($2) . ')' });
# Rewrite SELF.other_method(args...)
- s/\bSELF\b # Macro SELF
+ $body->subst( qr{
+ \bSELF\b # Macro SELF
\.(\w+) # other_method
\(\s*(.*?)\) # capture argument list
- /"Parrot_${pmcname}" . ($pmc->is_vtable_method($1) ? "" : "_nci") .
- "_$1(" . full_arguments($2) . ")"/xeg;
+ }x,
+ sub {
+ "Parrot_${pmcname}" . ($pmc->is_vtable_method($1) ? "" : "_nci") .
+ "_$1(" . full_arguments($2) . ")"
+ });
# Rewrite SELF -> pmc, INTERP -> interp
- s/\bSELF\b/pmc/g;
- s/\bINTERP\b/interp/g;
-
- return $_;
+ $body->subst( qr{\bSELF\b}, sub { 'pmc' } );
+ $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
}
=item C<rewrite_vtable_method($self, $pmc, $super, $super_table)>
@@ -233,12 +210,14 @@
=cut
sub rewrite_vtable_method {
- my ( $self, $pmc, $super, $super_table ) = @_;
+ my ( $self, $pmc ) = @_;
my $name = $self->name;
my $pmcname = $pmc->name;
+ my $super = $pmc->{super}{$name};
+ my $super_table = $pmc->{super};
+ my $body = $self->body;
+ my $sub;
- local $_ = $self->body;
-
# Rewrite method body
# Some MMD variants don't have a super mapping.
if ($super)
@@ -248,64 +227,93 @@
my $supermethod = "Parrot_" . $super_table->{$name} . "_$name";
# Rewrite DYNSUPER(args)
- s/\bDYNSUPER\b # Macro: DYNSUPER
- \(\s*(.*?)\) # capture argument list
- /"interp->vtables[$supertype].$name(" . full_arguments($1) . ')'/xeg;
+ $body->subst( qr{
+ \bDYNSUPER\b # Macro: DYNSUPER
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "interp->vtables[$supertype].$name(" . full_arguments($1) .
')' });
# Rewrite OtherClass.SUPER(args...)
- s/(\w+) # capture OtherClass
- \.SUPER\b # Macro: SUPER
- \(\s*(.*?)\) # capture argument list
- /"Parrot_${1}_$name(" . full_arguments($2) . ')'/xeg;
+ $body->subst( qr{
+ (\w+) # capture OtherClass
+ \.SUPER\b # Macro: SUPER
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "Parrot_${1}_$name(" . full_arguments($2) . ')' });
# Rewrite SUPER(args...)
- s/\bSUPER\b # Macro: SUPER
- \(\s*(.*?)\) # capture argument list
- /"$supermethod(" . full_arguments($1) . ')'/xeg;
+ $body->subst( qr{
+ \bSUPER\b # Macro: SUPER
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "$supermethod(" . full_arguments($1) . ')' });
}
# Rewrite DYNSELF.other_method(args...)
- s/\bDYNSELF\b # Macro: DYNSELF
- \.(\w+) # other_method
- \(\s*(.*?)\) # capture argument list
- /"pmc->vtable->$1(" . full_arguments($2) . ')'/xeg;
+ $body->subst( qr{
+ \bDYNSELF\b # Macro: DYNSELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "pmc->vtable->$1(" . full_arguments($2) . ')'});
# Rewrite DYNSELF(args...). See comments above.
- s/\bDYNSELF\b # Macro: DYNSELF
- \(\s*(.*?)\) # capture argument list
- /"pmc->vtable->$name(" . full_arguments($1) . ')'/xeg;
+ $body->subst( qr{
+ \bDYNSELF\b # Macro: DYNSELF
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "pmc->vtable->$name(" . full_arguments($1) . ')'});
# Rewrite OtherClass.SELF.other_method(args...)
- s/(\w+) # OtherClass
- \.\bSELF\b # Macro SELF
- \.(\w+) # other_method
- \(\s*(.*?)\) # capture argument list
- /"Parrot_${1}" . ($pmc->is_vtable_method($2) ? "" : "_nci") . "_$2(" .
- full_arguments($3) . ')'/xeg;
+ $body->subst( qr{
+ (\w+) # OtherClass
+ \.\bSELF\b # Macro SELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "Parrot_${1}" . ($pmc->is_vtable_method($2) ? "" : "_nci") .
"_$2(" .
+ full_arguments($3) . ')'});
# Rewrite OtherClass.object.other_method(args...)
- s/(\w+) # OtherClass
- \.\b(\w+)\b # any object
- \.(\w+) # other_method
- \(\s*(.*?)\) # capture argument list
- /"Parrot_${1}" . ($pmc->is_vtable_method($3) ? "" : "_nci") . "_$3("
- . full_arguments($4, $2) . ')'/xeg;
+ $body->subst( qr{
+ (\w+) # OtherClass
+ \.\b(\w+)\b # any object
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub { "Parrot_${1}" . ($pmc->is_vtable_method($3) ? "" : "_nci") .
"_$3("
+ . full_arguments($4, $2) . ')'});
# Rewrite SELF.other_method(args...)
- s/\bSELF\b # Macro SELF
- \.(\w+) # other_method
- \(\s*(.*?)\) # capture argument list
- /"Parrot_${pmcname}" .
- ($pmc->is_vtable_method($1) ? "" : "_nci") . "_$1(" .
full_arguments($2) . ")"/xeg;
+ $body->subst( qr{
+ \bSELF\b # Macro SELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ }x,
+ sub {"Parrot_${pmcname}" .
+ ($pmc->is_vtable_method($1) ? "" : "_nci") . "_$1(" .
full_arguments($2) . ")"});
# Rewrite SELF -> pmc, INTERP -> interp
- s/\bSELF\b/pmc/g;
- s/\bINTERP\b/interp/g;
-
+ $body->subst( qr{\bSELF\b}, sub { 'pmc' } );
+ $body->subst( qr{\bINTERP\b}, sub { 'interp' } );
# now use macros for all rewritten stuff
- s/\b(?:\w+)->vtable->(\w+)\(/ VTABLE_$1(/g;
+ $body->subst( qr{\b(?:\w+)->vtable->(\w+)\(}, sub { "VTABLE_$1(" } );
- return $_;
+ return 1;
+}
+
+=item C<full_arguments($args)>
+
+Prepends C<INTERP, SELF> to C<$args>.
+
+=cut
+
+sub full_arguments {
+ my $args = shift;
+ my $obj = shift || 'SELF';
+
+ return "INTERP, $obj, $args" if ( $args =~ m/\S/ );
+ return "INTERP, $obj";
}
1;
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PCCMETHOD.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PCCMETHOD.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PCCMETHOD.pm Wed May 30 06:30:14 2007
@@ -1,4 +1,4 @@
-# Copyright (C) 2004-2006, The Perl Foundation.
+;# Copyright (C) 2004-2006, The Perl Foundation.
# $Id$
package Parrot::Pmc2c::PCCMETHOD;
@@ -25,7 +25,7 @@
=head2 Publicly Available Methods
-=head3 C<rewrite_pccmethod($self, $method, $body)>
+=head3 C<rewrite_pccmethod($method, $pmc)>
B<Purpose:> Parse and Build PMC PCCMETHODS.
@@ -45,7 +45,7 @@
=back
-=head3 C<rewrite_pccinvoke($self, $method, $body)>
+=head3 C<rewrite_pccinvoke($method, $pmc)>
B<Purpose:> Parse and Build a PCCINVOKE Call.
@@ -195,43 +195,52 @@
}
}
-=head3 C<rewrite_PCCRETURNs($method, $body)>
+=head3 C<rewrite_PCCRETURNs($method, $pmc)>
Rewrites the method body performing the various macro substitutions for
PCCRETURNs.
=cut
sub rewrite_PCCRETURNs {
- my ( $self, $body ) = @_;
- my $method_name = $self->{meth};
+ my ( $self, $pmc) = @_;
+ my $method_name = $self->name;
+ my $body = $self->body;
my $regs_used = [];
my $signature_re = qr{
- (PCCRETURN #method name
+ (PCCRETURN #method name
\s* #optional whitespace
\( ([^\(]*) \) #returns ( stuff ... )
;?) #optional semicolon
}sx;
- if ( $body and $body =~ m/\breturn\b/ ) {
- croak "return not allowed in pccmethods, use PCCRETURN instead";
- }
+ croak "return not allowed in pccmethods, use PCCRETURN instead $body"
+ if ( $body and $body =~ m/\breturn\b/ );
+
+
+ while ($body) {
+ my $matched = undef;
+ if ( $body ) {
+ $matched = $body->find( $signature_re );
+ last unless $matched;
+ }
- while ( $$body and $$body =~ m/$signature_re/ ) {
+ $matched =~ /$signature_re/;
my ( $match, $returns ) = ( $1, $2 );
my $goto_string = "goto ${method_name}_returns;";
my ( $returns_n_regs_used, $returns_indexes, $returns_flags,
$returns_accessors ) =
process_pccmethod_args( parse_p_args_string($returns), 'return' );
push @$regs_used, $returns_n_regs_used;
- my $file = '"' . __FILE__ . '"';
- my $lineno1 = __LINE__ + 2;
- my $lineno2 = __LINE__ + 7;
- my $replacement = <<END;
-#line $lineno1 $file
+ my $e = Parrot::Pmc2c::Emitter->new($pmc->filename);
+
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
/*BEGIN PCCRETURN $returns */
/*BEGIN GENERATED ACCESSORS */
+END
+ $e->emit(<<"END");
$returns_accessors
-#line $lineno2 $file
+END
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
/*END GENERATED ACCESSORS */
{
opcode_t temp_return_indexes[] = { $returns_indexes };
@@ -242,9 +251,9 @@
$goto_string
/*END PCCRETURN $returns */
END
- $$body =~ s/\Q$1\E/$replacement/;
+ $matched->replace($match, $e);
}
-
+
return $regs_used;
}
@@ -324,16 +333,18 @@
=head3 C<rewrite_pccmethod()>
- rewrite_pccmethod($method_hash);
+ rewrite_pccmethod($method, $pmc);
=cut
sub rewrite_pccmethod {
- my ($self) = @_;
- croak "return method of PCCMETHOD must be void, not $self->{type}" if
$self->{type} ne 'void';
+ my ($self, $pmc) = @_;
+
+ my $e = Parrot::Pmc2c::Emitter->new($pmc->filename);
+ my $e_post = Parrot::Pmc2c::Emitter->new($pmc->filename);
# parse pccmethod parameters, then unshift the a PMC arg for the invocant
- my $linear_args = parse_p_args_string( $self->{parameters} );
+ my $linear_args = parse_p_args_string( $self->parameters );
unshift @$linear_args,
{
type => convert_type_string_to_reg_type('PMC'),
@@ -344,16 +355,12 @@
my ( $params_n_regs_used, $params_indexes, $params_flags,
$params_accessors, $named_names ) =
process_pccmethod_args( $linear_args, 'arg' );
- my $n_regs = rewrite_PCCRETURNs( $self, \$self->{body} );
- rewrite_pccinvoke( $self->{meth}, \$self->{body} );
+ my $n_regs = rewrite_PCCRETURNs( $self, $pmc );
+ rewrite_pccinvoke( $self, $pmc );
unshift @$n_regs, $params_n_regs_used;
my $n_regs_used = find_max_regs($n_regs);
- my $file = '"' . __FILE__ . '"';
- my $lineno = __LINE__ + 5;
- my $PRE_STUB = <<END;
-{
-#line $lineno $file
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
INTVAL n_regs_used[] = { $n_regs_used };
opcode_t param_indexes[] = { $params_indexes };
opcode_t *return_indexes;
@@ -375,7 +382,11 @@
current_args = interp->current_args;
interp->current_args = NULL;
+END
+ $e->emit(<<"END");
$named_names
+END
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
interp->params_signature = param_sig;
parrot_pass_args(interp, caller_ctx, ctx, current_args, param_indexes,
@@ -390,20 +401,28 @@
}
/* BEGIN PARMS SCOPE */
{
+END
+ $e->emit(<<"END");
$params_accessors
+END
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
/* BEGIN PMETHOD BODY */
+ {
END
- my $method_returns = $self->{meth} . "_returns:";
- $lineno = __LINE__ + 4;
- my $POST_STUB = <<END;
+ my $method_returns = $self->name . "_returns:";
+ $e_post->emit(<<"END", __FILE__, __LINE__ + 1);
-#line $lineno $file
+ }
goto no_return;
/* END PMETHOD BODY */
+END
+ $e_post->emit(<<"END");
$method_returns
+END
+ $e_post->emit(<<"END", __FILE__, __LINE__ + 1);
/* if (PMC_cont(ccont)->address) { */
{
@@ -427,8 +446,14 @@
PObj_live_CLEAR(return_sig);
Parrot_pop_context(interp);
END
- ( $self->{parameters}, $self->{pre_block}, $self->{post_block} ) =
- ( "", $PRE_STUB, $POST_STUB );
+ $self->return_type('void');
+ $self->parameters('');
+ my $e_body = Parrot::Pmc2c::Emitter->new($pmc->filename);
+ $e_body->emit($e);
+ $e_body->emit($self->body);
+ $e_body->emit($e_post);
+ $self->body($e_body);
+
return 1;
}
@@ -437,7 +462,8 @@
}
sub rewrite_pccinvoke {
- my ( $method, $body ) = @_;
+ my ( $method, $pmc ) = @_;
+ my $body = $method->body;
my $signature_re = qr{
(
(
@@ -452,10 +478,16 @@
;? #optional semicolon
)
}sx;
+
+ while ($body) {
+ my $matched = undef;
+ if ( $body ) {
+ $matched = $body->find( $signature_re );
+ last unless $matched;
+ }
- while ( $$body and $$body =~ m/$signature_re/ ) {
+ $matched =~ /$signature_re/;
my ( $match, $result_clause, $results, $parameters ) = ( $1, $2, $3,
$4 );
-
#optional results portion of pccinvoke statement
my ( $result_n_regs_used, $result_indexes, $result_flags,
$result_accessors ) =
( defined $results )
@@ -474,13 +506,10 @@
$method_name = "string_from_const_cstring(interp, (const char *)
$method_name, 0)"
if isquoted($method_name);
- my $file = '"' . __FILE__ . '"';
- my $lineno = __LINE__ + 8;
-
- my $replacement .= <<END;
+ my $e = Parrot::Pmc2c::Emitter->new($pmc->filename);
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
/*BEGIN PCCINVOKE $invocant */
-#line $lineno $file
{
INTVAL n_regs_used[] = { $n_regs_used };
opcode_t arg_indexes[] = { $arg_indexes };
@@ -505,9 +534,13 @@
ctx->current_results = result_indexes;
ctx->results_signature = results_sig;
+END
+ $e->emit(<<"END");
$named_names
$arg_accessors
+END
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
interp->current_object = $invocant;
interp->current_cont = NEED_CONTINUATION;
@@ -521,7 +554,11 @@
else
VTABLE_invoke(interp, pccinvoke_meth, NULL);
+END
+ $e->emit(<<"END");
$result_accessors
+END
+ $e->emit(<<"END", __FILE__, __LINE__ + 1);
PObj_live_CLEAR(_type);
PObj_live_CLEAR(args_sig);
@@ -535,8 +572,9 @@
/*END PCCINVOKE $method_name */
END
- $$body =~ s/\Q$match\E/$replacement/;
- }
+ $matched->replace($match, $e);
+ };
+ return 1;
}
1;
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMC.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMC.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMC.pm Wed May 30 06:30:14 2007
@@ -122,11 +122,12 @@
return get_method($self, $vt_meth)->is_vtable;
}
-sub implements_vtable_not_mmd {
+sub normal_unimplemented_vtable {
my ( $self, $vt_meth ) = @_;
- return 0 unless $self->has_method($vt_meth);
- my $method = $self->get_method($vt_meth);
- return $method->is_vtable and not $method->is_mmd;
+ return 0 if $vt_meth eq 'class_init';
+ return 0 if $self->vtable->is_mmd($vt_meth);
+ return 0 if $self->has_method($vt_meth);
+ return 1;
}
#getters
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMC/RO.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMC/RO.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMC/RO.pm Wed May 30 06:30:14 2007
@@ -85,7 +85,7 @@
internal_exception(WRITE_TO_CONSTCLASS, "$vt_method_name() in read-only
instance of $pmcname");
EOC
$body .= " $ret\n" if $ret;
- $ro_method->body($body);
+ $ro_method->body(Parrot::Pmc2c::Emitter->text($body));
$self->add_method($ro_method);
}
else {
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter.pm Wed May 30 06:30:14 2007
@@ -56,11 +56,11 @@
sub generate {
my ( $self ) = @_;
- my $emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new(
$self->filename(".c"), $self );
+ my $emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new(
$self->filename(".c") );
$self->generate_c_file;
$emitter->write_to_file;
- $emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new(
$self->filename(".h"), $self );
+ $emitter = $self->{emitter} = Parrot::Pmc2c::Emitter->new(
$self->filename(".h") );
$self->generate_h_file;
$emitter->write_to_file;
}
@@ -190,10 +190,11 @@
# (because the MRO will still be shared).
unless ( $self->implements_vtable('pmc_namespace')
or $self->super_method('pmc_namespace') ne 'default' ) {
+ my $body = Parrot::Pmc2c::Emitter->text('{ return
INTERP->vtables[SELF->vtable->base_type]->_namespace; }');
$self->add_method( Parrot::Pmc2c::Method->new( {
name => 'pmc_namespace',
parameters => '',
- body => '{ return
INTERP->vtables[SELF->vtable->base_type]->_namespace; }',
+ body => $body,
type => Parrot::Pmc2c::Method::VTABLE,
mmds => [],
return_type => 'PMC*',
@@ -287,24 +288,20 @@
sub gen_methods {
my ( $self ) = @_;
- {
- no warnings;
- *emit = sub { $self->{emitter}->emit(@_); };
- }
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
next if $vt_method_name eq 'class_init';
if ( $self->implements_vtable($vt_method_name) ) {
- emit( $self->get_method($vt_method_name)->generate_body($self) );
+ $self->get_method($vt_method_name)->generate_body($self);
}
}
# non-vtable methods
foreach my $method ( @{ $self->methods } ) {
next if $method->is_vtable;
- emit($method->generate_body($self));
+ $method->generate_body($self);
}
}
@@ -687,13 +684,6 @@
=cut
-sub implements_vtable2 {
- 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;
-}
-
sub is_vtable_method {
my ( $self, $vt_method_name ) = @_;
return 1 if $self->vtable->has_method($vt_method_name);
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Null.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Null.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Null.pm Wed May 30 06:30:14 2007
@@ -23,26 +23,26 @@
=cut
-sub gen_body {
- my ( $self, $method, ) = @_;
- my $methodname = $method->name;
-
- # existing methods get emitted
- if ( $self->SUPER::implements_vtable($methname) ) {
- return $self->SUPER::gen_body( $self->get_method($methodname));
- }
-
- my $decl = $method->decl( $self, 'CFILE' );
- my $ret = gen_ret($method);
-
- my $output = <<EOC;
-${decl} {
- real_exception(interp, NULL, NULL_REG_ACCESS,
- "Null PMC access in $meth()");
+sub pre_method_gen {
+ my ( $self ) = @_;
+
+ # vtable methods
+ foreach my $method ( @{ $self->vtable->methods } ) {
+ my $vt_method_name = $method->name;
+ next unless $self->normal_unimplemented_vtable($vt_method_name);
+ my $new_default_method = $method->clone();
+
+ my $ret = "";
+ $ret = gen_ret($method);
+ my $output = <<EOC;
+ real_exception(interp, NULL, NULL_REG_ACCESS, "Null PMC access in
$meth()");
EOC
-
- $output .= $ret if $ret;
- return $output .= "}\n";
+ $output .= $ret if $ret;
+ $new_default_method->body(Parrot::Pmc2c::Emitter->text($output));
+ $new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
+ $self->add_method($new_default_method);
+ }
+ return 1;
}
1;
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Ref.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Ref.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/Ref.pm Wed May 30 06:30:14 2007
@@ -60,8 +60,7 @@
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
- next if $vt_method_name eq 'class_init';
- next if $self->implements_vtable($vt_method_name);
+ next unless $self->normal_unimplemented_vtable($vt_method_name);
my $new_default_method = $method->clone();
my $n = 0;
@@ -88,7 +87,7 @@
$ret
EOC
- $new_default_method->body($body);
+ $new_default_method->body(Parrot::Pmc2c::Emitter->text($body));
$new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
$self->add_method($new_default_method);
}
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/default.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/default.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/default.pm Wed May 30
06:30:14 2007
@@ -24,18 +24,16 @@
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
- next if $vt_method_name eq 'class_init';
- unless ( $self->implements_vtable($vt_method_name) ) {
- my $new_default_method = $method->clone();
+ next unless $self->normal_unimplemented_vtable($vt_method_name);
+ my $new_default_method = $method->clone();
- my $ret = "";
- $ret = gen_ret($method);
- $new_default_method->body(<<"EOC");
+ my $ret = "";
+ $ret = gen_ret($method);
+ $new_default_method->body(Parrot::Pmc2c::Emitter->text(<<"EOC"));
cant_do_method(interp, pmc, "$vt_method_name");$ret
EOC
- $new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
- $self->add_method($new_default_method);
- }
+ $new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
+ $self->add_method($new_default_method);
}
return 1;
}
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/deleg_pmc.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/deleg_pmc.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/deleg_pmc.pm Wed May 30
06:30:14 2007
@@ -21,20 +21,18 @@
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
- next if $vt_method_name eq 'class_init';
- next if $self->implements_vtable($vt_method_name);
+ next unless $self->normal_unimplemented_vtable($vt_method_name);
my $new_default_method = $method->clone();
my $n = 0;
my @args = grep { $n++ & 1 ? $_ : 0 } split / /, $method->parameters;
my $arg = @args ? ", " . join( ' ', @args ) : '';
- my $ret = gen_ret( $method, "VTABLE_$method->name(interp, attr$arg)"
);
- my $body = <<EOC;
+ my $ret = gen_ret( $method, "VTABLE_$vt_method_name(interp,
attr$arg)" );
+ $new_default_method->body(Parrot::Pmc2c::Emitter->text(<<"EOC"));
PMC *attr = get_attrib_num(PMC_data_typed(pmc, SLOTTYPE *), 0);
$ret
EOC
- $new_default_method->body($body);
$new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
$self->add_method($new_default_method);
}
Modified: branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/delegate.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/delegate.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/PMCEmitter/delegate.pm Wed May 30
06:30:14 2007
@@ -26,12 +26,11 @@
# vtable methods
foreach my $method ( @{ $self->vtable->methods } ) {
my $vt_method_name = $method->name;
- next if $vt_method_name eq 'class_init';
- next if $self->implements_vtable($vt_method_name);
+ next unless $self->normal_unimplemented_vtable($vt_method_name);
my $new_default_method = $method->clone();
my ( $func_ret, $ret_suffix, $args, $sig ) = $self->signature($method);
- my $body = <<EOC;
+ $new_default_method->body(Parrot::Pmc2c::Emitter->text(<<"EOC"));
STRING *meth = CONST_STRING(interp, "$vt_method_name");
PMC *sub = Parrot_find_vtable_meth(interp, pmc, meth);
@@ -39,7 +38,6 @@
vtable_meth_not_found(interp, pmc, "$vt_method_name");
${func_ret}Parrot_run_meth_fromc_args$ret_suffix(interp, sub, pmc, meth,
"$sig"$args);
EOC
- $new_default_method->body($body);
$new_default_method->type(Parrot::Pmc2c::Method::VTABLE);
$self->add_method($new_default_method);
}
Modified: branches/pmc2c/lib/Parrot/Pmc2c/Parser.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/Parser.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/Parser.pm Wed May 30 06:30:14 2007
@@ -8,7 +8,7 @@
use Data::Dumper;
use Parrot::Pmc2c::PMC;
use Parrot::Pmc2c::Method;
-use Parrot::Pmc2c::CodeFragment;
+use Parrot::Pmc2c::Emitter;
use Parrot::Pmc2c::UtilFunctions qw(count_newlines filename slurp);
use Text::Balanced 'extract_bracketed';
@@ -61,7 +61,7 @@
= parse_top_level( $code );
my $pmc = Parrot::Pmc2c::PMC->new();
- $pmc->preamble( Parrot::Pmc2c::CodeFragment->new($preamble, $filename, 1));
+ $pmc->preamble( Parrot::Pmc2c::Emitter->text($preamble, $filename, 1));
$pmc->name($pmcname);
$pmc->set_filename($filename);
$pmc->set_flags($flags);
@@ -95,10 +95,11 @@
= ( $2, $3, $4, $5, parse_method_attrs($6));
( my $methodblock, $pmcbody ) = extract_balanced($pmcbody);
$methodblock = strip_outer_brackets($methodblock);
+ $methodblock =~ s/^[ ]{4}//mg;
my $method = Parrot::Pmc2c::Method->new( {
name => $methodname,
- body => Parrot::Pmc2c::CodeFragment->new($methodblock,
$filename, $lineno),
+ body => Parrot::Pmc2c::Emitter->text($methodblock,
$filename, $lineno),
return_type => $return_type,
parameters => $parameters,
type => Parrot::Pmc2c::Method::VTABLE,
@@ -107,8 +108,8 @@
#PCCMETHOD needs FixedIntegerArray header
if ( $marker and $marker =~ /PCCMETHOD/ ) {
- #Parrot::Pmc2c::PCCMETHOD::rewrite_pccmethod($method);
- $pmc->flag('need_fia_header');
+ Parrot::Pmc2c::PCCMETHOD::rewrite_pccmethod($method, $pmc);
+ $pmc->set_flag('need_fia_header');
}
#PCCINVOKE needs FixedIntegerArray header
@@ -132,7 +133,7 @@
$lineno += count_newlines($methodblock);
}
- $pmc->postamble(Parrot::Pmc2c::CodeFragment->new($post, $filename,
$lineno));
+ $pmc->postamble(Parrot::Pmc2c::Emitter->text($post, $filename, $lineno));
#ensure class_init is the last method in the method list
$pmc->add_method($class_init) if $class_init;
@@ -153,7 +154,7 @@
my $mmd_part = extract_bracketed_body_text( $body_text, '{' );
die "Empty MMD body near '$body_text'" if ( !$mmd_part );
my $mmd_part_lines = count_newlines($mmd_part);
- $mmd_part =~ s/(\n\s*)$//s;
+ #$mmd_part =~ s/(\n\s*)$//s;
if ( $right_type eq 'DEFAULT' ) {
$default_body = $mmd_part;
$default_body_lineno = $lineno;
@@ -161,7 +162,7 @@
else {
my $mmd_method = Parrot::Pmc2c::Method->new( {
name => $method->name . "_$right_type",
- body => Parrot::Pmc2c::CodeFragment->new($mmd_part,
$filename, $lineno),
+ body => Parrot::Pmc2c::Emitter->text($mmd_part,
$filename, $lineno),
return_type => $method->return_type,
parameters => $method->parameters,
type => Parrot::Pmc2c::Method::VTABLE,
@@ -174,8 +175,8 @@
$lineno += $mmd_part_lines;
}
$method->mmds($mmd_methods);
- $method->body(Parrot::Pmc2c::CodeFragment->
- new($default_body, $filename, $default_body_lineno));
+ $method->body(Parrot::Pmc2c::Emitter->
+ text($default_body, $filename, $default_body_lineno));
}
sub strip_outer_brackets {
Modified: branches/pmc2c/lib/Parrot/Pmc2c/VTable.pm
==============================================================================
--- branches/pmc2c/lib/Parrot/Pmc2c/VTable.pm (original)
+++ branches/pmc2c/lib/Parrot/Pmc2c/VTable.pm Wed May 30 06:30:14 2007
@@ -83,6 +83,12 @@
return $self->{'has_method'}->{$methodname};
}
+sub is_mmd {
+ my ( $self, $methodname ) = @_;
+ my $method = $self->get_method($methodname);
+ return (defined $method and $method->is_mmd);
+}
+
sub get_method {
my ( $self, $methodname ) = @_;
my $method_index = $self->has_method($methodname);
Modified: branches/pmc2c/src/pmc/class.pmc
==============================================================================
--- branches/pmc2c/src/pmc/class.pmc (original)
+++ branches/pmc2c/src/pmc/class.pmc Wed May 30 06:30:14 2007
@@ -871,7 +871,7 @@
/* Build attributes index. */
build_attrib_index(interp, SELF);
if (PMC_IS_NULL(_class->attrib_index))
- return;
+ PCCRETURN();
}
/* Set instantiated flag. */
Modified: branches/pmc2c/src/pmc/exporter.pmc
==============================================================================
--- branches/pmc2c/src/pmc/exporter.pmc (original)
+++ branches/pmc2c/src/pmc/exporter.pmc Wed May 30 06:30:14 2007
@@ -172,7 +172,7 @@
if (src->vtable->base_type != enum_class_NameSpace) {
real_exception(interp, NULL, 0,
"source must be a NameSpace PMC");
- return;
+ PCCRETURN();
}
exp->ns_src = src;
}
@@ -204,7 +204,7 @@
if (dest->vtable->base_type != enum_class_NameSpace) {
real_exception(interp, NULL, 0,
"destination must be a NameSpace PMC");
- return;
+ PCCRETURN();
}
exp->ns_dest = dest;
}
@@ -277,7 +277,7 @@
else {
real_exception(interp, NULL, 0,
"Invalid type %d in globals()", glb->vtable->base_type);
- return;
+ PCCRETURN();
}
exp->globals = temp_globals;
@@ -329,11 +329,11 @@
if (PMC_IS_NULL(exp->ns_src)) {
real_exception(interp, NULL, 0, "source namespace not set");
- return;
+ PCCRETURN();
}
if (PMC_IS_NULL(exp->ns_dest)) {
real_exception(interp, NULL, 0, "destination namespace not set");
- return;
+ PCCRETURN();
}
ns_src = exp->ns_src;
Modified: branches/pmc2c/src/pmc/parrotlibrary.pmc
==============================================================================
--- branches/pmc2c/src/pmc/parrotlibrary.pmc (original)
+++ branches/pmc2c/src/pmc/parrotlibrary.pmc Wed May 30 06:30:14 2007
@@ -34,7 +34,7 @@
#include "parrot/parrot.h"
-pmclass ParrotLibrary need_ext does library const_too {
+pmclass ParrotLibrary need_ext does library {
/*
Modified: branches/pmc2c/src/pmc/sarray.pmc
==============================================================================
--- branches/pmc2c/src/pmc/sarray.pmc (original)
+++ branches/pmc2c/src/pmc/sarray.pmc Wed May 30 06:30:14 2007
@@ -232,7 +232,7 @@
return e;
}
-pmclass SArray const_too need_ext does array {
+pmclass SArray need_ext does array {
/*
