cvsuser 02/09/05 08:04:27
Modified: . MANIFEST core.ops
languages/scheme/Scheme Generator.pm Tokenizer.pm
t/op string.t
Log:
chr op, and scheme fixes
Revision Changes Path
1.209 +7 -0 parrot/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.208
retrieving revision 1.209
diff -u -w -r1.208 -r1.209
--- MANIFEST 4 Sep 2002 23:14:46 -0000 1.208
+++ MANIFEST 5 Sep 2002 15:03:23 -0000 1.209
@@ -58,6 +58,8 @@
config/gen/config_h/config_h.in
config/gen/config_pm.pl
config/gen/config_pm/Config_pm.in
+config/gen/libparrot_def.pl
+config/gen/libparrot_def/libparrot_def.in
config/gen/makefiles.pl
config/gen/makefiles/classes.in
config/gen/makefiles/docs.in
@@ -68,6 +70,7 @@
config/gen/makefiles/perl6.in
config/gen/makefiles/root.in
config/gen/makefiles/scheme.in
+config/gen/makefiles/imcc.in
config/gen/myconfig.pl
config/gen/myconfig/myconfig.in
config/gen/platform.pl
@@ -379,6 +382,7 @@
languages/perl6/examples/mandel.p6
languages/perl6/examples/qsort.p6
languages/perl6/mkdistro.sh
+languages/perl6/overview.pod
languages/perl6/pconfig.pl
languages/perl6/perl6
languages/perl6/perl6re/Perl6RE.bnf
@@ -435,6 +439,7 @@
languages/perl6/t/parser/speed_3.exp
languages/perl6/t/parser/speed_3.pl
languages/perl6/t/rx/basic.t
+languages/perl6/t/rx/call.t
languages/perl6/t/rx/special.t
languages/python/python.bnf
languages/python/python.prd
@@ -488,6 +493,7 @@
languages/ruby/t/01_terminal.t
languages/ruby/t/02_expression.t
languages/scheme/Scheme.pm
+languages/scheme/Scheme/Builtins.pm
languages/scheme/Scheme/Generator.pm
languages/scheme/Scheme/Parser.pm
languages/scheme/Scheme/Test.pm
@@ -499,6 +505,7 @@
languages/scheme/t/harness
languages/scheme/t/io/basic.t
languages/scheme/t/logic/basic.t
+languages/scheme/t/logic/lists.t
lib/Class/Struct.pm
lib/Make.pm
lib/Parrot/BuildUtil.pm
1.206 +16 -0 parrot/core.ops
Index: core.ops
===================================================================
RCS file: /cvs/public/parrot/core.ops,v
retrieving revision 1.205
retrieving revision 1.206
diff -u -w -r1.205 -r1.206
--- core.ops 5 Sep 2002 14:54:00 -0000 1.205
+++ core.ops 5 Sep 2002 15:03:23 -0000 1.206
@@ -201,6 +201,22 @@
goto NEXT();
}
+=item B<chr>(out STR, in INT)
+
+Returns the character represented by the $2 number in the ASCII
+character set.
+
+=cut
+
+inline op chr (out STR, in INT) {
+ STRING *s;
+ s = string_make(interpreter, &$1, (UINTVAL)1, NULL, 0, NULL);
+ *(char *)s->bufstart = $2;
+ s->strlen = 1;
+ $1 = s;
+ goto NEXT();
+}
+
########################################
1.3 +177 -4 parrot/languages/scheme/Scheme/Generator.pm
Index: Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- Generator.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ Generator.pm 5 Sep 2002 15:03:55 -0000 1.3
@@ -2,6 +2,7 @@
use strict;
use Data::Dumper;
+use Scheme::Builtins;
sub _gensym {
return sprintf "G%04d",shift->{gensym}++;
@@ -39,6 +40,12 @@
@temp;
}
+sub _save_1 {
+ my $type = shift || 'I';
+ my @temp = _save 1, $type;
+ $temp[0];
+}
+
sub _restore {
die "Nothing to restore"
unless defined @_;
@@ -50,6 +57,15 @@
}
}
+sub _num_arg {
+ my ($node, $expected, $name) = @_;
+
+ my $children = scalar @{$node->{children}};
+
+ die "$name: Wrong number of arguments (expected $expected, got $children).\n"
+ if ($children != $expected);
+}
+
#------------------------------------
my $type_map = {
@@ -194,22 +210,105 @@
sub _op_equal_p {
}
-sub _op_pair {
+sub _op_pair_p {
+ my ($self, $node) = @_;
+ my $return;
+ my $label = $self->_gensym();
+
+ _num_arg ($node, 1, 'pair?');
+
+ my $item = $self->_generate($node->{children}->[0]);
+
+ $return = _save_1 ('I');
+
+ if ($item =~ /^[INS]/) {
+ $self->_add_inst ('', 'set', [$return,0]);
+ }
+ else {
+ $self->_add_inst ('', 'typeof', [$return,$item]);
+ $self->_add_inst ('', 'ne', [$return,'.Array',"FAIL_$label"]);
+ $self->_add_inst ('', 'set', [$return,$item]);
+ $self->_add_inst ('', 'ne', [$return,2,"FAIL_$label"]);
+ $self->_add_inst ('', 'set', [$return,1]);
+ $self->_add_inst ('', 'branch', ["DONE_$label"]);
+ $self->_add_inst ("FAIL_$label", 'set', [$return,0]);
+ $self->_add_inst ("DONE_$label");
+ }
+
+ return $return;
}
sub _op_cons {
+ my ($self, $node) = @_;
+ my $return;
+
+ _num_arg ($node, 2, 'cons');
+
+ my $car = $self->_generate($node->{children}->[0]);
+ $return = _save_1('P');
+
+ $self->_add_inst ('', 'new', [$return,'.Array']);
+ $self->_add_inst ('', 'set', [$return,2]);
+ $self->_add_inst ('', 'set', [$return.'[0]',$car]);
+ _restore ($car);
+
+ my $cdr = $self->_generate($node->{children}->[1]);
+ $self->_add_inst ('', 'set', [$return.'[1]', $cdr]);
+ _restore ($cdr);
+
+ return $return;
}
sub _op_car {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 1, 'car');
+
+ my $return = $self->_generate ($node->{children}->[0]);
+ die "car: Element not pair\n" unless $return =~ /^P/;
+ $self->_add_inst ('', 'set', [$return,$return.'[0]']);
+
+ return $return;
}
sub _op_cdr {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 1, 'cdr');
+
+ my $return = $self->_generate ($node->{children}->[0]);
+ die "cdr: Element not pair\n" unless $return =~ /^P/;
+ $self->_add_inst ('', 'set', [$return,$return.'[1]']);
+
+ return $return;
}
-sub _op_set_car {
+sub _op_set_car_bang {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'set-car!');
+
+ my $return = $self->_generate ($node->{children}->[0]);
+ die "set-car!: Element not pair\n" unless $return =~ /^P/;
+ my $value = $self->_generate ($node->{children}->[1]);
+ $self->_add_inst ('', 'set', [$return.'[0]',$value]);
+ _restore ($value);
+
+ return $return;
}
-sub _op_set_cdr {
+sub _op_set_cdr_bang {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'set-cdr!');
+
+ my $return = $self->_generate ($node->{children}->[0]);
+ die "set-cdr!: Element not pair\n" unless $return =~ /^P/;
+ my $value = $self->_generate ($node->{children}->[1]);
+ $self->_add_inst ('', 'set', [$return.'[1]',$value]);
+ _restore ($value);
+
+ return $return;
}
sub _op_null {
@@ -219,9 +318,53 @@
}
sub _op_list {
+ my ($self, $node) = @_;
+ my $label = $self->_gensym ();
+ my $return = _save_1 ('P');
+
+ $self->_add_inst ('', 'new',[$return,'.PerlUndef']);
+
+ return $return unless exists $node->{children};
+
+ for (reverse @{$node->{children}}) {
+ my $item = $self->_generate($_);
+ my $pair = _save_1 ('P');
+
+ $self->_add_inst ('', 'new',[$pair,'.Array']);
+ $self->_add_inst ('', 'set',[$pair,2]);
+ $self->_add_inst ('', 'set',[$pair.'[0]',$item]);
+ $self->_add_inst ('', 'set',[$pair.'[1]',$return]);
+ $self->_add_inst ('', 'set',[$return,$pair]);
+
+ _restore($item, $pair);
+ }
+
+ return $return;
}
sub _op_length {
+ my ($self, $node) = @_;
+ my $label = $self->_gensym ();
+ my $return = _save_1 ('I');
+
+ _num_arg ($node, 1, 'length');
+
+ my $list = $self->_generate($node->{children}->[0]);
+
+ $self->_add_inst ('', 'set',[$return,'0']);
+ my $type = _save_1 ('I');
+ $self->_add_inst ("NEXT_$label", 'typeof',[$type,$list]);
+ $self->_add_inst ('', 'eq',[$type,'.PerlUndef', "DONE_$label"]);
+ $self->_add_inst ('', 'ne',[$type,'.Array', "ERR_$label"]);
+ $self->_add_inst ('', 'inc',[$return]);
+ $self->_add_inst ('', 'set',[$list,$list.'[1]']);
+ $self->_add_inst ('', 'branch',["NEXT_$label"]);
+ # XXX Use exceptions here
+ $self->_add_inst ("ERR_$label", 'print',['"Object is not a list\n"']);
+
+ $self->_add_inst ("DONE_$label");
+
+ return $return;
}
sub _op_append {
@@ -903,7 +1046,20 @@
my ($self,$node) = @_;
for(@{$node->{children}}) {
my $temp = $self->_generate($_);
+ if ($temp =~ /[INS]/) {
$self->_add_inst('','print',[$temp]);
+ }
+ else {
+ $self->_use_function ('write');
+ if ($temp ne 'P5') {
+ $self->_add_inst('', 'save', ['P5']) if $regs->{P}{5};
+ $self->_add_inst('', 'set', ['P5',$temp]);
+ }
+ $self->_add_inst('', 'bsr', ['write_ENTRY']);
+ if ($temp ne 'P5' && $regs->{P}{5}) {
+ $self->_add_inst('', 'restore', ['P5']);
+ }
+ }
_restore($temp);
}
}
@@ -1264,6 +1420,13 @@
@max_len;
}
+sub _use_function {
+ my ($self, $name) = @_;
+
+ push @{$self->{functions}}, $name
+ unless grep { $_ eq $name } @{$self->{functitons}};
+}
+
sub _format_columns {
my $self = shift;
my $colref = $self->{instruction};
@@ -1290,6 +1453,7 @@
tree => $tree,
register => [(0) x 32],
gensym => 0,
+ functions=> [],
};
bless $self,$class;
}
@@ -1319,6 +1483,14 @@
$return;
}
+sub _link_buildins {
+ my ($self) = @_;
+
+ for (@{$self->{functions}}) {
+ Scheme::Builtins::generate ($self, $_);
+ }
+}
+
sub generate {
my $self = shift;
my @temp = _save(1);
@@ -1326,6 +1498,7 @@
#die Dumper($self->{tree});
_restore(@temp);
$self->_add_inst('',"end");
+ $self->_link_buildins();
$self->_format_columns();
}
1.3 +3 -0 parrot/languages/scheme/Scheme/Tokenizer.pm
Index: Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -w -r1.2 -r1.3
--- Tokenizer.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ Tokenizer.pm 5 Sep 2002 15:03:55 -0000 1.3
@@ -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]/) { # Exclamation marks can follow an identifier
+ $token .= $ch;
} elsif($ch eq '=' and
$token =~ /^[<>]/) { # Equal sign can follow '<','>'
$token .= $ch;
1.32 +19 -1 parrot/t/op/string.t
Index: string.t
===================================================================
RCS file: /cvs/public/parrot/t/op/string.t,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -w -r1.31 -r1.32
--- string.t 4 Sep 2002 13:49:55 -0000 1.31
+++ string.t 5 Sep 2002 15:04:27 -0000 1.32
@@ -1,6 +1,6 @@
#! perl -w
-use Parrot::Test tests => 91;
+use Parrot::Test tests => 94;
use Test::More;
output_is( <<'CODE', <<OUTPUT, "set_s_s|sc" );
@@ -1000,6 +1000,24 @@
set S0,"ab"
ord I0,S0,-3
print I0
+ end
+CODE
+
+output_is(<<'CODE',chr(32),'chr of 32 is space in ASCII');
+ chr S0, 32
+ print S0
+ end
+CODE
+
+output_is(<<'CODE',chr(65),'chr of 65 is A in ASCII');
+ chr S0, 65
+ print S0
+ end
+CODE
+
+output_is(<<'CODE',chr(122),'chr of 122 is z in ASCII');
+ chr S0, 122
+ print S0
end
CODE
