Author: pmichaud
Date: Sun Dec 7 07:40:09 2008
New Revision: 33611
Added:
trunk/languages/perl6/build/gen_metaop_pir.pl (contents, props changed)
Modified:
trunk/MANIFEST
trunk/languages/perl6/config/makefiles/root.in
trunk/languages/perl6/perl6.pir
trunk/languages/perl6/src/builtins/assign.pir
trunk/languages/perl6/src/builtins/op.pir
trunk/languages/perl6/src/parser/grammar-oper.pg
trunk/languages/perl6/src/parser/grammar.pg
Log:
[rakudo]: Fix assignment metaoperators, add reduction operators (e.g., [+]).
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Sun Dec 7 07:40:09 2008
@@ -1,7 +1,7 @@
# ex: set ro:
# $Id$
#
-# generated by tools/dev/mk_manifest_and_skip.pl Sat Dec 6 05:46:39 2008 UT
+# generated by tools/dev/mk_manifest_and_skip.pl Sun Dec 7 15:38:53 2008 UT
#
# See tools/dev/install_files.pl for documentation on the
# format of this file.
@@ -2098,6 +2098,7 @@
languages/perl6/Test.pm [perl6]
languages/perl6/build/gen_builtins_pir.pl [perl6]
languages/perl6/build/gen_junction_pir.pl [perl6]
+languages/perl6/build/gen_metaop_pir.pl [perl6]
languages/perl6/build/gen_objectref_pmc.pl [perl6]
languages/perl6/config/makefiles/root.in [perl6]
languages/perl6/config/makefiles/utils.in [perl6]
Added: trunk/languages/perl6/build/gen_metaop_pir.pl
==============================================================================
--- (empty file)
+++ trunk/languages/perl6/build/gen_metaop_pir.pl Sun Dec 7 07:40:09 2008
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+# Copyright (C) 2008, The Perl Foundation.
+# $Id$
+
+use strict;
+use warnings;
+
+my @ops = qw(
+ ** 1
+ * 1
+ / 'fail'
+ % 'fail'
+ x 'fail'
+ xx 'fail'
+ +& -1
+ +< 'fail'
+ +> 'fail'
+ ~& 'fail'
+ ~< 'fail'
+ ~> 'fail'
+ ?& 1
+ + 0
+ - 0
+ ~ ''
+ +| 0
+ +^ 0
+ ~| ''
+ ~^ ''
+ ?| 0
+ ?^ 0
+);
+
+
+my $output = $ARGV[0] || '-';
+
+
+my $assignfmt =
+ " optable.'newtok'('infix:%s=', 'equiv'=>'infix::=', 'lvalue'=>1)\n";
+my $reducefmt =
+ " optable.'newtok'('prefix:[%s]', 'equiv'=>'infix:=')\n";
+
+my @gtokens = ();
+my @code = ();
+
+while (@ops) {
+ my $opname = shift @ops;
+ my $identity = shift @ops;
+
+ push @gtokens, sprintf( $assignfmt, $opname );
+ push @gtokens, sprintf( $reducefmt, $opname );
+
+ push @code, qq(
+ .sub 'infix:$opname='
+ .param pmc a
+ .param pmc b
+ .tailcall '!ASSIGNMETAOP'('$opname', a, b)
+ .end
+
+ .sub 'prefix:[$opname]'
+ .param pmc args :slurpy
+ .tailcall '!REDUCEMETAOP'('$opname', $identity, args)
+ .end\n);
+}
+
+my $gtokens = join('', @gtokens);
+
+open my $fh, "> $output" or die "Could not write $output: $!";
+print $fh qq(
+.namespace []
+.sub '' :init :load
+ .local pmc optable
+ optable = get_hll_global ['Perl6';'Grammar'], '\$optable'
+$gtokens
+.end
+
+);
+
+print $fh @code;
+
+close $fh;
+0;
Modified: trunk/languages/perl6/config/makefiles/root.in
==============================================================================
--- trunk/languages/perl6/config/makefiles/root.in (original)
+++ trunk/languages/perl6/config/makefiles/root.in Sun Dec 7 07:40:09 2008
@@ -42,6 +42,7 @@
src/gen_grammar.pir \
src/gen_actions.pir \
src/gen_builtins.pir \
+ src/gen_metaop.pir \
src/gen_junction.pir \
src/parser/expression.pir \
src/parser/quote_expression.pir \
@@ -134,6 +135,9 @@
src/gen_builtins.pir: build/gen_builtins_pir.pl
$(PERL) build/gen_builtins_pir.pl $(BUILTINS_PIR) > src/gen_builtins.pir
+src/gen_metaop.pir: build/gen_metaop_pir.pl
+ $(PERL) build/gen_metaop_pir.pl > src/gen_metaop.pir
+
src/gen_junction.pir: build/gen_junction_pir.pl
$(PERL) build/gen_junction_pir.pl src/gen_junction.pir
@@ -243,9 +247,7 @@
perl6$(EXE) \
installable_perl6$(EXE) \
Test.pir \
- src/gen_grammar.pir \
- src/gen_actions.pir \
- src/gen_builtins.pir \
+ src/gen_*.pir \
$(PMC_DIR)/*.h \
$(PMC_DIR)/*.c \
$(PMC_DIR)/*.dump \
Modified: trunk/languages/perl6/perl6.pir
==============================================================================
--- trunk/languages/perl6/perl6.pir (original)
+++ trunk/languages/perl6/perl6.pir Sun Dec 7 07:40:09 2008
@@ -222,6 +222,7 @@
.include 'src/parser/expression.pir'
.include 'src/parser/quote_expression.pir'
.include 'src/gen_actions.pir'
+.include 'src/gen_metaop.pir'
.include 'src/gen_junction.pir'
Modified: trunk/languages/perl6/src/builtins/assign.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/assign.pir (original)
+++ trunk/languages/perl6/src/builtins/assign.pir Sun Dec 7 07:40:09 2008
@@ -74,185 +74,56 @@
.end
-.sub '!INIT_IF_PROTO'
- .param pmc var
- .param pmc val
- $I0 = defined var
- if $I0 goto done
- 'infix:='(var, val)
- done:
- .return ()
+.sub '!REDUCEMETAOP'
+ .param string opname
+ .param pmc identity
+ .param pmc args # already :slurpy array by caller
+
+ args.'!flatten'()
+ if args goto reduce
+ if identity == 'fail' goto fail
+ .return (identity)
+
+ fail:
+ .tailcall '!FAIL'()
+
+ reduce:
+ opname = concat 'infix:', opname
+ .local pmc opfunc
+ opfunc = find_name opname
+ .local pmc result
+ result = shift args
+ reduce_loop:
+ unless args goto reduce_done
+ $P0 = shift args
+ result = opfunc(result, $P0)
+ goto reduce_loop
+ reduce_done:
+ .return (result)
.end
-.sub 'infix:~='
+.sub '!ASSIGNMETAOP'
+ .param string opname
.param pmc a
.param pmc b
- '!INIT_IF_PROTO'(a, '')
- concat a, b
- .return (a)
-.end
-
-
-.sub 'infix:+='
- .param pmc a
- .param pmc b
- '!INIT_IF_PROTO'(a, 0)
- a += b
- .return (a)
-.end
-
-
-.sub 'infix:-='
- .param pmc a
- .param pmc b
- '!INIT_IF_PROTO'(a, 0)
- a -= b
- .return (a)
-.end
-
-.sub 'infix:*='
- .param pmc a
- .param pmc b
- '!INIT_IF_PROTO'(a, 1)
- a *= b
- .return (a)
-.end
-
-
-.sub 'infix:/='
- .param pmc a
- .param pmc b
- a /= b
- .return (a)
-.end
-
-
-.sub 'infix:%='
- .param pmc a
- .param pmc b
- a %= b
- .return (a)
-.end
-
-
-.sub 'infix:x='
- .param pmc a
- .param pmc b
- repeat a, b
- .return (a)
-.end
-
-
-## TODO: infix:Y=
-.sub 'infix:**='
- .param pmc a
- .param pmc b
- '!INIT_IF_PROTO'(a, 1)
- pow $P0, a, b
+ $I0 = defined a
+ if $I0 goto have_a
+ $S0 = concat 'prefix:[', opname
+ concat $S0, ']'
+ $P1 = find_name $S0
+ $P0 = $P1()
'infix:='(a, $P0)
- .return (a)
-.end
-
-
-## TODO: infix:xx= infix:||= infix:&&= infix://= infix:^^=
-
-
-.sub 'infix:+<='
- .param pmc a
- .param pmc b
- a <<= b
- .return (a)
-.end
-
-
-.sub 'infix:+>='
- .param pmc a
- .param pmc b
- a >>= b
- .return (a)
-.end
-
-
-.sub 'infix:+&='
- .param pmc a
- .param pmc b
- band a, b
- .return (a)
-.end
-
-
-.sub 'infix:+|='
- .param pmc a
- .param pmc b
- bor a, b
- .return (a)
-.end
+ have_a:
-
-.sub 'infix:+^='
- .param pmc a
- .param pmc b
- bxor a, b
- .return (a)
-.end
-
-
-.sub 'infix:~&='
- .param pmc a
- .param pmc b
- a = bands a, b
- .return (a)
-.end
-
-
-.sub 'infix:~|='
- .param pmc a
- .param pmc b
- bors a, b
- .return (a)
-.end
-
-
-.sub 'infix:~^='
- .param pmc a
- .param pmc b
- bxors a, b
- .return (a)
-.end
-
-
-.sub 'infix:?&='
- .param pmc a
- .param pmc b
- band a, b
- $I0 = istrue a
- a = $I0
- .return (a)
-.end
-
-
-.sub 'infix:?|='
- .param pmc a
- .param pmc b
- bor a, b
- $I0 = istrue a
- a = $I0
- .return (a)
-.end
-
-
-.sub 'infix:?^='
- .param pmc a
- .param pmc b
- bxor a, b
- $I0 = istrue a
- a = $I0
+ opname = concat 'infix:', opname
+ $P1 = find_name opname
+ $P0 = $P1(a, b)
+ 'infix:='(a, $P0)
.return (a)
.end
-
=back
=cut
Modified: trunk/languages/perl6/src/builtins/op.pir
==============================================================================
--- trunk/languages/perl6/src/builtins/op.pir (original)
+++ trunk/languages/perl6/src/builtins/op.pir Sun Dec 7 07:40:09 2008
@@ -31,7 +31,10 @@
.sub 'postfix:++' :multi(_)
.param pmc a
$P0 = clone a
- '!INIT_IF_PROTO'(a, 0)
+ $I0 = defined a
+ if $I0 goto have_a
+ 'infix:='(a, 0)
+ have_a:
inc a
.return ($P0)
.end
@@ -39,7 +42,10 @@
.sub 'postfix:--' :multi(_)
.param pmc a
$P0 = clone a
- '!INIT_IF_PROTO'(a, 0)
+ $I0 = defined a
+ if $I0 goto have_a
+ 'infix:='(a, 0)
+ have_a:
dec a
.return ($P0)
.end
@@ -47,7 +53,10 @@
.sub 'prefix:++' :multi(_)
.param pmc a
- '!INIT_IF_PROTO'(a, 0)
+ $I0 = defined a
+ if $I0 goto have_a
+ 'infix:='(a, 0)
+ have_a:
inc a
.return (a)
.end
@@ -55,7 +64,10 @@
.sub 'prefix:--' :multi(_)
.param pmc a
- '!INIT_IF_PROTO'(a, 0)
+ $I0 = defined a
+ if $I0 goto have_a
+ 'infix:='(a, 0)
+ have_a:
dec a
.return (a)
.end
Modified: trunk/languages/perl6/src/parser/grammar-oper.pg
==============================================================================
--- trunk/languages/perl6/src/parser/grammar-oper.pg (original)
+++ trunk/languages/perl6/src/parser/grammar-oper.pg Sun Dec 7 07:40:09 2008
@@ -142,34 +142,6 @@
proto infix:<:=> is precedence('i=') is pasttype('bind') { ... }
proto infix:<::=> is equiv(infix:<:=>) { ... }
proto infix:<.=> is equiv(infix:<:=>) { ... }
-proto infix:<~=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<-=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<*=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:</=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<%=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<x=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<Y=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<**=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<xx=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<||=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<&&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<//=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<^^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:«+<=» is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:«+>=» is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<+^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<~^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<?^=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<|=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<&=> is equiv(infix:<:=>) is lvalue(1) { ... }
-proto infix:<^=> is equiv(infix:<:=>) is lvalue(1) { ... }
proto infix:«=>» is equiv(infix:<:=>) { ... }
## loose unary
Modified: trunk/languages/perl6/src/parser/grammar.pg
==============================================================================
--- trunk/languages/perl6/src/parser/grammar.pg (original)
+++ trunk/languages/perl6/src/parser/grammar.pg Sun Dec 7 07:40:09 2008
@@ -842,7 +842,7 @@
token arglist {
[
| <?terminator>
- | <EXPR: 'e='> # EXPR(%list_assignment)
+ | <EXPR: 'd='> # EXPR(%list_assignment)
]
{*}
}
