# New Ticket Created by J�rgen B�mmels
# Please include the string: [perl #17030]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt2/Ticket/Display.html?id=17030 >
Hello,
The recent discussion of languages independence rememberd me of an
very old patch of mine which implements scheme pairs. (January 2002).
The languages/scheme directory did not change very much since then,
but the key system totally changed since then.
But neverless, I got it running. The dedicate SchemePair PMC is not
necessary any more, I just used an Array of size 2.
scheme now can create pairs with (cons) and lists with (list), print
them using (write) and access its elements using
(car), (cdr), (set-car!) and (set-cdr!). See lists.t for examples.
BTW: The MANIFEST-patch contains some auxillary files also missing,
which I delibrately haven't edited out. HINT: [perl #16839]
bye
juergen
-- attachment 1 ------------------------------------------------------
url: http://rt.perl.org/rt2/attach/36614/29555/b23eff/scheme.diff
Index: MANIFEST
===================================================================
RCS file: /cvs/public/parrot/MANIFEST,v
retrieving revision 1.207
diff -u -r1.207 MANIFEST
--- MANIFEST 4 Sep 2002 03:48:26 -0000 1.207
+++ MANIFEST 4 Sep 2002 23:53:27 -0000
@@ -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
@@ -67,6 +69,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
@@ -378,6 +381,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
@@ -434,6 +438,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
@@ -487,6 +492,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
@@ -498,6 +504,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
Index: languages/scheme/Scheme/Builtins.pm
===================================================================
RCS file: languages/scheme/Scheme/Builtins.pm
diff -N languages/scheme/Scheme/Builtins.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ languages/scheme/Scheme/Builtins.pm 4 Sep 2002 23:53:28 -0000
@@ -0,0 +1,50 @@
+package Scheme::Builtins;
+
+use strict;
+
+my %built_ins =
+(
+ write =>
+ [['# Write function', ''],
+ ['write_ENTRY', 'save', 'I0'],
+ ['', 'typeof', 'I0', 'P5'],
+ ['', 'ne', 'I0', '.PerlUndef', 'write_N_UNDEF'],
+ ['', 'print', '"()"'],
+ ['', 'branch', 'write_RET0'],
+ ['write_N_UNDEF','eq', 'I0', '.Array', 'write_ARRAY'],
+ ['', 'print', 'P5'],
+ ['', 'branch', 'write_RET0'],
+ ['write_ARRAY', 'save', 'P5'],
+ ['', 'save', 'P6'],
+ ['', 'print', '"("'],
+ ['write_NEXT', 'set', 'P6', 'P5'],
+ ['', 'set', 'P5', 'P6[0]'],
+ ['', 'bsr', 'write_ENTRY'],
+ ['', 'set', 'P5', 'P6[1]'],
+ ['', 'typeof', 'I0', 'P5'],
+ ['', 'eq', 'I0', '.PerlUndef', 'write_KET'],
+ ['', 'ne', 'I0', '.Array', 'write_DOT'],
+ ['', 'print', '" "'],
+ ['', 'branch', 'write_NEXT'],
+ ['write_DOT', 'print', '" . "'],
+ ['', 'bsr', 'write_ENTRY'],
+ ['write_KET', 'print', '")"'],
+ ['', 'restore', 'P6'],
+ ['', 'restore', 'P5'],
+ ['write_RET0', 'restore', 'I0'],
+ ['', 'ret'],
+ ]
+);
+
+sub generate {
+ my ($self, $name) = @_;
+
+ die "$name: Unknown buildin\n" unless exists $built_ins{$name};
+
+ for (@{$built_ins{$name}}) {
+ my ($label, $op, @args) = @$_;
+ $self->_add_inst ($label, $op, [ @args ]);
+ }
+}
+
+1;
Index: languages/scheme/Scheme/Generator.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Generator.pm,v
retrieving revision 1.2
diff -u -r1.2 Generator.pm
--- languages/scheme/Scheme/Generator.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ languages/scheme/Scheme/Generator.pm 4 Sep 2002 23:53:29 -0000
@@ -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($_);
- $self->_add_inst('','print',[$temp]);
+ 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();
}
Index: languages/scheme/Scheme/Tokenizer.pm
===================================================================
RCS file: /cvs/public/parrot/languages/scheme/Scheme/Tokenizer.pm,v
retrieving revision 1.2
diff -u -r1.2 Tokenizer.pm
--- languages/scheme/Scheme/Tokenizer.pm 24 Mar 2002 23:42:38 -0000 1.2
+++ languages/scheme/Scheme/Tokenizer.pm 4 Sep 2002 23:53:29 -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]/) { # Exclamation marks can follow an identifier
+ $token .= $ch;
} elsif($ch eq '=' and
$token =~ /^[<>]/) { # Equal sign can follow '<','>'
$token .= $ch;
Index: languages/scheme/t/logic/lists.t
===================================================================
RCS file: languages/scheme/t/logic/lists.t
diff -N languages/scheme/t/logic/lists.t
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ languages/scheme/t/logic/lists.t 4 Sep 2002 23:53:29 -0000
@@ -0,0 +1,84 @@
+#! perl -w
+
+use Scheme::Test tests => 15;
+
+###
+### Add
+###
+
+output_is(<<'CODE', '(2 . 5)', 'cons');
+(write (cons 2 5))
+CODE
+
+output_is(<<'CODE', '((2 . 3) . 4)', 'cons car');
+(write (cons (cons 2 3) 4))
+CODE
+
+output_is(<<'CODE', '(2 3 . 4)', 'cons cdr');
+(write (cons 2 (cons 3 4)))
+CODE
+
+output_is(<<'CODE', '((1 . 2) 3 . 4)', 'complex cons');
+(write
+ (cons
+ (cons 1 2)
+ (cons 3 4)))
+CODE
+
+output_is(<<'CODE', '1', 'pair?');
+(write
+ (pair? (cons 1 3)))
+CODE
+
+output_is(<<'CODE', '0', 'false pair?');
+(write
+ (pair? 12))
+CODE
+
+output_is(<<'CODE', '(3 2 1 0)', 'list');
+(write
+ (list 3 2 1 0))
+CODE
+
+output_is(<<'CODE', '1', 'pair? list');
+(write
+ (pair? (list 3 2 1)))
+CODE
+
+output_is(<<'CODE', '(1 2 3)', 'lists the hard way');
+(write
+ (cons 1
+ (cons 2
+ (cons 3
+ (list)))))
+CODE
+
+output_is(<<'CODE', '4', 'length');
+(write
+ (length (list 3 2 1 0)))
+CODE
+
+output_is(<<'CODE', '2', 'car');
+(write
+ (car (list 2 1 0)))
+CODE
+
+output_is(<<'CODE', '(1 0)', 'cdr');
+(write
+ (cdr (list 2 1 0)))
+CODE
+
+output_is(<<'CODE', '(4 2 3)', 'set-car!');
+(write
+ (set-car! (list 1 2 3) 4))
+CODE
+
+output_is(<<'CODE', '((4 . 2) 2 3)', 'set-car! II');
+(write
+ (set-car! (list 1 2 3) (cons 4 2)))
+CODE
+
+output_is(<<'CODE', '(1 4 2)', 'set-cdr!');
+(write
+ (set-cdr! (list 1 2 3) (list 4 2)))
+CODE
