# New Ticket Created by Jürgen Bömmels
# Please include the string: [perl #23547]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=23547 >
Hello,
I don't want to let my scheme playground to diverge to far from CVS,
so here is an intermediate patch.
It implements quasiquote and changes write to use Continuation Passing
Style. Some tests for quasiquote were added.
There is also a start of implementing the apply function in
continuation passing style, but its completely untested by now.
bye
boe
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/63534/46631/5a6663/scheme3.diff
Index: languages/scheme/Scheme.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme.pm,v
retrieving revision 1.2
diff -u -r1.2 Scheme.pm
--- languages/scheme/Scheme.pm 2 Aug 2003 23:05:19 -0000 1.2
+++ languages/scheme/Scheme.pm 20 Aug 2003 23:42:50 -0000
@@ -23,10 +23,16 @@
my $code = $main->{code};
+ my $header = "# Header information\n new_pad 0\n";
+
while (@missing) {
my $miss = shift @missing;
my $link = Scheme::Builtins->generate($miss);
+ $header .= << "END";
+ newsub P16, .Sub, ${miss}_ENTRY
+ store_lex 0, "$miss", P16
+END
push @function, $miss;
@@ -39,7 +45,7 @@
$code .= $link->{code};
}
- $code;
+ $header . $code;
}
sub compile {
Index: languages/scheme/Scheme/Builtins.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Builtins.pm,v
retrieving revision 1.3
diff -u -r1.3 Builtins.pm
--- languages/scheme/Scheme/Builtins.pm 2 Aug 2003 23:05:22 -0000 1.3
+++ languages/scheme/Scheme/Builtins.pm 20 Aug 2003 23:42:50 -0000
@@ -23,7 +23,9 @@
['write_NEXT', 'set', 'P6', 'P5'],
['', 'set', 'P5', 'P6[0]'],
['', 'save', 'P6'],
- ['', 'bsr', 'write_ENTRY'],
+ ['', 'save', 'P1'],
+ ['', 'invokecc'],
+ ['', 'restore', 'P1'],
['', 'restore', 'P6'],
['', 'set', 'P5', 'P6[1]'],
['', 'typeof', 'I0', 'P5'],
@@ -32,9 +34,72 @@
['', 'print', '" "'],
['', 'branch', 'write_NEXT'],
['write_DOT', 'print', '" . "'],
- ['', 'bsr', 'write_ENTRY'],
+ ['', 'save', 'P1'],
+ ['', 'invokecc'],
+ ['', 'restore', 'P1'],
['write_KET', 'print', '")"'],
- ['write_RET', 'ret'],
+ ['write_RET', 'invoke', 'P1'],
+ ],
+ apply =>
+ [['# Apply function'],
+ ['apply_ENTRY', 'set', 'P0', 'P5'],
+ ['', 'set', 'P16', 'P6'],
+ ['', 'typeof', 'I16', 'P16'],
+ ['', 'set', 'I1', 0],
+ ['', 'set', 'I2', 0],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P5', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P6', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P7', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P8', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P9', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P10', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P11', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P12', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P13', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P14', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P15', 'P16[0]'],
+ ['', 'bsr', 'apply_HELP'],
+ ['', 'eq', 'I16', '.PerlUndef', 'apply_CALL'],
+ ['', 'set', 'P17', 'P16'],
+ ['apply_COUNT', 'ne', 'I16', '.PerlUndef', 'apply_ARRAY'],
+ ['', 'inc', 'I2'],
+ ['', 'set', 'P17', 'P17[1]'],
+ ['', 'typeof', 'I16', 'P17'],
+ ['', 'branch', 'apply_COUNT'],
+ ['apply_ARRAY', 'new', 'P3', '.Array'],
+ ['', 'set', 'P3', 'I2'],
+ ['', 'set', 'I16', 0],
+ ['apply_ITER', 'set', 'P3[I16]', 'P16[0]'],
+ ['', 'set', 'P16', 'P16[1]'],
+ ['', 'inc', 'I16'],
+ ['', 'ne', 'I16', 'I2', 'apply_ITER'],
+ ['apply_CALL', 'set', 'I0', 0],
+ ['', 'invoke'],
+ ['apply_HELP', 'P16', 'P16[1]'],
+ ['', 'inc', 'I1'],
+ ['', 'typeof', 'I16', 'P16'],
+ ['', 'ret'],
],
);
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.5
diff -u -r1.5 Generator.pm
--- languages/scheme/Scheme/Generator.pm 2 Aug 2003 23:05:22 -0000 1.5
+++ languages/scheme/Scheme/Generator.pm 20 Aug 2003 23:42:51 -0000
@@ -124,6 +124,7 @@
my ($self, $symbol) = @_;
my $return = $self->_save_1 ('P');
$self->_add_inst ('','find_lex',[$return,"\"$symbol\""]);
+
return $return;
}
@@ -135,6 +136,17 @@
sub _new_lex {
my ($self, $symbol, $value) = @_;
$self->_add_inst ('','store_lex',[-1,"\"$symbol\"",$value]);
+ $self->{scope}->{$symbol} = $value;
+}
+
+sub _new_pair {
+ my ($self) = @_;
+ my $return = $self->_save_1('P');
+
+ $self->_add_inst('', 'new', [$return,'.Array']);
+ $self->_add_inst('', 'set', [$return, 2]);
+
+ return $return;
}
#------------------------------------
@@ -188,8 +200,7 @@
#---- Section 4 ----
sub __quoted {
- my ($self, $node) = @_;
- my $return = $self->_save_1 ('P');
+ my ($self, $node, $return, $special) = @_;
if (exists $node->{value}) {
my $value = $node->{value};
@@ -207,13 +218,27 @@
}
}
elsif (exists $node->{children}) {
+ my $children = $node->{children};
+
$self->_add_inst ('', 'new', [$return,'.PerlUndef']);
- for (reverse @{$node->{children}}) {
+ for (reverse @$children) {
+ if (exists $_->{children}) {
+ my $arg0 = _get_arg($_, 0);
+ if (exists $arg0->{value}) {
+ my $value = $arg0->{value};
+ if (exists $special->{$value}) {
+ _num_arg($_, 1);
+ $special->{$value}->($self, _get_arg($_, 1), $return);
+ next;
+ }
+ }
+ }
+ my $item = $self->_save_1 ('P');
+
+ __quoted ($self, $_, $item, $special);
+
+ my $pair = $self->_new_pair();
- my $item = __quoted ($self, $_);
- my $pair = $self->_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]);
@@ -226,13 +251,94 @@
sub _op_quote {
my ($self, $node) = @_;
- my $return;
+ my $return = $self->_save_1 ('P');
_num_arg ($node, 1, 'quote');
my $item = _get_arg($node,1);
- return __quoted ($self, $item);
+ return __quoted ($self, $item, $return, {});
+}
+
+sub _op_quasiquote {
+ my ($self, $node) = @_;
+ my $return = $self->_save_1 ('P');
+ my $special = {
+ unquote => \&_qq_unquote,
+ 'unquote-splicing' => \&_qq_unquote_splicing
+ };
+
+ _num_arg ($node, 1, 'quote');
+
+ my $item = _get_arg($node,1);
+
+ __quoted ($self, $item, $return, $special);
+}
+
+# helper functions for quasiquote
+
+sub _qq_unquote {
+ my ($self, $node, $return) = @_;
+
+ my $item = $self->_generate($node);
+
+ if ($item =~ /^[INS]/) {
+ my $temp = $self->_save_1('P');
+ $self->_morph($temp, $item);
+ $self->_restore($item);
+ $item = $temp;
+ }
+ my $pair = $self->_new_pair;
+ $self->_add_inst('', 'set', [$pair.'[0]',$item]);
+ $self->_add_inst('', 'set', [$pair.'[1]',$return]);
+ $self->_add_inst('', 'set', [$return,$pair]);
+ $self->_restore($item, $pair);
+
+ return $return;
+}
+
+sub _qq_unquote_splicing {
+ my ($self, $node, $return) = @_;
+
+ my $list = $self->_generate($node);
+
+ die "unquote-splicing called on no list" if ($list =~ /^[INS]/);
+
+ my $type = $self->_save_1('I');
+ my $head = $self->_save_1('P');
+ my $label = $self->_gensym;
+
+ # check for empty list
+ $self->_add_inst('', 'typeof', [$type, $list]);
+ $self->_add_inst('', 'eq', [$type,'.PerlUndef',"DONE_$label"]);
+
+ my $copy = $self->_new_pair;
+
+ $self->_add_inst('', 'set', [$head, $copy]);
+
+ # maybe ensure that $type is a pair here
+ my $temp = $self->_save_1('P');
+ $self->_add_inst("ITER_$label", 'set', [$temp,$list.'[0]']);
+ $self->_add_inst('', 'set', [$copy.'[0]',$temp]);
+ $self->_restore($temp);
+
+ $self->_add_inst('', 'set', [$list,$list.'[1]']);
+ $self->_add_inst('', 'typeof', [$type,$list]);
+ $self->_add_inst('', 'eq', [$type,'.PerlUndef',"FINISH_$label"]);
+
+ $temp = $self->_new_pair;
+ $self->_add_inst('', 'set', [$copy.'[1]',$temp]);
+ $self->_add_inst('', 'set', [$copy,$temp]);
+ $self->_add_inst('', 'branch', ["ITER_$label"]);
+ $self->_restore($temp);
+
+ # append the rest to the end of list
+ $self->_add_inst("FINISH_$label", 'set', [$copy.'[1]',$return]);
+ $self->_add_inst('', 'set', [$return,$head]);
+ $self->_add_inst("DONE_$label");
+
+ $self->_restore($list, $copy, $head, $type);
+ return $return;
}
sub _op_lambda {
@@ -243,12 +349,7 @@
$return = $self->_save_1 ('P');
- $self->_add_inst ('', 'new',[$return,'.Closure']);
-
- my $addr = $self->_save_1 ('I');
- $self->_add_inst ('', 'set_addr',[$addr,"LAMBDA_$label"]);
- $self->_add_inst ('', 'set',[$return,$addr]);
- $self->_restore ($addr);
+ $self->_add_inst ('', 'newsub',[$return,'.Closure',"LAMBDA_$label"]);
$self->_add_inst ('', 'branch',["DONE_$label"]);
$self->_add_inst ("LAMBDA_$label");
@@ -258,9 +359,12 @@
$self->{regs} = _new_regs;
# P1 is the return contination
$self->{regs}{P}{1} = 1;
-
+
# expand the lexical scope
$self->_add_inst('', 'new_pad', [-1]);
+ my $oldscope = $self->{scope};
+ $self->{scope} = { '*UP*' => $oldscope };
+
my $num = 5;
my @args = @{_get_arg($node,1)->{children}};
for (@args) {
@@ -282,6 +386,7 @@
$self->_add_inst("DONE_$label");
$self->{regs} = pop @{$self->{frames}};
+ $self->{scope} = $self->{scope}->{'*UP*'};
return $return;
}
@@ -315,25 +420,29 @@
_num_arg ($node, 2, 'define');
- my ($symbol, $value);
+ my ($symbol, $lambda, $value);
if (exists _get_arg($node,1)->{children}) {
my @formals;
($symbol, @formals) = @{_get_arg($node,1)->{children}};
$symbol = $symbol->{value};
- my $lambda = { children => [ { value => 'lambda' },
- { children => [ @formals ] },
- _get_args ($node, 2) ] };
- $value = $self->_generate($lambda);
+ $lambda = { children => [ { value => 'lambda' },
+ { children => [ @formals ] },
+ _get_args ($node, 2) ] };
}
else {
$symbol = _get_arg($node,1)->{value};
- $value = $self->_generate (_get_arg($node,2));
+ $lambda = _get_arg($node,2);
}
if (exists $self->{scope}->{$symbol}) {
die "define: $symbol is already defined\n";
}
+ else {
+ $self->{scope}->{$symbol} = '*unknown*';
+ }
+
+ $value = $self->_generate($lambda);
if ($value !~ /^P/) {
my $pmc = $self->_save_1 ('P');
@@ -342,7 +451,6 @@
$value = $pmc;
}
- $self->{scope}->{$symbol} = 1;
$self->_new_lex ($symbol,$value);
return $value;
@@ -478,9 +586,6 @@
sub _op_delay {
}
-sub _op_quasiquote {
-}
-
#---- Section 6 ----
sub _op_not {
@@ -1360,17 +1465,7 @@
my @args = _get_args ($node, 2);
die "apply: wrong number of args\n" unless @args;
- my $argl = $self->_generate(pop @args);
- while (@args) {
- my $elem = $self->_generate(pop @args);
- my $pair = _save_1('P');
- $self->_add_inst ('','new',[$pair,'.Array']);
- $self->_add_inst ('','set',[$pair,2]);
- $self->_add_inst ('','set',[$pair.'[0]',$elem]);
- $self->_add_inst ('','set',[$pair.'[1]',$argl]);
- }
-
-# $return = $self->_call_function ('apply');
+ $return = $self->_call_function_sym('apply');
return $return;
}
@@ -1448,13 +1543,8 @@
if ($temp =~ /[INS]/) {
$self->_add_inst('','print',[$temp]);
}
- else {
- push @{$self->{functions}}, 'write'
- unless grep { $_ eq 'write' } @{$self->{functions}};
- $self->_save_set;
- $self->_add_inst('', 'set', ['P5', $temp]);
- $self->_add_inst('', 'bsr', ['write_ENTRY']);
- $self->_restore_set;
+ else {
+ $self->_call_function_sym('write',$temp);
}
}
return $temp; # We need to return something
@@ -1815,7 +1905,28 @@
@max_len;
}
-sub _call_function {
+sub _call_function_sym {
+ my $self = shift;
+ my $symbol = shift;
+ my $func_obj = $self->_find_lex($symbol);
+
+ my $scope = $self->{scope};
+
+ while ($scope && !exists $scope->{$symbol}) {
+ $scope = $scope->{'*UP*'};
+ }
+ if (!$scope) {
+ push @{$self->{functions}}, $symbol
+ unless grep { $_ eq $symbol} @{$self->{functions}};
+ }
+
+ my $return = $self->_call_function_obj($func_obj, @_);
+ $self->_restore($func_obj);
+
+ return $return;
+}
+
+sub _call_function_obj {
my $self = shift;
my $func_obj = shift;
@@ -1890,6 +2001,7 @@
frames => [],
gensym => 0,
functions=> [],
+ scope => {},
};
bless $self,$class;
}
@@ -1918,14 +2030,13 @@
if (exists $global_ops{$symbol}) {
$return = $global_ops{$symbol}->($self, $node);
} else {
- my $func_obj = $self->_find_lex ($symbol);
my @args = map { $self->_generate($_); } _get_args($node);
- $return = $self->_call_function($func_obj, @args);
- $self->_restore($func_obj, @args);
+ $return = $self->_call_function_sym($symbol, @args);
+ $self->_restore(@args);
}
} else {
my @args = map { $self->_generate($_); } _get_args($node, 0);
- $return = $self->_call_function(@args);
+ $return = $self->_call_function_obj(@args);
$self->_restore(@args);
}
} else {
@@ -1946,11 +2057,9 @@
my $temp;
$self->{scope} = {};
- $self->_add_inst ('', 'new_pad',[0]);
$temp = $self->_generate($tree);
- $self->_add_inst ('', 'pop_pad');
$self->_restore($temp);
$self->_add_inst('',"end");
Index: languages/scheme/Scheme/Parser.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Parser.pm,v
retrieving revision 1.3
diff -u -r1.3 Parser.pm
--- languages/scheme/Scheme/Parser.pm 12 Dec 2002 16:01:29 -0000 1.3
+++ languages/scheme/Scheme/Parser.pm 20 Aug 2003 23:42:52 -0000
@@ -33,6 +33,27 @@
($count, $expr) = _build_tree ($tokens, $count);
push @{$temp->{children}}, $expr;
}
+ elsif ($tokens->[$count] eq "`") {
+ $temp = { children => [{ value => 'quasiquote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ elsif ($tokens->[$count] eq ",") {
+ $temp = { children => [{ value => 'unquote' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
+ elsif ($tokens->[$count] eq ",@") {
+ $temp = { children => [{ value => 'unquote-splicing' }] };
+ my $expr;
+ $count++;
+ ($count, $expr) = _build_tree ($tokens, $count);
+ push @{$temp->{children}}, $expr;
+ }
else {
$temp->{value} = $tokens->[$count++];
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.4
diff -u -r1.4 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 12 Dec 2002 16:01:29 -0000 1.4
+++ languages/scheme/Scheme/Tokenizer.pm 20 Aug 2003 23:42:52 -0000
@@ -55,6 +55,9 @@
} elsif($ch =~ /\s/ and
$token =~ /^\s/) { # White can follow white
$token .= $ch;
+ } elsif($ch =~ /@/ and
+ $token =~ /^,$/) { # token ,@
+ $token .= $ch;
} else {
push @$tokref,$token;
$token = $ch;
Index: languages/scheme/t/logic/lists.t
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/t/logic/lists.t,v
retrieving revision 1.2
diff -u -r1.2 lists.t
--- languages/scheme/t/logic/lists.t 12 Dec 2002 16:01:31 -0000 1.2
+++ languages/scheme/t/logic/lists.t 20 Aug 2003 23:42:52 -0000
@@ -1,6 +1,6 @@
#! perl -w
-use Scheme::Test tests => 21;
+use Scheme::Test tests => 26;
output_is(<<'CODE', '(2 . 5)', 'cons');
(write (cons 2 5))
@@ -105,4 +105,29 @@
output_is (<<'CODE', '(1 2 (3 4))', 'complex list II');
(write
(list 1 2 (list 3 4)))
+CODE
+
+output_is (<<'CODE', '(list 3 4)', 'quasiquote');
+(write
+ `(list ,(+ 1 2) 4))
+CODE
+
+output_is (<<'CODE', '(quasiquote (list (unquote (+ 1 2)) 4))', 'quoted quasiquote');
+(write
+ '`(list ,(+ 1 2) 4))
+CODE
+
+output_is(<<'CODE', '(list 1 2 3)', 'unquote-splicing');
+(write
+ `(list ,@(list 1 2 3)))
+CODE
+
+output_is(<<'CODE', '(list)', 'splicing empty list');
+(write
+ `(list ,@(list)))
+CODE
+
+output_is(<<'CODE', '(list 1 2 3 (4 5))', 'complex quasiquote');
+(write
+ `(list ,@(list 1 2) ,(+ 1 2) ,(list 4 5)))
CODE
