File Coverage

blib/lib/MarpaX/Languages/C/AST/Callback/Events.pm
Criterion Covered Total %
statement 178 290 61.3
branch 13 46 28.2
condition 8 27 29.6
subroutine 27 40 67.5
pod 0 1 0.0
total 226 404 55.9


line stmt bran cond sub pod time code
1 2     2   8 use strict;
  2         2  
  2         52  
2 2     2   7 use warnings FATAL => 'all';
  2         3  
  2         76  
3              
4             package MarpaX::Languages::C::AST::Callback::Events;
5 2     2   9 use MarpaX::Languages::C::AST::Util qw/:all/;
  2         3  
  2         305  
6 2     2   369 use parent qw/MarpaX::Languages::C::AST::Callback/;
  2         222  
  2         10  
7              
8             # ABSTRACT: Events callback when translating a C source to an AST
9              
10 2     2   80 use Carp qw/croak/;
  2         3  
  2         72  
11 2     2   908 use SUPER;
  2         3767  
  2         10  
12 2     2   65 use constant LHS_RESET_EVENT => '';
  2         3  
  2         124  
13 2     2   8 use constant LHS_PROCESS_EVENT => '';
  2         3  
  2         79  
14 2     2   8 use constant CLOSEANYSCOPE_PRIORITY => -1000;
  2         3  
  2         78  
15 2     2   6 use constant RESETANYDATA_PRIORITY => -2000;
  2         2  
  2         5265  
16              
17             our $VERSION = '0.46'; # VERSION
18              
19              
20             sub new {
21 1     1 0 2 my ($class, $outerSelf) = @_;
22              
23 1         13 my $self = $class->SUPER();
24              
25 1 50 33     502 if (! defined($outerSelf) || ref($outerSelf) ne 'MarpaX::Languages::C::AST') {
26 0         0 croak 'outerSelf must be a reference to MarpaX::Languages::C::AST';
27             }
28              
29 1         23 $self->hscratchpad('_impl', $outerSelf->{_impl});
30 1         26 $self->hscratchpad('_scope', $outerSelf->{_scope});
31 1         21 $self->hscratchpad('_sourcep', $outerSelf->{_sourcep});
32              
33             # #######################################################################################################################
34             # From now on, the technique is always the same:
35             #
36             # For a rule that will be isolated for convenience (the grammar uses the action => deref if needed) like:
37             # LHS ::= RHS1 RHS2 ... RHSn
38             #
39             # Suppose we want, at to inspect genome data aggregation associated with rule .
40             #
41             # - We create a brand new callback object:
42             # - We make sure LHS rule is unique, creating a proxy rule with action => deref if needed
43             # - We make sure completion event exist
44             # - We make sure completion events exist
45             # - We make sure <^LHSRHSn> predictions events exist
46             # - We create a dedicated callback that is subscribed to every unique and that collect its data
47             #
48             # - Every <^LHSRHSn> is resetting the data collections they depend upon
49             # - Every is copying the data collections they depend upon and reset it
50             # - The first LHSRHS has a special behaviour: if is hitted while there is a pending ,
51             # this mean that we are recursively hitting the rule. This will push one level. Levels are popped off at .
52             #
53             # - We create callbacks to that are firing the inner callback object.
54             #
55             # - For these callbacks we want to know if the scopes must be all closed before doing the processing.
56             # This is true in general except for functionDefinitionCheck1 and functionDefinitionCheck2 where we want to
57             # access the declarationList at scope 1 and the declarationSpecifiers at scope 0.
58             #
59             # #######################################################################################################################
60              
61             # ################################################################################################
62             # A directDeclarator introduces a typedef-name only when it eventually participates in the grammar
63             # rule:
64             # declaration ::= declarationSpecifiers initDeclaratorList SEMICOLON
65             #
66             # Isolated to single rule:
67             #
68             # declarationCheck ::= declarationCheckdeclarationSpecifiers declarationCheckinitDeclaratorList SEMICOLON
69             # #######################################################################################################################
70 1         7 my @callbacks = ();
71             push(@callbacks,
72             $self->_register_rule_callbacks({
73             lhs => 'declarationCheck',
74             rhs => [ [ 'declarationCheckdeclarationSpecifiers', [ [ 'storageClassSpecifierTypedef', 'typedef' ] ] ],
75 1     1   20 [ 'declarationCheckinitDeclaratorList', [ [ 'directDeclaratorIdentifier', sub { $outerSelf->{_lastIdentifier} } ] ] ]
  1         8  
76             ],
77             method => \&_declarationCheck,
78             # ---------------------------
79             # directDeclarator constraint
80             # ---------------------------
81             # In:
82             # structDeclarator ::= declarator COLON constantExpression | declarator
83             #
84             # ordinary name space names cannot be defined. Therefore all parse symbol activity must be
85             # suspended for structDeclarator.
86             #
87             # structDeclarator$ will be hitted many time (right recursive), but its container
88             # structDeclaration will be hitted only once.
89             # ---------------------------
90             counters => {
91             'structContext' => [ 'structContextStart[]', 'structContextEnd[]', 'level' ]
92             },
93             process_priority => CLOSEANYSCOPE_PRIORITY - 1,
94             }
95             )
96             );
97              
98              
99             # ------------------------------------------------------------------------------------------
100             # directDeclarator constraint
101             # ------------------------------------------------------------------------------------------
102             # In:
103             # functionDefinition ::= declarationSpecifiers declarator declarationList? compoundStatement
104             # typedef is syntactically allowed but never valid in either declarationSpecifiers or
105             # declarationList.
106             #
107             # Isolated to two rules:
108             #
109             # functionDefinitionCheck1 ::= functionDefinitionCheck1declarationSpecifiers declarator
110             # functionDefinitionCheck1declarationList
111             # compoundStatementReenterScope
112             # functionDefinitionCheck2 ::= functionDefinitionCheck2declarationSpecifiers declarator
113             # compoundStatementReenterScope
114             #
115             # Note: We want the processing to happen before the scopes are really closed.
116             # ------------------------------------------------------------------------------------------
117 1         12 push(@callbacks,
118             $self->_register_rule_callbacks({
119             lhs => 'functionDefinitionCheck1',
120             rhs => [ [ 'functionDefinitionCheck1declarationSpecifiers', [ [ 'storageClassSpecifierTypedef', 'typedef' ] ] ],
121             [ 'functionDefinitionCheck1declarationList', [ [ 'storageClassSpecifierTypedef', 'typedef' ] ] ]
122             ],
123             method => \&_functionDefinitionCheck1,
124             process_priority => CLOSEANYSCOPE_PRIORITY + 1,
125             }
126             )
127             );
128 1         13 push(@callbacks,
129             $self->_register_rule_callbacks({
130             lhs => 'functionDefinitionCheck2',
131             rhs => [ [ 'functionDefinitionCheck2declarationSpecifiers', [ [ 'storageClassSpecifierTypedef', 'typedef' ] ] ],
132             ],
133             method => \&_functionDefinitionCheck2,
134             process_priority => CLOSEANYSCOPE_PRIORITY + 1,
135             }
136             )
137             );
138              
139             # ------------------------------------------------------------------------------------------
140             # directDeclarator constraint
141             # ------------------------------------------------------------------------------------------
142             # In:
143             # parameterDeclaration ::= declarationSpecifiers declarator
144             # typedef is syntactically allowed but never valid, but can be obscured by a local parameter.
145             #
146             # Isolated to:
147             #
148             # parameterDeclarationCheck ::= declarationSpecifiers declarator
149             # ------------------------------------------------------------------------------------------
150             push(@callbacks,
151             $self->_register_rule_callbacks({
152             lhs => 'parameterDeclarationCheck',
153             rhs => [ [ 'parameterDeclarationdeclarationSpecifiers', [ [ 'storageClassSpecifierTypedef', 'typedef' ] ] ],
154 1     1   20 [ 'parameterDeclarationCheckDeclarator', [ [ 'directDeclaratorIdentifier', sub { $outerSelf->{_lastIdentifier} } ] ] ]
  1         5  
155             ],
156             counters => {
157             'structContext' => [ 'structContextStart[]', 'structContextEnd[]', 'level' ]
158             },
159             method => \&_parameterDeclarationCheck,
160             }
161             )
162             );
163             # ################################################################################################
164             # An enumerationConstantIdentifier introduces a enum-name. Full point.
165             # rule:
166             # enumerationConstantIdentifier ::= IDENTIFIER
167             # ################################################################################################
168             $self->register(MarpaX::Languages::C::AST::Callback::Method->new
169             (
170             description => 'enumerationConstantIdentifier$',
171 1         30 method => [ \&_enumerationConstantIdentifier_optimized, $outerSelf->{_impl}, $outerSelf->{_scope} ],
172             option => MarpaX::Languages::C::AST::Callback::Option->new
173             (
174             condition => [ [ 'auto' ] ],
175             )
176             )
177             );
178              
179             # #############################################################################################
180             # Register scope callbacks
181             # #############################################################################################
182 1         22 $self->hscratchpad('_scope')->parseEnterScopeCallback(\&_enterScopeCallback, $self, @callbacks);
183 1         17 $self->hscratchpad('_scope')->parseExitScopeCallback(\&_exitScopeCallback, $self, @callbacks);
184             #
185             # and the detection of filescope declarator
186             #
187             $self->register(MarpaX::Languages::C::AST::Callback::Method->new
188             (
189             description => 'fileScopeDeclarator$',
190             method => [ \&_set_helper_optimized, 'fileScopeDeclarator', 1, 'reenterScope', 0 ],
191             method_void => 1,
192             option => MarpaX::Languages::C::AST::Callback::Option->new
193             (
194             condition => [
195             [ 'auto' ],
196 5     5   8 [ sub { my ($method, $callback, $eventsp, $scope) = @_;
197 5         24 return ($scope->parseScopeLevel == 0);
198             },
199 1         26 $self->hscratchpad('_scope')
200             ]
201             ],
202             topic => {'fileScopeDeclarator' => 1,
203             'reenterScope' => 1},
204             topic_persistence => 'any',
205             )
206             )
207             );
208             #
209             # ^externalDeclaration will always close any remaining scope and reset all data
210             #
211 1         22 $self->register(MarpaX::Languages::C::AST::Callback::Method->new
212             (
213             description => '^externalDeclaration',
214             method => [ \&_closeAnyScope, $self->hscratchpad('_scope') ],
215             option => MarpaX::Languages::C::AST::Callback::Option->new
216             (
217             condition => [ [ 'auto' ] ],
218             priority => CLOSEANYSCOPE_PRIORITY
219             )
220             )
221             );
222 1         27 $self->register(MarpaX::Languages::C::AST::Callback::Method->new
223             (
224             description => '^externalDeclaration',
225             method => [ \&_resetAnyData, @callbacks ],
226             option => MarpaX::Languages::C::AST::Callback::Option->new
227             (
228             condition => [ [ 'auto' ] ],
229             priority => RESETANYDATA_PRIORITY
230             )
231             )
232             );
233              
234             #
235             # We are not going to register/unregister/unsubscribe/change topics etc... we can say to Callback that it can
236             # can cache everything that is intensive. Take care, any configuration data to Callback becomes then static.
237             #
238 1         8 foreach ($self, @callbacks) {
239 5         23 $_->cache();
240             }
241              
242 1         13 return $self;
243             }
244             # ----------------------------------------------------------------------------------------
245             sub _closeAnyScope {
246 2     2   4 my ($method, $callback, $eventsp, $scope) = @_;
247              
248 2         7 while ($scope->parseScopeLevel >= 1) {
249 1         6 $scope->doExitScope();
250             }
251             }
252             # ----------------------------------------------------------------------------------------
253             sub _resetAnyData {
254 2     2   5 my ($method, $callback, $eventsp, @callbacks) = @_;
255              
256 2         6 foreach (@callbacks) {
257 8         26 $_->exec(LHS_RESET_EVENT);
258             }
259             }
260             # ----------------------------------------------------------------------------------------
261             sub _enumerationConstantIdentifier {
262 0     0   0 my ($method, $callback, $eventsp) = @_;
263              
264 0         0 my $impl = $callback->hscratchpad('_impl');
265              
266 0         0 my $enum = lastCompleted($impl, 'enumerationConstantIdentifier');
267 0         0 $callback->hscratchpad('_scope')->parseEnterEnum($enum, startAndLength($impl));
268             }
269             sub _enumerationConstantIdentifier_optimized {
270             # my ($method, $callback, $eventsp, $impl, $scope) = @_;
271              
272 0     0   0 return $_[4]->parseEnterEnum(lastCompleted($_[3], 'enumerationConstantIdentifier'), startAndLength($_[3]));
273             }
274             # ----------------------------------------------------------------------------------------
275             sub _parameterDeclarationCheck {
276 0     0   0 my ($method, $callback, $eventsp) = @_;
277             #
278             # Get the topics data we are interested in
279             #
280 0         0 my $parameterDeclarationdeclarationSpecifiers = $callback->topic_level_fired_data('parameterDeclarationdeclarationSpecifiers$');
281 0         0 my $parameterDeclarationCheckDeclarator = $callback->topic_fired_data('parameterDeclarationCheckDeclarator$');
282              
283             #
284             # By definition parameterDeclarationdeclarationSpecifiers contains only typedefs
285             #
286 0         0 my $nbTypedef = $#{$parameterDeclarationdeclarationSpecifiers};
  0         0  
287 0 0       0 if ($nbTypedef >= 0) {
288 0         0 my ($start_lengthp, $line_columnp, $last_completed) = @{$parameterDeclarationdeclarationSpecifiers->[0]};
  0         0  
289 0         0 logCroak("[%s[%d]] %s is not valid in a parameter declaration\n%s\n", whoami(__PACKAGE__), $callback->currentTopicLevel, $last_completed, showLineAndCol(@{$line_columnp}, $callback->hscratchpad('_sourcep')));
  0         0  
290             }
291             #
292             # By definition parameterDeclarationCheckDeclarator contains only directDeclaratorIdentifier
293             #
294 0         0 _enterOrObscureTypedef($callback, $nbTypedef, $parameterDeclarationCheckDeclarator);
295             #
296             # We are called at every parameterDeclarationCheck, and parameterDeclarationCheckDeclarator is an aggregation
297             # of all directDeclaratorIdentifier. We don't need this data anymore
298             #
299 0         0 $callback->reset_topic_fired_data('parameterDeclarationCheckDeclarator$');
300             }
301             # ----------------------------------------------------------------------------------------
302             sub _functionDefinitionCheck1 {
303 0     0   0 my ($method, $callback, $eventsp) = @_;
304             #
305             # Get the topics data we are interested in
306             #
307 0         0 my $functionDefinitionCheck1declarationSpecifiers = $callback->topic_level_fired_data('functionDefinitionCheck1declarationSpecifiers$', -1);
308 0         0 my $functionDefinitionCheck1declarationList = $callback->topic_fired_data('functionDefinitionCheck1declarationList$');
309              
310             #
311             # By definition functionDefinitionCheck1declarationSpecifiers contains only typedefs
312             # By definition functionDefinitionCheck1declarationList contains only typedefs
313             #
314 0         0 my $nbTypedef1 = $#{$functionDefinitionCheck1declarationSpecifiers};
  0         0  
315 0 0       0 if ($nbTypedef1 >= 0) {
316 0         0 my ($start_lengthp, $line_columnp, $last_completed) = @{$functionDefinitionCheck1declarationSpecifiers->[0]};
  0         0  
317 0         0 logCroak("[%s[%d]] %s is not valid in a function declaration specifier\n%s\n", whoami(__PACKAGE__), $callback->currentTopicLevel, $last_completed, showLineAndCol(@{$line_columnp}, $callback->hscratchpad('_sourcep')));
  0         0  
318             }
319              
320 0         0 my $nbTypedef2 = $#{$functionDefinitionCheck1declarationList};
  0         0  
321 0 0       0 if ($nbTypedef2 >= 0) {
322 0         0 my ($start_lengthp, $line_columnp, $last_completed) = @{$functionDefinitionCheck1declarationList->[0]};
  0         0  
323 0         0 logCroak("[%s[%d]] %s is not valid in a function declaration list\n%s\n", whoami(__PACKAGE__), $callback->currentTopicLevel, $last_completed, showLineAndCol(@{$line_columnp}, $callback->hscratchpad('_sourcep')));
  0         0  
324             }
325             }
326             sub _functionDefinitionCheck2 {
327 1     1   2 my ($method, $callback, $eventsp) = @_;
328             #
329             # Get the topics data we are interested in
330             #
331 1         6 my $functionDefinitionCheck2declarationSpecifiers = $callback->topic_level_fired_data('functionDefinitionCheck2declarationSpecifiers$', -1);
332              
333             #
334             # By definition functionDefinitionCheck2declarationSpecifiers contains only typedefs
335             #
336 1         2 my $nbTypedef = $#{$functionDefinitionCheck2declarationSpecifiers};
  1         4  
337 1 50       6 if ($nbTypedef >= 0) {
338 0         0 my ($start_lengthp, $line_columnp, $last_completed) = @{$functionDefinitionCheck2declarationSpecifiers->[0]};
  0         0  
339 0         0 logCroak("[%s[%d]] %s is not valid in a function declaration specifier\n%s\n", whoami(__PACKAGE__), $callback->currentTopicLevel, $last_completed, showLineAndCol(@{$line_columnp}, $callback->hscratchpad('_sourcep')));
  0         0  
340             }
341             }
342             # ----------------------------------------------------------------------------------------
343             sub _declarationCheck {
344 0     0   0 my ($method, $callback, $eventsp) = @_;
345              
346             #
347             # Get the topics data we are interested in
348             #
349 0         0 my $declarationCheckdeclarationSpecifiers = $callback->topic_fired_data('declarationCheckdeclarationSpecifiers$');
350 0         0 my $declarationCheckinitDeclaratorList = $callback->topic_fired_data('declarationCheckinitDeclaratorList$');
351              
352             #
353             # By definition declarationCheckdeclarationSpecifiers contains only typedefs
354             # By definition declarationCheckinitDeclaratorList contains only directDeclaratorIdentifier
355             #
356              
357 0         0 my $nbTypedef = $#{$declarationCheckdeclarationSpecifiers};
  0         0  
358 0 0       0 if ($nbTypedef > 0) {
359             #
360             # Take the second typedef
361             #
362 0         0 my ($start_lengthp, $line_columnp, $last_completed) = @{$declarationCheckdeclarationSpecifiers->[1]};
  0         0  
363 0         0 logCroak("[%s[%d]] %s cannot appear more than once\n%s\n", whoami(__PACKAGE__), $callback->currentTopicLevel, $last_completed, showLineAndCol(@{$line_columnp}, $callback->hscratchpad('_sourcep')));
  0         0  
364             }
365              
366 0         0 _enterOrObscureTypedef($callback, $nbTypedef, $declarationCheckinitDeclaratorList);
367             }
368             # ----------------------------------------------------------------------------------------
369             sub _enterOrObscureTypedef {
370 0     0   0 my ($callback, $nbTypedef, $directDeclaratorIdentifierArrayp) = @_;
371              
372 0         0 my $scope = $callback->hscratchpad('_scope');
373              
374 0         0 foreach (@{$directDeclaratorIdentifierArrayp}) {
  0         0  
375 0         0 my ($start_lengthp, $line_columnp, $last_completed, %counters) = @{$_};
  0         0  
376 0 0       0 if (! $counters{structContext}) {
377 0 0       0 if ($nbTypedef >= 0) {
378 0         0 $scope->parseEnterTypedef($last_completed, $start_lengthp);
379             } else {
380 0         0 $scope->parseObscureTypedef($last_completed);
381             }
382             }
383             }
384             }
385             # ----------------------------------------------------------------------------------------
386             sub _enterScopeCallback {
387 1     1   3 foreach (@_) {
388 5         16 $_->pushTopicLevel();
389             }
390             }
391             sub _exitScopeCallback {
392 1     1   3 foreach (@_) {
393 5         17 $_->popTopicLevel();
394             }
395             }
396             # ----------------------------------------------------------------------------------------
397             sub _storage_helper {
398 0     0   0 my ($method, $callback, $eventsp, $event, $countersHashp, $fixedValue, $callbackValue, $impl) = @_;
399             #
400             # Collect the counters
401             #
402 0         0 my %counters = ();
403 0         0 foreach (keys %{$countersHashp}) {
  0         0  
404 0   0     0 my $counterDatap = $callback->topic_fired_data($_) || [0];
405 0   0     0 $counters{$_} = $counterDatap->[0] || 0;
406             }
407             #
408             # The event name, by convention, is 'event$' or '^$event'
409             #
410 0         0 my $rc;
411              
412 0         0 my $g1 = $impl->current_g1_location();
413 0         0 my ($start, $length) = $impl->g1_location_to_span($g1);
414 0 0       0 if (substr($event, 0, 1) eq '^') {
    0          
415 0         0 $rc = [ [ $start, $length ], lineAndCol($impl, $g1, $start), %counters ];
416             } elsif (substr($event, -1, 1) eq '$') {
417 0 0       0 if (defined($callbackValue)) {
418 0         0 $rc = [ [ $start, $length ], lineAndCol($impl, $g1, $start), &$callbackValue(), %counters ];
419             } else {
420 0         0 substr($event, -1, 1, '');
421 0   0     0 $rc = [ [ $start, $length ], lineAndCol($impl, $g1, $start), $fixedValue || lastCompleted($impl, $event), %counters ];
422             }
423             }
424              
425 0         0 return $rc;
426             }
427             sub _storage_helper_optimized {
428 2     2   5 my ($method, $callback, $eventsp, $event, $countersHashp, $fixedValue, $callbackValue, $impl) = @_;
429             #
430             # Collect the counters
431             #
432 2         3 my %counters = ();
433 2         1 foreach (keys %{$countersHashp}) {
  2         8  
434 2   50     31 my $counterDatap = $callback->topic_fired_data($_) || [0];
435 2   50     50 $counters{$_} = $counterDatap->[0] || 0;
436             }
437             #
438             # The event name, by convention, is 'event$' or '^$event'
439             #
440 2         3 my $rc;
441              
442 2         12 my $g1 = $_[7]->current_g1_location();
443 2         27 my ($start, $length) = $_[7]->g1_location_to_span($g1);
444              
445 2 50       23 if (substr($event, 0, 1) eq '^') {
    50          
446 0         0 $rc = [ [ $start, $length ], lineAndCol($_[7], $g1, $start), %counters ];
447             } elsif (substr($event, -1, 1) eq '$') {
448 2 50       5 if (defined($callbackValue)) {
449 2         11 $rc = [ [ $start, $length ], lineAndCol($_[7], $g1, $start), &$callbackValue(), %counters ];
450             } else {
451 0         0 substr($event, -1, 1, '');
452 0   0     0 $rc = [ [ $start, $length ], lineAndCol($_[7], $g1, $start), $_[5] || lastCompleted($_[7], $event), %counters ];
453             }
454             }
455              
456 2         10 return $rc;
457             }
458             # ----------------------------------------------------------------------------------------
459             sub _inc_helper {
460 0     0   0 my ($method, $callback, $eventsp, $topic, $increment) = @_;
461              
462 0   0     0 my $old_value = $callback->topic_fired_data($topic)->[0] || 0;
463 0         0 my $new_value = $old_value + $increment;
464              
465 0         0 return $new_value;
466             }
467             sub _inc_helper_optimized {
468             # my ($method, $callback, $eventsp, $topic, $increment) = @_;
469              
470 0   0 0   0 return (($_[1]->topic_fired_data($_[3])->[0] || 0) + $_[4]);
471             }
472             # ----------------------------------------------------------------------------------------
473             sub _set_helper {
474 0     0   0 my ($method, $callback, $eventsp, %topic) = @_;
475              
476 0         0 foreach (keys %topic) {
477 0         0 $callback->topic_fired_data($_, [ $topic{$_} ]);
478             }
479             }
480             sub _set_helper_optimized {
481 1     1   5 my (undef, undef, undef, %topic) = @_;
482              
483 1         5 foreach (keys %topic) {
484 2         42 $_[1]->topic_fired_data($_, [ $topic{$_} ]);
485             }
486             }
487             # ----------------------------------------------------------------------------------------
488             sub _reset_helper {
489 0     0   0 my ($method, $callback, $eventsp, @topics) = @_;
490              
491 0         0 my @rc = ();
492 0         0 return @rc;
493             }
494             sub _reset_helper_optimized {
495 8     8   20 return ();
496             }
497             # ----------------------------------------------------------------------------------------
498             sub _collect_and_reset_helper {
499 0     0   0 my ($method, $callback, $eventsp, @topics) = @_;
500              
501 0         0 my @rc = ();
502 0         0 foreach (@topics) {
503 0         0 my $topic = $_;
504 0         0 push(@rc, @{$callback->topic_fired_data($topic)});
  0         0  
505 0         0 $callback->topic_fired_data($topic, []);
506             }
507              
508 0         0 return @rc;
509             }
510             sub _collect_and_reset_helper_optimized {
511             #
512             # This routine is called very often, I tried top optimize it
513             #
514             # my ($method, $callback, $eventsp, @topics) = @_;
515              
516             map {
517 5     5   16 my $this = $_[1]->topic_fired_data($_);
  5         74  
518 5         106 $_[1]->topic_fired_data($_, []);
519 5         30 @{$this};
  5         19  
520             } @_[3..$#_];
521              
522             }
523             # ----------------------------------------------------------------------------------------
524             sub _subFire {
525 0     0   0 my ($method, $callback, $eventsp, $lhs, $subCallback, $filterEventsp, $transformEventsp) = @_;
526              
527 0         0 my @subEvents = grep {exists($filterEventsp->{$_})} @{$eventsp};
  0         0  
  0         0  
528 0 0       0 if (@subEvents) {
529 0 0       0 if (defined($transformEventsp)) {
530 0         0 my %tmp = ();
531 0 0       0 my @transformEvents = grep {++$tmp{$_} == 1} map {$transformEventsp->{$_} || $_} @subEvents;
  0         0  
  0         0  
532 0         0 $subCallback->exec(@transformEvents);
533             } else {
534 0         0 $subCallback->exec(@subEvents);
535             }
536             }
537             }
538             sub _subFire_optimized {
539             #
540             # This routine is called very often, I tried top optimize it
541             #
542             # my ($method, $callback, $eventsp, $lhs, $subCallback, $filterEventsp, $transformEventsp) = @_;
543              
544 7     7   8 my @subEvents = grep {exists($_[5]->{$_})} @{$_[2]};
  20         36  
  7         13  
545 7 50       17 if (@subEvents) {
546 7 100       13 if (defined($_[6])) {
547 1         4 my %tmp = ();
548 1 50       2 $_[4]->exec(grep {++$tmp{$_} == 1} map {$_[6]->{$_} || $_} @subEvents);
  1         6  
  1         7  
549             } else {
550 6         21 $_[4]->exec(@subEvents);
551             }
552             }
553             }
554             # ----------------------------------------------------------------------------------------
555             sub _register_rule_callbacks {
556 4     4   7 my ($self, $hashp) = @_;
557              
558             #
559             # Create inner callback object
560             #
561 4         70 my $callback = MarpaX::Languages::C::AST::Callback->new(log_prefix => ' ' . $hashp->{lhs} . ' ');
562             #
563             # Propagate internal variables to all callback instances
564             #
565 4         474 $callback->hscratchpad('_impl', $self->hscratchpad('_impl'));
566 4         100 $callback->hscratchpad('_scope', $self->hscratchpad('_scope'));
567 4         91 $callback->hscratchpad('_sourcep', $self->hscratchpad('_sourcep'));
568              
569             #
570             # rshProcessEvents will be the list of processing events that we forward to the inner callback object
571             #
572 4         42 my %rshProcessEvents = ();
573             #
574             # Counters are events associated to a counter: every ^xxx increases a counter.
575             # Every xxx$ is decreasing it.
576             # To any genome data, we have attached a hash like {counter1 => counter1_value, counter2 => etc...}
577             #
578 4   100     14 my $countersHashp = $hashp->{counters} || {};
579 4         6 foreach (keys %{$countersHashp}) {
  4         24  
580 2         4 my $counter = $_;
581 2         2 my ($eventStart, $eventEnd, $persistence) = @{$countersHashp->{$counter}};
  2         5  
582 2   50     6 $persistence ||= 'any';
583 2         6 ++$rshProcessEvents{$eventStart};
584 2         52 $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
585             (
586             description => $eventStart,
587             extra_description => $counter . ' [Start] ',
588             method => [ \&_inc_helper_optimized, $counter, 1 ],
589             method_mode => 'replace',
590             option => MarpaX::Languages::C::AST::Callback::Option->new
591             (
592             topic => {$counter => 1},
593             topic_persistence => $persistence,
594             condition => [ [ 'auto' ] ], # == match on description
595             priority => 999,
596             )
597             )
598             );
599 2         15 ++$rshProcessEvents{$eventEnd};
600 2         40 $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
601             (
602             description => $eventEnd,
603             extra_description => $counter . ' [End] ',
604             method => [ \&_inc_helper_optimized, $counter, -1 ],
605             method_mode => 'replace',
606             option => MarpaX::Languages::C::AST::Callback::Option->new
607             (
608             topic => {$counter => 1},
609             topic_persistence => $persistence,
610             condition => [ [ 'auto' ] ], # == match on description
611             priority => 999,
612             )
613             )
614             );
615             }
616              
617             #
618             # Collect the unique list of
619             #
620 4         19 my %genomeEvents = ();
621 4         6 my %genomeEventValues = ();
622 4         4 foreach (@{$hashp->{rhs}}) {
  4         8  
623 7         8 my ($rhs, $genomep) = @{$_};
  7         9  
624 7         7 foreach (@{$genomep}) {
  7         11  
625             #
626             # The genome events will call, by default, last_completed(), which cost
627             # quite a lot. There is no need to do such call when we know in advance
628             # what will be to token value.
629 7         6 my ($name, $value);
630 7 50       15 if (ref($_) eq 'ARRAY') {
631             #
632             # Token value known in advance
633             #
634 7         7 ($name, $value) = @{$_};
  7         10  
635             } else {
636 0         0 ($name, $value) = ($_, undef);
637             }
638 7         10 my $event = $name . '$';
639 7         18 ++$genomeEvents{$event};
640 7         9 ++$rshProcessEvents{$event};
641 7         19 $genomeEventValues{$event} = $value;
642             }
643             }
644             #
645             # Create data Gx$ data collectors. The data will be collected in a
646             # topic with the same name: Gx
647             #
648 4         10 foreach (keys %genomeEvents) {
649 6         17 my ($fixedValue, $callbackValue) = (undef, undef);
650 6 100       14 if (ref($genomeEventValues{$_}) eq 'CODE') {
651 2         8 $callbackValue = $genomeEventValues{$_};
652             } else {
653 4         5 $fixedValue = $genomeEventValues{$_};
654             }
655 6         105 $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
656             (
657             description => $_,
658             extra_description => "$_ [storage] ",
659             method => [ \&_storage_helper_optimized, $_, $countersHashp, $fixedValue, $callbackValue, $self->hscratchpad('_impl') ],
660             option => MarpaX::Languages::C::AST::Callback::Option->new
661             (
662             topic => {$_ => 1},
663             topic_persistence => 'level',
664             condition => [ [ 'auto' ] ], # == match on description
665             priority => 999,
666             )
667             )
668             );
669             }
670              
671 4         29 my $i = 0;
672 4         6 my %rhsTopicsToUpdate = ();
673 4         6 my %rhsTopicsNotToUpdate = ();
674 4         5 foreach (@{$hashp->{rhs}}) {
  4         10  
675 7         28 my ($rhs, $genomep) = @{$_};
  7         9  
676 7         15 my $rhsTopic = $rhs . '$';
677 7         12 $rhsTopicsToUpdate{$rhsTopic} = 1;
678 7         10 $rhsTopicsNotToUpdate{$rhsTopic} = -1;
679              
680 7         7 my %genomeTopicsToUpdate = ();
681 7         65 my %genomeTopicsNotToUpdate = ();
682 7         6 foreach (@{$genomep}) {
  7         12  
683 7         7 my ($name, $value);
684 7 50       15 if (ref($_) eq 'ARRAY') {
685             #
686             # Token value known in advance
687             #
688 7         7 ($name, $value) = @{$_};
  7         9  
689             } else {
690 0         0 ($name, $value) = ($_, undef);
691             }
692 7         12 $genomeTopicsToUpdate{$name . '$'} = 1;
693 7         12 $genomeTopicsNotToUpdate{$name . '$'} = -1;
694             }
695             #
696             # rhs$ event will collect into rhs$ topic all Gx$ topics (created automatically if needed)
697             # and reset them
698             #
699 7         10 my $event = $rhs . '$';
700 7         11 ++$rshProcessEvents{$event};
701 7         143 $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
702             (
703             description => $event,
704             extra_description => "$event [process] ",
705             method => [ \&_collect_and_reset_helper_optimized, keys %genomeTopicsNotToUpdate ],
706             method_mode => 'push',
707             option => MarpaX::Languages::C::AST::Callback::Option->new
708             (
709             condition => [ [ 'auto' ] ], # == match on description
710             topic => {$rhsTopic => 1,
711             %genomeTopicsNotToUpdate},
712             topic_persistence => 'level',
713             priority => 1,
714             )
715             )
716             );
717             }
718              
719             #
720             # Final callback: this will process the event
721             #
722 4         36 my $lhsProcessEvent = LHS_PROCESS_EVENT;
723 4         12 my %lhsProcessEvents = ($hashp->{lhs} . '$' => 1);
724 4         5 my $lhsResetEvent = LHS_RESET_EVENT;
725 4         11 my %lhsResetEvents = ($hashp->{lhs} . '$' => 1, 'translationUnit$' => 1);
726             $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
727             (
728             description => $lhsProcessEvent,
729 4         67 method => [ $hashp->{method} ],
730             option => MarpaX::Languages::C::AST::Callback::Option->new
731             (
732             condition => [ [ 'auto' ] ], # == match on description
733             topic => \%rhsTopicsNotToUpdate,
734             topic_persistence => 'level',
735             priority => 1,
736             )
737             )
738             );
739             #
740             # ... and reset rhs topic data
741             #
742 4         93 $callback->register(MarpaX::Languages::C::AST::Callback::Method->new
743             (
744             description => $lhsResetEvent,
745             method => [ \&_reset_helper_optimized, keys %rhsTopicsToUpdate ],
746             method_mode => 'replace',
747             option => MarpaX::Languages::C::AST::Callback::Option->new
748             (
749             condition => [ [ 'auto' ] ], # == match on description
750             topic => \%rhsTopicsToUpdate,
751             topic_persistence => 'level',
752             priority => 0,
753             )
754             )
755             );
756              
757             #
758             ## Sub-fire RHS processing events for this sub-callback object, except the
759             ## that is done just after.
760             #
761             $self->register(MarpaX::Languages::C::AST::Callback::Method->new
762             (
763             description => $hashp->{lhs} . ' [intermediary events]',
764             method => [ \&_subFire_optimized, $hashp->{lhs}, $callback, \%rshProcessEvents ],
765             option => MarpaX::Languages::C::AST::Callback::Option->new
766             (
767             condition => [
768 20     20   21 [ sub { return grep {exists($rshProcessEvents{$_})} @{$_[2]} }
  48         104  
  20         30  
769 4         106 ]
770             ],
771             )
772             )
773             );
774              
775             #
776             ## For we distinguish the processing event and the reset event.
777             ## Processing event can happen at a pre-defined priority because sometimes we
778             ## want to fire the processing before a scope is closed.
779             ## On the other hand, the reset will always happen after all scopes are
780             ## closed.
781             #
782             $self->register(MarpaX::Languages::C::AST::Callback::Method->new
783             (
784             description => $lhsProcessEvent,
785             method => [ \&_subFire_optimized, $hashp->{lhs}, $callback, \%lhsProcessEvents, {$hashp->{lhs} . '$' => $lhsProcessEvent} ],
786             option => MarpaX::Languages::C::AST::Callback::Option->new
787             (
788             condition => [
789 20     20   16 [ sub { return grep {exists($lhsProcessEvents{$_})} @{$_[2]} }
  48         97  
  20         24  
790             ]
791             ],
792 4   100     117 priority => $hashp->{process_priority} || 0
793             )
794             )
795             );
796              
797 4         39 return $callback;
798             }
799              
800             1;
801              
802             __END__