# New Ticket Created by Sam Ruby
# Please include the string: [perl #31975]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org:80/rt3/Ticket/Display.html?id=31975 >
Leopold Toetsch wrote:
> Sam Ruby <[EMAIL PROTECTED]> wrote:
>
>>I'm not overly concerned about __init methods, in fact, my concern is
>>the opposite: I'd like to solicit opinions on the viability of extending
>>pmc2c2.pl to enable non-vtable methods to be defined, in C, in the .pmc
>>file itself.
>
> That sounds great.
>
> METHOD find(PMC* substr) {
> }
How about:
METHOD INTVAL find(PMC* substr) {
}
Patch attached. Should the Object parameter be named "pmc" or "self"?
- Sam Ruby
P.S. I miss embracing elses.
Index: classes/perlstring.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlstring.pmc,v
retrieving revision 1.87
diff -u -r1.87 perlstring.pmc
--- classes/perlstring.pmc 21 Jul 2004 08:45:46 -0000 1.87
+++ classes/perlstring.pmc 13 Oct 2004 20:25:53 -0000
@@ -21,24 +21,26 @@
#include "parrot/parrot.h"
#include "parrot/perltypes.h"
-static PMC*
-string_lower(Interp *interpreter, PMC *self)
-{
- STRING *s = string_downcase(interpreter, PMC_str_val(self));
- PMC *ret = pmc_new(interpreter, enum_class_PerlString);
- string_set(interpreter, PMC_str_val(ret), s);
- return ret;
-}
-
pmclass PerlString extends perlscalar {
void class_init () {
- /* this should be autmatically done - probably */
- if (pass) {
- enter_nci_method(INTERP, enum_class_PerlString,
- F2DPTR(string_lower),
- "lower", "PIO");
- }
+ }
+
+/*
+
+=item C<void* lower(void *next)>
+
+downcase this string
+
+=cut
+
+*/
+
+ METHOD PMC* lower() {
+ STRING *s = string_downcase(interpreter, PMC_str_val(pmc));
+ PMC *ret = pmc_new(interpreter, enum_class_PerlString);
+ string_set(interpreter, PMC_str_val(ret), s);
+ return ret;
}
/*
Index: classes/pmc2c2.pl
===================================================================
RCS file: /cvs/public/parrot/classes/pmc2c2.pl,v
retrieving revision 1.17
diff -u -r1.17 pmc2c2.pl
--- classes/pmc2c2.pl 8 Sep 2004 05:25:12 -0000 1.17
+++ classes/pmc2c2.pl 13 Oct 2004 20:25:54 -0000
@@ -363,6 +363,7 @@
(?:/\*.*?\*/)? # C-like comments
)*
+ (METHOD\s+)? #method flag
(\w+\**) #type
\s+
(\w+) #method name
@@ -380,7 +381,7 @@
while ($classblock =~ s/($signature_re)//) {
$lineno += count_newlines($1);
- my ($type, $methodname, $parameters) = ($2,$3,$4);
+ my ($flag, $type, $methodname, $parameters) = ($2,$3,$4,$5);
my ($methodblock, $rema, $lines) = extract_balanced($classblock);
$lineno += $lines;
$methodblock = "" if $opt{nobody};
@@ -390,7 +391,8 @@
'body' => $methodblock,
'line' => $lineno,
'type' => $type,
- 'parameters' => $parameters
+ 'parameters' => $parameters,
+ 'loc' => "vtable"
};
}
else {
@@ -401,7 +403,8 @@
'body' => $methodblock,
'line' => $lineno,
'type' => $type,
- 'parameters' => $parameters
+ 'parameters' => $parameters,
+ 'loc' => $flag ? "nci" : "vtable"
};
}
$classblock = $rema;
Index: lib/Parrot/Pmc2c.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Pmc2c.pm,v
retrieving revision 1.41
diff -u -r1.41 Pmc2c.pm
--- lib/Parrot/Pmc2c.pm 8 Oct 2004 07:08:36 -0000 1.41
+++ lib/Parrot/Pmc2c.pm 13 Oct 2004 20:25:54 -0000
@@ -395,14 +395,71 @@
}
}
-=item C<rewrite_method($class, $method, $super, $super_table)>
+=item C<proto($type,$parameters)>
-Rewrites the method body performing the various macro subsitiutions for
+Determines the prototype (argument signature) for a method body
+(see F<src/call_list>).
+
+=cut
+
+my %calltype = (
+ "char" => "c",
+ "short" => "s",
+ "char" => "c",
+ "short" => "s",
+ "int" => "i",
+ "INTVAL" => "i",
+ "float" => "f",
+ "FLOATVAL" => "f",
+ "double" => "d",
+ "STRING*" => "t",
+ "char*" => "t",
+ "PMC*" => "P",
+ "short*" => "2",
+ "int*" => "3",
+ "long*" => "4",
+ "void" => "v",
+ "void*" => "b",
+ "void**" => "B",
+ #"BIGNUM*" => "???" # XXX
+);
+
+sub proto ($$) {
+ my ($type, $parameters) = @_;
+
+ # reduce to a comma separated set of types
+ $parameters =~ s/ +\w+(,|$)/,/g;
+ $parameters =~ s/ //g;
+
+ # type method(interpreter, self, parameters...)
+ my $ret = $calltype{$type or "void"};
+ $ret .= "IO";
+ $ret .= join('', map {$calltype{$_} or "?"} split(/,/, $parameters));
+
+ return $ret;
+}
+
+=item C<rewrite_nci_method($class, $method, $super, $super_table)>
+
+Rewrites the method body performing the various macro substitutions for
+nci method bodies (see F<classes/pmc2c.pl>).
+
+=cut
+
+sub rewrite_nci_method ($$$) {
+ my ($class, $method) = @_;
+ local $_ = $_[2];
+ return $_;
+}
+
+=item C<rewrite_vtable_method($class, $method, $super, $super_table)>
+
+Rewrites the method body performing the various macro substitutions for
vtable method bodies (see F<classes/pmc2c.pl>).
=cut
-sub rewrite_method ($$$$$) {
+sub rewrite_vtable_method ($$$$$) {
my ($class, $method, $super, $super_table) = @_;
local $_ = $_[4];
@@ -465,8 +522,16 @@
$body =~ s/^\t/ /mg;
$body =~ s/^[ ]{4}//mg;
my $super = $self->{super}{$meth};
- my $total_body = rewrite_method($classname, $meth, $super,
- $self->{super}, $body);
+
+ my $total_body;
+ if ($method->{loc} eq 'vtable') {
+ $total_body = rewrite_vtable_method($classname, $meth, $super,
+ $self->{super}, $body);
+ }
+ else {
+ $total_body = rewrite_nci_method($classname, $meth, $body);
+ }
+
# now split into MMD if necessary:
my $additional_bodies= '';
$total_body = substr $total_body, 1, -1;
@@ -513,6 +578,7 @@
my ($self, $line) = @_;
my $cout = "";
+ # vtable methods
foreach my $method (@{ $self->{vtable}{methods}} ) {
my $meth = $method->{meth};
next if $meth eq 'class_init';
@@ -522,6 +588,15 @@
$cout .= $ret;
}
}
+
+ # nci methods
+ foreach my $method (@{ $self->{methods}} ) {
+ next unless $method->{loc} eq 'nci';
+ my $ret = $self->body($method, $line);
+ $line += count_newlines($ret);
+ $cout .= $ret;
+ }
+
$cout;
}
@@ -716,10 +791,32 @@
$cout .= <<"EOC";
} /* pass */
EOC
+
+ # declare each nci method for this class
+ my $firstnci = 1;
+ foreach my $method (@{ $self->{methods} }) {
+ next unless $method->{loc} eq 'nci';
+ my $proto = proto($method->{type}, $method->{parameters});
+ $cout .= <<"EOC" if $firstnci;
+ if (pass) {
+EOC
+ $cout .= <<"EOC";
+ enter_nci_method(interp, enum_class_${classname},
+ F2DPTR(Parrot_${classname}_$method->{meth}),
+ "$method->{meth}", "$proto");
+EOC
+ $firstnci = 0;
+ }
+ $cout .= <<"EOC" unless $firstnci;
+ }
+EOC
+
+ # include any class specific init code from the .pmc file
$cout .= <<"EOC";
$class_init_code
if (pass == 1) {
EOC
+
# declare auxiliary variables for dyncpmc IDs
foreach my $dynclass (keys %init_mmds) {
next if $dynclass eq $classname;
