[svn:parrot] r43196 - trunk/t/compilers/pge
bubaflub at svn.parrot.org
bubaflub at svn.parrot.org
Tue Dec 22 05:38:20 UTC 2009
Author: bubaflub
Date: Tue Dec 22 05:38:20 2009
New Revision: 43196
URL: https://trac.parrot.org/parrot/changeset/43196
Log:
convert t/compilers/pge/03-optable.t to PIR
Modified:
trunk/t/compilers/pge/03-optable.t
Modified: trunk/t/compilers/pge/03-optable.t
==============================================================================
--- trunk/t/compilers/pge/03-optable.t Tue Dec 22 05:34:14 2009 (r43195)
+++ trunk/t/compilers/pge/03-optable.t Tue Dec 22 05:38:20 2009 (r43196)
@@ -1,100 +1,88 @@
-#! perl
+#!parrot
# $Id$
-# Copyright (C) 2006-2007, Parrot Foundation.
+# Copyright (C) 2006-2009, Parrot Foundation.
-use strict;
-use warnings;
-use lib qw( t . lib ../lib ../../lib ../../../lib );
-use Test::More;
-use Parrot::Test tests => 37;
-
-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=1)', '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', 'prefix:-(term:a)', 'prefix ltm');
-optable_output_is( '->a', 'term:->a', 'prefix ltm');
-
-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)+4', 'failed', 'only close paren' );
-optable_output_is( '(a*b+c', 'failed', 'missing close paren' );
-optable_output_is( '(a*b+c]', 'failed', 'mismatch close paren' );
-
-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' );
-
-optable_output_is(
- '(a=b;c;d)',
- 'circumfix:( )(infix:;(infix:=(term:a, term:b), term:c, term:d))',
- 'loose list associativity in circumfix'
-);
-
-optable_output_is(
- '(a;b);d',
- 'circumfix:( )(infix:;(term:a, term:b)) (pos=5)',
- 'top-level stop token'
-);
-
-optable_output_is( 'a,b;c', 'infix:,(term:a, term:b) (pos=3)', 'top-level stop token' );
-
-################
-
-sub optable_output_is {
- my ( $test, $output, $msg, %opt ) = @_;
- my ($pir) = <<'CODE';
.sub main :main
+ .include 'test_more.pir'
+ plan(37)
+
load_bytecode 'compilers/pge/PGE.pbc'
load_bytecode 'dumper.pbc'
load_bytecode 'PGE/Dumper.pbc'
+ 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=1)', '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', 'prefix:-(term:a)', 'prefix ltm')
+ optable_output_is( '->a', 'term:->a', 'prefix ltm')
+
+ 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)+4', 'failed', 'only close paren' )
+ optable_output_is( '(a*b+c', 'failed', 'missing close paren' )
+ optable_output_is( '(a*b+c]', 'failed', 'mismatch close paren' )
+
+ 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' )
+
+ optable_output_is( '(a=b;c;d)', 'circumfix:( )(infix:;(infix:=(term:a, term:b), term:c, term:d))', 'loose list associativity in circumfix' )
+
+ optable_output_is( '(a;b);d', 'circumfix:( )(infix:;(term:a, term:b)) (pos=5)', 'top-level stop token' )
+
+ optable_output_is( 'a,b;c', 'infix:,(term:a, term:b) (pos=3)', 'top-level stop token' )
+.end
+
+.sub optable_output_is
+ .param string test
+ .param string output
+ .param string message
+
+ $S0 = test_optable(test)
+ is($S0, output, message)
+.end
+
+################
+
+.sub test_optable
+ .param string test
+
.local pmc optable
+ .local string return_string
+ return_string = ''
$P0 = get_hll_global ['PGE'], 'OPTable'
optable = $P0.'new'()
@@ -127,38 +115,40 @@
arrow = $P0("'->' <ident>")
optable.'newtok'('term:->', 'equiv'=>'term:', 'parsed'=>arrow, 'skipkey'=>0)
- .local string test
- test = "<<test>>"
-
.local pmc match
match = optable.'parse'(test, 'stop'=>' ;')
unless match goto fail
$P0 = match['expr']
- tree($P0)
+ $S1 = tree($P0)
+ return_string .= $S1
$I0 = match.'to'()
$I1 = length test
if $I0 == $I1 goto succeed
- print " (pos="
- print $I0
- print ")"
+ return_string .= " (pos="
+ $S1 = $I0
+ return_string .= $S1
+ return_string .= ")"
succeed:
- print "\n"
- goto end
+ goto endz
fail:
- print "failed\n"
- end:
+ return_string = "failed"
+ endz:
+ .begin_return
+ .set_return return_string
+ .end_return
.end
.sub 'tree'
.param pmc match
.local string type
+ .local string return_string
$S0 = match
if $S0 == "" goto print_null
type = match['type']
- print type
+ return_string .= type
if type == 'term:' goto print_term
if type == 'term:->' goto print_term_arrow
- print '('
+ return_string .= '('
.local pmc it
$P0 = match.'list'()
if null $P0 goto iter_end
@@ -167,35 +157,35 @@
unless it goto iter_end
iter_loop:
$P0 = shift it
- tree($P0)
+ $S1 = tree($P0)
+ return_string .= $S1
unless it goto iter_end
- print ', '
+ return_string .= ', '
goto iter_loop
iter_end:
- print ')'
- goto end
+ return_string .= ')'
+ goto endz
print_null:
- print "null"
- goto end
+ return_string .= "null"
+ goto endz
print_term:
- print match
- goto end
+ $S1 = match
+ return_string .= $S1
+ goto endz
print_term_arrow:
$S0 = match['ident']
- print $S0
- end:
+ return_string .= $S0
+ endz:
+ .begin_return
+ .set_return return_string
+ .end_return
.return ()
.end
-CODE
- $pir =~ s/<<test>>/$test/g;
- $output .= "\n";
- pir_output_is( $pir, $output, $msg, %opt );
-}
# Local Variables:
# mode: cperl
# cperl-indent-level: 4
# fill-column: 100
# End:
-# vim: expandtab shiftwidth=4:
+# vim: expandtab shiftwidth=4 filetype=pir:
More information about the parrot-commits
mailing list