t/compilers/pge/03-optable.t

   1 #!./parrot
   2 # Copyright (C) 2006-2010, Parrot Foundation.
   3 # $Id$
   4
   5 .sub main :main
   6     .include 'test_more.pir'
   7     plan(37)
   8
   9     load_bytecode 'compilers/pge/PGE.pbc'
  10     load_bytecode 'dumper.pbc'
  11     load_bytecode 'PGE/Dumper.pbc'
  12
  13     optable_output_is( 'a',     'term:a',                                   'Simple term' )
  14     optable_output_is( 'a+b',   'infix:+(term:a, term:b)',                  'Simple infix' )
  15     optable_output_is( 'a-b',   'infix:-(term:a, term:b)',                  'Simple infix' )
  16     optable_output_is( 'a+b+c', 'infix:+(infix:+(term:a, term:b), term:c)', 'left associativity' )
  17     optable_output_is( 'a+b-c', 'infix:-(infix:+(term:a, term:b), term:c)', 'left associativity' )
  18     optable_output_is( 'a-b+c', 'infix:+(infix:-(term:a, term:b), term:c)', 'left associativity' )
  19
  20     optable_output_is( 'a+b*c', 'infix:+(term:a, infix:*(term:b, term:c))', 'tighter precedence' )
  21     optable_output_is( 'a*b+c', 'infix:+(infix:*(term:a, term:b), term:c)', 'tighter precedence' )
  22
  23     optable_output_is( 'a/b/c', 'infix:/(infix:/(term:a, term:b), term:c)', 'left associativity' )
  24     optable_output_is( 'a*b/c', 'infix:/(infix:*(term:a, term:b), term:c)', 'left associativity' )
  25     optable_output_is( 'a/b*c', 'infix:*(infix:/(term:a, term:b), term:c)', 'left associativity' )
  26
  27     optable_output_is( 'a=b*c', 'infix:=(term:a, infix:*(term:b, term:c))', 'looser precedence' )
  28
  29     optable_output_is( 'a=b=c', 'infix:=(term:a, infix:=(term:b, term:c))', 'right associativity' )
  30
  31     optable_output_is( 'a=b,c,d+e', 'infix:=(term:a, infix:,(term:b, term:c, infix:+(term:d, term:e)))', 'list associativity' )
  32
  33     optable_output_is( 'a b',     'term:a (pos=1)', 'two terms in sequence' )
  34     optable_output_is( 'a = = b', 'term:a (pos=1)', 'two opers in sequence' )
  35     optable_output_is( 'a +',     'term:a (pos=1)', 'infix missing rhs' )
  36
  37     optable_output_is( 'a++', 'postfix:++(term:a)', 'postfix' )
  38     optable_output_is( 'a--', 'postfix:--(term:a)', 'postfix' )
  39     optable_output_is( '++a', 'prefix:++(term:a)',  'prefix' )
  40     optable_output_is( '--a', 'prefix:--(term:a)',  'prefix' )
  41
  42     optable_output_is( '-a',  'prefix:-(term:a)',   'prefix ltm')
  43     optable_output_is( '->a', 'term:->a',           'prefix ltm')
  44
  45     optable_output_is( 'a*(b+c)', 'infix:*(term:a, circumfix:( )(infix:+(term:b, term:c)))', 'circumfix parens' )
  46     optable_output_is( 'a*b+c)+4','infix:+(infix:*(term:a, term:b), term:c) (pos=5)', 'extra close paren' )
  47     optable_output_is( '  )a*b+c)+4', 'failed', 'only close paren' )
  48     optable_output_is( '(a*b+c',      'failed', 'missing close paren' )
  49     optable_output_is( '(a*b+c]',     'failed', 'mismatch close paren' )
  50
  51     optable_output_is( 'a+++--b', 'infix:+(postfix:++(term:a), prefix:--(term:b))', 'mixed tokens' )
  52
  53     optable_output_is( '=a+4', 'failed', 'missing lhs term' )
  54
  55     optable_output_is( 'a(b,c)', 'postcircumfix:( )(term:a, infix:,(term:b, term:c))', 'postcircumfix' )
  56     optable_output_is( 'a (b,c)', 'term:a (pos=1)', 'nows on postcircumfix' )
  57
  58     optable_output_is( 'a()', 'postcircumfix:( )(term:a, null)', 'nullterm in postcircumfix' )
  59     optable_output_is( 'a[]', 'term:a (pos=1)', 'nullterm disallowed' )
  60
  61     optable_output_is( '(a=b;c;d)', 'circumfix:( )(infix:;(infix:=(term:a, term:b), term:c, term:d))', 'loose list associativity in circumfix' )
  62
  63     optable_output_is( '(a;b);d', 'circumfix:( )(infix:;(term:a, term:b)) (pos=5)', 'top-level stop token' )
  64
  65     optable_output_is( 'a,b;c', 'infix:,(term:a, term:b) (pos=3)', 'top-level stop token' )
  66 .end
  67
  68 .sub optable_output_is
  69     .param string test
  70     .param string output
  71     .param string message
  72
  73     $S0 = test_optable(test)
  74     is($S0, output, message)
  75 .end
  76
  77 ################
  78
  79 .sub test_optable
  80     .param string test
  81
  82     .local pmc optable
  83     .local string return_string
  84     return_string = ''
  85     $P0 = get_hll_global ['PGE'], 'OPTable'
  86     optable = $P0.'new'()
  87
  88     optable.'newtok'('infix:+', 'precedence'=>'=')
  89     optable.'newtok'('infix:-', 'equiv'=>'infix:+')
  90     optable.'newtok'('infix:*', 'tighter'=>'infix:+')
  91     optable.'newtok'('infix:/', 'equiv'=>'infix:*')
  92     optable.'newtok'('infix:**', 'tighter'=>'infix:*')
  93     optable.'newtok'('infix:==', 'looser'=>'infix:+')
  94     optable.'newtok'('infix:=', 'looser'=>'infix:==', 'assoc'=>'right')
  95     optable.'newtok'('infix:,', 'tighter'=>'infix:=', 'assoc'=>'list')
  96     optable.'newtok'('infix:;', 'looser'=>'infix:=', 'assoc'=>'list')
  97
  98     optable.'newtok'('prefix:++', 'tighter'=>'infix:**')
  99     optable.'newtok'('prefix:--', 'equiv'=>'prefix:++')
 100     optable.'newtok'('postfix:++', 'equiv'=>'prefix:++')
 101     optable.'newtok'('postfix:--', 'equiv'=>'prefix:++')
 102     optable.'newtok'('prefix:-', 'equiv'=>'prefix:++')
 103
 104     .local pmc ident
 105     ident = get_global ['PGE';'Match'], 'ident'
 106     optable.'newtok'('term:', 'tighter'=>'prefix:++', 'parsed'=>ident)
 107     optable.'newtok'('circumfix:( )', 'equiv'=>'term:')
 108     optable.'newtok'('circumfix:[ ]', 'equiv'=>'term:')
 109     optable.'newtok'('postcircumfix:( )', 'looser'=>'term:', 'nows'=>1, 'nullterm'=>1)
 110     optable.'newtok'('postcircumfix:[ ]', 'equiv'=>'postcircumfix:( )', 'nows'=>1)
 111
 112     .local pmc arrow
 113     $P0 = compreg 'PGE::Perl6Regex'
 114     arrow = $P0("'->' <ident>")
 115     optable.'newtok'('term:->', 'equiv'=>'term:', 'parsed'=>arrow, 'skipkey'=>0)
 116
 117     .local pmc match
 118     match = optable.'parse'(test, 'stop'=>' ;')
 119     unless match goto fail
 120     $P0 = match['expr']
 121     $S1 = tree($P0)
 122     return_string .= $S1
 123     $I0 = match.'to'()
 124     $I1 = length test
 125     if $I0 == $I1 goto succeed
 126     return_string .= " (pos="
 127     $S1 = $I0
 128     return_string .= $S1
 129     return_string .= ")"
 130   succeed:
 131     goto endz
 132   fail:
 133     return_string = "failed"
 134   endz:
 135     .begin_return
 136     .set_return return_string
 137     .end_return
 138 .end
 139
 140 .sub 'tree'
 141     .param pmc match
 142     .local string type
 143     .local string return_string
 144     $S0 = match
 145     if $S0 == "" goto print_null
 146     type = match['type']
 147     return_string .= type
 148     if type == 'term:' goto print_term
 149     if type == 'term:->' goto print_term_arrow
 150     return_string .= '('
 151     .local pmc it
 152     $P0 = match.'list'()
 153     if null $P0 goto iter_end
 154     unless $P0 goto iter_end
 155     it = iter $P0
 156     unless it goto iter_end
 157   iter_loop:
 158     $P0 = shift it
 159     $S1 = tree($P0)
 160     return_string .= $S1
 161     unless it goto iter_end
 162     return_string .= ', '
 163     goto iter_loop
 164   iter_end:
 165     return_string .= ')'
 166     goto endz
 167
 168   print_null:
 169     return_string .= "null"
 170     goto endz
 171   print_term:
 172     $S1 = match
 173     return_string .= $S1
 174     goto endz
 175   print_term_arrow:
 176     $S0 = match['ident']
 177     return_string .= $S0
 178   endz:
 179     .begin_return
 180     .set_return return_string
 181     .end_return
 182     .return ()
 183 .end
 184
 185 # Local Variables:
 186 #   mode: pir
 187 #   fill-column: 100
 188 # End:
 189 # vim: expandtab shiftwidth=4 ft=pir: