Ok, here is the updated schemepair-patch. The diff is agains a fresh update of anoncvs and should hopefully apply clean.
A Pair is implemented as an array with exact 2 elements. This elements may be PMC values, especially other Pairs. The car-element is index 0, the cdr-element is index 1. Lists are nested pairs with PerlUndef as end-of-list-marker. Maybe I should introduce a new PMC-type for this. To implement nested pairs its nessary to introduce 2 new vtable functions and the acompaning core.ops to get and set the PMC value of the indexed element. I choosed set_p_p_i and set_p_i_p. The later one is inconsistent with indexed set operations set_p_i_i, set_p_n_i and set_p_s_i. Maybe this time there is a little bit more discussion Juergen
? t.s
? boeboe
? pair.diff
? sp.diff
? t.diff
? classes/schemepair.pmc
? languages/scheme/foo.scheme
? languages/scheme/t/lists
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.100
diff -u -r1.100 MANIFEST
--- MANIFEST 22 Jan 2002 16:01:33 -0000 1.100
+++ MANIFEST 23 Jan 2002 20:21:00 -0000
@@ -51,6 +51,7 @@
classes/perlstring.pmc
classes/perlundef.pmc
classes/pmc2c.pl
+classes/schemepair.pmc
config_h.in
core.ops
disassemble.pl
@@ -180,6 +181,7 @@
languages/scheme/t/arith/nested.t
languages/scheme/t/harness
languages/scheme/t/io/basic.t
+languages/scheme/t/lists/basic.t
languages/scheme/t/logic/basic.t
make.pl
make_vtable_ops.pl
Index: Makefile.in
===================================================================
RCS file: /cvs/public/parrot/Makefile.in,v
retrieving revision 1.120
diff -u -r1.120 Makefile.in
--- Makefile.in 21 Jan 2002 03:25:25 -0000 1.120
+++ Makefile.in 23 Jan 2002 20:21:01 -0000
@@ -67,7 +67,8 @@
CLASS_O_FILES = classes/default$(O) classes/perlint$(O) classes/perlstring$(O) \
classes/perlnum$(O) classes/perlarray$(O) classes/perlundef$(O) \
-classes/perlhash$(O) classes/parrotpointer$(O) classes/intqueue$(O)
+classes/perlhash$(O) classes/parrotpointer$(O) classes/intqueue$(O) \
+classes/schemepair$(O)
ENCODING_O_FILES = encodings/singlebyte$(O) encodings/utf8$(O) encodings/utf16$(O) \
encodings/utf32$(O)
Index: core.ops
===================================================================
RCS file: /cvs/public/parrot/core.ops,v
retrieving revision 1.80
diff -u -r1.80 core.ops
--- core.ops 19 Jan 2002 07:12:53 -0000 1.80
+++ core.ops 23 Jan 2002 20:21:02 -0000
@@ -516,6 +516,14 @@
Set $1 to index $3 of hash $2
+=item B<set>(out PMC, in INT, in PMC)
+
+Set $1[$2] to $3
+
+=item B<set>(out PMC, in PMC, in INT)
+
+Set $1 to $2[$3]
+
=cut
@@ -574,6 +582,11 @@
goto NEXT();
}
+inline op set(out PMC, in PMC) {
+ $1 = $2;
+ goto NEXT();
+}
+
inline op set(out PMC, in INT, in INT) {
$1->vtable->set_integer_index(interpreter, $1, $2, $3);
goto NEXT();
@@ -604,6 +617,17 @@
goto NEXT();
}
+/* FIXME: Order of arguments diffrent from above */
+inline op set(out PMC, in INT, in PMC) {
+ $1->vtable->set_pmc_index (interpreter, $1, $3, $2);
+ goto NEXT();
+}
+
+inline op set(out PMC, in PMC, in INT) {
+ $1 = $2->vtable->get_pmc_index (interpreter, $2, $3);
+ goto NEXT();
+}
+
inline op set(out PMC, in INT, in STR) {
$1->vtable->set_integer_index_s(interpreter, $1, $2, $3);
goto NEXT();
@@ -2475,6 +2499,28 @@
}
newpmc = pmc_new(interpreter, $2);
$1 = newpmc;
+ goto NEXT();
+}
+
+=item B<get_type>(out INT, in PMC)
+
+get the type of the PMC C<p> and store it in C<i>
+
+=cut
+
+op get_type (out INT, in PMC) {
+ $1 = $2->vtable->type(interpreter, $2);
+ goto NEXT();
+}
+
+=item B<get_type>(out STR, in PMC)
+
+get the typename of the PMC C<p> and store it in C<s>
+
+=cut
+
+op get_type (out STR, in PMC) {
+ $1 = $2->vtable->name(interpreter, $2);
goto NEXT();
}
Index: global_setup.c
===================================================================
RCS file: /cvs/public/parrot/global_setup.c,v
retrieving revision 1.19
diff -u -r1.19 global_setup.c
--- global_setup.c 22 Jan 2002 01:04:50 -0000 1.19
+++ global_setup.c 23 Jan 2002 20:21:02 -0000
@@ -27,6 +27,7 @@
Parrot_PerlHash_class_init();
Parrot_ParrotPointer_class_init();
Parrot_IntQueue_class_init();
+ Parrot_SchemePair_class_init();
}
/*
Index: vtable.tbl
===================================================================
RCS file: /cvs/public/parrot/vtable.tbl,v
retrieving revision 1.12
diff -u -r1.12 vtable.tbl
--- vtable.tbl 14 Jan 2002 20:18:23 -0000 1.12
+++ vtable.tbl 23 Jan 2002 20:21:02 -0000
@@ -58,3 +58,7 @@
unique void logical_not PMC* value
str void match PMC* value REGEX* re
str void repeat PMC* value PMC* dest
+
+unique void set_pmc_index PMC* value INTVAL index
+unique PMC* get_pmc_index INTVAL index
+
Index: classes/Makefile.in
===================================================================
RCS file: /cvs/public/parrot/classes/Makefile.in,v
retrieving revision 1.18
diff -u -r1.18 Makefile.in
--- classes/Makefile.in 15 Jan 2002 16:15:16 -0000 1.18
+++ classes/Makefile.in 23 Jan 2002 20:21:02 -0000
@@ -5,9 +5,8 @@
H_FILES = $(INC)/parrot.h default.h
-
O_FILES = default$(O) perlint$(O) perlstring$(O) perlnum$(O) perlarray$(O) \
-perlhash$(O) perlundef$(O) parrotpointer$(O) intqueue$(O)
+perlhash$(O) perlundef$(O) parrotpointer$(O) intqueue$(O) schemepair$(O)
#DO NOT ADD C COMPILER FLAGS HERE
#Add them in Configure.pl--look for the
@@ -70,6 +69,11 @@
$(PERL) pmc2c.pl intqueue.pmc
intqueue$(O): $(H_FILES)
+
+schemepair.c schemepair.h: schemepair.pmc
+ $(PERL) pmc2c.pl schemepair.pmc
+
+schemepair$(O): $(H_FILES)
clean:
$(RM_F) *.c *$(O) default.h
Index: classes/default.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/default.pmc,v
retrieving revision 1.9
diff -u -r1.9 default.pmc
--- classes/default.pmc 22 Jan 2002 01:04:52 -0000 1.9
+++ classes/default.pmc 23 Jan 2002 20:21:03 -0000
@@ -562,4 +562,10 @@
value->vtable->get_integer(INTERP, value), NULL) );
}
+ void set_pmc_index (PMC * value, INTVAL index) {
+ }
+
+ PMC* get_pmc_index (INTVAL index) {
+ }
+
}
Index: classes/perlarray.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlarray.pmc,v
retrieving revision 1.8
diff -u -r1.8 perlarray.pmc
--- classes/perlarray.pmc 22 Jan 2002 01:04:53 -0000 1.8
+++ classes/perlarray.pmc 23 Jan 2002 20:21:03 -0000
@@ -15,7 +15,7 @@
pmclass PerlArray {
INTVAL type () {
- return 0;
+ return enum_class_PerlArray;
}
STRING* name() {
Index: classes/perlint.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlint.pmc,v
retrieving revision 1.15
diff -u -r1.15 perlint.pmc
--- classes/perlint.pmc 22 Jan 2002 01:04:53 -0000 1.15
+++ classes/perlint.pmc 23 Jan 2002 20:21:03 -0000
@@ -15,7 +15,7 @@
pmclass PerlInt {
INTVAL type () {
- return 0;
+ return enum_class_PerlInt;
}
STRING* name() {
Index: classes/perlnum.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlnum.pmc,v
retrieving revision 1.17
diff -u -r1.17 perlnum.pmc
--- classes/perlnum.pmc 22 Jan 2002 01:04:53 -0000 1.17
+++ classes/perlnum.pmc 23 Jan 2002 20:21:03 -0000
@@ -15,7 +15,7 @@
pmclass PerlNum {
INTVAL type () {
- return 0;
+ return enum_class_PerlNum;
}
STRING* name() {
Index: classes/perlstring.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlstring.pmc,v
retrieving revision 1.15
diff -u -r1.15 perlstring.pmc
--- classes/perlstring.pmc 22 Jan 2002 01:04:53 -0000 1.15
+++ classes/perlstring.pmc 23 Jan 2002 20:21:03 -0000
@@ -15,7 +15,7 @@
pmclass PerlString {
INTVAL type () {
- return 0;
+ return enum_class_PerlString;
}
STRING* name() {
Index: classes/perlundef.pmc
===================================================================
RCS file: /cvs/public/parrot/classes/perlundef.pmc,v
retrieving revision 1.6
diff -u -r1.6 perlundef.pmc
--- classes/perlundef.pmc 22 Jan 2002 01:04:53 -0000 1.6
+++ classes/perlundef.pmc 23 Jan 2002 20:21:03 -0000
@@ -15,6 +15,7 @@
pmclass PerlUndef {
INTVAL type () {
+ return enum_class_PerlUndef;
}
STRING* name () {
Index: include/parrot/pmc.h
===================================================================
RCS file: /cvs/public/parrot/include/parrot/pmc.h,v
retrieving revision 1.14
diff -u -r1.14 pmc.h
--- include/parrot/pmc.h 13 Jan 2002 17:46:24 -0000 1.14
+++ include/parrot/pmc.h 23 Jan 2002 20:21:04 -0000
@@ -22,6 +22,7 @@
enum_class_PerlHash,
enum_class_ParrotPointer,
enum_class_IntQueue,
+ enum_class_SchemePair,
enum_class_max
};
VAR_SCOPE VTABLE Parrot_base_vtables[enum_class_max];
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.1
diff -u -r1.1 Generator.pm
--- languages/scheme/Scheme/Generator.pm 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/Scheme/Generator.pm 23 Jan 2002 20:21:04 -0000
@@ -3,6 +3,9 @@
use strict;
use Data::Dumper;
+sub PerlUndef { 0 }
+sub SchemePair { 8 }
+
sub _gensym {
return sprintf "G%04d",shift->{gensym}++;
}
@@ -11,7 +14,6 @@
my $self = shift;
push @{$self->{instruction}},[@_];
}
-
#------------------------------------
my $regs = {
@@ -39,6 +41,12 @@
@temp;
}
+sub _save_1 {
+ my $type = shift || 'I';
+ my @temp = _save 1, $type;
+ $temp[0];
+}
+
sub _restore {
die "Nothing to restore"
unless defined @_;
@@ -92,7 +100,7 @@
my $return;
my $label = $self->_gensym();
- $return = "I"._save(1,'I');
+ $return = "I"._save(1,'I');
my $cond = $self->_generate($node->{children}[0]);
$self->_add_inst('','eq',[$cond,0,"FALSE_$label"]);
my $true = $self->_generate($node->{children}[1]);
@@ -194,34 +202,206 @@
sub _op_equal_p {
}
-sub _op_pair {
+sub _op_pair_p {
+ my ($self,$node) = @_;
+ my $return;
+
+ print STDERR "pair?: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ $return = $self->_constant(0);
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ if ($temp =~ m/^P/) {
+ my $type = _save_1('I');
+ my $label = $self->_gensym();
+
+ $self->_add_inst ('', 'get_type', [$type,$temp]);
+ $self->_add_inst ('', 'ne', [SchemePair,$type,"DONE_$label"]);
+ $self->_add_inst ('', 'set', [$return,'1']);
+ $self->_add_inst("DONE_$label");
+ _restore ($type);
+ }
+
+ _restore($temp);
+ return $return;
}
sub _op_cons {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "cons: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $car = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'new', [$return,'SchemePair']);
+ if ($car =~ m/^P/) { # FIXME: This is for the strange order index in set
+ $self->_add_inst ('', 'set', [$return,'0',$car]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$return,$car,'0']);
+ }
+ _restore ($car);
+
+ my $cdr = $self->_generate($node->{children}->[1]);
+ if ($cdr =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$return,'1',$cdr]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$return,$cdr,'1']);
+ }
+ _restore ($cdr);
+
+ return $return;
}
sub _op_car {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "car: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'set', [$return,$temp,'0']);
+ _restore ($temp);
+
+ return $return;
}
sub _op_cdr {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "cdr: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+ $self->_add_inst ('', 'set', [$return,$temp,'1']);
+ _restore ($temp);
+
+ return $return;
}
sub _op_set_car {
+ my ($self, $node) = @_;
+
+ print STDERR "set-cdr!: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $pair = $self->_generate($node->{children}->[0]);
+ my $value = $self->_generate($node->{children}->[1]);
+
+ if ($value =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$pair, '0', $value]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$pair, $value, '0']);
+ }
+ _restore ($value);
+
+ return $pair; # FIXME: This value should be unspecified
}
sub _op_set_cdr {
+ my ($self, $node) = @_;
+
+ print STDERR "set-cdr!: wrong number of arguments\n"
+ unless $#{$node->{children}} == 1;
+
+ my $pair = $self->_generate($node->{children}->[0]);
+ my $value = $self->_generate($node->{children}->[1]);
+
+ if ($value =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$pair, '1', $value]);
+ }
+ else {
+ $self->_add_inst ('', 'set', [$pair, $value, '1']);
+ }
+ _restore ($value);
+
+ return $pair; # FIXME: This value should be unspecified
}
-sub _op_null {
+sub _op_null_p {
+ my ($self, $node) = @_;
+ my $return;
+
+ print STDERR "null?: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ my $temp = $self->_generate($self->{children}->[0]);
+ $return = $self->constant(0);
+ if ( $temp =~ m/^P/) {
+ my $label = $self->_gensym();
+ my $type = _save_1('1');
+
+ $self->_add_inst ('', 'get_type', [$type, $temp]);
+ $self->_add_inst ('', 'ne', [$type, PerlUndef, "DONE_$label"]);
+ $self->_add_inst ('', 'set', [$return, '1']);
+ _restore ($type);
+ }
+
+ _restore ($temp);
+
+ return $return;
}
sub _op_list_p {
}
sub _op_list {
+ my ($self, $node) = @_;
+ my $return = _save_1 ('P');
+
+ $self->_add_inst ('', 'new', [$return, 'PerlUndef']);
+
+ if ($node->{children}) {
+ my $item;
+ my $lastitem;
+ for (my $i = $#{$node->{children}}; $i >= 0; $i--) {
+ $item = $self->_generate ($node->{children}->[$i]);
+ $lastitem = _save_1 ('P');
+ $self->_add_inst ('', 'new', [$lastitem, 'SchemePair']);
+ $self->_add_inst ('', 'set', [$lastitem, '1', $return]);
+ if ($item =~ m/^P/) {
+ $self->_add_inst ('', 'set', [$lastitem, '0', $item]);
+ } else {
+ $self->_add_inst ('', 'set', [$lastitem, $item, '0']);
+ }
+ $self->_add_inst ('', 'set', [$return, $lastitem]);
+ _restore ($item, $lastitem);
+ }
+ }
+
+ return $return;
}
sub _op_length {
+ my ($self,$node) = @_;
+ my $return;
+ my $label = $self->_gensym();
+
+ print STDERR "length: wrong number of arguments\n"
+ unless $#{$node->{children}} == 0;
+
+ $return = $self->_constant(0);
+
+ my $list = $self->_generate($node->{children}->[0]);
+ my $type = _save_1('I');
+ $self->_add_inst("LOOP_$label", 'get_type', [$type,$list]);
+ $self->_add_inst('', 'ne', [$type,SchemePair,"DONE_$label"]);
+ $self->_add_inst('', 'inc', [$return]);
+ $self->_add_inst('', 'set', [$list,$list,'1']);
+ $self->_add_inst('', 'branch', ["LOOP_$label"]);
+ $self->_add_inst("DONE_$label");
+ _restore ($list, $type);
+
+ return $return
}
sub _op_append {
@@ -1019,8 +1199,8 @@
'cons' => \&_op_cons,
'car' => \&_op_car,
'cdr' => \&_op_cdr,
- 'set-car!' => \&_op_set_car_bang,
- 'set-cdr!' => \&_op_set_cdr_bang,
+ 'set-car!' => \&_op_set_car,
+ 'set-cdr!' => \&_op_set_cdr,
# Not adding caar/cadr/cdar/whatever
'null?' => \&_op_null_p,
'list?' => \&_op_list_p,
@@ -1322,10 +1502,11 @@
sub generate {
my $self = shift;
my @temp = _save(1);
- $self->_generate($self->{tree},$temp[0]);
#die Dumper($self->{tree});
+ $self->_generate($self->{tree},$temp[0]);
_restore(@temp);
$self->_add_inst('',"end");
+# print STDERR Dumper $self->{instruction};
$self->_format_columns();
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.1
diff -u -r1.1 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/Scheme/Tokenizer.pm 23 Jan 2002 20:21:05 -0000
@@ -34,6 +34,9 @@
} elsif($ch eq '?' and
$token =~ /^[a-z]/) { # Question marks can follow an identifier
$token .= $ch;
+ } elsif($ch eq '!' and
+ $token =~ /^[a-z]/) { # Exclamaition marks can follow an identifier
+ $token .= $ch;
} elsif($ch eq '=' and
$token =~ /^[<>]/) { # Equal sign can follow '<','>'
$token .= $ch;
Index: languages/scheme/t/harness
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/t/harness,v
retrieving revision 1.1
diff -u -r1.1 harness
--- languages/scheme/t/harness 24 Oct 2001 19:27:20 -0000 1.1
+++ languages/scheme/t/harness 23 Jan 2002 20:21:05 -0000
@@ -4,5 +4,5 @@
use Test::Harness qw(runtests);
use lib '../..';
-my @tests = map { glob( "t/$_/*.t" ) } ( qw(io arith logic) );
+my @tests = map { glob( "t/$_/*.t" ) } ( qw(io arith logic lists) );
runtests( @tests );
schemepair.pmc
Description: Binary data
basic.t
Description: Binary data
