Author: pmichaud
Date: Wed Apr 19 23:32:54 2006
New Revision: 12386
Added:
trunk/t/compilers/pge/pge_optable.t (contents, props changed)
Modified:
trunk/MANIFEST
Log:
[PGE]: Added some operator precedence parser tests.
Modified: trunk/MANIFEST
==============================================================================
--- trunk/MANIFEST (original)
+++ trunk/MANIFEST Wed Apr 19 23:32:54 2006
@@ -2054,6 +2054,7 @@
t/compilers/pge/pge.t []
t/compilers/pge/pge_examples.t []
t/compilers/pge/pge_globs.t []
+t/compilers/pge/pge_optable.t []
t/compilers/pge/pge_util.t []
t/compilers/pge/pge-hs.t []
t/compilers/pge/p5regexp/p5rx.t []
Added: trunk/t/compilers/pge/pge_optable.t
==============================================================================
--- (empty file)
+++ trunk/t/compilers/pge/pge_optable.t Wed Apr 19 23:32:54 2006
@@ -0,0 +1,190 @@
+#! perl
+# $Id: $
+
+use strict;
+use warnings;
+use lib qw( t . lib ../lib ../../lib ../../../lib );
+use Test::More;
+use Parrot::Test;
+
+## remember to change the number of tests :-)
+BEGIN { plan tests => 31; }
+
+optable_output_is('a', 'term:a', 'Simple term');
+optable_output_is('a+b', 'infix:+(term:a, term:b)', 'Simple infix');
+optable_output_is('a-b', 'infix:-(term:a, term:b)', 'Simple infix');
+optable_output_is('a+b+c',
+ 'infix:+(infix:+(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a+b-c',
+ 'infix:-(infix:+(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a-b+c',
+ 'infix:+(infix:-(term:a, term:b), term:c)',
+ 'left associativity');
+
+optable_output_is('a+b*c',
+ 'infix:+(term:a, infix:*(term:b, term:c))',
+ 'tighter precedence');
+optable_output_is('a*b+c',
+ 'infix:+(infix:*(term:a, term:b), term:c)',
+ 'tighter precedence');
+
+optable_output_is('a/b/c',
+ 'infix:/(infix:/(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a*b/c',
+ 'infix:/(infix:*(term:a, term:b), term:c)',
+ 'left associativity');
+optable_output_is('a/b*c',
+ 'infix:*(infix:/(term:a, term:b), term:c)',
+ 'left associativity');
+
+optable_output_is('a=b*c',
+ 'infix:=(term:a, infix:*(term:b, term:c))',
+ 'looser precedence');
+
+optable_output_is('a=b=c',
+ 'infix:=(term:a, infix:=(term:b, term:c))',
+ 'right associativity');
+
+optable_output_is('a=b,c,d+e',
+ 'infix:=(term:a, infix:,(term:b, term:c, infix:+(term:d, term:e)))',
+ 'list associativity');
+
+optable_output_is('a b', 'term:a (pos=1)', 'two terms in sequence');
+optable_output_is('a = = b', 'term:a (pos=2)', 'two opers in sequence');
+optable_output_is('a+', 'term:a (pos=1)', 'infix missing rhs');
+
+optable_output_is('a++', 'postfix:++(term:a)', 'postfix');
+optable_output_is('a--', 'postfix:--(term:a)', 'postfix');
+optable_output_is('++a', 'prefix:++(term:a)', 'prefix');
+optable_output_is('--a', 'prefix:--(term:a)', 'prefix');
+
+optable_output_is('a*(b+c)',
+ 'infix:*(term:a, circumfix:( )(infix:+(term:b, term:c)))',
+ 'circumfix parens');
+optable_output_is('a*b+c)+4',
+ 'infix:+(infix:*(term:a, term:b), term:c) (pos=5)',
+ 'extra close paren');
+optable_output_is('(a*b+c', '', 'missing close paren',
+ todo => 'fix close tokens');
+optable_output_is('(a*b+c]', '', 'mismatch close paren',
+ todo => 'fix close tokens');
+
+
+optable_output_is('a+++--b',
+ 'infix:+(postfix:++(term:a), prefix:--(term:b))',
+ 'mixed tokens');
+
+optable_output_is('=a+4', 'failed', 'missing lhs term');
+
+optable_output_is('a(b,c)',
+ 'postcircumfix:( )(term:a, infix:,(term:b, term:c))',
+ 'postcircumfix');
+optable_output_is('a (b,c)',
+ 'term:a (pos=1)',
+ 'nows on postcircumfix');
+
+optable_output_is('a()', 'postcircumfix:( )(term:a, null)',
+ 'nullterm in postcircumfix');
+optable_output_is('a[]', 'term:a (pos=1)',
+ 'nullterm disallowed');
+
+
+################
+
+sub optable_output_is {
+ my($test, $output, $msg, %opt) = @_;
+ my($pir) = <<'CODE';
+.sub main :main
+ load_bytecode 'PGE.pbc'
+ load_bytecode 'dumper.pbc'
+ load_bytecode 'PGE/Dumper.pbc'
+
+ .local pmc optable
+ optable = new 'PGE::OPTable'
+
+ optable.newtok('infix:+', 'precedence'=>'=')
+ optable.newtok('infix:-', 'equiv'=>'infix:+')
+ optable.newtok('infix:*', 'tighter'=>'infix:+')
+ optable.newtok('infix:/', 'equiv'=>'infix:*')
+ optable.newtok('infix:**', 'tighter'=>'infix:*')
+ optable.newtok('infix:==', 'looser'=>'infix:+')
+ optable.newtok('infix:=', 'looser'=>'infix:==', 'assoc'=>'right')
+ optable.newtok('infix:,', 'tighter'=>'infix:=', 'assoc'=>'list')
+
+ optable.newtok('prefix:++', 'tighter'=>'infix:**')
+ optable.newtok('prefix:--', 'equiv'=>'prefix:++')
+ optable.newtok('postfix:++', 'equiv'=>'prefix:++')
+ optable.newtok('postfix:--', 'equiv'=>'prefix:++')
+
+ .local pmc ident
+ ident = find_global 'PGE::Rule', 'ident'
+ optable.newtok('term:', 'tighter'=>'prefix:++', 'parsed'=>ident)
+ optable.newtok('circumfix:( )', 'equiv'=>'term:')
+ optable.newtok('circumfix:[ ]', 'equiv'=>'term:')
+ optable.newtok('postcircumfix:( )', 'looser'=>'term:', 'nows'=>1,
'nullterm'=>1)
+ optable.newtok('postcircumfix:[ ]', 'equiv'=>'postcircumfix:( )',
'nows'=>1)
+
+ .local string test
+ test = "<<test>>"
+
+ .local pmc match
+ match = optable.parse(test)
+ unless match goto fail
+ $P0 = match['expr']
+ tree($P0)
+ $I0 = match.to()
+ $I1 = length test
+ if $I0 == $I1 goto succeed
+ print " (pos="
+ print $I0
+ print ")"
+ succeed:
+ print "\n"
+ goto end
+ fail:
+ print "failed\n"
+ end:
+.end
+
+.sub 'tree'
+ .param pmc match
+ .local string type
+ $S0 = match
+ if $S0 == "" goto print_null
+ type = match['type']
+ print type
+ if type == 'term:' goto print_term
+ print '('
+ .local pmc iter
+ $P0 = match.get_array()
+ if null $P0 goto iter_end
+ unless $P0 goto iter_end
+ iter = new .Iterator, $P0
+ iter = 0
+ unless iter goto iter_end
+ iter_loop:
+ $P0 = shift iter
+ tree($P0)
+ unless iter goto iter_end
+ print ', '
+ goto iter_loop
+ iter_end:
+ print ')'
+ goto end
+
+ print_null:
+ print "null"
+ goto end
+ print_term:
+ print match
+ end:
+ .return ()
+.end
+CODE
+ $pir =~ s/<<test>>/$test/g;
+ $output .= "\n";
+ pir_output_is($pir, $output, $msg, %opt);
+}
