#! perl
# $Id: /local/t/compilers/pge/03-optable.t 12668 2006-05-14T15:36:59.519628Z pmichaud  $

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 => 35; }

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*(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
    load_bytecode 'compilers/pge/PGE.pir'
    load_bytecode 'dumper.pir'
    load_bytecode 'PGE/Dumper.pir'

    .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('infix:;', 'looser'=>'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::Match', '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, 'stop'=>' ;')
    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);
}