1$DEBUG=0;
2$|=1;
3
4@tests=(
5  [ #1  Basic test
6<<'EOT'
7%{ my $out; %}
8%%
9S:  A { return($out) } ;
10A:  'a' 'b' 'c' D { $out=$_[1].$_[2].$_[3].$_[4]; undef } ;
11D:  'd' ;
12%%
13EOT
14, [ 'a','b','c','d' ], "abcd"
15],[ #2  In rule actions
16<<'EOT'
17%{ my $out; %}
18%%
19S:  A { return($out) } ;
20A:  'a' { $out=$_[1] } 'b' { $out.=$_[3]} 'c' { $out.=$_[5]}
21    D { $out.=$_[7].$_[5].$_[3].$_[1] } ;
22D:  'd' ;
23%%
24EOT
25, [ 'a', 'b', 'c', 'd' ], "abcdcba"
26],[ #3  YYSemval > 0
27<<'EOT'
28%{ my $out; %}
29%%
30S:  A { return($out) } ;
31A:  'a' 'b' 'c' D { $out.=$_[0]->YYSemval(1).
32                          $_[0]->YYSemval(2).
33                          $_[0]->YYSemval(3).
34                          $_[0]->YYSemval(4);
35                    undef
36                  }
37;
38D:  'd' ;
39%%
40EOT
41, [ 'a', 'b', 'c', 'd' ], "abcd"
42],[ #4  YYSemval < 0
43<<'EOT'
44%{ my $out; %}
45%%
46S:  A { return($out) } ;
47A:  'a' 'b' X ;
48X:  'c' 'd' { $out=$_[0]->YYSemval(-1).$_[0]->YYSemval(0).$_[1].$_[2] };
49%%
50EOT
51, [ 'a', 'b', 'c', 'd' ], "abcd"
52],[ #5  Left assoc
53<<'EOT'
54%{ my $out; %}
55%left '*'
56%%
57S:  A { return($out) } ;
58A:  A '*' A { $out="($_[1]$_[2]$_[3])" }
59  | B
60;
61B:  'a' | 'b' | 'c' | 'd' ;
62%%
63EOT
64, [ 'a', '*', 'b', '*', 'c', '*', 'd' ], "(((a*b)*c)*d)"
65],[ #6  Right assoc
66<<'EOT'
67%{ my $out; %}
68%right '*'
69%%
70S:  A { return($out) } ;
71A:  A '*' A { $out="($_[1]$_[2]$_[3])" }
72  | B
73;
74B:  'a' | 'b' | 'c' | 'd' ;
75%%
76EOT
77, [ 'a', '*', 'b', '*', 'c', '*', 'd' ], "(a*(b*(c*d)))"
78],
79[ #7 nonassoc
80<<'EOT'
81%{ my $out; %}
82%nonassoc '+'
83#%left '+'
84%%
85S:      S '+' S { $out }
86    |   'a'
87    |   error { $out="nonassoc" }
88    ;
89%%
90EOT
91, [ 'a' , '+', 'a', '+', 'a' ], "nonassoc"
92],
93[ #8  Left assoc with '\\'
94<<'EOT'
95%{ my $out; %}
96%left '\\'
97%%
98S:  A { return($out) } ;
99A:  A '\\' A { $out="($_[1]$_[2]$_[3])" }
100  | B
101;
102B:  'a' | 'b' | 'c' | 'd' ;
103%%
104EOT
105, [ 'a', '\\', 'b', '\\', 'c', '\\', 'd' ], '(((a\b)\c)\d)'
106],
107);
108
109use Parse::Yapp;
110
111my($count)=0;
112
113sub TestIt {
114    my($g,$in,$chk)=@_;
115
116    my($lex) = sub {
117        my($t)=shift(@$in);
118
119            defined($t)
120        or  $t='';
121        return($t,$t);
122    };
123
124    ++$count;
125
126    my($p)=new Parse::Yapp(input => $g);
127    $p=$p->Output(classname => 'Test');
128
129        $DEBUG
130    and print $p;
131
132    eval $p;
133        $@
134    and do {
135        print "$@\n";
136        print "not ok $count\n";
137        return;
138    };
139
140    $p=new Test(yylex => $lex, yyerror => sub {});
141
142    $out=$p->YYParse;
143    undef $p;
144
145        $out eq $chk
146    or  do {
147        print "Got '$out' instead of '$chk'\n";
148        print 'not ';
149    };
150    print 'ok'," $count\n";
151    undef(&Test::new);
152}
153
154print '1..'.@tests."\n";
155
156for (@tests) {
157    TestIt(@$_);
158}
159