# New Ticket Created by Jürgen Bömmels
# Please include the string: [perl #17109]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=17109 >
Hi,
the next patch to languages/scheme. It implements the quote and a
first cut of define and set!. They work only for values at the Moment,
functions are next.
In order to get quote working I had to change the Parser in a
fundamentel way: The tree now monitors exaktly the structure of the
parens, and not special-casing the first argument. I think this is
also neccessary to get things like ((if (= 1 0) + -) 1 2) running.
It leads to an off by one in the node children, but thats rather
trivial to fix. Anyway all tests pass.
define and set! use find_lex and store_lex to read and store its
values. As there are no functions ATM they only work for values.
bye
b.
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/37055/29973/418c30/scheme.diff
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.216
diff -u -r1.216 MANIFEST
--- MANIFEST 9 Sep 2002 07:21:48 -0000 1.216
+++ MANIFEST 9 Sep 2002 22:48:14 -0000
@@ -514,6 +514,7 @@
languages/scheme/t/harness
languages/scheme/t/io/basic.t
languages/scheme/t/logic/basic.t
+languages/scheme/t/logic/defines.t
languages/scheme/t/logic/lists.t
lib/Class/Struct.pm
lib/Make.pm
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.3
diff -u -r1.3 Generator.pm
--- languages/scheme/Scheme/Generator.pm 5 Sep 2002 15:03:55 -0000 1.3
+++ languages/scheme/Scheme/Generator.pm 9 Sep 2002 22:48:15 -0000
@@ -60,10 +60,25 @@
sub _num_arg {
my ($node, $expected, $name) = @_;
- my $children = scalar @{$node->{children}};
+ my $args = scalar @{$node->{children}} - 1;
- die "$name: Wrong number of arguments (expected $expected, got $children).\n"
- if ($children != $expected);
+ die "$name: Wrong number of arguments (expected $expected, got $args).\n"
+ if ($args != $expected);
+}
+
+sub _get_arg {
+ my ($node, $num) = @_;
+ $node->{children}->[$num];
+}
+
+sub _get_args {
+ my ($node, $num) = @_;
+ $num = 1 unless defined $num;
+
+ my @args = @{$node->{children}};
+ splice @args, 0, $num;
+
+ return @args;
}
#------------------------------------
@@ -78,26 +93,90 @@
#------------------------------------
-sub _op_constant {
- my ($self,$node) = @_;
- my ($num_registers,$type) = @{$type_map->{$node->{type}}};
- my @register = _save($num_registers,$type);
- for(@register) {
- $self->_add_inst('','set',[$_,$node->{value}]);
+sub _constant {
+ my ($self, $value) = @_;
+ my $return;
+
+ if ($value =~ /^[-+]?\d+$/) {
+ $return = _save_1 ('I');
+ $self->_add_inst ('', 'set', [$return,$value]);
+ }
+ elsif ($value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/) {
+ $return = _save_1 ('N');
+ $self->_add_inst ('', 'set', [$return,$value]);
+ }
+ else {
+ $return = _save_1 ('I');
+ $self->_add_inst ('', 'set', [$return,0]);
}
- return $register[0];
-}
-sub _constant {
- my ($self,$value) = @_;
- return $self->_generate({value=>$value,type=>'INTEGER'});
+ return $return;
}
-#------------------------------------
+sub _morph {
+ my ($self, $to, $from) = @_;
+
+ if ($to =~ /P/) {
+ if ($from =~ /P/) {
+ $self->_add_inst ('', 'clone',[$to,$from]);
+ } elsif ($from =~ /I/) {
+ $self->_add_inst ('', 'new',[$to,'.PerlInt']);
+ $self->_add_inst ('', 'set',[$to,$from]);
+ } elsif ($from =~ /N/) {
+ $self->_add_inst ('', 'new',[$to,'.PerlNum']);
+ $self->_add_inst ('', 'set',[$to,$from]);
+ }
+ }
+}
#---- Section 4 ----
+sub __quoted {
+ my ($self, $node) = @_;
+ my $return = _save_1 ('P');
+
+ if (exists $node->{value}) {
+ my $value = $node->{value};
+ if ($value =~ /^[-+]?\d+$/) {
+ $self->_add_inst ('', 'new',[$return,'.PerlInt']);
+ $self->_add_inst ('', 'set',[$return,$value]);
+ }
+ elsif ($value =~ /^[-+]?((\d+\.\d*)|(\.d+))([eE][-+]?\d+)?$/) {
+ $self->_add_inst ('', 'new',[$return,'.PerlNum']);
+ $self->_add_inst ('', 'set',[$return,$value]);
+ }
+ else { # assume its a symbol
+ $self->_add_inst ('', 'new',[$return,'.PerlString']);
+ $self->_add_inst ('', 'set',[$return,"\"$value\""]);
+ }
+ }
+ elsif (exists $node->{children}) {
+ $self->_add_inst ('', 'new', [$return,'.PerlUndef']);
+ for (reverse @{$node->{children}}) {
+
+ my $item = __quoted ($self, $_);
+ 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_quote {
+ my ($self, $node) = @_;
+ my $return;
+
+ _num_arg ($node, 1, 'quote');
+
+ my $item = _get_arg($node,1);
+
+ return __quoted ($self, $item);
}
sub _op_lambda {
@@ -108,23 +187,73 @@
my $return;
my $label = $self->_gensym();
- $return = "I"._save(1,'I');
- my $cond = $self->_generate($node->{children}[0]);
+ my $cond = $self->_generate(_get_arg($node,1));
$self->_add_inst('','eq',[$cond,0,"FALSE_$label"]);
- my $true = $self->_generate($node->{children}[1]);
- $self->_add_inst('','set',[$return,$true]);
+ _restore($cond);
+ $return = _save_1 ('P');
+
+ my $true = $self->_generate(_get_arg($node,2));
+ $self->_morph($return,$true);
$self->_add_inst('','branch',["DONE_$label"]);
- $self->_add_inst("FALSE_$label");
_restore($true);
- _restore($cond);
- my $false = $self->_generate($node->{children}[2]);
- $self->_add_inst('','set',[$return,$false]);
+
+ $self->_add_inst("FALSE_$label");
+ my $false = $self->_generate(_get_arg($node,3));
+ $self->_morph($return,$false);
_restore($false);
+
$self->_add_inst("DONE_$label");
return $return;
}
+sub _op_define {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'define');
+
+ if (!exists _get_arg($node,1)->{value}) {
+ die "define: function defines not yet implemented";
+ }
+ my $symbol = _get_arg($node,1)->{value};
+
+ if (exists $self->{scope}->{$symbol}) {
+ die "define: $symbol is already defined\n";
+ }
+
+ my $temp = $self->_generate (_get_arg($node,2));
+
+ if ($temp !~ /^P/) {
+ my $pmc = _save_1 ('P');
+ $self->_morph ($pmc, $temp);
+ _restore ($temp);
+ $temp = $pmc;
+ }
+
+ $self->{scope}->{$symbol} = 1;
+ $self->_add_inst ('', 'store_lex', ["\"$symbol\"",$temp]);
+
+ return $temp;
+}
+
sub _op_set_bang {
+ my ($self, $node) = @_;
+
+ _num_arg ($node, 2, 'set!');
+
+ my $symbol = _get_arg ($node, 1)->{value};
+ if (!exists $self->{scope}->{$symbol}) {
+ die "set!: $symbol not in current scope!";
+ }
+ my $temp = $self->_generate(_get_arg($node,2));
+ if ($temp !~ /^P/) {
+ my $pmc = _save_1 ('P');
+ $self->_morph ($pmc, $temp);
+ _restore ($temp);
+ $temp = $pmc;
+ }
+ $self->_add_inst ('', 'store_lex', ["\"$symbol\"",$temp]);
+
+ return $temp;
}
sub _op_cond {
@@ -139,7 +268,7 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- for(@{$node->{children}}) {
+ for(_get_args($node)) {
my $temp = $self->_generate($_);
$self->_add_inst('' ,'eq' ,[$temp,0,"DONE_$label"]);
_restore($temp);
@@ -155,7 +284,7 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- for(@{$node->{children}}) {
+ for(_get_args($node)) {
my $temp = $self->_generate($_);
$self->_add_inst('' ,'eq' ,[$temp,1,"DONE_$label"]);
_restore($temp);
@@ -175,6 +304,16 @@
}
sub _op_begin {
+ my ($self, $node) = @_;
+ my $temp = _save_1('I');
+
+ my @args = _get_args ($node);
+
+ for (@args) {
+ _restore ($temp);
+ $temp = $self->_generate ($_);
+ }
+ return $temp;
}
sub _op_do {
@@ -189,13 +328,13 @@
#---- Section 6 ----
sub _op_not {
- my ($self,$node,$return) = @_;
+ my ($self,$node) = @_;
- my @temp = _save(1);
- $self->_generate($node->{children}[0],$temp[0]);
- $self->_add_inst('','not',[$temp[0],$temp[0]]);
- $self->_add_inst('','and',[$return,$temp[0],1]);
- _restore(@temp);
+ my $return = _save_1 ('I');
+ $self->_generate(_get_arg($node,1));
+ $self->_add_inst('','not',[$return,$return]);
+
+ $return;
}
sub _op_boolean_p {
@@ -217,7 +356,7 @@
_num_arg ($node, 1, 'pair?');
- my $item = $self->_generate($node->{children}->[0]);
+ my $item = $self->_generate(_get_arg($node,1));
$return = _save_1 ('I');
@@ -244,7 +383,7 @@
_num_arg ($node, 2, 'cons');
- my $car = $self->_generate($node->{children}->[0]);
+ my $car = $self->_generate(_get_arg($node,1));
$return = _save_1('P');
$self->_add_inst ('', 'new', [$return,'.Array']);
@@ -252,7 +391,7 @@
$self->_add_inst ('', 'set', [$return.'[0]',$car]);
_restore ($car);
- my $cdr = $self->_generate($node->{children}->[1]);
+ my $cdr = $self->_generate(_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[1]', $cdr]);
_restore ($cdr);
@@ -264,7 +403,7 @@
_num_arg ($node, 1, 'car');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "car: Element not pair\n" unless $return =~ /^P/;
$self->_add_inst ('', 'set', [$return,$return.'[0]']);
@@ -276,7 +415,7 @@
_num_arg ($node, 1, 'cdr');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "cdr: Element not pair\n" unless $return =~ /^P/;
$self->_add_inst ('', 'set', [$return,$return.'[1]']);
@@ -288,9 +427,9 @@
_num_arg ($node, 2, 'set-car!');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "set-car!: Element not pair\n" unless $return =~ /^P/;
- my $value = $self->_generate ($node->{children}->[1]);
+ my $value = $self->_generate (_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[0]',$value]);
_restore ($value);
@@ -302,16 +441,32 @@
_num_arg ($node, 2, 'set-cdr!');
- my $return = $self->_generate ($node->{children}->[0]);
+ my $return = $self->_generate (_get_arg($node,1));
die "set-cdr!: Element not pair\n" unless $return =~ /^P/;
- my $value = $self->_generate ($node->{children}->[1]);
+ my $value = $self->_generate (_get_arg($node,2));
$self->_add_inst ('', 'set', [$return.'[1]',$value]);
_restore ($value);
return $return;
}
-sub _op_null {
+sub _op_null_p {
+ my ($self, $node) = @_;
+ my $return = _save_1 ('I');
+ my $label = $self->_gensym();
+
+ _num_arg ($node, 1, 'null?');
+
+ my $temp = $self->_generate(_get_arg($node,1));
+ $self->_add_inst ('', 'typeof',[$return,$temp]);
+ $self->_add_inst ('', 'ne', [$return,'.PerlUndef',"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");
+ _restore ($temp);
+
+ return $return;
}
sub _op_list_p {
@@ -324,9 +479,9 @@
$self->_add_inst ('', 'new',[$return,'.PerlUndef']);
- return $return unless exists $node->{children};
+ my @reverse = reverse _get_args($node);
- for (reverse @{$node->{children}}) {
+ for (@reverse) {
my $item = $self->_generate($_);
my $pair = _save_1 ('P');
@@ -349,7 +504,7 @@
_num_arg ($node, 1, 'length');
- my $list = $self->_generate($node->{children}->[0]);
+ my $list = $self->_generate(_get_arg($node,1));
$self->_add_inst ('', 'set',[$return,'0']);
my $type = _save_1 ('I');
@@ -430,9 +585,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','ne',[$temp_0,$temp_1,"DONE_$label"]);
_restore($temp_1);
}
@@ -448,9 +603,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','ge',[$temp_0,$temp_1,"DONE_$label"]);
_restore($temp_1);
}
@@ -466,9 +621,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','le',[$temp_0,$temp_1,"DONE_$label"]);
_restore($temp_1);
}
@@ -484,9 +639,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$_]);
$self->_add_inst('','gt',[$temp_0,$temp_1,"DONE_$label"]);
_restore($temp_1);
}
@@ -502,9 +657,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my $temp_0 = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
- my $temp_1 = $self->_generate($node->{children}[1]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
+ my $temp_1 = $self->_generate($node->{children}[$1]);
$self->_add_inst('','lt',[$temp_0,$temp_1,"DONE_$label"]);
_restore($temp_1);
}
@@ -520,10 +675,9 @@
my $label = $self->_gensym();
$return = $self->_constant(0);
- my @temp = _save(1);
$self->_add_inst('' ,'set' ,[$return,1]);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'eq' ,[$temp,0,"DONE_$label"]);
_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
@@ -537,7 +691,7 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'gt' ,[$temp,0,"DONE_$label"]);
_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
@@ -551,7 +705,7 @@
my $label = $self->_gensym();
$return = $self->_constant(1);
- my $temp = $self->_generate($node->{children}[0]);
+ my $temp = $self->_generate($node->{children}[1]);
$self->_add_inst('' ,'lt' ,[$temp,0,"DONE_$label"]);
_restore($temp);
$self->_add_inst('' ,'set' ,[$return,0]);
@@ -564,7 +718,7 @@
my $return;
my $label = $self->_gensym();
- my $temp_0 = $self->_generate($node->{children}[0]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
$return = $self->_constant(1);
my $temp_1 = $self->_constant(2);
$self->_add_inst('' ,'mod' ,[$temp_0,$temp_0,$temp_1]);
@@ -580,7 +734,7 @@
my $return;
my $label = $self->_gensym();
- my $temp_0 = $self->_generate($node->{children}[0]);
+ my $temp_0 = $self->_generate($node->{children}[1]);
$return = $self->_constant(1);
my $temp_1 = $self->_constant(2);
$self->_add_inst('' ,'mod' ,[$temp_0,$temp_0,$temp_1]);
@@ -596,8 +750,8 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
my $label = $self->_gensym();
$self->_add_inst('','gt', [$return,$temp,"NEXT_$label"]);
@@ -613,8 +767,8 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
my $label = $self->_gensym();
$self->_add_inst('','lt', [$return,$temp,"NEXT_$label"]);
@@ -628,14 +782,14 @@
sub _op_plus {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','add',[$return,$return,$temp]);
_restore($temp);
@@ -647,18 +801,18 @@
sub _op_minus {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
my $temp = $self->_constant(0);
$self->_add_inst('','sub',[$return,$temp,$return]);
_restore($temp);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','sub',[$return,$return,$temp]);
_restore($temp);
@@ -670,15 +824,15 @@
sub _op_times {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1: 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','mul',[$return,$return,$temp]);
_restore($temp);
@@ -690,18 +844,18 @@
sub _op_divide {
my ($self,$node) = @_;
my $return;
- my $num_children = defined $node->{children} ? @{$node->{children}} : 0;
+ my $num_children = defined $node->{children} ? @{$node->{children}} - 1 : 0;
if($num_children==0) {
$return = $self->_constant(0);
} elsif($num_children==1) {
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
my $temp = $self->_constant(1);
$self->_add_inst('','div',[$return,$temp,$return]);
_restore($temp);
} else {
- $return = $self->_generate($node->{children}[0]);
- for(1..$#{$node->{children}}) {
+ $return = $self->_generate($node->{children}[1]);
+ for(2..$#{$node->{children}}) {
my $temp = $self->_generate($node->{children}[$_]);
$self->_add_inst('','div',[$return,$return,$temp]);
_restore($temp);
@@ -715,7 +869,7 @@
my $return;
my $label = $self->_gensym();
- $return = $self->_generate($node->{children}[0]);
+ $return = $self->_generate($node->{children}[1]);
$self->_add_inst('', 'gt', [$return,0,"DONE_$label"]);
my $temp = $self->_constant(-1);
$self->_add_inst('', 'mul',[$return,$return,$temp]);
@@ -1044,8 +1198,11 @@
sub _op_write {
my ($self,$node) = @_;
- for(@{$node->{children}}) {
- my $temp = $self->_generate($_);
+ my $temp = _save_1 ('I');
+
+ for(_get_args($node)) {
+ _restore ($temp); # ugly trick
+ $temp = $self->_generate($_);
if ($temp =~ /[INS]/) {
$self->_add_inst('','print',[$temp]);
}
@@ -1060,8 +1217,8 @@
$self->_add_inst('', 'restore', ['P5']);
}
}
- _restore($temp);
}
+ return $temp; # We need to return something
}
sub _op_display {
@@ -1122,8 +1279,6 @@
my %global_ops = (
- 'CONSTANT' => \&_op_constant,
-
#----------------------
#
# Section 4 Expressions
@@ -1133,6 +1288,7 @@
'quote' => \&_op_quote,
'lambda' => \&_op_lambda,
'if' => \&_op_if,
+ 'define' => \&_op_define,
'set!' => \&_op_set_bang,
'cond' => \&_op_cond,
'case' => \&_op_case,
@@ -1424,7 +1580,7 @@
my ($self, $name) = @_;
push @{$self->{functions}}, $name
- unless grep { $_ eq $name } @{$self->{functitons}};
+ unless grep { $_ eq $name } @{$self->{functions}};
}
sub _format_columns {
@@ -1475,15 +1631,29 @@
my ($self,$node) = @_;
my $return;
- if($node->{value} =~ /\d/) {
- $return = $global_ops{CONSTANT}->($self,$node);
- } else {
- $return = $global_ops{$node->{value}}->($self,$node);
+ if (exists $node->{children}) {
+ my $func = $node->{children}->[0]->{value};
+ if (exists $global_ops{$func}) {
+ $return = $global_ops{$func}->($self, $node);
+ }
+ else {
+ print STDERR "Error: $func not defined\n";
+ }
+ }
+ else {
+ my $value = $node->{value};
+ if (exists $self->{scope}->{$value}) {
+ $return = _save_1 ('P');
+ $self->_add_inst ('', 'find_lex',[$return,"\"$value\""]);
+ }
+ else {
+ $return = $self->_constant($node->{value});
+ }
}
- $return;
+ return $return;
}
-sub _link_buildins {
+sub _link_builtins {
my ($self) = @_;
for (@{$self->{functions}}) {
@@ -1493,12 +1663,18 @@
sub generate {
my $self = shift;
- my @temp = _save(1);
- $self->_generate($self->{tree},$temp[0]);
+ my $temp;
+
+ $self->{scope} = {};
+ $self->_add_inst ('', 'new_pad');
+
+ $temp = $self->_generate($self->{tree});
+
+ $self->_add_inst ('', 'pop_pad');
#die Dumper($self->{tree});
- _restore(@temp);
+ _restore($temp);
$self->_add_inst('',"end");
- $self->_link_buildins();
+ $self->_link_builtins();
$self->_format_columns();
}
Index: languages/scheme/Scheme/Parser.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Parser.pm,v
retrieving revision 1.2
diff -u -r1.2 Parser.pm
--- languages/scheme/Scheme/Parser.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ languages/scheme/Scheme/Parser.pm 9 Sep 2002 22:48:15 -0000
@@ -9,27 +9,34 @@
use Data::Dumper;
+my $ind = 0;
sub _build_tree {
my ($tokens,$count) = @_;
my $temp = {};
- $count++;
+ die "EOF reached" if $count >= $#$tokens;
- while($tokens->[$count] ne ')') {
- if($tokens->[$count] eq '(') {
- my ($lcount,$ltemp) = _build_tree($tokens,$count);
- $count = $lcount;
- push @{$temp->{children}},$ltemp;
- } else {
- if(exists $temp->{value} or exists $temp->{children}) {
- push @{$temp->{children}},{value=>$tokens->[$count]};
- } else {
- $temp->{value} = $tokens->[$count];
- }
+ if ($tokens->[$count] eq '(') {
+ $temp->{children} = [];
+ $count++;
+ while($tokens->[$count] ne ')') {
+ my $expr;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
}
$count++;
}
-
+ elsif ($tokens->[$count] eq "'") {
+ $temp = { children => [{ value => 'quote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ else {
+ $temp->{value} = $tokens->[$count++];
+ }
+
return ($count,$temp);
}
@@ -57,9 +64,23 @@
sub parse {
my $tokens = shift;
- my (undef,$tree) = _build_tree($tokens,0);
- _dataflow($tree);
+ my @tree;
+ my $tree;
+ my $count = 0;
+
+ while ($count < scalar @$tokens) {
+ #print Dumper $tokens;
+ ($count,$tree) = _build_tree($tokens,$count);
+ #_dataflow($tree);
+ #print Data::Dumper->Dump ([$count, $tree]);
+ push @tree, $tree;
+ }
+
+ # Implicit begin at toplevel
+ if (@tree > 1) {
+ $tree = { children => [ { value => 'begin' }, @tree ] };
+ }
return $tree;
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.3
diff -u -r1.3 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 5 Sep 2002 15:03:55 -0000 1.3
+++ languages/scheme/Scheme/Tokenizer.pm 9 Sep 2002 22:48:15 -0000
@@ -18,6 +18,7 @@
open SOURCE,"<$file";
while(<SOURCE>) {
next if /^\s*;/;
+ s/;.*$//;
$text .= $_;
}
close SOURCE;
Index: languages/scheme/t/logic/defines.t
===================================================================
RCS file: languages/scheme/t/logic/defines.t
diff -N languages/scheme/t/logic/defines.t
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ languages/scheme/t/logic/defines.t 9 Sep 2002 22:48:15 -0000
@@ -0,0 +1,30 @@
+#! perl -w
+
+use Scheme::Test tests => 5;
+
+output_is (<<'CODE', 'a', 'a symbol');
+(write 'a) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '5', 'define');
+(define a 5)
+(write a)
+CODE
+
+output_is (<<'CODE', '5', 'define II');
+(define a 4)
+(define b (+ a 1))
+(write b)
+CODE
+
+output_is (<<'CODE', '8', 'set!');
+(define a 5)
+(set! a 8)
+(write a)
+CODE
+
+output_is (<<'CODE', '13', 'set! II');
+(define a 5)
+(set! a (+ a 8))
+(write a)
+CODE
Index: languages/scheme/t/logic/lists.t
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/t/logic/lists.t,v
retrieving revision 1.1
diff -u -r1.1 lists.t
--- languages/scheme/t/logic/lists.t 5 Sep 2002 19:55:13 -0000 1.1
+++ languages/scheme/t/logic/lists.t 9 Sep 2002 22:48:15 -0000
@@ -1,10 +1,6 @@
#! perl -w
-use Scheme::Test tests => 15;
-
-###
-### Add
-###
+use Scheme::Test tests => 21;
output_is(<<'CODE', '(2 . 5)', 'cons');
(write (cons 2 5))
@@ -81,4 +77,32 @@
output_is(<<'CODE', '(1 4 2)', 'set-cdr!');
(write
(set-cdr! (list 1 2 3) (list 4 2)))
+CODE
+
+output_is(<<'CODE', '(1 2 3 4)', 'quoted list');
+(write '(1 2 3 4)) ; for emacs ')
+CODE
+
+output_is(<<'CODE', '1', 'null?');
+(write
+ (null? (list)))
+CODE
+
+output_is (<<'CODE', '()', "'()");
+(write '()) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '0', 'failed null?');
+(write
+ (null? (list 1)))
+CODE
+
+output_is (<<'CODE', '(1 2 (3 4))', 'complex list');
+(write
+ '(1 2 (3 4))) ; for emacs ')
+CODE
+
+output_is (<<'CODE', '(1 2 (3 4))', 'complex list II');
+(write
+ (list 1 2 (list 3 4)))
CODE
