cvsuser 05/03/20 04:47:03
Modified: classes fixedbooleanarray.pmc fixedfloatarray.pmc
fixedintegerarray.pmc fixedstringarray.pmc
pmc2c2.pl
lib/Parrot Pmc2c.pm
Log:
DYNDYNSELF in the Fixed*Array PMC looks like a typo. Using SELF propably
saves one dereferencing.
----
Beautifications in pmc2c2.pl and Pmc2c.pm.
Comment some regexes in Pmc2c.pm.
Revision Changes Path
1.5 +3 -3 parrot/classes/fixedbooleanarray.pmc
Index: fixedbooleanarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/fixedbooleanarray.pmc,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- fixedbooleanarray.pmc 12 Dec 2004 23:03:45 -0000 1.4
+++ fixedbooleanarray.pmc 20 Mar 2005 12:47:01 -0000 1.5
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: fixedbooleanarray.pmc,v 1.4 2004/12/12 23:03:45 chromatic Exp $
+$Id: fixedbooleanarray.pmc,v 1.5 2005/03/20 12:47:01 bernhard Exp $
=head1 NAME
@@ -112,7 +112,7 @@
*/
INTVAL get_bool () {
- INTVAL size = DYNDYNSELF.elements();
+ INTVAL size = SELF.elements();
return (INTVAL)(size != 0);
}
@@ -139,7 +139,7 @@
*/
INTVAL get_integer () {
- return DYNDYNSELF.elements();
+ return SELF.elements();
}
1.6 +3 -3 parrot/classes/fixedfloatarray.pmc
Index: fixedfloatarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/fixedfloatarray.pmc,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- fixedfloatarray.pmc 12 Dec 2004 23:03:45 -0000 1.5
+++ fixedfloatarray.pmc 20 Mar 2005 12:47:01 -0000 1.6
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: fixedfloatarray.pmc,v 1.5 2004/12/12 23:03:45 chromatic Exp $
+$Id: fixedfloatarray.pmc,v 1.6 2005/03/20 12:47:01 bernhard Exp $
=head1 NAME
@@ -112,7 +112,7 @@
*/
INTVAL get_bool () {
- INTVAL size = DYNDYNSELF.elements();
+ INTVAL size = SELF.elements();
return (INTVAL)(size != 0);
}
@@ -139,7 +139,7 @@
*/
INTVAL get_integer () {
- return DYNDYNSELF.elements();
+ return SELF.elements();
}
1.5 +3 -3 parrot/classes/fixedintegerarray.pmc
Index: fixedintegerarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/fixedintegerarray.pmc,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- fixedintegerarray.pmc 12 Dec 2004 23:03:45 -0000 1.4
+++ fixedintegerarray.pmc 20 Mar 2005 12:47:01 -0000 1.5
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: fixedintegerarray.pmc,v 1.4 2004/12/12 23:03:45 chromatic Exp $
+$Id: fixedintegerarray.pmc,v 1.5 2005/03/20 12:47:01 bernhard Exp $
=head1 NAME
@@ -112,7 +112,7 @@
*/
INTVAL get_bool () {
- INTVAL size = DYNDYNSELF.elements();
+ INTVAL size = SELF.elements();
return (INTVAL)(size != 0);
}
@@ -139,7 +139,7 @@
*/
INTVAL get_integer () {
- return DYNDYNSELF.elements();
+ return SELF.elements();
}
1.7 +3 -3 parrot/classes/fixedstringarray.pmc
Index: fixedstringarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/fixedstringarray.pmc,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- fixedstringarray.pmc 24 Feb 2005 11:56:42 -0000 1.6
+++ fixedstringarray.pmc 20 Mar 2005 12:47:01 -0000 1.7
@@ -1,6 +1,6 @@
/*
Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
-$Id: fixedstringarray.pmc,v 1.6 2005/02/24 11:56:42 leo Exp $
+$Id: fixedstringarray.pmc,v 1.7 2005/03/20 12:47:01 bernhard Exp $
=head1 NAME
@@ -138,7 +138,7 @@
*/
INTVAL get_bool () {
- INTVAL size = DYNDYNSELF.elements();
+ INTVAL size = SELF.elements();
return (INTVAL)(size != 0);
}
@@ -167,7 +167,7 @@
*/
INTVAL get_integer () {
- return DYNDYNSELF.elements();
+ return SELF.elements();
}
1.26 +21 -18 parrot/classes/pmc2c2.pl
Index: pmc2c2.pl
===================================================================
RCS file: /cvs/public/parrot/classes/pmc2c2.pl,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- pmc2c2.pl 5 Mar 2005 10:18:19 -0000 1.25
+++ pmc2c2.pl 20 Mar 2005 12:47:01 -0000 1.26
@@ -1,7 +1,6 @@
#! perl -w
-
# Copyright: 2001-2005 The Perl Foundation. All Rights Reserved.
-# $Id: pmc2c2.pl,v 1.25 2005/03/05 10:18:19 leo Exp $
+# $Id: pmc2c2.pl,v 1.26 2005/03/20 12:47:01 bernhard Exp $
=head1 NAME
@@ -201,7 +200,7 @@
Converted to the interpreter object.
-=item C<Otherclass.SELF.method(a,b,c)>
+=item C<OtherClass.SELF.method(a,b,c)>
Calls the static vtable method 'method' in C<OtherClass>.
@@ -257,7 +256,7 @@
main();
sub find_file {
- my ( $include, $file, $die_unless_found ) = @_;
+ my ($include, $file, $die_unless_found) = @_;
foreach my $dir ( @$include ) {
my $path = File::Spec->catfile( $dir, $file );
@@ -322,6 +321,7 @@
sub parse_flags {
my $c = shift;
+
$$c =~ s/^(.*?^\s*)pmclass ([\w]*)//ms;
my ($pre, $classname) = ($1, $2);
my %has_value = ( does => 1, extends => 1, group => 1, lib => 1 );
@@ -355,8 +355,8 @@
}
sub parse_pmc {
-
local $_ = shift;
+
my $signature_re = qr{
^
(?: #blank spaces and comments and spurious semicolons
@@ -417,21 +417,20 @@
}
- return ( $classname, {
- 'pre' => $pre,
- 'flags' => $flags,
- 'methods' => [EMAIL PROTECTED],
- 'post' => $post,
- 'class' => $classname,
- 'has_method' => \%meth_hash
- }
- );
+ return ( $classname, { 'pre' => $pre,
+ 'flags' => $flags,
+ 'methods' => [EMAIL PROTECTED],
+ 'post' => $post,
+ 'class' => $classname,
+ 'has_method' => \%meth_hash
+ }
+ );
}
# make a linear list of class->{parents} array
sub gen_parent_list {
- my $include = shift;
- my ($this, $all) = @_;
+ my ($include, $this, $all) = @_;
+
my @todo = ($this);
my $class = $all->{$this};
while (@todo) {
@@ -456,6 +455,7 @@
sub dump_1_pmc {
my $file = shift;
+
$file =~ s/\.\w+$/.pmc/;
print "Reading $file\n" if $opt{verbose};
open F, "<$file" or die "Can't read '$file'";
@@ -467,6 +467,7 @@
sub gen_super_meths {
my ($self, $vt) = @_;
+
# look through all meths in class and locate the nearest parent
foreach my $entry (@{ $vt->{methods} } ) {
my $meth = $entry->{meth};
@@ -498,6 +499,7 @@
sub add_defaulted {
my ($class, $vt) = @_;
+
my $i = @{ $class->{methods} };
foreach my $e ( @{$vt->{methods}} ) {
my $meth = $e->{meth};
@@ -507,6 +509,7 @@
sub dump_is_newer {
my $file = shift;
+
my $pmc;
($pmc = $file) =~ s/\.\w+$/\.pmc/;
my ($pmc_dt, $dump_dt);
@@ -517,6 +520,7 @@
sub dump_pmc {
my $include = shift;
+
my @files = @_;
my %all;
# help these dumb 'shells' that are no shells
@@ -584,8 +588,7 @@
}
sub gen_c {
- my $include = shift;
- my (@files) = @_;
+ my ($include, @files) = @_;
my $library = Parrot::Pmc2c::Library->new
( \%opt, read_dump($include, "vtable.pmc"),
1.65 +74 -18 parrot/lib/Parrot/Pmc2c.pm
Index: Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- Pmc2c.pm 13 Mar 2005 12:16:11 -0000 1.64
+++ Pmc2c.pm 20 Mar 2005 12:47:03 -0000 1.65
@@ -1,5 +1,5 @@
-# Copyright: 2004 The Perl Foundation. All Rights Reserved.
-# $Id: Pmc2c.pm,v 1.64 2005/03/13 12:16:11 leo Exp $
+# Copyright: 2004-2005 The Perl Foundation. All Rights Reserved.
+# $Id: Pmc2c.pm,v 1.65 2005/03/20 12:47:03 bernhard Exp $
=head1 NAME
@@ -21,6 +21,7 @@
=cut
package Parrot::Pmc2c;
+
use strict;
use vars qw(@EXPORT_OK @writes %writes );
use Parrot::PMC qw(%pmc_types);
@@ -43,6 +44,7 @@
sub does_write($$) {
my ($meth, $section) = @_;
+
warn "no $meth\n" unless $section;
exists $writes{$section} || $meth eq 'morph';
}
@@ -66,6 +68,7 @@
sub dont_edit {
my ($pmcfile) = @_;
+
return <<"EOC";
/*
* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
@@ -91,6 +94,7 @@
sub gen_ret {
my ($method, $body) = @_;
+
my $ret;
if ($body) {
$ret = $method->{type} eq 'void' ? "$body;" : "return $body;" ;
@@ -111,6 +115,7 @@
sub class_name {
my ($self, $class) = @_;
+
my %special = ( 'Ref' => 1, 'default' => 1, 'Null' => 1,
'delegate' => 1, 'SharedRef' => 1,
'deleg_pmc' => 1,
@@ -141,6 +146,7 @@
sub dynext_load_code {
my ($libname, %classes ) = @_;
+
my $lc_libname = lc $libname;
my $cout;
@@ -229,8 +235,9 @@
sub new {
my $this = shift;
- my $class = ref($this) || $this;
my $self = shift;
+
+ my $class = ref($this) || $this;
$self->{opt} = shift;
$class = class_name($self, $class);
bless $self, $class;
@@ -253,6 +260,7 @@
sub line_directive {
my ($self, $line, $file) = @_;
+
return '' if $self->{opt}{nolines};
return qq{#line $line "$file"\n} if defined $file;
return qq{#line $line\n};
@@ -267,6 +275,7 @@
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
@@ -283,6 +292,7 @@
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} } ) {
@@ -299,6 +309,7 @@
sub make_const() {
my ($self, $class) = @_;
+
my $const = bless {}, $class . '::Const';
$self->{const} = $const;
my @methods = @{ $self->{methods} };
@@ -346,6 +357,7 @@
sub init() {
my ($self, $class) = @_;
+
$self->get_vtable_section();
$self->make_const($class) if $self->{flags}{const_too};
@@ -360,6 +372,7 @@
sub decl() {
my ($self, $classname, $method, $for_header) = @_;
+
my $ret = $method->{type};
my $meth= $method->{meth};
my $args= $method->{parameters};
@@ -392,6 +405,7 @@
sub includes() {
my $self = shift;
+
my $cout = "";
$cout .= <<"EOC";
#include "parrot/parrot.h"
@@ -413,6 +427,7 @@
"$cout\n";
}
+
=item C<full_arguments($args)>
Prepends C<INTERP, SELF> to C<$args>.
@@ -421,7 +436,8 @@
sub full_arguments {
my $args = shift;
- if ($args =~ /\S/) {
+
+ if ($args =~ m/\S/) {
return "INTERP, SELF, $args";
} else {
return "INTERP, SELF";
@@ -485,6 +501,7 @@
sub rewrite_nci_method ($$$) {
my ($class, $method) = @_;
+
local $_ = $_[2];
# Rewrite SELF -> pmc, INTERP -> interpreter
s/SELF/pmc/g;
@@ -507,29 +524,48 @@
# Rewrite method body
my $supertype = "enum_class_$super";
die "$class defines unknown vtable method '$method'\n"
- if ! defined $super_table->{$method};
+ unless defined $super_table->{$method};
my $supermethod = "Parrot_" . $super_table->{$method} . "_$method";
- # Rewrite DYNSUPER(args...)
-
s/DYNSUPER\(\s*(.*?)\)/"Parrot_base_vtables[$supertype].$method(".full_arguments($1).")"/eg;
+ # Rewrite DYNSUPER(args)
+ s/DYNSUPER # Macro: DYNSUPER
+ \(\s*(.*?)\) # capture argument list
+ /"Parrot_base_vtables[$supertype].$method(" . full_arguments($1) .
')'/xeg;
# Rewrite OtherClass.SUPER(args...)
-
s/(\w+)\.SUPER\(\s*(.*?)\)/"Parrot_${1}_$method(".full_arguments($2).")"/eg;
+ s/(\w+) # capture OtherClass
+ \.SUPER # Macro: SUPER
+ \(\s*(.*?)\) # capture argument list
+ /"Parrot_${1}_$method(" . full_arguments($2) . ')'/xeg;
# Rewrite SUPER(args...)
- s/SUPER\(\s*(.*?)\)/"$supermethod(".full_arguments($1).")"/eg;
+ s/SUPER # Macro: SUPER
+ \(\s*(.*?)\) # capture argument list
+ /"$supermethod(" . full_arguments($1) . ')'/xeg;
# Rewrite DYNSELF.other_method(args...)
-
s/DYNSELF\.(\w+)\(\s*(.*?)\)/"pmc->vtable->$1(".full_arguments($2).")"/eg;
+ s/DYNSELF # Macro: DYNSELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ /"pmc->vtable->$1(" . full_arguments($2) . ')'/xeg;
# Rewrite DYNSELF(args...). See comments above.
- s/DYNSELF\(\s*(.*?)\)/"pmc->vtable->$method(".full_arguments($1).")"/eg;
+ s/DYNSELF # Macro: DYNSELF
+ \(\s*(.*?)\) # capture argument list
+ /"pmc->vtable->$method(" . full_arguments($1) . ')'/xeg;
# Rewrite OtherClass.SELF.other_method(args...)
-
s/(\w+)\.SELF\.(\w+)\(\s*(.*?)\)/"Parrot_${1}_$2(".full_arguments($3).")"/eg;
+ s/(\w+) # OtherClass
+ \.SELF # Macro SELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ /"Parrot_${1}_$2(" . full_arguments($3) . ')'/xeg;
# Rewrite SELF.other_method(args...)
-
s/SELF\.(\w+)\(\s*(.*?)\)/"Parrot_${class}_$1(".full_arguments($2).")"/eg;
+ s/SELF # Macro SELF
+ \.(\w+) # other_method
+ \(\s*(.*?)\) # capture argument list
+ /"Parrot_${class}_$1(".full_arguments($2).")"/xeg;
# Rewrite SELF -> pmc, INTERP -> interpreter
s/SELF/pmc/g;
@@ -552,6 +588,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $cout = "";
my $classname = $self->{class};
my $meth = $method->{meth};
@@ -621,6 +658,7 @@
sub methods {
my ($self, $line, $out_name) = @_;
+
my $cout = "";
# vtable methods
@@ -653,6 +691,7 @@
sub lib_load_code() {
my $self = shift;
+
my $classname = $self->{class};
return dynext_load_code($classname, $classname => {});
}
@@ -677,6 +716,7 @@
sub init_func() {
my $self = shift;
+
my $cout = "";
return "" if exists $self->{flags}{noinit};
@@ -931,6 +971,7 @@
sub gen_c {
my ($self, $out_name) = @_;
+
my $cout = dont_edit($self->{file});
$cout .= $self->line_directive(1, $self->{file})
. $self->{pre};
@@ -958,6 +999,7 @@
sub hdecls() {
my $self = shift;
+
my $hout;
my $classname = $self->{class};
# generat decls for all methods in this file
@@ -986,6 +1028,7 @@
sub gen_h() {
my ($self, $out_name) = @_;
+
my $hout = dont_edit($self->{file});
my $name = uc $self->{class};
$hout .= <<"EOH";
@@ -1018,6 +1061,7 @@
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';
@@ -1049,6 +1093,7 @@
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);
@@ -1079,6 +1124,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
my $decl = $self->decl($self->{class}, $method, 0);
@@ -1131,7 +1177,7 @@
sub implements
{
- 1;
+ return 1;
}
=item C<body($method, $line, $out_name)>
@@ -1148,6 +1194,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
@@ -1207,6 +1254,7 @@
sub gen_ret
{
my ($self, $type) = @_;
+
return "ret_val = ";
}
@@ -1223,6 +1271,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
@@ -1281,7 +1330,7 @@
sub implements
{
- 1;
+ return 1;
}
=item C<body($method, $line, $out_name)>
@@ -1298,6 +1347,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
@@ -1342,7 +1392,7 @@
sub implements
{
- 1;
+ return 1;
}
=item C<body($method, $line, $out_name)>
@@ -1358,6 +1408,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
@@ -1398,7 +1449,7 @@
sub implements
{
- 1;
+ return 1;
}
=item C<trans($type)>
@@ -1410,6 +1461,7 @@
sub trans
{
my ($self, $type) = @_;
+
my $char = substr $type, 0, 1;
return $1 if ($char =~ /([ISP])/);
return 'N' if ($char eq 'F');
@@ -1426,6 +1478,7 @@
sub signature
{
my ($self, $params) = @_;
+
my $n=1;
my @types = grep {$n++ & 1 ? $_ : 0} split / /, $params;
@types = map { $self->trans($_) } @types;
@@ -1441,6 +1494,7 @@
sub gen_ret
{
my ($self, $type) = @_;
+
#return "ret_val = *($1*) " if ($type =~ /((?:INT|FLOAT)VAL)/);
return "ret_val = ($type) ";
}
@@ -1458,6 +1512,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
@@ -1516,7 +1571,7 @@
sub implements
{
- 1;
+ return 1;
}
=item C<body($method, $line, $out_name)>
@@ -1533,6 +1588,7 @@
sub body
{
my ($self, $method, $line, $out_name) = @_;
+
my $meth = $method->{meth};
# existing methods get emitted
if ($self->SUPER::implements($meth)) {
