File Coverage

blib/lib/Parse/Eyapp/Treeregexp.pm
Criterion Covered Total %
statement 528 585 90.2
branch 136 208 65.3
condition 16 29 55.1
subroutine 104 124 83.8
pod 0 19 0.0
total 784 965 81.2


line stmt bran cond sub pod time code
1             ########################################################################################
2             #
3             # This file was generated using Parse::Eyapp version 1.182.
4             #
5             # (c) Parse::Yapp Copyright 1998-2001 Francois Desarmenien.
6             # (c) Parse::Eyapp Copyright 2006-2008 Casiano Rodriguez-Leon. Universidad de La Laguna.
7             # Don't edit this file, use source file 'lib/Parse/Eyapp/Treeregexp.yp' instead.
8             #
9             # ANY CHANGE MADE HERE WILL BE LOST !
10             #
11             ########################################################################################
12             package Parse::Eyapp::Treeregparser;
13 36     36   80688 use strict;
  36         93  
  36         3897  
14              
15             push @Parse::Eyapp::Treeregparser::ISA, 'Parse::Eyapp::Driver';
16              
17              
18              
19              
20             BEGIN {
21             # This strange way to load the modules is to guarantee compatibility when
22             # using several standalone and non-standalone Eyapp parsers
23              
24 36 50   36   570 require Parse::Eyapp::Driver unless Parse::Eyapp::Driver->can('YYParse');
25 36 50       3105 require Parse::Eyapp::Node unless Parse::Eyapp::Node->can('hnew');
26             }
27            
28              
29 0 0   0   0 sub unexpendedInput { defined($_) ? substr($_, (defined(pos $_) ? pos $_ : 0)) : '' }
    0          
30              
31              
32 36     36   359 use Carp;
  36         82  
  36         6837  
33 36     36   260 use Data::Dumper;
  36         93  
  36         234255  
34              
35             our $VERSION = $Parse::Eyapp::Driver::VERSION;
36              
37             my $debug = 0; # comment
38             $Data::Dumper::Indent = 1;
39              
40             # %times: Hash indexed in the variables: stores the number of
41             # appearances in the treereg formula
42             my %times = ();
43             my ($tokenbegin, $tokenend);
44             my $filename; # Name of the input file
45              
46             { # closure for $numstar: support code for * treeregexes
47              
48             my $numstar = -1; # Number of stars in treereg formula
49              
50             sub new_star {
51 2     2   3 $numstar++;
52 2         8 return "W_$numstar";
53             }
54              
55             sub reset_times {
56 51     51   154 %times = ();
57 51         126 $numstar = -1; # New formula
58             }
59             }
60              
61             # treereg: IDENT '(' childlist ')' ('and' CODE)?
62             sub new_ident_inner {
63 82     82   115 my ($id, $line) = @{$_[1]};
  82         241  
64 82         320 my ($semantic) = $_[5]->children;
65 82         138 my $node = $_[3];
66              
67 82         179 $times{$id}++;
68              
69 82         183 $node->{id} = $id;
70 82         163 $node->{line} = $line;
71 82 100       261 $node->{semantic} = $semantic? $semantic->{attr} : undef;
72 82         669 return (bless $node, 'Parse::Eyapp::Treeregexp::IDENT_INNER');
73             }
74              
75             # treereg: REGEXP (':' IDENT)? '(' childlist ')' ('and' CODE)?
76             sub new_regexp_inner {
77 11     11   34 my $node = $_[4];
78 11         30 my $line = $_[1][1];
79              
80 11         23 my $id;
81              
82             # $W and @W are default variables for REGEXPs
83 11 100       99 if ( $_[2]->children) {
84 4         46 $id = $_[2]->child(0)->{attr}[0];
85             }
86             else {
87 7         20 $id = 'W';
88             }
89 11         40 $times{$id}++;
90              
91 11         31 $node->{id} = $id;
92 11         30 $node->{line} = $line;
93 11         49 $node->{regexp} = $_[1][0];
94 11         39 $node->{options} = $_[1][2];
95              
96 11         62 my ($semantic) = $_[6]->children;
97 11 50       139 $node->{semantic} = $semantic? $semantic->{attr} : undef;
98 11         68 return bless $node, 'Parse::Eyapp::Treeregexp::REGEXP_INNER';
99             }
100              
101             # treereg: SCALAR '(' childlist ')' ('and' CODE)?
102             sub new_scalar_inner {
103 2     2   5 my $node = $_[3];
104 2         3 my ($var, $line) = @{$_[1]};
  2         5  
105 2         7 $var =~ s/\$//;
106              
107 2         6 $times{$var}++;
108 2 50       9 _SyntaxError('Repeated scalar in treereg', $_[1][1]) if $times{$var} > 1;
109 2 50       7 _SyntaxError(q{Can't use $W to identify an scalar treeregexp}, $_[1][1]) if $var eq 'W';
110              
111 2         5 $node->{id} = $var;
112 2         12 $node->{line} = $line;
113 2         21 my ($semantic) = $_[5]->children;
114 2 50       8 $node->{semantic} = $semantic? $semantic->{attr} : undef;
115 2         9 return (bless $node, 'Parse::Eyapp::Treeregexp::SCALAR_INNER');
116             }
117              
118             # treereg: : '.' '(' childlist ')' ('and' CODE)?
119             sub new_dot_inner {
120 1     1   2 my $node = $_[3];
121 1         3 my $line = $_[1][1];
122 1         3 my $var = 'W';
123              
124 1         3 $times{$var}++;
125              
126 1         2 $node->{id} = $var;
127 1         4 $node->{line} = $line;
128 1         4 my ($semantic) = $_[5]->children;
129 1 50       4 $node->{semantic} = $semantic? $semantic->{attr} : undef;
130              
131 1         6 return (bless $node, 'Parse::Eyapp::Treeregexp::SCALAR_INNER');
132             }
133              
134             # treereg: IDENT ('and' CODE)?
135             sub new_ident_terminal {
136 24     24   61 my $id = $_[1][0];
137 24         60 $times{$id}++;
138            
139 24         199 my ($semantic) = $_[2]->children;
140 24 100       83 $semantic = $semantic? $semantic->{attr} : undef;
141            
142             return (
143 24         183 bless { children => [], attr => $id, semantic => $semantic }, 'Parse::Eyapp::Treeregexp::IDENT_TERMINAL'
144             );
145             }
146              
147             # treereg: REGEXP (':' IDENT)? ('and' CODE)?
148             sub new_regexp_terminal {
149             # $regexp and @regexp are default variables for REGEXPs
150 1     1   1 my $id;
151 1 50       10 if ($_[2]->children) {
152 0         0 $id = {$_[2]->child(0)}->{attr}[0];
153             }
154             else {
155 1         2 $id = 'W';
156             }
157 1         2 $times{$id}++;
158              
159 1         4 my ($semantic) = $_[3]->children;
160 1 50       4 $semantic = $semantic? $semantic->{attr} : undef;
161              
162 1         18 return bless {
163             children => [],
164             regexp => $_[1][0],
165             options => $_[1][2],
166             attr => $id,
167             semantic => $semantic
168             }, 'Parse::Eyapp::Treeregexp::REGEXP_TERMINAL'
169             }
170              
171             # treereg: SCALAR ('and' CODE)?
172             sub new_scalar_terminal {
173 50     50   114 my $var = $_[1][0];
174 50         206 $var =~ s/\$//;
175 50         125 $times{$var}++;
176 50 50       238 _SyntaxError('Repeated scalar in treereg', $_[1][1]) if $times{$var} > 1;
177 50 50       152 _SyntaxError(q{Can't use $W to identify an scalar treeregexp}, $_[1][1]) if $var eq 'W';
178              
179 50         277 my ($semantic) = $_[2]->children;
180 50 50       209 $semantic = $semantic? $semantic->{attr} : undef;
181              
182 50         423 return bless {
183             children => [],
184             attr => $var,
185             semantic => $semantic
186             }, 'Parse::Eyapp::Treeregexp::SCALAR_TERMINAL';
187             }
188              
189             # treereg: '.' ('and' CODE)?
190             sub new_dot_terminal {
191             # $W and @W are implicit variables for dots "."
192 23     23   40 $times{'W'}++;
193              
194 23         91 my ($semantic) = $_[2]->children;
195 23 50       56 $semantic = $semantic? $semantic->{attr} : undef;
196              
197 23         148 return bless {
198             children => [],
199             attr => 'W',
200             semantic => $semantic
201             }, 'Parse::Eyapp::Treeregexp::SCALAR_TERMINAL';
202             }
203              
204             # treereg: ARRAY
205             sub new_array_terminal {
206 33     33   92 my $var = $_[1][0];
207 33         147 $var =~ s/\@//;
208              
209 33         111 $times{$var} += 2; # awful trick so that fill_declarations works
210 33 50       146 _SyntaxError( 'Repeated array in treereg', $_[1][1]) if $times{$var} > 2;
211 33 50       120 _SyntaxError("Can't use $var to identify an array treeregexp", $_[1][1]) if $var =~ /^W(_\d+)?$/;
212              
213 33         259 return bless {
214             children => [],
215             attr => $var,
216             }, 'Parse::Eyapp::Treeregexp::ARRAY_TERMINAL';
217             }
218              
219             # treereg: '*'
220             sub new_array_star {
221             # $wathever_#number and @wathever_#number are reserved for "*"
222 2     2   8 my $var = new_star();
223 2         7 $times{$var} += 2;
224              
225 2         13 return bless {
226             children => [],
227             attr => $var,
228             }, 'Parse::Eyapp::Treeregexp::ARRAY_TERMINAL';
229             }
230              
231              
232              
233              
234             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
235              
236             my $warnmessage =<< "EOFWARN";
237             Warning!: Did you changed the \@Parse::Eyapp::Treeregparser::ISA variable inside the header section of the eyapp program?
238             EOFWARN
239              
240             sub new {
241 27     27   154 my($class)=shift;
242 27 50       204 ref($class) and $class=ref($class);
243              
244 27 50       366 warn $warnmessage unless __PACKAGE__->isa('Parse::Eyapp::Driver');
245             my($self)=$class->SUPER::new(
246             yyversion => '1.182',
247             yyGRAMMAR =>
248             [#[productionNameAndLabel => lhs, [ rhs], bypass]]
249             [ '_SUPERSTART' => '$start', [ 'treeregexplist', '$end' ], 0 ],
250             [ '_STAR_LIST' => 'STAR-1', [ 'STAR-1', 'treeregexp' ], 0 ],
251             [ '_STAR_LIST' => 'STAR-1', [ ], 0 ],
252             [ 'treeregexplist_3' => 'treeregexplist', [ 'STAR-1' ], 0 ],
253             [ '_PAREN' => 'PAREN-2', [ '=>', 'CODE' ], 0 ],
254             [ '_OPTIONAL' => 'OPTIONAL-3', [ 'PAREN-2' ], 0 ],
255             [ '_OPTIONAL' => 'OPTIONAL-3', [ ], 0 ],
256             [ '_PLUS_LIST' => 'PLUS-4', [ 'PLUS-4', 'IDENT' ], 0 ],
257             [ '_PLUS_LIST' => 'PLUS-4', [ 'IDENT' ], 0 ],
258             [ 'treeregexp_9' => 'treeregexp', [ 'IDENT', ':', 'treereg', 'OPTIONAL-3' ], 0 ],
259             [ 'treeregexp_10' => 'treeregexp', [ 'CODE' ], 0 ],
260             [ 'treeregexp_11' => 'treeregexp', [ 'IDENT', '=', 'PLUS-4', ';' ], 0 ],
261             [ 'treeregexp_12' => 'treeregexp', [ 'REGEXP' ], 0 ],
262             [ '_PAREN' => 'PAREN-5', [ 'and', 'CODE' ], 0 ],
263             [ '_OPTIONAL' => 'OPTIONAL-6', [ 'PAREN-5' ], 0 ],
264             [ '_OPTIONAL' => 'OPTIONAL-6', [ ], 0 ],
265             [ '_PAREN' => 'PAREN-7', [ ':', 'IDENT' ], 0 ],
266             [ '_OPTIONAL' => 'OPTIONAL-8', [ 'PAREN-7' ], 0 ],
267             [ '_OPTIONAL' => 'OPTIONAL-8', [ ], 0 ],
268             [ '_PAREN' => 'PAREN-9', [ 'and', 'CODE' ], 0 ],
269             [ '_OPTIONAL' => 'OPTIONAL-10', [ 'PAREN-9' ], 0 ],
270             [ '_OPTIONAL' => 'OPTIONAL-10', [ ], 0 ],
271             [ '_PAREN' => 'PAREN-11', [ 'and', 'CODE' ], 0 ],
272             [ '_OPTIONAL' => 'OPTIONAL-12', [ 'PAREN-11' ], 0 ],
273             [ '_OPTIONAL' => 'OPTIONAL-12', [ ], 0 ],
274             [ '_PAREN' => 'PAREN-13', [ 'and', 'CODE' ], 0 ],
275             [ '_OPTIONAL' => 'OPTIONAL-14', [ 'PAREN-13' ], 0 ],
276             [ '_OPTIONAL' => 'OPTIONAL-14', [ ], 0 ],
277             [ '_PAREN' => 'PAREN-15', [ 'and', 'CODE' ], 0 ],
278             [ '_OPTIONAL' => 'OPTIONAL-16', [ 'PAREN-15' ], 0 ],
279             [ '_OPTIONAL' => 'OPTIONAL-16', [ ], 0 ],
280             [ '_PAREN' => 'PAREN-17', [ ':', 'IDENT' ], 0 ],
281             [ '_OPTIONAL' => 'OPTIONAL-18', [ 'PAREN-17' ], 0 ],
282             [ '_OPTIONAL' => 'OPTIONAL-18', [ ], 0 ],
283             [ '_PAREN' => 'PAREN-19', [ 'and', 'CODE' ], 0 ],
284             [ '_OPTIONAL' => 'OPTIONAL-20', [ 'PAREN-19' ], 0 ],
285             [ '_OPTIONAL' => 'OPTIONAL-20', [ ], 0 ],
286             [ '_PAREN' => 'PAREN-21', [ 'and', 'CODE' ], 0 ],
287             [ '_OPTIONAL' => 'OPTIONAL-22', [ 'PAREN-21' ], 0 ],
288             [ '_OPTIONAL' => 'OPTIONAL-22', [ ], 0 ],
289             [ '_PAREN' => 'PAREN-23', [ 'and', 'CODE' ], 0 ],
290             [ '_OPTIONAL' => 'OPTIONAL-24', [ 'PAREN-23' ], 0 ],
291             [ '_OPTIONAL' => 'OPTIONAL-24', [ ], 0 ],
292             [ 'treereg_43' => 'treereg', [ 'IDENT', '(', 'childlist', ')', 'OPTIONAL-6' ], 0 ],
293             [ 'treereg_44' => 'treereg', [ 'REGEXP', 'OPTIONAL-8', '(', 'childlist', ')', 'OPTIONAL-10' ], 0 ],
294             [ 'treereg_45' => 'treereg', [ 'SCALAR', '(', 'childlist', ')', 'OPTIONAL-12' ], 0 ],
295             [ 'treereg_46' => 'treereg', [ '.', '(', 'childlist', ')', 'OPTIONAL-14' ], 0 ],
296             [ 'treereg_47' => 'treereg', [ 'IDENT', 'OPTIONAL-16' ], 0 ],
297             [ 'treereg_48' => 'treereg', [ 'REGEXP', 'OPTIONAL-18', 'OPTIONAL-20' ], 0 ],
298             [ 'treereg_49' => 'treereg', [ 'SCALAR', 'OPTIONAL-22' ], 0 ],
299             [ 'treereg_50' => 'treereg', [ '.', 'OPTIONAL-24' ], 0 ],
300             [ 'treereg_51' => 'treereg', [ 'ARRAY' ], 0 ],
301             [ 'treereg_52' => 'treereg', [ '*' ], 0 ],
302             [ '_STAR_LIST' => 'STAR-25', [ 'STAR-25', ',', 'treereg' ], 0 ],
303             [ '_STAR_LIST' => 'STAR-25', [ 'treereg' ], 0 ],
304             [ '_STAR_LIST' => 'STAR-26', [ 'STAR-25' ], 0 ],
305             [ '_STAR_LIST' => 'STAR-26', [ ], 0 ],
306             [ 'childlist_57' => 'childlist', [ 'STAR-26' ], 0 ],
307             ],
308             yyLABELS =>
309             {
310             '_SUPERSTART' => 0,
311             '_STAR_LIST' => 1,
312             '_STAR_LIST' => 2,
313             'treeregexplist_3' => 3,
314             '_PAREN' => 4,
315             '_OPTIONAL' => 5,
316             '_OPTIONAL' => 6,
317             '_PLUS_LIST' => 7,
318             '_PLUS_LIST' => 8,
319             'treeregexp_9' => 9,
320             'treeregexp_10' => 10,
321             'treeregexp_11' => 11,
322             'treeregexp_12' => 12,
323             '_PAREN' => 13,
324             '_OPTIONAL' => 14,
325             '_OPTIONAL' => 15,
326             '_PAREN' => 16,
327             '_OPTIONAL' => 17,
328             '_OPTIONAL' => 18,
329             '_PAREN' => 19,
330             '_OPTIONAL' => 20,
331             '_OPTIONAL' => 21,
332             '_PAREN' => 22,
333             '_OPTIONAL' => 23,
334             '_OPTIONAL' => 24,
335             '_PAREN' => 25,
336             '_OPTIONAL' => 26,
337             '_OPTIONAL' => 27,
338             '_PAREN' => 28,
339             '_OPTIONAL' => 29,
340             '_OPTIONAL' => 30,
341             '_PAREN' => 31,
342             '_OPTIONAL' => 32,
343             '_OPTIONAL' => 33,
344             '_PAREN' => 34,
345             '_OPTIONAL' => 35,
346             '_OPTIONAL' => 36,
347             '_PAREN' => 37,
348             '_OPTIONAL' => 38,
349             '_OPTIONAL' => 39,
350             '_PAREN' => 40,
351             '_OPTIONAL' => 41,
352             '_OPTIONAL' => 42,
353             'treereg_43' => 43,
354             'treereg_44' => 44,
355             'treereg_45' => 45,
356             'treereg_46' => 46,
357             'treereg_47' => 47,
358             'treereg_48' => 48,
359             'treereg_49' => 49,
360             'treereg_50' => 50,
361             'treereg_51' => 51,
362             'treereg_52' => 52,
363             '_STAR_LIST' => 53,
364             '_STAR_LIST' => 54,
365             '_STAR_LIST' => 55,
366             '_STAR_LIST' => 56,
367             'childlist_57' => 57,
368             },
369             yyTERMS =>
370             { '' => { ISSEMANTIC => 0 },
371             '(' => { ISSEMANTIC => 0 },
372             ')' => { ISSEMANTIC => 0 },
373             '*' => { ISSEMANTIC => 0 },
374             ',' => { ISSEMANTIC => 0 },
375             '.' => { ISSEMANTIC => 0 },
376             ':' => { ISSEMANTIC => 0 },
377             ';' => { ISSEMANTIC => 0 },
378             '=' => { ISSEMANTIC => 0 },
379             '=>' => { ISSEMANTIC => 0 },
380             'and' => { ISSEMANTIC => 0 },
381             ARRAY => { ISSEMANTIC => 1 },
382             CODE => { ISSEMANTIC => 1 },
383             IDENT => { ISSEMANTIC => 1 },
384             REGEXP => { ISSEMANTIC => 1 },
385             SCALAR => { ISSEMANTIC => 1 },
386             error => { ISSEMANTIC => 0 },
387             },
388             yyFILENAME => 'lib/Parse/Eyapp/Treeregexp.yp',
389             yystates =>
390             [
391             {#State 0
392             DEFAULT => -2,
393             GOTOS => {
394             'STAR-1' => 1,
395             'treeregexplist' => 2
396             }
397             },
398             {#State 1
399             ACTIONS => {
400             'REGEXP' => 3,
401             'IDENT' => 6,
402             'CODE' => 5
403             },
404             DEFAULT => -3,
405             GOTOS => {
406             'treeregexp' => 4
407             }
408             },
409             {#State 2
410             ACTIONS => {
411             '' => 7
412             }
413             },
414             {#State 3
415             DEFAULT => -12
416             },
417             {#State 4
418             DEFAULT => -1
419             },
420             {#State 5
421             DEFAULT => -10
422             },
423             {#State 6
424             ACTIONS => {
425             ":" => 8,
426             "=" => 9
427             }
428             },
429             {#State 7
430             DEFAULT => 0
431             },
432             {#State 8
433             ACTIONS => {
434             'REGEXP' => 10,
435             "*" => 11,
436             'IDENT' => 12,
437             "." => 14,
438             'ARRAY' => 13,
439             'SCALAR' => 15
440             },
441             GOTOS => {
442             'treereg' => 16
443             }
444             },
445             {#State 9
446             ACTIONS => {
447             'IDENT' => 17
448             },
449             GOTOS => {
450             'PLUS-4' => 18
451             }
452             },
453             {#State 10
454             ACTIONS => {
455             ":" => 19,
456             "(" => -18
457             },
458             DEFAULT => -33,
459             GOTOS => {
460             'OPTIONAL-18' => 21,
461             'PAREN-17' => 20,
462             'OPTIONAL-8' => 22,
463             'PAREN-7' => 23
464             }
465             },
466             {#State 11
467             DEFAULT => -52
468             },
469             {#State 12
470             ACTIONS => {
471             "(" => 25,
472             "and" => 26
473             },
474             DEFAULT => -30,
475             GOTOS => {
476             'PAREN-15' => 24,
477             'OPTIONAL-16' => 27
478             }
479             },
480             {#State 13
481             DEFAULT => -51
482             },
483             {#State 14
484             ACTIONS => {
485             "(" => 28,
486             "and" => 29
487             },
488             DEFAULT => -42,
489             GOTOS => {
490             'OPTIONAL-24' => 30,
491             'PAREN-23' => 31
492             }
493             },
494             {#State 15
495             ACTIONS => {
496             "(" => 33,
497             "and" => 35
498             },
499             DEFAULT => -39,
500             GOTOS => {
501             'OPTIONAL-22' => 32,
502             'PAREN-21' => 34
503             }
504             },
505             {#State 16
506             ACTIONS => {
507             "=>" => 36
508             },
509             DEFAULT => -6,
510             GOTOS => {
511             'OPTIONAL-3' => 38,
512             'PAREN-2' => 37
513             }
514             },
515             {#State 17
516             DEFAULT => -8
517             },
518             {#State 18
519             ACTIONS => {
520             ";" => 39,
521             'IDENT' => 40
522             }
523             },
524             {#State 19
525             ACTIONS => {
526             'IDENT' => 41
527             }
528             },
529             {#State 20
530             DEFAULT => -32
531             },
532             {#State 21
533             ACTIONS => {
534             "and" => 44
535             },
536             DEFAULT => -36,
537             GOTOS => {
538             'PAREN-19' => 42,
539             'OPTIONAL-20' => 43
540             }
541             },
542             {#State 22
543             ACTIONS => {
544             "(" => 45
545             }
546             },
547             {#State 23
548             DEFAULT => -17
549             },
550             {#State 24
551             DEFAULT => -29
552             },
553             {#State 25
554             ACTIONS => {
555             'IDENT' => 12,
556             'ARRAY' => 13,
557             'REGEXP' => 10,
558             "*" => 11,
559             "." => 14,
560             'SCALAR' => 15
561             },
562             DEFAULT => -56,
563             GOTOS => {
564             'STAR-26' => 46,
565             'STAR-25' => 48,
566             'childlist' => 47,
567             'treereg' => 49
568             }
569             },
570             {#State 26
571             ACTIONS => {
572             'CODE' => 50
573             }
574             },
575             {#State 27
576             DEFAULT => -47
577             },
578             {#State 28
579             ACTIONS => {
580             'IDENT' => 12,
581             'ARRAY' => 13,
582             'REGEXP' => 10,
583             "*" => 11,
584             "." => 14,
585             'SCALAR' => 15
586             },
587             DEFAULT => -56,
588             GOTOS => {
589             'STAR-26' => 46,
590             'STAR-25' => 48,
591             'childlist' => 51,
592             'treereg' => 49
593             }
594             },
595             {#State 29
596             ACTIONS => {
597             'CODE' => 52
598             }
599             },
600             {#State 30
601             DEFAULT => -50
602             },
603             {#State 31
604             DEFAULT => -41
605             },
606             {#State 32
607             DEFAULT => -49
608             },
609             {#State 33
610             ACTIONS => {
611             'IDENT' => 12,
612             'ARRAY' => 13,
613             'REGEXP' => 10,
614             "*" => 11,
615             "." => 14,
616             'SCALAR' => 15
617             },
618             DEFAULT => -56,
619             GOTOS => {
620             'STAR-26' => 46,
621             'STAR-25' => 48,
622             'childlist' => 53,
623             'treereg' => 49
624             }
625             },
626             {#State 34
627             DEFAULT => -38
628             },
629             {#State 35
630             ACTIONS => {
631             'CODE' => 54
632             }
633             },
634             {#State 36
635             ACTIONS => {
636             'CODE' => 55
637             }
638             },
639             {#State 37
640             DEFAULT => -5
641             },
642             {#State 38
643             DEFAULT => -9
644             },
645             {#State 39
646             DEFAULT => -11
647             },
648             {#State 40
649             DEFAULT => -7
650             },
651             {#State 41
652             ACTIONS => {
653             "(" => -16
654             },
655             DEFAULT => -31
656             },
657             {#State 42
658             DEFAULT => -35
659             },
660             {#State 43
661             DEFAULT => -48
662             },
663             {#State 44
664             ACTIONS => {
665             'CODE' => 56
666             }
667             },
668             {#State 45
669             ACTIONS => {
670             'IDENT' => 12,
671             'ARRAY' => 13,
672             'REGEXP' => 10,
673             "*" => 11,
674             "." => 14,
675             'SCALAR' => 15
676             },
677             DEFAULT => -56,
678             GOTOS => {
679             'STAR-26' => 46,
680             'STAR-25' => 48,
681             'childlist' => 57,
682             'treereg' => 49
683             }
684             },
685             {#State 46
686             DEFAULT => -57
687             },
688             {#State 47
689             ACTIONS => {
690             ")" => 58
691             }
692             },
693             {#State 48
694             ACTIONS => {
695             "," => 59
696             },
697             DEFAULT => -55
698             },
699             {#State 49
700             DEFAULT => -54
701             },
702             {#State 50
703             DEFAULT => -28
704             },
705             {#State 51
706             ACTIONS => {
707             ")" => 60
708             }
709             },
710             {#State 52
711             DEFAULT => -40
712             },
713             {#State 53
714             ACTIONS => {
715             ")" => 61
716             }
717             },
718             {#State 54
719             DEFAULT => -37
720             },
721             {#State 55
722             DEFAULT => -4
723             },
724             {#State 56
725             DEFAULT => -34
726             },
727             {#State 57
728             ACTIONS => {
729             ")" => 62
730             }
731             },
732             {#State 58
733             ACTIONS => {
734             "and" => 65
735             },
736             DEFAULT => -15,
737             GOTOS => {
738             'PAREN-5' => 63,
739             'OPTIONAL-6' => 64
740             }
741             },
742             {#State 59
743             ACTIONS => {
744             'REGEXP' => 10,
745             "*" => 11,
746             'IDENT' => 12,
747             "." => 14,
748             'ARRAY' => 13,
749             'SCALAR' => 15
750             },
751             GOTOS => {
752             'treereg' => 66
753             }
754             },
755             {#State 60
756             ACTIONS => {
757             "and" => 69
758             },
759             DEFAULT => -27,
760             GOTOS => {
761             'PAREN-13' => 67,
762             'OPTIONAL-14' => 68
763             }
764             },
765             {#State 61
766             ACTIONS => {
767             "and" => 71
768             },
769             DEFAULT => -24,
770             GOTOS => {
771             'OPTIONAL-12' => 70,
772             'PAREN-11' => 72
773             }
774             },
775             {#State 62
776             ACTIONS => {
777             "and" => 75
778             },
779             DEFAULT => -21,
780             GOTOS => {
781             'OPTIONAL-10' => 73,
782             'PAREN-9' => 74
783             }
784             },
785             {#State 63
786             DEFAULT => -14
787             },
788             {#State 64
789             DEFAULT => -43
790             },
791             {#State 65
792             ACTIONS => {
793             'CODE' => 76
794             }
795             },
796             {#State 66
797             DEFAULT => -53
798             },
799             {#State 67
800             DEFAULT => -26
801             },
802             {#State 68
803             DEFAULT => -46
804             },
805             {#State 69
806             ACTIONS => {
807             'CODE' => 77
808             }
809             },
810             {#State 70
811             DEFAULT => -45
812             },
813             {#State 71
814             ACTIONS => {
815             'CODE' => 78
816             }
817             },
818             {#State 72
819             DEFAULT => -23
820             },
821             {#State 73
822             DEFAULT => -44
823             },
824             {#State 74
825             DEFAULT => -20
826             },
827             {#State 75
828             ACTIONS => {
829             'CODE' => 79
830             }
831             },
832             {#State 76
833             DEFAULT => -13
834             },
835             {#State 77
836             DEFAULT => -25
837             },
838             {#State 78
839             DEFAULT => -22
840             },
841             {#State 79
842             DEFAULT => -19
843             }
844             ],
845             yyrules =>
846             [
847             [#Rule _SUPERSTART
848             '$start', 2, undef
849             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
850             ],
851             [#Rule _STAR_LIST
852             'STAR-1', 2,
853 63     63   230 sub { goto &Parse::Eyapp::Driver::YYActionforT_TX1X2 }
854             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
855             ],
856             [#Rule _STAR_LIST
857             'STAR-1', 0,
858 27     27   1246 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
859             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
860             ],
861             [#Rule treeregexplist_3
862             'treeregexplist', 1,
863 27     27   121 sub { $_[1]->{children} }
864             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
865             ],
866             [#Rule _PAREN
867             'PAREN-2', 2,
868 47     47   197 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
869             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
870             ],
871             [#Rule _OPTIONAL
872             'OPTIONAL-3', 1,
873 47     47   215 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
874             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
875             ],
876             [#Rule _OPTIONAL
877             'OPTIONAL-3', 0,
878 4     4   10 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
879             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
880             ],
881             [#Rule _PLUS_LIST
882             'PLUS-4', 2,
883 5     5   19 sub { goto &Parse::Eyapp::Driver::YYActionforT_TX1X2 }
884             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
885             ],
886             [#Rule _PLUS_LIST
887             'PLUS-4', 1,
888 3     3   15 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
889             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
890             ],
891             [#Rule treeregexp_9
892             'treeregexp', 4,
893             sub {
894 51     51   143 my $name = $_[1][0];
895 51         99 my $tree = $_[3];
896 51         218 my ($action) = $_[4]->children;
897 51         985 my $self = bless {
898             name => $name,
899             times => [ %times ],
900             children => [$tree, $action->{attr} ]
901             }, 'Parse::Eyapp::Treeregexp::TREEREGEXP';
902 51         227 reset_times();
903 51 50       154 print Dumper($self) if $debug;
904 51         152 $self;
905             }
906             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
907             ],
908             [#Rule treeregexp_10
909             'treeregexp', 1,
910 9     9   54 sub { bless $_[1], 'Parse::Eyapp::Treeregexp::GLOBALCODE'; }
911             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
912             ],
913             [#Rule treeregexp_11
914             'treeregexp', 4,
915 3     3   35 sub { bless { name => $_[1], members => $_[3] }, 'Parse::Eyapp::Treeregexp::FAMILY'; }
916             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
917             ],
918             [#Rule treeregexp_12
919             'treeregexp', 1,
920             sub {
921 0     0   0 _SyntaxError("Expected an Identifier for the treeregexp", $tokenend);
922             }
923             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
924             ],
925             [#Rule _PAREN
926             'PAREN-5', 2,
927 10     10   56 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
928             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
929             ],
930             [#Rule _OPTIONAL
931             'OPTIONAL-6', 1,
932 10     10   38 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
933             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
934             ],
935             [#Rule _OPTIONAL
936             'OPTIONAL-6', 0,
937 72     72   398 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
938             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
939             ],
940             [#Rule _PAREN
941             'PAREN-7', 2,
942 4     4   21 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
943             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
944             ],
945             [#Rule _OPTIONAL
946             'OPTIONAL-8', 1,
947 4     4   20 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
948             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
949             ],
950             [#Rule _OPTIONAL
951             'OPTIONAL-8', 0,
952 7     7   28 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
953             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
954             ],
955             [#Rule _PAREN
956             'PAREN-9', 2,
957 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
958             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
959             ],
960             [#Rule _OPTIONAL
961             'OPTIONAL-10', 1,
962 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
963             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
964             ],
965             [#Rule _OPTIONAL
966             'OPTIONAL-10', 0,
967 11     11   48 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
968             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
969             ],
970             [#Rule _PAREN
971             'PAREN-11', 2,
972 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
973             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
974             ],
975             [#Rule _OPTIONAL
976             'OPTIONAL-12', 1,
977 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
978             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
979             ],
980             [#Rule _OPTIONAL
981             'OPTIONAL-12', 0,
982 2     2   8 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
983             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
984             ],
985             [#Rule _PAREN
986             'PAREN-13', 2,
987 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
988             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
989             ],
990             [#Rule _OPTIONAL
991             'OPTIONAL-14', 1,
992 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
993             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
994             ],
995             [#Rule _OPTIONAL
996             'OPTIONAL-14', 0,
997 1     1   5 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
998             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
999             ],
1000             [#Rule _PAREN
1001             'PAREN-15', 2,
1002 4     4   20 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
1003             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1004             ],
1005             [#Rule _OPTIONAL
1006             'OPTIONAL-16', 1,
1007 4     4   15 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1008             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1009             ],
1010             [#Rule _OPTIONAL
1011             'OPTIONAL-16', 0,
1012 20     20   81 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1013             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1014             ],
1015             [#Rule _PAREN
1016             'PAREN-17', 2,
1017 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
1018             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1019             ],
1020             [#Rule _OPTIONAL
1021             'OPTIONAL-18', 1,
1022 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1023             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1024             ],
1025             [#Rule _OPTIONAL
1026             'OPTIONAL-18', 0,
1027 1     1   4 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1028             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1029             ],
1030             [#Rule _PAREN
1031             'PAREN-19', 2,
1032 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
1033             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1034             ],
1035             [#Rule _OPTIONAL
1036             'OPTIONAL-20', 1,
1037 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1038             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1039             ],
1040             [#Rule _OPTIONAL
1041             'OPTIONAL-20', 0,
1042 1     1   4 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1043             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1044             ],
1045             [#Rule _PAREN
1046             'PAREN-21', 2,
1047 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
1048             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1049             ],
1050             [#Rule _OPTIONAL
1051             'OPTIONAL-22', 1,
1052 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1053             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1054             ],
1055             [#Rule _OPTIONAL
1056             'OPTIONAL-22', 0,
1057 50     50   188 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1058             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1059             ],
1060             [#Rule _PAREN
1061             'PAREN-23', 2,
1062 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforParenthesis}
1063             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1064             ],
1065             [#Rule _OPTIONAL
1066             'OPTIONAL-24', 1,
1067 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1068             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1069             ],
1070             [#Rule _OPTIONAL
1071             'OPTIONAL-24', 0,
1072 23     23   76 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1073             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1074             ],
1075             [#Rule treereg_43
1076             'treereg', 5,
1077             sub {
1078 82     82   269 goto &new_ident_inner;
1079             }
1080             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1081             ],
1082             [#Rule treereg_44
1083             'treereg', 6,
1084             sub {
1085 11     11   61 goto &new_regexp_inner;
1086             }
1087             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1088             ],
1089             [#Rule treereg_45
1090             'treereg', 5,
1091             sub {
1092 2     2   8 goto &new_scalar_inner;
1093             }
1094             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1095             ],
1096             [#Rule treereg_46
1097             'treereg', 5,
1098             sub {
1099 1     1   5 goto &new_dot_inner;
1100             }
1101             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1102             ],
1103             [#Rule treereg_47
1104             'treereg', 2,
1105             sub {
1106 24     24   163 goto &new_ident_terminal;
1107             }
1108             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1109             ],
1110             [#Rule treereg_48
1111             'treereg', 3,
1112             sub {
1113 1     1   4 goto &new_regexp_terminal;
1114             }
1115             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1116             ],
1117             [#Rule treereg_49
1118             'treereg', 2,
1119             sub {
1120 50     50   173 goto &new_scalar_terminal;
1121             }
1122             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1123             ],
1124             [#Rule treereg_50
1125             'treereg', 2,
1126             sub {
1127 23     23   92 goto &new_dot_terminal;
1128             }
1129             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1130             ],
1131             [#Rule treereg_51
1132             'treereg', 1,
1133             sub {
1134 33     33   131 goto &new_array_terminal;
1135             }
1136             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1137             ],
1138             [#Rule treereg_52
1139             'treereg', 1,
1140             sub {
1141 2     2   9 goto &new_array_star;
1142             }
1143             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1144             ],
1145             [#Rule _STAR_LIST
1146             'STAR-25', 3,
1147 82     82   509 sub { goto &Parse::Eyapp::Driver::YYActionforT_TX1X2 }
1148             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1149             ],
1150             [#Rule _STAR_LIST
1151             'STAR-25', 1,
1152 96     96   344 sub { goto &Parse::Eyapp::Driver::YYActionforT_single }
1153             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1154             ],
1155             [#Rule _STAR_LIST
1156             'STAR-26', 1,
1157 96     96   251 sub { { $_[1] } # optimize
  96         268  
1158             }
1159             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1160             ],
1161             [#Rule _STAR_LIST
1162             'STAR-26', 0,
1163 0     0   0 sub { goto &Parse::Eyapp::Driver::YYActionforT_empty }
1164             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1165             ],
1166             [#Rule childlist_57
1167             'childlist', 1,
1168             sub {
1169 96     96   490 my @list = $_[1]->children();
1170 96         204 my @New = ();
1171 96         136 my ($r, $b);
1172 96         188 my $numarrays = 0;
1173              
1174             # Merge array prefixes with its successors
1175 96         148 local $_;
1176 96         300 while (@list) {
1177 162         254 $_ = shift @list;
1178 162 100       1631 if ($_->isa('Parse::Eyapp::Treeregexp::ARRAY_TERMINAL')) {
1179 35         65 $numarrays++;
1180 35         56 $r = shift @list;
1181 35 100       113 if (defined($r)) {
1182 16 50       219 croak "Error. Two consecutive lists are not allowed!" if $r->isa('Parse::Eyapp::Treeregexp::ARRAY_TERMINAL');
1183 16         131 $r->{arrayprefix} = $_->{attr};
1184 16         45 $_ = $r;
1185             }
1186             }
1187 162         449 push @New, $_;
1188             }
1189 96         360 $_[1]->{numarrays} = $numarrays;
1190 96         222 $_[1]->{children} = \@New;
1191 96         485 $_[1];
1192             }
1193             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1194 27         28710 ]
1195             ],
1196             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
1197             yybypass => 0,
1198             yybuildingtree => 0,
1199             yyprefix => '',
1200             yyaccessors => {
1201             },
1202             yyconflicthandlers => {}
1203             ,
1204             yystateconflict => { },
1205             @_,
1206             );
1207 27         446 bless($self,$class);
1208              
1209 27         336 $self->make_node_classes('TERMINAL', '_OPTIONAL', '_STAR_LIST', '_PLUS_LIST',
1210             '_SUPERSTART',
1211             '_STAR_LIST',
1212             '_STAR_LIST',
1213             'treeregexplist_3',
1214             '_PAREN',
1215             '_OPTIONAL',
1216             '_OPTIONAL',
1217             '_PLUS_LIST',
1218             '_PLUS_LIST',
1219             'treeregexp_9',
1220             'treeregexp_10',
1221             'treeregexp_11',
1222             'treeregexp_12',
1223             '_PAREN',
1224             '_OPTIONAL',
1225             '_OPTIONAL',
1226             '_PAREN',
1227             '_OPTIONAL',
1228             '_OPTIONAL',
1229             '_PAREN',
1230             '_OPTIONAL',
1231             '_OPTIONAL',
1232             '_PAREN',
1233             '_OPTIONAL',
1234             '_OPTIONAL',
1235             '_PAREN',
1236             '_OPTIONAL',
1237             '_OPTIONAL',
1238             '_PAREN',
1239             '_OPTIONAL',
1240             '_OPTIONAL',
1241             '_PAREN',
1242             '_OPTIONAL',
1243             '_OPTIONAL',
1244             '_PAREN',
1245             '_OPTIONAL',
1246             '_OPTIONAL',
1247             '_PAREN',
1248             '_OPTIONAL',
1249             '_OPTIONAL',
1250             '_PAREN',
1251             '_OPTIONAL',
1252             '_OPTIONAL',
1253             'treereg_43',
1254             'treereg_44',
1255             'treereg_45',
1256             'treereg_46',
1257             'treereg_47',
1258             'treereg_48',
1259             'treereg_49',
1260             'treereg_50',
1261             'treereg_51',
1262             'treereg_52',
1263             '_STAR_LIST',
1264             '_STAR_LIST',
1265             '_STAR_LIST',
1266             '_STAR_LIST',
1267             'childlist_57', );
1268 27         82 $self;
1269             }
1270              
1271              
1272              
1273             my $input;
1274              
1275             sub _Lexer {
1276              
1277 788 50   788   1642 return('', undef) unless defined($input);
1278              
1279             #Skip blanks
1280             $input=~m{\G((?:
1281             \s+ # any white space char
1282             | \#[^\n]* # Perl like comments
1283             | /\*.*?\*/ # C like comments
1284             )+)}xsgc
1285 788 100       3357 and do {
1286 383         783 my($blanks)=$1;
1287              
1288             #Maybe At EOF
1289 383 100       968 pos($input) >= length($input)
1290             and return('', undef);
1291 356         640 $tokenend += $blanks =~ tr/\n//;
1292             };
1293            
1294 761         972 $tokenbegin = $tokenend;
1295              
1296 761 100       1877 $input=~/\G(and)/gc
1297             and return($1, [$1, $tokenbegin]);
1298              
1299             $input=~/\G([A-Za-z_][A-Za-z0-9_]*)/gc
1300 747 100       2030 and do {
1301 172         899 return('IDENT', [$1, $tokenbegin]);
1302             };
1303              
1304             $input=~/\G(\$[A-Za-z_][A-Za-z0-9_]*)/gc
1305 575 100       1244 and do {
1306 52         262 return('SCALAR', [$1, $tokenbegin]);
1307             };
1308              
1309             $input=~/\G(\@[A-Za-z_][A-Za-z0-9_]*)/gc
1310 523 100       1088 and do {
1311 33         202 return('ARRAY', [$1, $tokenbegin]);
1312             };
1313             $input=~m{\G/(
1314             (?:[^/\\]| # no escape or slash
1315             \\\\| # escaped escape
1316             \\/| # escaped slash
1317             \\ # escape
1318             )+?
1319             )
1320             /([Begiomxsc]*)}xgc
1321 490 100       1564 and do {
1322             # $x=~ s/((?:[a-zA_Z_]\w*::)*(?:[a-zA_Z_]\w*))/\\b$1\\b/g
1323 12         40 my $string = $1;
1324 12 100       72 my $options = $2? $2 : '';
1325 12         29 $tokenend += $string =~ tr/\n//;
1326              
1327             # Default behavior: Each perl identifier is surrounded by \b boundaries
1328             # Use "B" option to negate this behavior
1329 12 50       466 $string =~ s/((?:[a-zA-Z_][a-zA-Z_0-9]*::)*(?:[a-zA-Z_][a-zA-Z_0-9]*))/\\b$1\\b/g
1330             unless $options =~ s{B}{};
1331              
1332             # Default behavior: make "x" default option
1333             # Use X option to negate this behavior
1334 12 50 33     123 $options .= "x" unless ($options =~ m{x} or $options =~ s{X}{});
1335              
1336 12         84 return('REGEXP', [$string, $tokenbegin, $options]);
1337             };
1338             $input=~/\G%{/gc
1339 478 50       1033 and do {
1340 0         0 my($code);
1341              
1342 0 0       0 $input=~/\G(.*?)%}/sgc
1343             or _SyntaxError( "Unmatched %{", $tokenbegin);
1344              
1345 0         0 $code=$1;
1346 0         0 $tokenend+= $code=~tr/\n//;
1347 0         0 return('Parse::Eyapp::Treeregexp::GLOBALCODE', [$code, $tokenbegin]);
1348             };
1349              
1350             $input=~/\G{/gc
1351 478 100       1055 and do {
1352 70         106 my($level,$from,$code);
1353              
1354 70         135 $from=pos($input);
1355              
1356 70         167 $level=1;
1357 70         316 while($input=~/([{}])/gc) {
1358 272 50       741 substr($input,pos($input)-1,1) eq '\\' #Quoted
1359             and next;
1360 272 100       1255 $level += ($1 eq '{' ? 1 : -1)
    100          
1361             or last;
1362             }
1363             $level
1364 70 50       220 and _SyntaxError("Not closed open curly bracket { at $tokenbegin");
1365 70         196 $code = substr($input,$from,pos($input)-$from-1);
1366 70         132 $tokenend+= $code=~tr/\n//;
1367 70         376 return('CODE', [$code, $tokenbegin]);
1368             };
1369              
1370 408 100       1161 $input=~/\G(=>)/gc
1371             and return($1, $1);
1372              
1373             #Always return something
1374             $input=~/\G(.)/sg
1375 361 50       1276 and do {
1376 361 50       982 $1 eq "\n" and ++$tokenend;
1377 361         2131 return ($1, [$1, $tokenbegin]);
1378             };
1379             #At EOF
1380 0         0 return('', undef);
1381             }
1382              
1383             sub _Error {
1384 0     0   0 my($value)=$_[0]->YYCurval;
1385              
1386 0 0 0     0 die "Syntax Error at end of file\n" unless (defined($value) and ref($value) eq 'ARRAY');
1387 0         0 my($what)= "input: '$$value[0]'";
1388              
1389 0         0 _SyntaxError("Unexpected $what",$$value[1]);
1390             }
1391              
1392             sub _SyntaxError {
1393 0     0   0 my($message,$lineno)=@_;
1394              
1395 0 0       0 $message= "Error in file $filename: $message, at ".
1396             ($lineno < 0 ? "eof" : "line $lineno").
1397             ".\n";
1398              
1399 0         0 die $message;
1400             }
1401              
1402             ####################################################################
1403             # Purpose : Treeregexp compiler bottom end. Code generation.
1404              
1405             package Parse::Eyapp::Treeregexp;
1406 36     36   493 use Carp;
  36         118  
  36         3623  
1407 36     36   261 use List::Util qw(first);
  36         96  
  36         2887  
1408 36     36   233 use Parse::Eyapp::Base qw(compute_lines slurp_file valid_keys invalid_keys write_file);
  36         78  
  36         177248  
1409              
1410             my %index; # Index of each ocurrence of a variable
1411             my $prefix; # Assume each AST node name /class is prefixed by $prefix
1412             my $severity = 0; # 0 = Don't check arity. 1 = Check arity. 2 = Check and give a warning 3 = ... croak
1413             my $allowlinenumbers = 1; # Enable/Disable line number directives
1414             #my $warninfo = "Line numbers in error messages are relative to the line where new is called.\n";
1415             my %methods; # $method{$treeclass} = [ array of YATW objects or transformations ]
1416             my $ouputlinepattern = '##line NUM FILE # line in code by treeregexp';
1417              
1418             sub compute_var_name {
1419 209     209 0 338 my $var = shift;
1420              
1421 209         222 my $nodename;
1422 209 100       489 if ($times{$var} > 1) { # node is array
1423 40         80 $nodename = $index{$var}++;
1424 40         79 $nodename = '$'."$var\[$nodename]";
1425             }
1426             else {
1427 169         279 $nodename = '$'.$var;
1428             }
1429 209         436 return $nodename;
1430             }
1431              
1432             ####################################################################
1433             # Usage :
1434             # my $transform = Parse::Eyapp::Treeregexp->new( STRING => q{
1435             # zero_times: TIMES(NUM($x), ., .) and { $x->{attr} == 0 } => { $_[0] = $NUM }
1436             # times_zero: TIMES(., ., NUM($x)) and { $x->{attr} == 0 } => { $_[0] = $NUM }
1437             # },
1438             # PACKAGE => 'Transformations',
1439             # OUTPUTFILE => 'main.pm',
1440             # SEVERITY => 0,
1441             # NUMBERS => 0,
1442             # ) ;
1443             # Returns : A Parse::Eyapp::Treeregexp object
1444             # Throws : croak if STRING and INFILE are defined or if no input is provided
1445             # also if the PACKAGE isrg does not contain a valid identifier
1446             # Parameters :
1447             my %_Trnew = (
1448             PACKAGE => 'STRING', # The package where the module will reside
1449             PREFIX => 'STRING', # prefix for all the node classes
1450             OUTPUTFILE => 'STRING', # If specified the package will be dumped to such file
1451             SYNTAX => 'BOOL', # Check perl actions syntax after generating the package
1452             SEVERITY => 'INT', # Controls the level of checking matching the number of childrens
1453             PERL5LIB => 'ARRAY', # Search path
1454             INFILE => 'STRING', # Input file containing the grammar
1455             STRING => 'STRING', # Input string containing the grammar. Incompatible with INFILE
1456             NUMBERS => 'BOOL', # Generate (or not) #line directives
1457             FIRSTLINE => 'INT', # Use it only with STRING. The linenumber where the string
1458             # containing the grammar begins
1459             );
1460             my $validkeys = valid_keys(%_Trnew);
1461              
1462             sub new {
1463 30     30 0 15908 my $class = shift;
1464 30 50       179 croak "Error in new_package: Use named arguments" if (@_ %2);
1465 30         157 my %arg = @_;
1466              
1467 30 50       235 if (defined($a = invalid_keys(\%_Trnew, \%arg))) {
1468 0         0 croak( "Parse::Eyapp::Treeregexp::new Error!: unknown argument $a. "
1469             ."Valid arguments are: $validkeys")
1470             }
1471 30         171 my $checksyntax = 1;
1472 30 50       150 $checksyntax = $arg{SYNTAX} if exists($arg{SYNTAX});
1473              
1474 30         113 my ($packagename, $outputfile) = ($arg{PACKAGE}, $arg{OUTPUTFILE});
1475              
1476             # file scope variables
1477 30         73 $filename = $arg{INFILE};
1478            
1479 30   50     249 my $perl5lib = $arg{PERL5LIB} || [];
1480              
1481             #package scope variables
1482 30         80 $severity = $arg{SEVERITY};
1483 30   100     226 $prefix = $arg{PREFIX} || '';
1484 30 100       225 $allowlinenumbers = defined($arg{NUMBERS})?$arg{NUMBERS}:1 ;
1485              
1486 30         125 my $input_from_file = 0;
1487 30         83 $tokenbegin = $tokenend = 1;
1488              
1489 30         84 $input = $arg{STRING};
1490 30 50       261 if (defined($filename)) {
    50          
1491 0         0 $input_from_file = 1;
1492 0 0       0 croak "STRING and INFILE parameters are mutually exclusive " if defined($input);
1493 0         0 $input = slurp_file($filename, 'trg');
1494             }
1495             elsif (defined($input)) { # input from string
1496 30         106 my ($callerpackagename);
1497 30         183 ($callerpackagename, $filename, $tokenend) = caller;
1498              
1499 30 100 66     275 $packagename = $callerpackagename
1500             unless defined($packagename) # Perl identifier regexp
1501             and $packagename =~ /(?:[A-Za-z_][A-Za-z0-9_]*::)*[A-Za-z_][A-Za-z0-9_]*/;
1502              
1503             }
1504             else {
1505 0         0 croak "Undefined input.";
1506             }
1507 30 50       126 ($packagename) = $filename =~ m{(^[a-zA-Z_]\w*)} if !defined($packagename);
1508 30 100 66     261 $tokenend = $arg{FIRSTLINE} if exists($arg{FIRSTLINE}) and $arg{FIRSTLINE} =~ m{^\s*\d+};
1509 30         85 $tokenbegin = $tokenend;
1510 30 50       365 croak "Bad formed package name"
1511             unless $packagename =~ m{^(?:[A-Za-z_][A-Za-z0-9_]*::)* # Perl identifier: prefix
1512             (?:[A-Za-z_][A-Za-z0-9_]*)$}x;
1513              
1514              
1515             #my ($basename) = $packagename =~ m{([a-zA-Z]\w*$)};
1516             #$outputfile = "$basename.pm" unless defined($outputfile);
1517              
1518 30         275 my $object = bless {
1519             'INPUT_FROM_FILE' => $input_from_file,
1520             'PACKAGENAME' => $packagename,
1521             'OUTPUTFILE' => $outputfile,
1522             'CHECKSYNTAX' => $checksyntax,
1523             'PERL5LIB' => $perl5lib,
1524             }, $class;
1525 30         164 return $object;
1526             }
1527              
1528             sub has_array_prefix {
1529 620     620 0 772 my $self = shift;
1530              
1531 620         2914 return defined($self->{arrayprefix})
1532             }
1533              
1534             { # closure with $formula $declarations and $text
1535              
1536             my $formula;
1537             my $declarations;
1538             my $text = '';
1539              
1540             sub _generate_treereg_code {
1541 229     229   412 my $treereg = shift; # the node
1542 229         300 my $father = shift;
1543 229         442 my $source = shift; # Perl code describing how access this node
1544 229         271 my $order = shift; # my index in the array of children
1545              
1546 229   33     562 my $name = ref($treereg) || $treereg;
1547 229         327 my $aux;
1548             my $nodename;
1549 229         498 my $is_array = has_array_prefix($treereg);
1550              
1551 229         927 ($nodename, $aux) = $treereg->translate($father, $source, $order);
1552 229         555 $formula .= $aux;
1553 229 100 100     3321 return if (ref($treereg) =~ m{TERMINAL$} or $is_array);
1554              
1555             # $j : index of the child in the treeregexp formula not counting arrays
1556 96         145 my $j = 0;
1557 96         143 for (@{$treereg->{children}}) {
  96         272  
1558              
1559             # Saving $is_array has to be done before the call to
1560             #_generate_treereg_code, since
1561             # we delete the array_prefix entry after processing node $_
1562             # (See sub translate_array_prefix)
1563 162         324 $is_array = has_array_prefix($_);
1564 162         810 _generate_treereg_code($_, $nodename, "$nodename->child($j+\$child_index)", $j);
1565 162 100       497 $j++ unless $is_array;
1566             }
1567 96 100       404 if (my $pat = $treereg->{semantic}) {
1568 10         32 my $pattern = process_pattern($pat, $filename);
1569 10         31 $formula .= $pattern;
1570             }
1571             }
1572              
1573             sub generate_treereg_code {
1574 67     67 0 141 my $treereg = shift;
1575              
1576 67         119 $formula = '';
1577 67         390 _generate_treereg_code($treereg, '', '$_[$child_index]', undef);
1578             }
1579            
1580             # Parameters:
1581             # $checksyntax: controls whether or not to check Perl code for syntax errors
1582             sub generate {
1583 27     27 0 167 my $self = shift;
1584 27 50       317 croak "Error at ".__PACKAGE__."::generate. Expected a ".__PACKAGE__." object."
1585             unless $self->isa(__PACKAGE__);
1586 27   50     220 my $checksyntax = $self->{'CHECKSYNTAX'} || 1;
1587 27         116 my ($input_from_file, $packagename, $outputfile)
1588             = @$self{'INPUT_FROM_FILE', 'PACKAGENAME', 'OUTPUTFILE',};
1589              
1590 27         252 my $parser = Parse::Eyapp::Treeregparser->new();
1591 27         306 my $t = $parser->YYParse( yylex => \&Parse::Eyapp::Treeregparser::_Lexer,
1592             yyerror => \&Parse::Eyapp::Treeregparser::_Error,
1593             yybuildingtree => 1);
1594              
1595             # Traverse the tree generating the pattern-action subroutine
1596 27         171 my ($names, @names, %family); # Names of the generated subroutines
1597 27         185 my @Transformations = @$t;
1598 27         91 for my $transform (@Transformations) {
1599             $transform->isa('Parse::Eyapp::Treeregexp::GLOBALCODE')
1600 63 100       770 and do {
1601 9         130 $text .= $transform->translate();
1602 9         24 next; # iteration done
1603             };
1604              
1605             $transform->isa('Parse::Eyapp::Treeregexp::FAMILY')
1606 54 100       394 and do {
1607 3         9 my ($name, @members) = ($transform->{name}[0], @{$transform->{members}{children}});
  3         12  
1608 3         8 push @{$family{$name}}, @members;
  3         12  
1609 3         8 next;
1610             };
1611 51         78 my ($treereg, $action) = @{$transform->{children}};
  51         163  
1612              
1613 51         98 %times = @{$transform->{times}}; # global scope visible. Weakness
  51         252  
1614 51         161 %index = ();
1615 51         228 &fill_declarations(\$declarations);
1616              
1617 51         156 my $name = $transform->{name};
1618              
1619 51   100     229 $action ||= ""; # To Do
1620 51         136 $names .= "$name ";
1621 51         267 generate_treereg_code($treereg);
1622 51         198 my @classes = $treereg->classes;
1623 51         135 push @{$methods{$_}}, $name for @classes;
  79         348  
1624              
1625 51         232 $text .= fill_translation_sub($name, \$declarations, \$formula, $action, $filename);
1626             } # for my $transform ...
1627              
1628 27         155 $text = fill_translation_package($filename, $packagename, \$text, $names, \%family);
1629              
1630 27 50 33     271 if ($input_from_file or defined($outputfile)) {
1631 0 0       0 compute_lines(\$text, $outputfile, $ouputlinepattern) if $self->{NUMBERS};
1632 0         0 write_file($outputfile, \$text);
1633 0 0       0 if ($self->{CHECKSYNTAX}) {
1634 0         0 push @INC, @{$self->{PERL5LIB}};
  0         0  
1635 0         0 require $outputfile;
1636             }
1637             }
1638             else {
1639 27 50       111 print $text if $debug;
1640 27 50       146 if ($self->{CHECKSYNTAX}) {
1641 27         74 push @INC, @{$self->{PERL5LIB}};
  27         93  
1642 27 50   27   250 croak $@ unless eval $text;
  27 100   27   66  
  27 100   27   1178  
  27 100   27   208  
  27 100   691   57  
  27 100   70   1092  
  27 50   65   148  
  27 100   52   51  
  27 50   35   2694  
  27 50   52   25569  
  27 50       79  
  27 100       16698  
  27 50       4918  
  691 50       1025  
  691 50       1430  
  155 100       588  
  239 100       1743  
  237 100       1042  
  230 50       4115  
  170 50       817  
  166 0       390  
  180 0       822  
  140         434  
  75         141  
  110         3132  
  82         606  
  82         1823  
  98         1032  
  39         172  
  28         144  
  22         81  
  19         85  
  57         116  
  55         92  
  0         0  
  0         0  
  52         55  
  52         56  
  52         261  
  1         7  
  1         30  
  1         10  
  1         6  
  1         2  
  1         15  
  0         0  
  0         0  
  35         45  
  35         35  
  52         75  
  52         129  
  35         36  
  35         33  
  35         158  
  54         58  
  54         56  
  54         325  
  5         22  
  4         16  
  4         14  
  4         20  
  52         82  
  52         49  
  0         0  
  0         0  
  52         54  
  52         55  
  52         241  
  1         6  
  0            
  0            
  0            
  0            
  0            
  0            
  0            
1643             }
1644             }
1645              
1646 27         485 undef %times;
1647 27         73 undef %index;
1648 27         133 undef $tokenbegin;
1649 27         54 undef $tokenend;
1650 27         62 undef $prefix;
1651 27         72 undef $input;
1652 27         77 undef $declarations;
1653 27         60 undef $text;
1654 27         66 undef $filename;
1655 27         11016 return 1;
1656             }
1657              
1658             sub translate_array_prefix {
1659 16     16 0 186 my ($self, $father, $order) = @_;
1660              
1661 16         48 my $localformula = $formula;
1662            
1663 16         51 my $arrname = $self->{arrayprefix};
1664 16         61 delete($self->{arrayprefix});
1665 16         152 generate_treereg_code($self);
1666 16         84 my $aux = fill_translation_array_sub($self, $arrname, $order, \$formula, $father);
1667            
1668 16         48 $formula = $localformula;
1669              
1670 16         44 return $aux;
1671             }
1672              
1673             } # closure with $formula $declarations and $text
1674              
1675             sub make_references_to_subs {
1676 30     30 0 408 $_[0] =~ s/\b([a-z_A-Z]\w*)\b/$1 => \\\&$1,/g;
1677             }
1678              
1679             sub unique {
1680 3     3 0 6 my %saw = ();
1681 3         21 my @out = grep(!$saw{$_}++, @_);
1682 3         13 return @out;
1683             }
1684              
1685             # Checks that all the transformation rules in the list have been defined
1686             sub check_existence {
1687 3     3 0 13 my $familyname = shift;
1688 3         6 my $names = shift;
1689 3         5 my $line = shift;
1690              
1691 3         6 for (@_) {
1692 8 50       140 croak "Error! treereg rule '$_' not defined (family '$familyname' at line $line)."
1693             unless $names =~ m/\b$_\b/;
1694             }
1695             }
1696              
1697             sub translate {
1698 229     229 0 564 my ($self, $father, $order, $translation) = @_;
1699              
1700 229 100       413 $translation = translate_array_prefix($self, $father, $order) if has_array_prefix($self);
1701 229         491 return $translation;
1702             }
1703              
1704             ######### Fill subroutines ##########
1705              
1706             sub linenumber {
1707 73     73 0 128 my ($linenumber, $filename) = @_;
1708              
1709 73 100       336 return "#line $linenumber \"$filename\"" if $allowlinenumbers;
1710 14         21 return '';
1711             }
1712              
1713             ####################################################################
1714             # Usage : fill_translation_array_sub($self, $arrname, $order, \$formula, $father);
1715             # Purpose : translation of array atoms in treeregexps like ABC(@a, B, @c)
1716             # Returns : the text containing the sub handler and the loop
1717             # Parameters : $name: gives the name to the array and to the sub handler
1718             # $order: index of the array formula as child
1719             # $formula: declarations
1720             # $father: the father node of the array tree pattern
1721              
1722             sub fill_translation_array_sub {
1723 16     16 0 62 my ($self, $name, $order, $formula, $father, $line) = @_;
1724            
1725 16         54 chomp($$formula);
1726 16         42 my $sname = '$'.$name; # var referencing the sub
1727 16         39 my $aname = '@'.$name; # the array that will hold the nodes
1728 16 50       77 $line = '' unless defined($line);
1729              
1730 16         124 return <<"END_TRANSLATION_STAR_SUB";
1731             my $sname = sub {
1732             my \$child_index = 0;
1733             $$formula
1734             $line
1735             return 1;
1736             }; # end anonymous sub $sname
1737              
1738             return 0 unless until_first_match(
1739             $father, $order, $sname, \\$aname);
1740             \$child_index += 1+$aname;
1741             END_TRANSLATION_STAR_SUB
1742             } # sub fill_translation_array_sub
1743              
1744             sub process_pattern {
1745 14     14 0 28 my ($pat, $filename) = @_;
1746            
1747 14         42 my $linenodirective = linenumber($pat->[1], $filename);
1748 14         99 my ($pattern);
1749 14 50       44 if (defined($pat)) {
1750 14         61 $pattern =<<"ENDOFPATTERN";
1751             return 0 unless do
1752             $linenodirective
1753             {$pat->[0]};
1754             ENDOFPATTERN
1755             }
1756             else {
1757 0         0 $pattern = '';
1758             #chomp($formula);
1759             }
1760 14         51 return $pattern;
1761             }
1762              
1763             sub process_action {
1764 51     51 0 109 my ($action, $filename) = @_;
1765              
1766 51         78 my ($actiontext);
1767              
1768 51 100       172 if ($action) {
1769 47         185 my $line_directive = linenumber($action->[1], $filename);
1770 47         198 $actiontext = "$line_directive\n".
1771             " { $action->[0]}";
1772             }
1773             else {
1774 4         6 $actiontext = " 1;"
1775             }
1776 51         156 return $actiontext;
1777             }
1778              
1779             sub fill_translation_sub {
1780 51     51 0 142 my ($name, $declarations, $formula, $action, $filename, $line) = @_;
1781 51         83 my ($actiontext);
1782              
1783 51 50       195 $line = '' unless defined($line);
1784 51         153 $actiontext = process_action($action, $filename);
1785              
1786 51         593 return <<"END_TREEREG_TRANSLATIONS";
1787              
1788             sub $name {
1789             my \$$name = \$_[3]; # reference to the YATW pattern object
1790             $$declarations
1791             {
1792             my \$child_index = 0;
1793              
1794             $$formula
1795             } # end block of child_index
1796             $actiontext
1797              
1798             } # end of $name
1799             $line
1800             END_TREEREG_TRANSLATIONS
1801             } # end sub fill_translation_sub
1802              
1803             sub fill_declarations {
1804 51     51 0 88 my $declarations = shift;
1805              
1806 51         116 $$declarations = '';
1807 51         182 for (keys(%times)) {
1808 209 100       909 $$declarations .= " my \$$_;\n", next if ($times{$_} == 1);
1809 55         278 $$declarations .= " my \@$_;\n"
1810             }
1811             }
1812              
1813             sub fill_translation_package {
1814 27     27 0 85 my ($filename, $packagename, $code, $names, $family) = @_;
1815 27         74 my $familiesdecl = '';
1816              
1817 27         113 for (keys %$family) {
1818 3         6 my $t;
1819 3         4 my @members = map { $t = $_->{attr}; $t->[0] } @{$family->{$_}};
  8         14  
  8         21  
  3         9  
1820 3         12 @members = unique(@members);
1821 3         10 my $line = $family->{$_}[0]{attr}[1];
1822 3         28 check_existence($_, $names, $line, @members);
1823 3         11 $t = "@members";
1824 3         10 &make_references_to_subs($t);
1825 3         7 my $line_directive = linenumber($line, $filename);
1826 3         18 $familiesdecl .= "$line_directive\n".
1827             "our \@$_ = Parse::Eyapp::YATW->buildpatterns($t);\n"; # TODO lines, etc.
1828             }
1829              
1830 27         65 my $scalar_names;
1831 27         374 ($scalar_names = $names) =~ s/\b([a-z_A-Z]\w*)\b/our \$$1,/g;;
1832 27         139 &make_references_to_subs($names);
1833 27         138 $familiesdecl .= "our \@all = ( $scalar_names) = Parse::Eyapp::YATW->buildpatterns($names);\n";
1834              
1835 27         377 return <<"END_PACKAGE_TRANSLATIONS";
1836             package $packagename;
1837              
1838             # This module has been generated using Parse::Eyapp::Treereg
1839             # from file $filename. Don't modify it.
1840             # Change $filename instead.
1841             # Copyright (c) Casiano Rodriguez-Leon 2006. Universidad de La Laguna.
1842             # You may use it and distribute it under the terms of either
1843             # the GNU General Public License or the Artistic License,
1844             # as specified in the Perl README file.
1845              
1846             use strict;
1847             use warnings;
1848             use Carp;
1849             use Parse::Eyapp::_TreeregexpSupport qw(until_first_match checknumchildren);
1850              
1851             $familiesdecl
1852             $$code
1853             1;
1854              
1855             END_PACKAGE_TRANSLATIONS
1856             } # end of sub fill_translation_package
1857              
1858             ######## TERMINAL classes #########
1859             sub code_translation {
1860 107     107 0 166 my $self = shift;
1861              
1862 107         184 my $pat = $self->{semantic};
1863 107 100       283 return process_pattern($pat, $filename) if $pat;
1864 103         241 return '';
1865             }
1866              
1867             ######## Parse::Eyapp::Treeregexp::REGEXP_TERMINAL #########
1868              
1869             sub Parse::Eyapp::Treeregexp::REGEXP_TERMINAL::translate {
1870 1     1   2 my ($self, $father, $source, $order) = @_;
1871              
1872             # nodename is the variable associated with the tree node i.e.
1873             # for a node NUM it may be $NUM[0] or similar
1874 1         2 my ($nodename, $aux);
1875 1         2 $nodename = '$'.$self->{attr};
1876            
1877 1         3 my ($regexp, $options) = ($self->{regexp}, $self->{options});
1878 1         7 $aux = translate($self, $father, $order,
1879             " return 0 unless ref($nodename = $source) =~ m{$regexp}$options;\n");
1880 1         4 $aux .= code_translation($self);
1881 1         4 return ($nodename, $aux);
1882             }
1883              
1884             sub Parse::Eyapp::Treeregexp::REGEXP_TERMINAL::classes {
1885 12     12   34 my $treereg = shift;
1886              
1887 12         30 my $regexp = $treereg->{regexp};
1888              
1889             # what if option "B" is used?
1890 12         27 my @classes;
1891 12         198 @classes = $regexp =~ m/\\b|((?:[a-zA-Z_][a-zA-Z_0-9]*::)*(?:[a-zA-Z_][a-zA-Z_0-9]*))/g;
1892 12         65 return grep {defined($_) } @classes;
  120         214  
1893             }
1894              
1895             ######## Parse::Eyapp::Treeregexp::SCALAR_TERMINAL #########
1896              
1897             sub Parse::Eyapp::Treeregexp::SCALAR_TERMINAL::translate {
1898 73     73   145 my ($self, $father, $source, $order) = @_;
1899              
1900 73         88 my ($nodename, $aux);
1901              
1902             # Warning! not needed for scalars but for Ws (see alias)
1903 73         172 $nodename = Parse::Eyapp::Treeregexp::compute_var_name($self->{attr});
1904 73         292 $aux = translate($self, $father, $order,
1905             " return 0 unless defined($nodename = $source);\n");
1906              
1907 73         168 $aux .= code_translation($self);
1908 73         7019 return ($nodename, $aux);
1909             }
1910              
1911             sub Parse::Eyapp::Treeregexp::SCALAR_TERMINAL::classes {
1912 3     3   8 my $self = shift;
1913              
1914 3         11 return ('*');
1915             }
1916              
1917             ######## Parse::Eyapp::Treeregexp::IDENT_TERMINAL #########
1918             sub Parse::Eyapp::Treeregexp::IDENT_TERMINAL::translate {
1919 33     33   76 my ($self, $father, $source, $order) = @_;
1920              
1921 33         50 my ($nodename, $aux);
1922 33         71 my $name = $self->{attr};
1923 33         110 $nodename = Parse::Eyapp::Treeregexp::compute_var_name($self->{attr});
1924 33         223 $aux = translate($self, $father, $order,
1925             " return 0 unless ref($nodename = $source) eq '$prefix$name';\n");
1926 33         263 $aux .= code_translation($self);
1927 33         128 return ($nodename, $aux);
1928             }
1929              
1930             sub Parse::Eyapp::Treeregexp::IDENT_TERMINAL::classes {
1931 8     8   11 my $treereg = shift;
1932              
1933 8         20 my @classes = ($treereg->{attr});
1934 8         24 return @classes;
1935             }
1936              
1937             ######## Parse::Eyapp::Treeregexp::ARRAY_TERMINAL #########
1938             sub Parse::Eyapp::Treeregexp::ARRAY_TERMINAL::translate {
1939 19     19   75 my ($self, $father, $source, $order) = @_;
1940              
1941 19         42 my ($nodename, $aux);
1942 19         84 my $id = $self->{attr};
1943 19         48 $nodename = '@'.$id;
1944 19         121 $aux = translate($self, $father, $order,
1945             " $nodename = ($father->children);\n".
1946             " $nodename = $nodename\[\$child_index+$order..\$#$id];\n"
1947             );
1948 19         70 return ($nodename, $aux);
1949             }
1950              
1951             sub Parse::Eyapp::Treeregexp::ARRAY_TERMINAL::classes {
1952 0     0   0 croak "Fatal error: Parse::Eyapp::Treeregexp::ARRAY_TERMINAL::classes called from the root of a tree";
1953             }
1954              
1955             ############### INNER classes ###############
1956             sub generate_check_numchildren {
1957 103     103 0 181 my ($self, $nodename, $severity) = @_;
1958              
1959 103 100       445 return '' unless $severity;
1960              
1961 4         6 my $name = $self->{id};
1962 4         7 my $numexpected = @{$self->{children}};
  4         9  
1963 4         5 my $line = $self->{line};
1964              
1965 4         20 my $warning = " return 0 unless checknumchildren($nodename, $numexpected, $line, ".
1966             "'$filename', $self->{numarrays}, $severity);\n";
1967 4         8 return $warning;
1968             }
1969              
1970             ############### Parse::Eyapp::Treeregexp::REGEXP_INNER ###############
1971              
1972             sub Parse::Eyapp::Treeregexp::REGEXP_INNER::translate {
1973 11     11   41 my ($self, $father, $source, $order) = @_;
1974              
1975 11         30 my ($nodename, $aux);
1976              
1977 11         32 my $name = $self->{id};
1978 11         45 $nodename = Parse::Eyapp::Treeregexp::compute_var_name($name);
1979              
1980 11         159 my $warning = generate_check_numchildren($self, $nodename, $severity);
1981              
1982 11         46 my ($regexp, $options) = ($self->{regexp}, $self->{options});
1983              
1984             # TODO #line goes here
1985 11         52 my $template = " return 0 unless ref($nodename = $source) =~ m{$regexp}$options;\n"
1986             . $warning;
1987 11         58 $aux = translate($self, $father, $order, $template);
1988 11         46 return ($nodename, $aux);
1989             }
1990              
1991             *Parse::Eyapp::Treeregexp::REGEXP_INNER::classes = \&Parse::Eyapp::Treeregexp::REGEXP_TERMINAL::classes;
1992            
1993             ############### Parse::Eyapp::Treeregexp::IDENT_INNER ###############
1994              
1995             sub Parse::Eyapp::Treeregexp::IDENT_INNER::translate {
1996 89     89   176 my ($self, $father, $source, $order) = @_;
1997              
1998 89         209 my ($nodename, $aux);
1999              
2000 89         347 my $name = $self->{id};
2001 89         198 $nodename = Parse::Eyapp::Treeregexp::compute_var_name($name);
2002              
2003 89         214 my $warning = generate_check_numchildren($self, $nodename, $severity);
2004              
2005 89         495 my $template = " return 0 unless (ref($nodename = $source) eq '$prefix$name');\n"
2006             . $warning;
2007 89         202 $aux = translate($self, $father, $order, $template);
2008 89         280 return ($nodename, $aux);
2009             }
2010              
2011             sub Parse::Eyapp::Treeregexp::IDENT_INNER::classes {
2012 28     28   66 my $treereg = shift;
2013              
2014 28         178 my @classes = ( $treereg->{id} );
2015 28         101 return @classes;
2016             }
2017              
2018             ############### Parse::Eyapp::Treeregexp::SCALAR_INNER ###############
2019              
2020             sub Parse::Eyapp::Treeregexp::SCALAR_INNER::translate {
2021 3     3   9 my ($self, $father, $source, $order) = @_;
2022              
2023 3         6 my ($nodename, $aux);
2024              
2025 3         9 my $name = $self->{id};
2026              
2027             # Warning! not needed for scalars but for Ws
2028 3         13 $nodename = Parse::Eyapp::Treeregexp::compute_var_name($name);
2029              
2030 3         23 my $warning = generate_check_numchildren($self, $nodename, $severity);
2031              
2032 3         15 my $template = " return 0 unless defined($nodename = $source);\n"
2033             . $warning;
2034 3         29 $aux = translate($self, $father, $order, $template);
2035 3         13 return ($nodename, $aux);
2036             }
2037              
2038             *Parse::Eyapp::Treeregexp::SCALAR_INNER::classes = \&Parse::Eyapp::Treeregexp::SCALAR_TERMINAL::classes;
2039              
2040             ########## Parse::Eyapp::Treeregexp::GLOBALCODE #############
2041              
2042             sub Parse::Eyapp::Treeregexp::GLOBALCODE::translate {
2043 9     9   21 my $transform = shift;
2044              
2045 9         73 my $line_directive = linenumber($transform->[1], $filename);
2046 9         59 return "$line_directive\n".
2047             "$transform->[0]\n";
2048             };
2049              
2050              
2051              
2052             =for None
2053              
2054             =cut
2055              
2056              
2057             ################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
2058              
2059              
2060              
2061             1;