cvsuser 03/08/25 10:49:03
Modified: classes pmc2c.pl sarray.pmc
config/inter pmc.pl
include/parrot exceptions.h
lib/Parrot Vtable.pm
t/pmc objects.t sarray.t
. vtable.tbl
Log:
ConstClass-1: vtables; test in SArray
Revision Changes Path
1.34 +72 -1 parrot/classes/pmc2c.pl
Index: pmc2c.pl
===================================================================
RCS file: /cvs/public/parrot/classes/pmc2c.pl,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -w -r1.33 -r1.34
--- pmc2c.pl 25 Aug 2003 11:59:01 -0000 1.33
+++ pmc2c.pl 25 Aug 2003 17:48:34 -0000 1.34
@@ -420,6 +420,14 @@
return $_;
}
+sub is_const($$) {
+ my ($meth, $section) = @_;
+ my @consts = qw(STORE PUSH POP SHIFT UNSHIFT DELETE);
+ my %consts;
+ @[EMAIL PROTECTED] = (1) x @consts;
+ exists $consts{$section};
+}
+
=head2 filter
The filter function choreographs the previous functions actions on the
@@ -569,12 +577,45 @@
# vtable.tbl file.
@methods = ();
+ my @cmethods;
for (@$default)
{
my $methodname = $_->[1];
+ my $isconst;
push @methods, "Parrot_$methodloc->{$methodname}_$methodname";
+ if ($flags{const_too}) {
+ if (is_const($methodname, $_->[3]) &&
+ exists $methodbody{ $methodname }) {
+ $isconst = 1;
+ push @cmethods,
+ "Parrot_Const$methodloc->{$methodname}_$methodname";
+ }
+ else {
+ push @cmethods, "Parrot_$methodloc->{$methodname}_$methodname";
+ }
+
+ }
if (exists $methodbody{ $methodname }) {
- $OUT .= $methodbody{ $methodname } . "\n\n"
+ $OUT .= $methodbody{ $methodname } . "\n\n";
+ if ($isconst) {
+ my $type = $_->[0];
+ my $parameters = $_->[2];
+ $parameters = ", $parameters" if $parameters;
+ my $retval = "($type) 0";
+ my $ret = $type eq 'void' ? '' : "return $retval;" ;
+ my $ln = 1 + ($OUT =~ tr/\n/\n/);
+ my $line = $suppress_lines ? '' : "#line $ln \"$cfile\"\n";
+ my $decl = "$type Parrot_Const${classname}_${methodname} (struct
Parrot_Interp *interpreter, PMC* pmc$parameters)";
+ $HOUT .= "extern $decl;\n";
+ $OUT .= <<EOC;
+$line
+ $decl {
+ internal_exception(WRITE_TO_CONSTCLASS,
+ "$methodname() in Const$classname");
+ $ret
+ }
+EOC
+ }
}
elsif ($classname eq 'default') {
# generate default body
@@ -603,6 +644,7 @@
# this collapses the array and makes sure the spacing is right for
# the vtable
my $methodlist = join (",\n ", @methods);
+ my $cmethodlist = join (",\n ", @cmethods);
my $initname = "Parrot_$classname" . "_class_init";
unless (exists $flags{noinit}) {
@@ -634,6 +676,35 @@
EOC
}
+ if (exists $flags{const_too}) {
+ my $initline = 1+count_newlines($OUT)+1;
+ $initname = "Parrot_Const$classname" . "_class_init";
+ $OUT .= qq(#line $initline "$cfile"\n) unless $suppress_lines;
+ $HOUT .= <<EOH;
+void $initname (Interp *, int);
+EOH
+ $OUT .= <<EOC;
+void $initname (Interp * interp, int entry) {
+
+ struct _vtable temp_base_vtable = {
+ NULL, /* package */
+ enum_class_Const$classname,
+ NULL, /* whoami */
+ NULL, /* method_table */
+ 0, /* reserved */
+ 0, /* reserved */
+ $cmethodlist
+ };
+
+ if (!temp_base_vtable.whoami)
+ temp_base_vtable.whoami = string_make(interp,
+ "Const$classname", @{[length("Const$classname")]}, 0, PObj_constant_FLAG,
0);
+
+ Parrot_base_vtables[entry] = temp_base_vtable;
+ $class_init_code
+}
+EOC
+ }
if (exists $flags{dynpmc}) {
my $lc_classname = lc $classname;
$OUT .= <<EOC;
1.14 +2 -2 parrot/classes/sarray.pmc
Index: sarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/sarray.pmc,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -w -r1.13 -r1.14
--- sarray.pmc 25 Aug 2003 09:46:23 -0000 1.13
+++ sarray.pmc 25 Aug 2003 17:48:34 -0000 1.14
@@ -1,7 +1,7 @@
/* sarray.pmc
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: sarray.pmc,v 1.13 2003/08/25 09:46:23 leo Exp $
+ * $Id: sarray.pmc,v 1.14 2003/08/25 17:48:34 leo Exp $
* Overview:
* These are the vtable functions for the SArray base class
* Data Structure and Algorithms:
@@ -23,7 +23,7 @@
#include "parrot/parrot.h"
-pmclass SArray {
+pmclass SArray const_too {
void init () {
SELF->cache.int_val = 0;
PMC_data(SELF) = NULL;
1.9 +3 -0 parrot/config/inter/pmc.pl
Index: pmc.pl
===================================================================
RCS file: /cvs/public/parrot/config/inter/pmc.pl,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -w -r1.8 -r1.9
--- pmc.pl 23 Aug 2003 10:19:49 -0000 1.8
+++ pmc.pl 25 Aug 2003 17:48:42 -0000 1.9
@@ -91,11 +91,13 @@
PMC: foreach my $pmc_file (split(/\s+/, $pmc_list)) {
my $name;
open(PMC, "classes/$pmc_file") or die "open classes/$pmc_file: $!";
+ my $const;
while (<PMC>) {
if (/^pmclass (\w+)(.*)/) {
$name = $1;
my $decl = $2;
$decl .= <PMC> until ($decl =~ s/\{.*//);
+ $const = 1 if $decl =~ /\bconst_too\b/;
next PMC if $decl =~ /\babstract\b/;
next PMC if $decl =~ /\bextension\b/;
last;
@@ -105,6 +107,7 @@
die "No pmclass declaration found in $pmc_file"
if ! defined $name;
push @names, $name;
+ push @names, "Const$name" if $const;
}
Configure::Data->set(
1.37 +2 -1 parrot/include/parrot/exceptions.h
Index: exceptions.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/exceptions.h,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -w -r1.36 -r1.37
--- exceptions.h 25 Aug 2003 09:46:31 -0000 1.36
+++ exceptions.h 25 Aug 2003 17:48:49 -0000 1.37
@@ -1,7 +1,7 @@
/* exceptions.h
* Copyright: 2001-2003 The Perl Foundation. All Rights Reserved.
* CVS Info
- * $Id: exceptions.h,v 1.36 2003/08/25 09:46:31 leo Exp $
+ * $Id: exceptions.h,v 1.37 2003/08/25 17:48:49 leo Exp $
* Overview:
* define the internal interpreter exceptions
* Data Structure and Algorithms:
@@ -63,6 +63,7 @@
#define LEX_NOT_FOUND 4
#define GLOBAL_NOT_FOUND 5
#define METH_NOT_FOUND 6
+#define WRITE_TO_CONSTCLASS 7
/* &end_gen */
1.19 +18 -3 parrot/lib/Parrot/Vtable.pm
Index: Vtable.pm
===================================================================
RCS file: /cvs/public/parrot/lib/Parrot/Vtable.pm,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -w -r1.18 -r1.19
--- Vtable.pm 25 Aug 2003 09:46:32 -0000 1.18
+++ Vtable.pm 25 Aug 2003 17:48:59 -0000 1.19
@@ -29,6 +29,7 @@
my $vtable = [];
my $fh = new FileHandle ($file, O_RDONLY) or
die "Can't open $file for reading: $!\n";
+ my $section = 'MAIN';
while(<$fh>) {
@@ -36,8 +37,11 @@
next if /^\s*#/ or /^\s*$/;
- if (/^\s*($type_re)\s+($ident_re)\s*\(($arglist_re)\)\s*$/) {
- push @{$vtable}, [ $1, $2, $3 ];
+ if (/^\[(\w+)\]/) {
+ $section = $1;
+ }
+ elsif (/^\s*($type_re)\s+($ident_re)\s*\(($arglist_re)\)\s*$/) {
+ push @{$vtable}, [ $1, $2, $3, $section ];
} else {
die "Syntax error at $file line ".$fh->input_line_number()."\n";
}
@@ -117,4 +121,15 @@
=head1 DESCRIPTION
-No user-serviceable parts inside.
+=over 4
+
+=item parse_vtable
+
+Returns a ref to an array containing
+
+ [ return_type method_name parameters section ]
+
+per vtable method defined in vtable.tbl
+
+=back
+
1.3 +13 -1 parrot/t/pmc/objects.t
Index: objects.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/objects.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- objects.t 21 Jul 2003 00:37:40 -0000 1.2
+++ objects.t 25 Aug 2003 17:49:02 -0000 1.3
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 3;
+use Parrot::Test tests => 4;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "findclass (base class)");
@@ -63,3 +63,15 @@
Bar
Baz
OUTPUT
+
+output_like(<<'CODE', <<'OUTPUT', "getclass");
+ newclass P1, "Foo"
+ getclass P2, "Foo"
+ printerr "ok 1\n"
+ getclass P3, "NoSuch"
+ end
+CODE
+/ok 1
+Class doesn't exist/
+OUTPUT
+
1.3 +16 -1 parrot/t/pmc/sarray.t
Index: sarray.t
===================================================================
RCS file: /cvs/public/parrot/t/pmc/sarray.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- sarray.t 4 Jul 2003 18:20:30 -0000 1.2
+++ sarray.t 25 Aug 2003 17:49:02 -0000 1.3
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 11;
+use Parrot::Test tests => 13;
use Test::More;
output_is(<<'CODE', <<'OUTPUT', "Setting sarray size");
@@ -410,3 +410,18 @@
ok 12
OUTPUT
+output_like(<<'CODE', <<'OUTPUT', "const SArray");
+ new P0, .ConstSArray
+ set P0, 10
+ end
+CODE
+/set_integer_native\(\) in ConstSArray/
+OUTPUT
+
+output_like(<<'CODE', <<'OUTPUT', "const SArray");
+ new P0, .ConstSArray
+ push P0, 10
+ end
+CODE
+/push_integer\(\) in ConstSArray/
+OUTPUT
1.41 +29 -27 parrot/vtable.tbl
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.40
retrieving revision 1.41
diff -u -w -r1.40 -r1.41
--- vtable.tbl 5 Aug 2003 13:47:53 -0000 1.40
+++ vtable.tbl 25 Aug 2003 17:49:03 -0000 1.41
@@ -1,4 +1,5 @@
-# $Id: vtable.tbl,v 1.40 2003/08/05 13:47:53 leo Exp $
+# $Id: vtable.tbl,v 1.41 2003/08/25 17:49:03 leo Exp $
+# [MAIN] #default section name
void init()
void init_pmc(PMC* initializer)
@@ -32,6 +33,7 @@
PMC* find_method_keyed(PMC* key, STRING* method_name)
PMC* find_method_keyed_int(INTVAL key, STRING* method_name)
+[FETCH]
INTVAL get_integer()
INTVAL get_integer_keyed(PMC* key)
INTVAL get_integer_keyed_int(INTVAL key)
@@ -52,18 +54,11 @@
INTVAL get_bool_keyed(PMC* key)
INTVAL get_bool_keyed_int(INTVAL key)
-INTVAL elements()
-INTVAL elements_keyed(PMC* key)
-INTVAL elements_keyed_int(INTVAL key)
-
PMC* get_pmc()
PMC* get_pmc_keyed(PMC* key)
PMC* get_pmc_keyed_int(INTVAL key)
-INTVAL is_same(PMC* value)
-INTVAL is_same_keyed(PMC* key, PMC* value)
-INTVAL is_same_keyed_int(INTVAL key, PMC* value)
-
+[STORE]
void set_integer(PMC* value)
void set_integer_native(INTVAL value)
void set_integer_same(PMC* value)
@@ -96,50 +91,45 @@
void set_same_keyed(PMC* key, PMC* value)
void set_same_keyed_int(INTVAL key, PMC* value)
-INTVAL pop_integer()
+[FETCHSIZE]
+INTVAL elements()
+INTVAL elements_keyed(PMC* key)
+INTVAL elements_keyed_int(INTVAL key)
+[POP]
+INTVAL pop_integer()
FLOATVAL pop_float()
-
BIGNUM* pop_bignum()
-
STRING* pop_string()
-
PMC* pop_pmc()
+[PUSH]
void push_integer(INTVAL value)
-
void push_float(FLOATVAL value)
-
void push_bignum(BIGNUM* value)
-
void push_string(STRING* value)
-
void push_pmc(PMC* value)
+[SHIFT]
INTVAL shift_integer()
-
FLOATVAL shift_float()
-
BIGNUM* shift_bignum()
-
STRING* shift_string()
-
PMC* shift_pmc()
+[UNSHIFT]
void unshift_integer(INTVAL value)
-
void unshift_float(FLOATVAL value)
-
void unshift_bignum(BIGNUM* value)
-
void unshift_string(STRING* value)
-
void unshift_pmc(PMC* value)
## void splice ???
+[SPLICE]
void splice(PMC* value, INTVAL offset, INTVAL count)
+[MATH]
void add(PMC* value, PMC* dest)
void add_int(INTVAL value, PMC* dest)
void add_bignum(BIGNUM* value, PMC* dest)
@@ -172,6 +162,7 @@
void neg(PMC* dest)
+[BITWISE]
void bitwise_or(PMC* value, PMC* dest)
void bitwise_or_int(INTVAL value, PMC* dest)
void bitwise_or_same(PMC* value, PMC* dest)
@@ -206,12 +197,18 @@
void bitwise_shr_int(INTVAL value, PMC* dest)
void bitwise_shr_same(PMC* value, PMC* dest)
+[STRING]
void concatenate(PMC* value, PMC* dest)
void concatenate_native(STRING* value, PMC* dest)
void concatenate_same(PMC* value, PMC* dest)
+[CMP]
INTVAL is_equal(PMC* value)
+INTVAL is_same(PMC* value)
+INTVAL is_same_keyed(PMC* key, PMC* value)
+INTVAL is_same_keyed_int(INTVAL key, PMC* value)
+
INTVAL cmp(PMC* value)
INTVAL cmp_num(PMC* value)
INTVAL cmp_string(PMC* value)
@@ -227,27 +224,32 @@
void repeat(PMC* value, PMC* dest)
void repeat_int(INTVAL value, PMC* dest)
+[MATH]
void increment()
-
void decrement()
+[EXISTS]
INTVAL exists_keyed(PMC* key)
INTVAL exists_keyed_int(INTVAL key)
+[MAIN]
INTVAL defined()
INTVAL defined_keyed(PMC* key)
INTVAL defined_keyed_int(INTVAL key)
+[DELETE]
void delete_keyed(PMC* key)
void delete_keyed_int(INTVAL key)
+[MAIN]
PMC* nextkey_keyed(PMC* key, INTVAL what)
PMC* nextkey_keyed_int(INTVAL key, INTVAL what)
+[STRING]
void substr(INTVAL offset, INTVAL length, PMC* dest)
-
STRING* substr_str(INTVAL offset, INTVAL length)
+[MAIN]
void* invoke(void* next)
void* invoke_pmc(PMC* sub, void* next)
