File Coverage

blib/lib/MarpaX/Languages/C/AST.pm
Criterion Covered Total %
statement 261 410 63.6
branch 84 174 48.2
condition 31 62 50.0
subroutine 22 25 88.0
pod 4 4 100.0
total 402 675 59.5


line stmt bran cond sub pod time code
1 2     2   13253 use strict;
  2         2  
  2         52  
2 2     2   7 use warnings FATAL => 'all';
  2         0  
  2         91  
3              
4             package MarpaX::Languages::C::AST;
5              
6             # ABSTRACT: Translate a C source to an AST
7              
8 2     2   719 use Log::Any qw/$log/;
  2         12743  
  2         7  
9 2     2   3071 use Carp qw/croak/;
  2         8  
  2         82  
10 2     2   705 use MarpaX::Languages::C::AST::Util qw/:all/;
  2         3  
  2         292  
11 2     2   654 use MarpaX::Languages::C::AST::Grammar qw//;
  2         2  
  2         32  
12 2     2   695 use MarpaX::Languages::C::AST::Impl qw//;
  2         8  
  2         56  
13 2     2   851 use MarpaX::Languages::C::AST::Scope qw//;
  2         5  
  2         46  
14 2     2   929 use MarpaX::Languages::C::AST::Callback::Events qw//;
  2         4  
  2         47  
15 2     2   932 use Regexp::Common qw/comment delimited/;
  2         4142  
  2         6  
16              
17             our $WS_RE = qr/[ \t\v\n\f]/; # C.f. doAsmOpaque()
18             our $ASM_COMMENT_RE = qr/(?:;[^\n]*|$RE{comment}{'C++'})/;
19              
20             our $VERSION = '0.47'; # VERSION
21              
22              
23             # ----------------------------------------------------------------------------------------
24             sub new {
25 1     1 1 37 my ($class, %opts) = @_;
26              
27 1   50     6 my $logInfo = $opts{logInfo} || [];
28 1 50       4 if (ref($logInfo) ne 'ARRAY') {
29 0         0 croak 'logInfo must be a reference to ARRAY';
30             }
31 1         3 my %logInfo = ();
32 1         2 map {$logInfo{$_}++} @{$logInfo};
  0         0  
  1         2  
33              
34 1   50     6 my $grammarName = $opts{grammarName} || 'ISO-ANSI-C-2011';
35              
36 1         13 my $grammar = MarpaX::Languages::C::AST::Grammar->new($grammarName, \%logInfo, $opts{start}, $opts{actionObject}, $opts{nonTerminalSemantic}, $opts{terminalSemantic});
37 1         5 my $grammar_option = $grammar->grammar_option();
38 1         3 $grammar_option->{bless_package} = 'C::AST';
39 1         4 $grammar_option->{source} = \$grammar->content();
40 1         3 my $recce_option = $grammar->recce_option();
41              
42 1   50     8 my $lexemeCallback = $opts{lexemeCallback} || '';
43 1         2 my @lexemeCallbackArgs = ();
44 1 50       3 if ($opts{lexemeCallback}) {
45 0 0       0 if (ref($opts{lexemeCallback}) ne 'ARRAY') {
46 0         0 croak 'lexemeCallback option must be an ARRAY reference';
47             }
48 0 0       0 if (! @{$opts{lexemeCallback}}) {
  0         0  
49 0         0 croak 'lexemeCallback is a reference to an empty array';
50             }
51 0 0       0 if (ref($opts{lexemeCallback}->[0]) ne 'CODE') {
52 0         0 croak 'lexemeCallback must start with a CODE reference';
53             }
54 0         0 @lexemeCallbackArgs = @{$opts{lexemeCallback}};
  0         0  
55 0         0 $lexemeCallback = shift(@lexemeCallbackArgs);
56             }
57              
58 1   50     8 my $typedef = $opts{typedef} || [];
59 1 50       4 if (ref($typedef) ne 'ARRAY') {
60 0         0 croak 'typedef must be a reference to ARRAY';
61             }
62              
63 1   50     4 my $enum = $opts{enum} || [];
64 1 50       5 if (ref($enum) ne 'ARRAY') {
65 0         0 croak 'enum must be a reference to ARRAY';
66             }
67              
68 1   50     5 my $lazy = $opts{lazy} || 0;
69              
70             my $self = {
71             _scope => MarpaX::Languages::C::AST::Scope->new(),
72             _grammar => $grammar,
73             _impl => MarpaX::Languages::C::AST::Impl->new($grammar_option, $recce_option),
74             _sourcep => undef,
75             _lexemeCallback => $lexemeCallback,
76             _lexemeCallbackArgs => \@lexemeCallbackArgs,
77             _logInfo => \%logInfo,
78             _typedef => $typedef,
79             _enum => $enum,
80             _lazy => $lazy,
81             _start => $opts{start}
82 1         14 };
83              
84 1         7 bless($self, $class);
85              
86 1         5 $self->_init();
87              
88 1         8 return $self;
89             }
90              
91             # ----------------------------------------------------------------------------------------
92              
93             sub _init {
94 1     1   2 my $self = shift;
95              
96             #
97             # Insert known typedef and enum at the top-level scope
98             #
99 1         2 foreach (@{$self->{_typedef}}) {
  1         8  
100 0         0 $self->scope->parseEnterTypedef($_, [0, length($_)]);
101             }
102 1         2 foreach (@{$self->{_enum}}) {
  1         3  
103 0         0 $self->scope->parseEnterEnum($_, [0, length($_)]);
104             }
105              
106 1         3 return;
107             }
108             # ----------------------------------------------------------------------------------------
109              
110             sub _context {
111 0     0   0 my $self = shift;
112              
113             my $context = $log->is_debug() ?
114 0 0       0 sprintf("\n\nContext:\n\n%s", $self->{_impl}->show_progress()) :
115             '';
116              
117 0         0 return $context;
118             }
119             # ----------------------------------------------------------------------------------------
120              
121              
122             sub parse {
123 1     1 1 6 my ($self, $sourcep) = @_;
124              
125 1         2 $self->{_sourcep} = $sourcep;
126 1         11 $self->{_callbackEvents} = MarpaX::Languages::C::AST::Callback::Events->new($self);
127              
128 1         3 my $max = length(${$sourcep});
  1         4  
129 1         68 my $pos = $[;
130 1         6 $self->_doPreprocessing($pos);
131 1         2 eval {$pos = $self->{_impl}->read($sourcep, $pos)};
  1         9  
132 1 50       39 if ($@) {
133 0         0 my $origError = $@;
134             #
135             # The very first error could be at line 0 / column 0...
136             #
137 0         0 my $line_columnp = eval { lineAndCol($self->{_impl}) };
  0         0  
138 0 0       0 if (! $@) {
139 0         0 logCroak("%s\nLast position:\n\n%s%s", $origError, showLineAndCol(@{$line_columnp}, $self->{_sourcep}), $self->_context());
  0         0  
140             } else {
141 0         0 logCroak("%s", $origError);
142             }
143             }
144             #
145             # The following will be used by callbacks to avoid a call to lastCompleted:
146             #
147             # In Callback/Events.pm, it is clear that we need to retreive the lexeme value
148             # in only one single case: directDeclaratorIdentifier$. This can be done
149             # in a generic way using lastCompleted(), but this is cost a lot and this is not
150             # needed! In fact, if you look to the grammar you will see that IDENTIFIER is
151             # systematically paused before.It is only in _doPauseBeforeLexeme() that IDENTIFIER
152             # can setted. so if _doPauseBeforeLexeme() is setting $self->{_lastIdentifier} value
153             # everytime it is doing a lexeme_read() on IDENTIFIER, the directDeclaratorIdentifier$
154             # event will be triggered and the directDeclaratorIdentifier LHS symbol value is
155             # guaranteed to be what _doPauseBeforeLexeme() has used for its lexeme_read.
156             #
157             # This is because directDeclaratorIdentifier rule is made of only ONE rhs:
158             #
159             # directDeclaratorIdentifier ::= IDENTIFIER
160              
161              
162 1         4 $self->{_lastIdentifier} = undef;
163 1         1 do {
164 18         21 my %lexeme = ();
165             #
166             # Note 1: it is very important that neither _getLexeme() or _doScope() could
167             # generate an event
168             #
169 18         49 $self->_getLexeme(\%lexeme);
170 18         32 $self->_doScope(\%lexeme);
171 18         38 $self->_doEvents();
172             #
173             # Note 2: Any routine below that could generate an event must call again
174             # _doEvents()
175             #
176 18         39 $self->_doAsmOpaque(\%lexeme, $pos, $max);
177 18         37 $pos += $self->_doPauseBeforeLexeme(\%lexeme);
178 18         31 $self->_doLogInfo(\%lexeme);
179 18         27 $self->_doLexemeCallback(\%lexeme);
180 18         27 $self->_doPreprocessing($pos);
181 18         18 eval {$pos = $self->{_impl}->resume()};
  18         45  
182 18 50       11907 if ($@) {
183 0         0 my $line_columnp = lineAndCol($self->{_impl});
184 0         0 logCroak("%s\nLast position:\n\n%s%s", "$@", showLineAndCol(@{$line_columnp}, $self->{_sourcep}), , $self->_context());
  0         0  
185             }
186             } while ($pos < $max);
187              
188 1         6 return $self;
189             }
190              
191             # ----------------------------------------------------------------------------------------
192              
193             sub scope {
194 0     0 1 0 my ($self) = @_;
195              
196 0         0 return $self->{_scope};
197             }
198              
199              
200             # ----------------------------------------------------------------------------------------
201             sub _show_last_expression {
202 0     0   0 my ($self) = @_;
203              
204 0         0 my ($start, $end) = $self->{_impl}->last_completed_range('externalDeclaration');
205 0 0       0 return 'No expression was successfully parsed' if (! defined($start));
206 0         0 my $lastExpression = $self->{_impl}->range_to_string($start, $end);
207 0         0 return "Last expression successfully parsed was: $lastExpression";
208             }
209             # ----------------------------------------------------------------------------------------
210              
211              
212             sub value {
213 1     1 1 2 my ($self, $arrayOfValuesb) = @_;
214              
215 1   50     6 $arrayOfValuesb ||= 0;
216              
217 1         2 my @rc = ();
218              
219 1   33     6 my $valuep = $self->{_impl}->value() || logCroak('%s', $self->_show_last_expression());
220 1 50       10616 if (defined($valuep)) {
221 1         3 push(@rc, $valuep);
222             } else {
223 0         0 logCroak('No parse tree value.');
224             }
225 1         1 do {
226 1         9 $valuep = $self->{_impl}->value();
227 1 50       65 if (defined($valuep)) {
228 0 0       0 if (! $arrayOfValuesb) {
229 0 0       0 if ($self->{_lazy}) {
230 0         0 $log->infof('There is more than just one parse tree value, but lazy mode allow this.');
231 0         0 $valuep = undef;
232             } else {
233 0         0 logCroak('There is more than just one parse tree value.');
234             }
235             }
236 0 0       0 if (defined($valuep)) {
237 0         0 push(@rc, $valuep);
238             }
239             }
240             } while (defined($valuep));
241 1 50       3 if ($arrayOfValuesb) {
242 0         0 return \@rc;
243             } else {
244 1         6 return $rc[0];
245             }
246             }
247             # ----------------------------------------------------------------------------------------
248             sub _doEvents {
249 28     28   27 my $self = shift;
250              
251 28         46 my %events = ();
252 28         23 my $iEvent = 0;
253 28         75 while (defined($_ = $self->{_impl}->event($iEvent++))) {
254 12         66 ++$events{$_->[0]};
255             }
256              
257 28 100       142 if (%events) {
258 5         13 my @events = keys %events;
259 5 50       28 if ($log->is_debug) {
260 0         0 $log->debugf('[%s] Events: %s', whoami(__PACKAGE__), \@events);
261             }
262 5         82 $self->{_callbackEvents}->exec(@events);
263             }
264             }
265             # ----------------------------------------------------------------------------------------
266             sub _getLexeme {
267 25     25   31 my ($self, $lexemeHashp) = @_;
268              
269             #
270             # Get paused lexeme
271             # Trustable if pause after
272             # See _doPauseBeforeLexeme for the others
273             #
274 25         66 my $lexeme = $self->{_impl}->pause_lexeme();
275 25 100       362 if (defined($lexeme)) {
276 23         38 $lexemeHashp->{name} = $lexeme;
277 23         53 ($lexemeHashp->{start}, $lexemeHashp->{length}) = $self->{_impl}->pause_span();
278 23         133 ($lexemeHashp->{line}, $lexemeHashp->{column}) = $self->{_impl}->line_column($lexemeHashp->{start});
279 23         134 $lexemeHashp->{value} = $self->{_impl}->literal($lexemeHashp->{start}, $lexemeHashp->{length});
280             }
281              
282 25         119 return;
283             }
284             # ----------------------------------------------------------------------------------------
285             sub _doLogInfo {
286 18     18   15 my ($self, $lexemeHashp) = @_;
287              
288 18 50 33     94 if (exists($lexemeHashp->{name}) && (exists($self->{_logInfo}->{$lexemeHashp->{name}}) || exists($self->{_logInfo}->{__ALL__}))) {
      66        
289 0 0       0 if ($log->is_info) {
290 0         0 $log->infof("[%8d:%3d] %-30s %s", $lexemeHashp->{line}, $lexemeHashp->{column}, $lexemeHashp->{name}, $lexemeHashp->{value});
291             }
292             }
293              
294 18         18 return;
295             }
296             # ----------------------------------------------------------------------------------------
297             sub _doLexemeCallback {
298 18     18   17 my ($self, $lexemeHashp) = @_;
299              
300 18 0 33     35 if ($self->{_lexemeCallback} && exists($lexemeHashp->{name})) {
301 0         0 my $callback = $self->{_lexemeCallback};
302 0         0 &$callback(@{$self->{_lexemeCallbackArgs}}, $lexemeHashp);
  0         0  
303             }
304              
305 18         16 return;
306             }
307             # ----------------------------------------------------------------------------------------
308             sub _doPreprocessing {
309 19     19   22 my ($self, $pos) = @_;
310             #
311             # Until there is MarpaX::Languages::C::Preprocessor, any preprocessing line is
312             # done HERE: embedding the preprocessing grammar IN C grammar is NOT the thing to do.
313             # These are different grammars, different things. Try to do so, and this will cause
314             # a lot of problems, you will see.
315             # It has to be done in a separate phase.
316             # Fortunately the C grammar is doing a pause on EVERY lexeme. So at every pause
317             # (plus the very beginning), we do recognize ourself preprocessor directives.
318             #
319             # And if a preprocessor directive would not follow exactly a lexeme, too bad, we will
320             # not catch it, letting Marpa silently discard it.
321             #
322 19         15 my $previous = pos(${$self->{_sourcep}});
  19         29  
323 19         16 my $delta = 0;
324 19         15 my $line = 1;
325 19 100       330 if ($pos > $[) {
326 17         46 my $line_columnp = lineAndCol($self->{_impl});
327 17         30 $line = $line_columnp->[0];
328             }
329              
330 19         16 pos(${$self->{_sourcep}}) = $pos;
  19         40  
331 19         24 while (${$self->{_sourcep}} =~ m{\G(\s*^)(\#\s*(\S+)(?:\\.|[^\n])*)(\n|\Z)}smg) {
  19         59  
332 0         0 my $start = $-[0];
333 0         0 my $length = $+[0] - $-[0];
334 0         0 my $match = substr(${$self->{_sourcep}}, $start, $length);
  0         0  
335 0         0 my $pre = substr(${$self->{_sourcep}}, $-[1], $+[1] - $-[1]);
  0         0  
336 0         0 my $preprocessorDirective = substr(${$self->{_sourcep}}, $-[2], $+[2] - $-[2]);
  0         0  
337 0         0 my $directive = substr(${$self->{_sourcep}}, $-[3], $+[3] - $-[3]);
  0         0  
338 0         0 my $lastChar = substr(${$self->{_sourcep}}, $-[4], $+[4] - $-[4]);
  0         0  
339 0 0       0 if ($log->is_debug) {
340 0         0 $log->debugf('Preprocessor: %s', $preprocessorDirective);
341             }
342             #
343             # Last char is newline ?
344             #
345 0 0       0 if (length($lastChar) > 0) {
346             #
347             # We unshift so that next match will see this newline.
348             # This is needed because a preprocessor directive must
349             # start on a fresh new line up to EOF or another newline.
350             # And we used the regexp upper to eat last newline.
351 0         0 my $newPos = pos(${$self->{_sourcep}});
  0         0  
352 0         0 $newPos--;
353 0         0 pos(${$self->{_sourcep}}) = $newPos;
  0         0  
354 0         0 $length--;
355 0         0 substr($match, -1, 1, '');
356             }
357             #
358             # Count the number of newlines we eated in $pre
359             #
360 0         0 $line += ($pre =~ tr/\n//);
361             #
362             # If this is a #line, fake a callback event PREPROCESSOR_LINE_DIRECTIVE
363             #
364 0 0 0     0 if ($directive eq 'line' || $directive =~ /^\d+$/) {
365 0         0 my %lexeme = ();
366 0         0 $lexeme{name} = 'PREPROCESSOR_LINE_DIRECTIVE';
367 0         0 $lexeme{start} = $pos + $delta;
368 0         0 $lexeme{length} = $length;
369 0         0 $lexeme{line} = $line;
370 0         0 $lexeme{column} = -1; # we do not compute column, but send -1 instead of undef just in case
371 0         0 $lexeme{value} = $match;
372 0         0 $self->_doLexemeCallback(\%lexeme);
373             }
374              
375 0         0 $delta += $length;
376             }
377 19         17 pos(${$self->{_sourcep}}) = $previous;
  19         25  
378              
379 19         31 return;
380             }
381             # ----------------------------------------------------------------------------------------
382             sub _doScope {
383 18     18   19 my ($self, $lexemeHashp) = @_;
384              
385             #
386             # Get paused lexeme
387             #
388 18 100       36 if (exists($lexemeHashp->{name})) {
389              
390 16         16 my $lexemeFormatString = "%s \"%s\" at position %d:%d";
391 16         34 my @lexemeCommonInfo = ($lexemeHashp->{name}, $lexemeHashp->{value}, $lexemeHashp->{line}, $lexemeHashp->{column});
392 16         39 my $is_debug = $log->is_debug;
393              
394 16 100       395 if (defined($self->{_callbackEvents}->topic_fired_data('fileScopeDeclarator'))) {
395 15 50       299 if ($self->{_callbackEvents}->topic_fired_data('fileScopeDeclarator')->[0] == -1) {
    100          
396             #
397             # This will be for next round.
398             #
399 0 0       0 if ($is_debug) {
400 0         0 $log->debugf('[%s] fileScopeDeclarator: flagging lookup required at next round.', whoami(__PACKAGE__));
401             }
402 0         0 $self->{_callbackEvents}->topic_fired_data('fileScopeDeclarator')->[0] = 1;
403              
404             } elsif ($self->{_callbackEvents}->topic_fired_data('fileScopeDeclarator')->[0] == 1) {
405             #
406             # Lookup what follows the file-scope declarator
407             #
408 1 50 33     42 if ($lexemeHashp->{name} ne 'COMMA' &&
      33        
409             $lexemeHashp->{name} ne 'SEMICOLON' &&
410             $lexemeHashp->{name} ne 'EQUAL') {
411 1 50       4 if ($is_debug) {
412 0         0 $log->debugf('[%s] fileScopeDeclarator: next lexeme is %s, flagging reenterScope.', whoami(__PACKAGE__), $lexemeHashp->{name});
413             }
414 1         14 $self->{_callbackEvents}->topic_fired_data('reenterScope')->[0] = 1;
415             }
416             #
417             # Flag lookup done
418             #
419 1 50       10 if ($is_debug) {
420 0         0 $log->debugf('[%s] fileScopeDeclarator: flagging lookup done.', whoami(__PACKAGE__));
421             }
422 1         12 $self->{_callbackEvents}->topic_fired_data('fileScopeDeclarator')->[0] = 0;
423             }
424             }
425              
426 16 100 66     431 if ($lexemeHashp->{name} eq 'LCURLY_SCOPE' || $lexemeHashp->{name} eq 'LPAREN_SCOPE') {
    100 100        
427 1 50       3 if ($is_debug) {
428 0         0 $log->debugf("[%s] $lexemeFormatString: entering scope.", whoami(__PACKAGE__), @lexemeCommonInfo);
429             }
430 1         5 $self->{_scope}->parseEnterScope();
431             } elsif ($lexemeHashp->{name} eq 'RCURLY_SCOPE' || $lexemeHashp->{name} eq 'RPAREN_SCOPE') {
432 2 50       7 if ($self->{_scope}->parseScopeLevel == 1) {
433 2 50       5 if ($is_debug) {
434 0         0 $log->debugf("[%s] $lexemeFormatString: delay leaving scope.", whoami(__PACKAGE__), @lexemeCommonInfo);
435             }
436 2         7 $self->{_scope}->parseExitScope(0);
437             } else {
438 0 0       0 if ($is_debug) {
439 0         0 $log->debugf("[%s] $lexemeFormatString: immediate leaving scope.", whoami(__PACKAGE__), @lexemeCommonInfo);
440             }
441 0         0 $self->{_scope}->parseExitScope(1);
442             }
443             } else {
444 13 50       24 if ($is_debug) {
445 0         0 $log->debugf("[%s] $lexemeFormatString.", whoami(__PACKAGE__), @lexemeCommonInfo);
446             }
447 13 100 100     39 if ($self->{_scope}->parseScopeLevel == 1 && $self->{_scope}->parseDelay) {
448 1 50 33     15 if (defined($self->{_callbackEvents}->topic_fired_data('reenterScope')) &&
449             $self->{_callbackEvents}->topic_fired_data('reenterScope')->[0]) {
450 1 50       30 if ($is_debug) {
451 0         0 $log->debugf('[%s] reenterScope flag is on at scope 1.', whoami(__PACKAGE__));
452             }
453 1         6 $self->{_scope}->parseReenterScope();
454 1 50       3 if ($is_debug) {
455 0         0 $log->debugf('[%s] Unflagging reenterScope.', whoami(__PACKAGE__));
456             }
457 1         15 $self->{_callbackEvents}->topic_fired_data('reenterScope')->[0] = 0;
458             } else {
459 0 0       0 if ($is_debug) {
460 0         0 $log->debugf('[%s] reenterScope flag is off at scope 1.', whoami(__PACKAGE__));
461             }
462 0         0 $self->{_scope}->doExitScope();
463             }
464             }
465             }
466             }
467              
468 18         27 return;
469             }
470             # ----------------------------------------------------------------------------------------
471             sub _doAsmOpaque {
472 18     18   21 my ($self, $lexemeHashp, $pos, $max) = @_;
473              
474             #
475             # Get paused lexeme
476             #
477 18 100       37 if (exists($lexemeHashp->{name})) {
478              
479 16         18 my $lexemeFormatString = "%s \"%s\" at position %d:%d";
480 16         33 my @lexemeCommonInfo = ($lexemeHashp->{name}, $lexemeHashp->{value}, $lexemeHashp->{line}, $lexemeHashp->{column});
481 16         33 my $is_debug = $log->is_debug;
482              
483 16 100       86 if ($lexemeHashp->{name} eq 'ANY_ASM') {
484 8 50       15 if ($is_debug) {
485 0         0 $log->debugf("[%s] $lexemeFormatString: checking for the need of ASM_OPAQUE at current position $pos", whoami(__PACKAGE__), @lexemeCommonInfo);
486             }
487 8         7 my $prevpos = pos(${$self->{_sourcep}});
  8         11  
488 8         7 pos(${$self->{_sourcep}}) = $pos;
  8         12  
489 8 100 66     9 if (${$self->{_sourcep}} =~ /\G${WS_RE}*\(/ ||
  8 100       109  
    50          
490 7         71 ${$self->{_sourcep}} =~ /\G${WS_RE}+\w+${WS_RE}*\(/) {
491             #
492             # assume to be eventually GCC style ASM : supported in the BNF
493             #
494 1         2 my $style = substr(${$self->{_sourcep}}, $pos, $+[0] - $pos);
  1         4  
495 1 50       4 if ($is_debug) {
496 0         0 $log->debugf("[%s] $lexemeFormatString: GCC style detected %s%s...)", whoami(__PACKAGE__), @lexemeCommonInfo, $lexemeHashp->{value}, $style);
497             }
498 7         45 } elsif (${$self->{_sourcep}} =~ /\G${WS_RE}*\{/) {
499             #
500             # Opaque ASM block
501             #
502 2         5 my $tmpPos = $+[0];
503 2 50       5 if ($is_debug) {
504 0         0 $log->debugf("[%s] $lexemeFormatString: '{' detected.", whoami(__PACKAGE__), @lexemeCommonInfo);
505             }
506             #
507             # We scan character per character until a matching '}'
508             #
509 2         3 my $found = substr(${$self->{_sourcep}}, $-[0], $+[0] - $-[0]);
  2         8  
510 2         3 my $remain = 1;
511 2         3 my $opaque = '';
512 2         5 while ($tmpPos < $max) {
513 92         60 pos(${$self->{_sourcep}}) = $tmpPos;
  92         105  
514 92 100       65 if (${$self->{_sourcep}} =~ /\G$ASM_COMMENT_RE/) {
  92 100       270  
    50          
515             #
516             # Full comment in one regexp
517             #
518 3         5 my $posAfterComment = $+[0];
519 3         2 my $comment = substr(${$self->{_sourcep}}, $tmpPos, $posAfterComment - $tmpPos);
  3         8  
520 3 50       6 if ($is_debug) {
521 0         0 $log->debugf("[%s] $lexemeFormatString: skipping comment %s", whoami(__PACKAGE__), @lexemeCommonInfo, $comment);
522             }
523 3         3 $found .= $comment;
524 3         5 $tmpPos = $posAfterComment;
525 89         130 } elsif (${$self->{_sourcep}} =~ /\GCOMMENT\s+([^\s])\s+/) {
526             #
527             # MSASM comment directive
528             #
529 3         3 my $delimiter = substr(${$self->{_sourcep}}, $-[1], $+[1] - $-[1]);
  3         11  
530 3         5 pos(${$self->{_sourcep}}) = $-[1];
  3         4  
531 3 50       4 if (${$self->{_sourcep}} =~ /\G(?:$RE{delimited}{-delim=>$delimiter})[^\n]*/) {
  3         17  
532 3         442 my $posAfterComment = $+[0];
533 3         4 my $comment = substr(${$self->{_sourcep}}, $tmpPos, $posAfterComment - $tmpPos);
  3         7  
534 3 50       6 if ($is_debug) {
535 0         0 $log->debugf("[%s] $lexemeFormatString: skipping comment %s", whoami(__PACKAGE__), @lexemeCommonInfo, $comment);
536             }
537 3         6 $found .= $comment;
538 3         23 $tmpPos = $posAfterComment;
539             } else {
540 0         0 my $line_columnp = lineAndCol($self->{_impl});
541 0         0 logCroak("[%s] Failed to find MSASM's COMMENT end delimiter %s.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $delimiter, showLineAndCol($lexemeHashp->{line}, $lexemeHashp->{column}, $self->{_sourcep}), $self->_context());
542             }
543 86         113 } elsif (${$self->{_sourcep}} =~ /\G['"]/) {
544             #
545             # MSASM string, no escape character
546             #
547 0         0 my $delimiter = substr(${$self->{_sourcep}}, $-[0], 1);
  0         0  
548 0         0 pos(${$self->{_sourcep}}) = $-[0];
  0         0  
549 0 0       0 if (${$self->{_sourcep}} =~ /\G(?:$RE{delimited}{-delim=>$delimiter})/) {
  0         0  
550 0         0 my $posAfterString = $+[0];
551 0         0 my $string = substr(${$self->{_sourcep}}, $tmpPos, $posAfterString - $tmpPos);
  0         0  
552 0 0       0 if ($is_debug) {
553 0         0 $log->debugf("[%s] $lexemeFormatString: skipping string %s", whoami(__PACKAGE__), @lexemeCommonInfo, $string);
554             }
555 0         0 $found .= $string;
556 0         0 $tmpPos = $posAfterString;
557             } else {
558 0         0 my $line_columnp = lineAndCol($self->{_impl});
559 0         0 logCroak("[%s] Failed to find MSASM's string delimiter %s.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $delimiter, showLineAndCol($lexemeHashp->{line}, $lexemeHashp->{column}, $self->{_sourcep}), $self->_context());
560             }
561             } else {
562 86         52 my $c = substr(${$self->{_sourcep}}, $tmpPos, 1);
  86         79  
563 86 50       173 if ($c eq '{') {
    100          
564 0         0 ++$remain;
565             } elsif ($c eq '}') {
566 2         1 --$remain;
567             }
568 86         75 $found .= $c;
569 86         53 ++$tmpPos;
570 86 100       207 if ($remain == 0) {
571 2         3 last;
572             }
573             }
574             }
575 2 50       5 if ($remain != 0) {
576 0         0 $log->warnf("[%s] $lexemeFormatString: could not determine opaque asm statement", whoami(__PACKAGE__), @lexemeCommonInfo);
577             } else {
578 2         2 my $newlexeme = 'ASM_OPAQUE';
579 2 50       6 if ($log->is_debug) {
580 0         0 $log->debugf('[%s] Pushing lexeme %s "%s"', whoami(__PACKAGE__), $newlexeme, $found);
581             }
582 2 50       19 if (! defined($self->{_impl}->lexeme_read($newlexeme, $pos, length($found), $found))) {
583 0         0 my $line_columnp = lineAndCol($self->{_impl});
584 0         0 logCroak("[%s] Lexeme value \"%s\" cannot be associated to lexeme name %s at position %d:%d.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $found, $newlexeme, $lexemeHashp->{line}, $lexemeHashp->{column}, showLineAndCol(@{$line_columnp}, $self->{_sourcep}), $self->_context());
  0         0  
585             }
586             #
587             # A lexeme_read() can generate an event
588             #
589 2         155 $self->_getLexeme($lexemeHashp);
590 2         4 $self->_doEvents();
591             }
592 5         16 } elsif (${$self->{_sourcep}} =~ /\G[^\n]*/) {
593             #
594             # Could be an opaque ASM on a single line. If we are wrong, BNF will take over this wrong assumption
595             # by invalidating the tree. Please note that this will handle eventual multiple __asm statements, all
596             # on the same line -;
597             #
598 5         3 my $found = substr(${$self->{_sourcep}}, $-[0], $+[0] - $-[0]);
  5         22  
599 5         7 my $newlexeme = 'ASM_OPAQUE';
600 5 50       11 if ($log->is_debug) {
601 0         0 $log->debugf('[%s] Pushing lexeme %s "%s"', whoami(__PACKAGE__), $newlexeme, $found);
602             }
603 5 50       37 if (! defined($self->{_impl}->lexeme_read($newlexeme, $pos, length($found), $found))) {
604 0         0 my $line_columnp = lineAndCol($self->{_impl});
605 0         0 logCroak("[%s] Lexeme value \"%s\" cannot be associated to lexeme name %s at position %d:%d.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $found, $newlexeme, $lexemeHashp->{line}, $lexemeHashp->{column}, showLineAndCol(@{$line_columnp}, $self->{_sourcep}), $self->_context());
  0         0  
606             }
607             #
608             # A lexeme_read() can generate an event
609             #
610 5         363 $self->_getLexeme($lexemeHashp);
611 5         7 $self->_doEvents();
612             }
613 8         9 pos(${$self->{_sourcep}}) = $prevpos;
  8         28  
614             }
615             }
616              
617 18         21 return;
618             }
619             # ----------------------------------------------------------------------------------------
620             sub _doPauseBeforeLexeme {
621 18     18   19 my ($self, $lexemeHashp) = @_;
622              
623 18         17 my $delta = 0;
624              
625             #
626             # Get paused lexeme
627             #
628 18 100       37 if (exists($lexemeHashp->{name})) {
629             #
630             # C grammar typedef/enumeration_constant/identifier ambiguity
631             #
632 16 100 33     92 if ($lexemeHashp->{name} eq 'TYPEDEF_NAME' ||
      66        
633             $lexemeHashp->{name} eq 'ENUMERATION_CONSTANT' ||
634             $lexemeHashp->{name} eq 'IDENTIFIER') {
635 3         4 my @alternatives = ();
636             #
637             # Determine the correct lexeme
638             #
639 3 50       8 if ($self->{_lazy}) {
640 0 0       0 if ($self->{_scope}->parseIsTypedef($lexemeHashp->{value})) {
    0          
641 0         0 @alternatives = qw/TYPEDEF_NAME IDENTIFIER/;
642             } elsif ($self->{_scope}->parseIsEnum($lexemeHashp->{value})) {
643 0         0 @alternatives = qw/ENUMERATION_CONSTANT IDENTIFIER/;
644             } else {
645 0         0 @alternatives = qw/TYPEDEF_NAME ENUMERATION_CONSTANT IDENTIFIER/;
646             }
647             } else {
648 3         4 my %terminals_expected = map {$_ => 1} @{$self->{_impl}->terminals_expected()};
  95         747  
  3         11  
649 3 50 33     34 if (exists($terminals_expected{TYPEDEF_NAME}) && $self->{_scope}->parseIsTypedef($lexemeHashp->{value})) {
    50 66        
    50          
650 0         0 push(@alternatives, 'TYPEDEF_NAME');
651             } elsif (exists($terminals_expected{ENUMERATION_CONSTANT}) && $self->{_scope}->parseIsEnum($lexemeHashp->{value})) {
652 0         0 push(@alternatives, 'ENUMERATION_CONSTANT');
653             } elsif (exists($terminals_expected{IDENTIFIER})) {
654 3         6 push(@alternatives, 'IDENTIFIER');
655             #
656             # Hack for the Callback framework: store in advance the IDENTIFIER, preventing
657             # a call to lastCompleted
658             #
659 3         12 $self->{_lastIdentifier} = $lexemeHashp->{value};
660             }
661             }
662 3 50       8 if (! @alternatives) {
663 0         0 my $line_columnp = lineAndCol($self->{_impl});
664 0         0 logCroak("[%s] Lexeme value \"%s\" cannot be associated to TYPEDEF_NAME, ENUMERATION_CONSTANT nor IDENTIFIER at line %d, column %d.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $lexemeHashp->{value}, $lexemeHashp->{line}, $lexemeHashp->{column}, showLineAndCol($lexemeHashp->{line}, $lexemeHashp->{column}, $self->{_sourcep}), $self->_context());
665             }
666             #
667             # Push the alternatives, more than one possible only if lazy mode is turned on
668             #
669 3         4 my @alternativesOk = ();
670 3         7 my $is_debug = $log->is_debug;
671 3         16 foreach (@alternatives) {
672 3 50       13 if (defined($self->{_impl}->lexeme_alternative($_, $lexemeHashp->{value}))) {
673 3         66 push(@alternativesOk, $_);
674 3 50       8 if ($is_debug) {
675 0         0 $log->debugf('[%s] Pushed alternative %s "%s"', whoami(__PACKAGE__), $_, $lexemeHashp->{value});
676             }
677 3 50       7 if ($_ eq 'IDENTIFIER') {
678 3         6 $self->{_lastIdentifier} = $lexemeHashp->{value};
679             }
680             } else {
681 0 0       0 if ($is_debug) {
682 0         0 $log->debugf('[%s] Failed alternative %s "%s"', whoami(__PACKAGE__), $_, $lexemeHashp->{value});
683             }
684             }
685             }
686 3 50       8 if (! @alternativesOk) {
687 0         0 my $line_columnp = lineAndCol($self->{_impl});
688 0         0 logCroak("[%s] Lexeme value \"%s\" cannot be associated to %s at position %d:%d.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $lexemeHashp->{value}, \@alternatives, $lexemeHashp->{line}, $lexemeHashp->{column}, showLineAndCol(@{$line_columnp}, $self->{_sourcep}), $self->_context());
  0         0  
689             }
690 3 50       13 if (! defined($self->{_impl}->lexeme_complete($lexemeHashp->{start}, $lexemeHashp->{length}))) {
691 0         0 my $line_columnp = lineAndCol($self->{_impl});
692 0         0 logCroak("[%s] Lexeme value \"%s\" cannot be completed at position %d:%d.\n\nLast position:\n\n%s%s", whoami(__PACKAGE__), $lexemeHashp->{value}, $lexemeHashp->{line}, $lexemeHashp->{column}, showLineAndCol(@{$line_columnp}, $self->{_sourcep}), $self->_context());
  0         0  
693             }
694 3         145 $lexemeHashp->{name} = $alternativesOk[0];
695 3         5 $delta = $lexemeHashp->{length};
696             #
697             # A lexeme_read() can generate an event
698             #
699 3         7 $self->_doEvents();
700             }
701             }
702              
703 18         22 return $delta;
704             }
705              
706              
707             1;
708              
709             __END__