File Coverage

pperl/Marpa/R2/Perl.pm
Criterion Covered Total %
statement 330 399 82.7
branch 122 198 61.6
condition 46 84 54.7
subroutine 17 19 89.4
pod 0 10 0.0
total 515 710 72.5


line stmt bran cond sub pod time code
1             # Copyright 2022 Jeffrey Kegler
2             # This file is part of Marpa::R2. Marpa::R2 is free software: you can
3             # redistribute it and/or modify it under the terms of the GNU Lesser
4             # General Public License as published by the Free Software Foundation,
5             # either version 3 of the License, or (at your option) any later version.
6             #
7             # Marpa::R2 is distributed in the hope that it will be useful,
8             # but WITHOUT ANY WARRANTY; without even the implied warranty of
9             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10             # Lesser General Public License for more details.
11             #
12             # You should have received a copy of the GNU Lesser
13             # General Public License along with Marpa::R2. If not, see
14             # http://www.gnu.org/licenses/.
15              
16             package Marpa::R2::Perl;
17              
18 4     4   2667 use 5.010001;
  4         13  
19 4     4   28 use strict;
  4         7  
  4         98  
20 4     4   18 use warnings;
  4         8  
  4         161  
21              
22             package Marpa::R2::Internal::Perl;
23              
24 4     4   20 use English qw( -no_match_vars );
  4         8  
  4         22  
25 4     4   3231 use charnames ':full';
  4         33656  
  4         37  
26              
27 4     4   2778 use Marpa::R2::Perl::Version ();
  4         9  
  4         27877  
28              
29             # This code is about Perl GRAMMAR.
30             # If you're looking here
31             # for a Perl SEMANTICS here,
32             # you won't find one.
33              
34             my $reference_grammar = <<'END_OF_GRAMMAR';
35              
36             # This is taken from perly.y for Perl 5.12.1
37             prog: prog ::= lineseq ;
38              
39             # /* An ordinary block */
40             block: block ::= '{' lineseq '}' ;
41              
42             mblock ::= '{' lineseq '}' ;
43              
44             # /* A collection of "lines" in the program */
45             lineseq_t: lineseq ::= ;
46             lineseq__decl: lineseq ::= lineseq decl ;
47             lineseq__line: lineseq ::= lineseq line ;
48              
49             # /* A "line" in the program */
50             line ::= label cond ;
51             line ::= loop ; # /* loops add their own labels */
52             line ::= switch ; # /* ... and so do switches */
53             line ::= label case ;
54             line ::= label ';' ;
55             line__sideff: line ::= label sideff ';' ;
56             line ::= label PLUGSTMT ;
57              
58             /* An expression which may have a side-effect */
59             sideff ::= error ;
60             sideff: sideff ::= expr ;
61             sideff ::= expr IF expr ;
62             sideff ::= expr UNLESS expr ;
63             sideff ::= expr WHILE expr ;
64             sideff ::= expr UNTIL iexpr ;
65             sideff ::= expr FOR expr ;
66             sideff ::= expr WHEN expr ;
67              
68             /* else and elsif blocks */
69             else ::= ; /* NULL */
70             else ::= ELSE mblock ;
71             else ::= ELSIF '(' mexpr ')' mblock else ;
72              
73             /* Real conditional expressions */
74             cond ::= IF '(' mexpr ')' mblock else ;
75             cond ::= UNLESS '(' miexpr ')' mblock else ;
76              
77             /* Cases for a switch statement */
78             case ::= WHEN '(' remember mexpr ')' mblock ;
79             case ::= DEFAULT block ;
80              
81             /* Continue blocks */
82             cont ::= ; /* NULL */
83             cont ::= CONTINUE block ;
84              
85             /* Loops: while, until, for, and a bare block */
86             loop ::= label WHILE '(' remember texpr ')' mintro mblock cont ;
87             loop ::= label UNTIL '(' remember iexpr ')' mintro mblock cont ;
88             loop ::= label FOR MY remember my_scalar '(' mexpr ')' mblock cont ;
89             loop ::= label FOR scalar '(' remember mexpr ')' mblock cont ;
90             loop ::= label FOR '(' remember mexpr ')' mblock cont ;
91             loop ::= label FOR '(' remember mnexpr ';' texpr ';' mintro mnexpr ')' mblock ;
92             /* basically fake up an initialize-while lineseq */
93             loop ::= label block cont ; /* a block is a loop that happens once */
94              
95             /* Switch blocks */
96             switch ::= label GIVEN '(' remember mydefsv mexpr ')' mblock ;
97              
98             /* determine whether there are any new my declarations */
99             mintro ::= ; /* NULL */
100              
101             /* Normal expression */
102             nexpr ::= ;
103             nexpr ::= sideff ;
104              
105             /* Boolean expression */
106             texpr ::= ; /* NULL means true */
107             texpr ::= expr ;
108              
109             /* Inverted boolean expression */
110             iexpr ::= expr ;
111              
112             /* Expression with its own lexical scope */
113             mexpr ::= expr ;
114              
115             mnexpr ::= nexpr ;
116              
117             miexpr ::= iexpr ;
118              
119             /* Optional "MAIN:"-style loop labels */
120             label ::= ; /* empty */
121             label ::= LABEL ;
122              
123             /* Some kind of declaration - just hang on peg in the parse tree */
124             decl ::= format ;
125             decl ::= subrout ;
126             decl ::= mysubrout ;
127             decl ::= package ;
128             decl ::= use ;
129             decl ::= peg ;
130              
131             peg ::= PEG ;
132              
133             format ::= FORMAT startformsub formname block ;
134              
135             formname ::= WORD ;
136             formname ::= ; /* NULL */
137              
138             /* Unimplemented "my sub foo { }" */
139             mysubrout ::= MYSUB startsub subname proto subattrlist subbody ;
140              
141             /* Subroutine definition */
142             subrout ::= SUB startsub subname proto subattrlist subbody ;
143              
144             startsub ::= ; /* NULL */ /* start a regular subroutine scope */
145              
146             startanonsub ::= ; /* NULL */ /* start an anonymous subroutine scope */
147              
148             startformsub ::= ; /* NULL */ /* start a format subroutine scope */
149              
150             /* Name of a subroutine - must be a bareword, could be special */
151             subname ::= WORD ;
152              
153             /* Subroutine prototype */
154             proto ::= ; /* NULL */
155             proto ::= THING ;
156              
157             /* Optional list of subroutine attributes */
158             subattrlist ::= ; /* NULL */
159             subattrlist ::= COLONATTR THING ;
160             subattrlist ::= COLONATTR ;
161              
162             /* List of attributes for a "my" variable declaration */
163             myattrlist ::= COLONATTR THING ;
164             myattrlist ::= COLONATTR ;
165              
166             /* Subroutine body - either null or a block */
167             subbody ::= block ;
168             subbody ::= ';' ;
169              
170             package ::= PACKAGE WORD WORD ';' ;
171              
172             /* use ::= USE startsub WORD WORD listexpr ';' ; */
173             long_use: use ::= USE startsub WORD VERSION listexpr ';' ;
174             revlong_use: use ::= USE startsub VERSION WORD listexpr ';' ;
175             perl_version_use: use ::= USE startsub VERSION ';' ;
176             short_use: use ::= USE startsub WORD listexpr ';' ;
177              
178             /* Ordinary expressions; logical combinations */
179              
180             expr: expr ::= or_expr;
181              
182             # %left OROP DOROP
183             or_expr: or_expr ::= or_expr OROP and_expr ;
184             or_expr__dor: or_expr ::= or_expr DOROP and_expr ;
185             or_expr__t : or_expr ::= and_expr ;
186              
187             # %left ANDOP
188             and_expr: and_expr ::= and_expr ANDOP argexpr ;
189             and_expr__t: and_expr ::= argexpr ;
190              
191             /* Expressions are a list of terms joined by commas */
192             argexpr__comma: argexpr ::= argexpr ',' ;
193             argexpr: argexpr ::= argexpr ',' term ;
194             argexpr__t: argexpr ::= term ;
195              
196             /* Names of methods. May use $object->$methodname */
197             method ::= METHOD ;
198             method ::= scalar ;
199              
200              
201             # %nonassoc PREC_LOW
202             # %nonassoc LOOPEX
203             # %left OROP DOROP
204             # %left ANDOP
205             # %right NOTOP
206             # %nonassoc LSTOP LSTOPSUB
207             # %left ','
208             # %right ASSIGNOP
209             # %right '?' ':'
210             # %nonassoc DOTDOT YADAYADA
211             # %left OROR DORDOR
212             # %left ANDAND
213             # %left BITOROP
214             # %left BITANDOP
215             # %nonassoc EQOP
216             # %nonassoc RELOP
217             # %nonassoc UNIOP UNIOPSUB
218             # %nonassoc REQUIRE
219             # %left SHIFTOP
220             # %left ADDOP
221             # %left MULOP
222             # %left MATCHOP
223             # %right '!' '~' UMINUS REFGEN
224             # %right POWOP
225             # %nonassoc PREINC PREDEC POSTINC POSTDEC
226             # %left ARROW
227             # %nonassoc ')'
228             # %left '('
229             # %left '[' '{'
230              
231             # %nonassoc PREC_LOW
232             # no terms
233              
234             # %nonassoc LOOPEX
235             term__t: term ::= term_notop ;
236             term ::= LOOPEX ; /* loop exiting command (goto, last, dump, etc) */
237             term ::= LOOPEX term_notop ;
238              
239             # %left OROP DOROP
240             # %left ANDOP
241             # no terms, just expr's
242              
243             # %right NOTOP
244             term_notop__t: term_notop ::= term_listop ;
245             term_notop ::= NOTOP argexpr ; /* not $foo */
246              
247             # %nonassoc LSTOP LSTOPSUB
248             /* List operators */
249             term_listop__t: term_listop ::= term_assign ;
250             term_listop ::= LSTOP indirob argexpr ; /* map {...} @args or print $fh @args */
251             term_lstop: term_listop ::= LSTOP listexpr ; /* print @args */
252             term_listop ::= LSTOPSUB startanonsub block listexpr ;
253             term_listop ::= METHOD indirob listexpr ; /* new Class @args */
254             term_assign_lstop: term_listop ::= term_cond ASSIGNOP term_listop ; /* $x = bless $x, $y */
255              
256             # /* sub f(&@); f { foo } ... */ /* ... @bar */
257              
258             # %left ','
259             # no terms
260              
261             # %right ASSIGNOP
262             /* Binary operators between terms */
263             term_assign__t: term_assign ::= term_cond ;
264             # $x = $y
265             term_assign: term_assign ::= term_cond ASSIGNOP term_assign ;
266              
267             # %right '?' ':'
268             term_cond__t: term_cond ::= term_dotdot ;
269             term_cond: term_cond ::= term_dotdot '?' term_cond ':' term_cond ;
270              
271             # %nonassoc DOTDOT YADAYADA
272             term_dotdot__t: term_dotdot ::= term_oror ;
273             # $x..$y, $x...$y */
274             term_dotdot: term_dotdot ::= term_oror DOTDOT term_oror ;
275             YADAYADA: term_dotdot ::= YADAYADA ;
276              
277             # %left OROR DORDOR
278             term_oror__t: term_oror ::= term_andand ;
279             term_oror ::= term_oror OROR term_andand ; /* $x || $y */
280             term_oror ::= term_oror DORDOR term_andand ; /* $x // $y */
281              
282             # %left ANDAND
283             term_andand__t: term_andand ::= term_bitorop ;
284             term_andand ::= term_andand ANDAND term_bitorop ; /* $x && $y */
285              
286             # %left BITOROP
287             term_bitorop__t: term_bitorop ::= term_bitandop;
288             term_bitorop ::= term_bitorop BITOROP term_bitandop ; /* $x | $y */
289              
290             # %left BITANDOP
291             term_bitandop__t: term_bitandop ::= term_eqop ;
292             term_bitandop ::= term_bitandop BITANDOP term_eqop ; /* $x & $y */
293              
294             # %nonassoc EQOP
295             term_eqop__t: term_eqop ::= term_relop ;
296             term_eqop ::= term_relop EQOP term_relop ; /* $x == $y, $x eq $y */
297              
298             # %nonassoc RELOP
299             term_relop__t: term_relop ::= term_uniop ;
300             term_relop ::= term_uniop RELOP term_uniop ; /* $x > $y, etc. */
301              
302             # %nonassoc UNIOP UNIOPSUB
303             term_uniop__t: term_uniop ::= term_require ;
304             uniop: term_uniop ::= UNIOP ; /* Unary op, $_ implied */
305             term_uniop ::= UNIOP block ; /* eval { foo }* */
306             term_uniop ::= UNIOP term_require ; /* Unary op */
307             term_uniop ::= UNIOPSUB ;
308             term_uniop ::= UNIOPSUB term_require ; /* Sub treated as unop */
309             /* Things called with "do" */
310             term_uniop ::= DO term_require ; /* do $filename */
311             /* "my" declarations, with optional attributes */
312             # MY has no precedence
313             # so apparently %prec UNIOP for term ::= myattrterm does the job
314             term_myattr: term_uniop ::= MY myterm myattrlist ;
315             term_my: term_uniop ::= MY myterm ;
316             term_local: term_uniop ::= LOCAL term_require ;
317              
318             # %nonassoc REQUIRE
319             term_require__t: term_require ::= term_shiftop ;
320             term_require ::= REQUIRE ; /* require, $_ implied */
321             term_require ::= REQUIRE term_shiftop ; /* require Foo */
322              
323             # %left SHIFTOP
324             term_shiftop__t: term_shiftop ::= term_addop ;
325             term_shiftop ::= term_shiftop SHIFTOP term_addop ; /* $x >> $y, $x << $y */
326              
327             # %left ADDOP
328             term_addop__t: term_addop ::= term_mulop ;
329             term_addop ::= term_addop ADDOP term_mulop ; /* $x + $y */
330              
331             # %left MULOP
332             term_mulop__t: term_mulop ::= term_matchop ;
333             term_mulop ::= term_mulop MULOP term_matchop ; /* $x * $y, $x x $y */
334              
335             # %left MATCHOP
336             term_matchop__t: term_matchop ::= term_uminus ;
337             term_matchop ::= term_matchop MATCHOP term_uminus ; /* $x =~ /$y/ */
338              
339             # %right '!' '~' UMINUS REFGEN
340             term_uminus__t: term_uminus ::= term_powop ;
341             term_uminus ::= '!' term_uminus ; /* !$x */
342             term_uminus ::= '~' term_uminus ; /* ~$x */
343             /* Unary operators and terms */
344             term_uminus ::= '-' term_uminus ; /* -$x */
345             term_uminus ::= '+' term_uminus ; /* +$x */
346             refgen: term_uminus ::= REFGEN term_uminus ; /* \$x, \@y, \%z */
347              
348             # %right POWOP
349             term_powop__t: term_powop ::= term_increment ;
350             term_powop ::= term_increment POWOP term_powop ; /* $x ** $y */
351              
352             # %nonassoc PREINC PREDEC POSTINC POSTDEC
353             term_increment__t: term_increment ::= term_arrow ;
354             term_increment ::= term_arrow POSTINC ; /* $x++ */
355             term_increment ::= term_arrow POSTDEC ; /* $x-- */
356             term_increment ::= PREINC term_arrow ; /* ++$x */
357             term_increment ::= PREDEC term_arrow ; /* --$x */
358              
359             # %left ARROW
360             term_arrow__t: term_arrow ::= term_hi ;
361             term_arrow ::= term_arrow ARROW method '(' listexprcom ')' ; /* $foo->bar(list) */
362             term_arrow ::= term_arrow ARROW method ; /* $foo->bar */
363              
364             # Able to collapse the last few
365             # because no RHS terms
366             # %nonassoc ')'
367             # %left '('
368             # %left '[' '{' -- no terms at this precedence
369              
370             term_hi ::= DO WORD '(' ')' ; /* do somesub() */
371             term_hi ::= DO WORD '(' expr ')' ; /* do somesub(@args) */
372             term_hi ::= DO scalar '(' ')' ; /* do $subref () */
373             term_hi ::= DO scalar '(' expr ')' ; /* do $subref (@args) */
374             term_hi__parens: term_hi ::= '(' expr ')' ;
375             term_hi ::= '(' ')' ;
376             term_hi ::= amper '(' ')' ; /* &foo() */
377             term_hi ::= amper '(' expr ')' ; /* &foo(@args) */
378             term_hi ::= FUNC0 '(' ')' ;
379             term_hi ::= FUNC1 '(' ')' ; /* not () */
380             term_hi ::= FUNC1 '(' expr ')' ; /* not($foo) */
381             term_hi ::= PMFUNC '(' argexpr ')' ; /* m//, s///, tr/// */
382             term_hi ::= FUNC '(' indirob expr ')' ; /* print ($fh @args */
383             term_hi ::= FUNCMETH indirob '(' listexprcom ')' ; /* method $object (@args) */
384             term_hi ::= FUNC '(' listexprcom ')' ; /* print (@args) */
385             anon_hash: term_hi ::= HASHBRACK expr ';' '}' ; /* { foo => "Bar" } */
386             anon_empty_hash: term_hi ::= HASHBRACK ';' '}' ; /* { } (';' by tokener) */
387             term_hi ::= ANONSUB startanonsub proto subattrlist block ;
388             do_block: term_hi ::= DO block ; /* do { code */
389             term_hi__scalar: term_hi ::= scalar ;
390             term_hi__star: term_hi ::= star ;
391             term_hi__hsh: term_hi ::= hsh ;
392             term_hi__ary: term_hi ::= ary ;
393             # $#x, $#{ something }
394             term_hi__arylen: term_hi ::= arylen ;
395             term_hi__subscripted: term_hi ::= subscripted ;
396             term_hi__THING: term_hi ::= THING ;
397             /* Constructors for anonymous data */
398             term_hi__anon_array: term_hi ::= '[' expr ']' ;
399             term_hi__anon_empty_array: term_hi ::= '[' ']' ;
400              
401             # Some kind of subscripted expression
402             subscripted ::= star '{' expr ';' '}' ; /* *main::{something} */
403             array_index: subscripted ::= scalar '[' expr ']' ; /* $array[$element] */
404             term_hi__arrow_array: subscripted ::= term_hi ARROW '[' expr ']' ; /* somearef->[$element] */
405             array_index_r: subscripted ::= subscripted '[' expr ']' ; /* $foo->[$bar]->[$baz] */
406             hash_index: subscripted ::= scalar '{' expr ';' '}' ; /* $foo->{bar();} */
407             term_hi__arrow_hash: subscripted ::= term_hi ARROW '{' expr ';' '}' ; /* somehref->{bar();} */
408             hash_index_r: subscripted ::= subscripted '{' expr ';' '}' ; /* $foo->[bar]->{baz;} */
409             subscripted ::= term_hi ARROW '(' ')' ; /* $subref->() */
410             subscripted ::= term_hi ARROW '(' expr ')' ; /* $subref->(@args) */
411             subscripted ::= subscripted '(' expr ')' ; /* $foo->{bar}->(@args) */
412             subscripted ::= subscripted '(' ')' ; /* $foo->{bar}->() */
413             subscripted ::= '(' expr ')' '[' expr ']' ; /* list slice */
414             subscripted ::= '(' ')' '[' expr ']' ; /* empty list slice! */
415              
416             term_hi ::= ary '[' expr ']' ; /* array slice */
417             term_hi ::= ary '{' expr ';' '}' ; /* @hash{@keys} */
418              
419             term_hi ::= amper ; /* &foo; */
420             term_hi ::= NOAMP WORD listexpr ; /* foo(@args) */
421             term_hi ::= FUNC0 ; /* Nullary operator */
422             term_hi ::= FUNC0SUB ; /* Sub treated as nullop */
423             term_hi ::= WORD ;
424             term_hi ::= PLUGEXPR ;
425              
426             # End of list of terms
427              
428             /* Things that can be "my"'d */
429             myterm_scalar: myterm ::= scalar ;
430             myterm_hash: myterm ::= hsh ;
431             myterm_array: myterm ::= ary ;
432              
433             /* Basic list expressions */
434             # Essentially, a listexpr is a nullable argexpr
435             listexpr_t: listexpr ::= ; /* NULL */
436             listexpr: listexpr ::= argexpr ;
437              
438             # In perly.y listexprcom occurs only inside parentheses
439             listexprcom ::= ; /* NULL */
440             listexprcom ::= expr ;
441             listexprcom ::= expr ',' ;
442              
443             /* A little bit of trickery to make "for my $foo (@bar)" actually be lexical */
444             my_scalar ::= scalar ;
445              
446             amper ::= '&' indirob ;
447              
448             scalar: scalar ::= '$' indirob ;
449              
450             ary ::= '@' indirob ;
451              
452             hsh ::= '%' indirob ;
453              
454             arylen ::= DOLSHARP indirob ;
455              
456             star ::= '*' indirob ;
457              
458             /* Indirect objects */
459             indirob__WORD: indirob ::= WORD ;
460             indirob ::= scalar ;
461             indirob__block: indirob ::= block ;
462             indirob ::= PRIVATEREF ;
463             END_OF_GRAMMAR
464              
465             my %symbol_name = (
466             q{~} => 'TILDE',
467             q{-} => 'MINUS',
468             q{,} => 'COMMA',
469             q{;} => 'SEMI',
470             q{:} => 'COLON',
471             q{!} => 'BANG',
472             q{?} => 'QUESTION',
473             q{(} => 'LPAREN',
474             q{)} => 'RPAREN',
475             q{[} => 'LSQUARE',
476             q{]} => 'RSQUARE',
477             q[{] => 'LCURLY',
478             q[}] => 'RCURLY',
479             q{@} => 'ATSIGN',
480             q{$} => 'DOLLAR',
481             q{*} => 'ASTERISK',
482             q{&} => 'AMPERSAND',
483             q{%} => 'PERCENT',
484             q{+} => 'PLUS',
485             );
486              
487             my %perl_type_by_cast = (
488             q{\\} => 'REFGEN',
489             q{*} => 'ASTERISK',
490             q{&} => 'AMPERSAND',
491             q{$} => 'DOLLAR',
492             q{@} => 'ATSIGN',
493             q{%} => 'PERCENT',
494             );
495              
496             my %perl_type_by_structure = (
497             q{(} => 'LPAREN',
498             q{)} => 'RPAREN',
499             q{[} => 'LSQUARE',
500             q{]} => 'RSQUARE',
501             q[{] => 'LCURLY',
502             q[}] => 'RCURLY',
503             q{;} => 'SEMI',
504             );
505              
506             my %perl_type_by_op = (
507             q{->} => 'ARROW', # 1
508             q{--} => 'PREDEC', # 2
509             q{++} => 'PREINC', # 2
510             q{**} => 'POWOP', # 3
511             q{~} => 'TILDE', # 4
512             q{!} => 'BANG', # 4
513             q{\\} => 'REFGEN', # 4
514             q{=~} => 'MATCHOP', # 5
515             q{!~} => 'MATCHOP', # 5
516             q{/} => 'MULOP', # 6
517             q{*} => 'MULOP', # 6
518             q{%} => 'MULOP', # 6
519             q{x} => 'MULOP', # 6
520             q{-} => 'MINUS', # 7
521             q{.} => 'ADDOP', # 7
522             q{+} => 'PLUS', # 7
523             q{<<} => 'SHIFTOP', # 8
524             q{>>} => 'SHIFTOP', # 8
525             q{-A} => 'UNIOP', # 9
526             q{-b} => 'UNIOP', # 9
527             q{-B} => 'UNIOP', # 9
528             q{-c} => 'UNIOP', # 9
529             q{-C} => 'UNIOP', # 9
530             q{-d} => 'UNIOP', # 9
531             q{-e} => 'UNIOP', # 9
532             q{-f} => 'UNIOP', # 9
533             q{-g} => 'UNIOP', # 9
534             q{-k} => 'UNIOP', # 9
535             q{-l} => 'UNIOP', # 9
536             q{-M} => 'UNIOP', # 9
537             q{-o} => 'UNIOP', # 9
538             q{-O} => 'UNIOP', # 9
539             q{-p} => 'UNIOP', # 9
540             q{-r} => 'UNIOP', # 9
541             q{-R} => 'UNIOP', # 9
542             q{-s} => 'UNIOP', # 9
543             q{-S} => 'UNIOP', # 9
544             q{-t} => 'UNIOP', # 9
545             q{-T} => 'UNIOP', # 9
546             q{-u} => 'UNIOP', # 9
547             q{-w} => 'UNIOP', # 9
548             q{-W} => 'UNIOP', # 9
549             q{-x} => 'UNIOP', # 9
550             q{-X} => 'UNIOP', # 9
551             q{-z} => 'UNIOP', # 9
552             q{ge} => 'RELOP', # 10
553             q{gt} => 'RELOP', # 10
554             q{le} => 'RELOP', # 10
555             q{lt} => 'RELOP', # 10
556             q{<=} => 'RELOP', # 10
557             q{<} => 'RELOP', # 10
558             q{>=} => 'RELOP', # 10
559             q{>} => 'RELOP', # 10
560             q{cmp} => 'EQOP', # 11
561             q{eq} => 'EQOP', # 11
562             q{ne} => 'EQOP', # 11
563             q{~~} => 'EQOP', # 11
564             q{<=>} => 'EQOP', # 11
565             q{==} => 'EQOP', # 11
566             q{!=} => 'EQOP', # 11
567             q{&} => 'BITANDOP', # 12
568             q{^} => 'BITOROP', # 13
569             q{|} => 'BITOROP', # 13
570             q{&&} => 'ANDAND', # 14
571             q{||} => 'OROR', # 15
572             q{//} => 'DORDOR', # 15
573             q{..} => 'DOTDOT', # 16
574             q{...} => 'YADAYADA', # 17
575             q{:} => 'COLON', # 18
576             q{?} => 'QUESTION', # 18
577             q{^=} => 'ASSIGNOP', # 19
578             q{<<=} => 'ASSIGNOP', # 19
579             q{=} => 'ASSIGNOP', # 19
580             q{>>=} => 'ASSIGNOP', # 19
581             q{|=} => 'ASSIGNOP', # 19
582             q{||=} => 'ASSIGNOP', # 19
583             q{-=} => 'ASSIGNOP', # 19
584             q{/=} => 'ASSIGNOP', # 19
585             q{.=} => 'ASSIGNOP', # 19
586             q{*=} => 'ASSIGNOP', # 19
587             q{**=} => 'ASSIGNOP', # 19
588             q{&=} => 'ASSIGNOP', # 19
589             q{&&=} => 'ASSIGNOP', # 19
590             q{%=} => 'ASSIGNOP', # 19
591             q{+=} => 'ASSIGNOP', # 19
592             q{x=} => 'ASSIGNOP', # 19
593             q{,} => 'COMMA', # 20
594             q{=>} => 'COMMA', # 20
595             q{not} => 'NOTOP', # 22
596             q{and} => 'ANDOP', # 23
597             q{or} => 'OROP', # 24
598             q{xor} => 'DOROP', # 24
599             );
600              
601             my %perl_type_by_word = (
602             'AUTOLOAD' => 'PHASER',
603             'BEGIN' => 'PHASER',
604             'CHECK' => 'PHASER',
605             'CORE' => 'TO_BE_DETERMINED',
606             'DESTROY' => 'PHASER',
607             'END' => 'PHASER',
608             'INIT' => 'PHASER',
609             'NULL' => 'TO_BE_DETERMINED',
610             'UNITCHECK' => 'PHASER',
611             '__DATA__' => 'TO_BE_DETERMINED',
612             '__END__' => 'TO_BE_DETERMINED',
613             '__FILE__' => 'THING',
614             '__LINE__' => 'THING',
615             '__PACKAGE__' => 'THING',
616             'abs' => 'UNIOP',
617             'accept' => 'LSTOP',
618             'alarm' => 'UNIOP',
619             'atan2' => 'LSTOP',
620             'bind' => 'LSTOP',
621             'binmode' => 'LSTOP',
622             'bless' => 'LSTOP',
623             'bless' => 'LSTOP',
624             'break' => 'LOOPEX',
625             'caller' => 'UNIOP',
626             'chdir' => 'UNIOP',
627             'chmod' => 'LSTOP',
628             'chomp' => 'UNIOP',
629             'chop' => 'UNIOP',
630             'chown' => 'LSTOP',
631             'chr' => 'UNIOP',
632             'chroot' => 'UNIOP',
633             'close' => 'UNIOP',
634             'closedir' => 'UNIOP',
635             'connect' => 'LSTOP',
636             'continue' => 'CONTINUE',
637             'cos' => 'UNIOP',
638             'crypt' => 'LSTOP',
639             'dbmclose' => 'UNIOP',
640             'dbmopen' => 'LSTOP',
641             'default' => 'DEFAULT',
642             'defined' => 'UNIOP',
643             'delete' => 'UNIOP',
644             'die' => 'LSTOP',
645             'do' => 'DO',
646             'dump' => 'UNIOP',
647             'each' => 'UNIOP',
648             'else' => 'ELSE',
649             'elsif' => 'ELSIF',
650             'endgrent' => 'FUNC0',
651             'endhostent' => 'FUNC0',
652             'endnetent' => 'FUNC0',
653             'endprotoent' => 'FUNC0',
654             'endpwent' => 'FUNC0',
655             'endservent' => 'FUNC0',
656             'eof' => 'UNIOP',
657             'eval' => 'UNIOP',
658             'exec' => 'LSTOP',
659             'exists' => 'UNIOP',
660             'exit' => 'UNIOP',
661             'exp' => 'UNIOP',
662             'fcntl' => 'LSTOP',
663             'fileno' => 'UNIOP',
664             'flock' => 'LSTOP',
665             'for' => 'FOR',
666             'foreach' => 'FOR',
667             'fork' => 'FUNC0',
668             'format' => 'FUNC0',
669             'formline' => 'LSTOP',
670             'getc' => 'UNIOP',
671             'getgrent' => 'FUNC0',
672             'getgrgid' => 'UNIOP',
673             'getgrnam' => 'UNIOP',
674             'gethostbyaddr' => 'LSTOP',
675             'gethostbyname' => 'UNIOP',
676             'gethostent' => 'FUNC0',
677             'getlogin' => 'FUNC0',
678             'getnetbyaddr' => 'LSTOP',
679             'getnetbyname' => 'UNIOP',
680             'getnetent' => 'FUNC0',
681             'getpeername' => 'UNIOP',
682             'getpgrp' => 'UNIOP',
683             'getppid' => 'FUNC0',
684             'getpriority' => 'LSTOP',
685             'getprotobyname' => 'UNIOP',
686             'getprotobynumber' => 'UNIOP',
687             'getprotoent' => 'FUNC0',
688             'getpwent' => 'FUNC0',
689             'getpwnam' => 'UNIOP',
690             'getpwuid' => 'UNIOP',
691             'getservbyname' => 'LSTOP',
692             'getservbyport' => 'LSTOP',
693             'getservent' => 'FUNC0',
694             'getsockname' => 'UNIOP',
695             'getsockopt' => 'LSTOP',
696             'given' => 'GIVEN',
697             'glob' => 'UNIOP',
698             'gmtime' => 'UNIOP',
699             'goto' => 'LOOPEX',
700             'grep' => 'LSTOP',
701             'hex' => 'UNIOP',
702             'if' => 'IF',
703             'import' => 'LSTOP', # not really a keyword, but make it a LSTOP
704             'index' => 'LSTOP',
705             'int' => 'UNIOP',
706             'ioctl' => 'LSTOP',
707             'join' => 'LSTOP',
708             'keys' => 'UNIOP',
709             'kill' => 'LSTOP',
710             'last' => 'LOOPEX',
711             'lc' => 'UNIOP',
712             'lcfirst' => 'UNIOP',
713             'length' => 'UNIOP',
714             'link' => 'LSTOP',
715             'listen' => 'LSTOP',
716             'local' => 'LOCAL',
717             'localtime' => 'UNIOP',
718             'lock' => 'UNIOP',
719             'log' => 'UNIOP',
720             'lstat' => 'UNIOP',
721             'm' => 'QUOTEABLE -- TO BE DETERMINED',
722             'map' => 'LSTOP',
723             'mkdir' => 'LSTOP',
724             'msgctl' => 'LSTOP',
725             'msgget' => 'LSTOP',
726             'msgrcv' => 'LSTOP',
727             'msgsnd' => 'LSTOP',
728             'my' => 'MY',
729             'my' => 'MY',
730             'next' => 'LOOPEX',
731             'no' => 'USE',
732             'oct' => 'UNIOP',
733             'open' => 'LSTOP',
734             'opendir' => 'LSTOP',
735             'ord' => 'UNIOP',
736             'our' => 'MY',
737             'pack' => 'LSTOP',
738             'package' => 'PACKAGE',
739             'pipe' => 'LSTOP',
740             'pop' => 'UNIOP',
741             'pos' => 'UNIOP',
742             'print' => 'LSTOP',
743             'printf' => 'LSTOP',
744             'prototype' => 'UNIOP',
745             'push' => 'LSTOP',
746             'q' => 'QUOTEABLE -- TO BE DETERMINED',
747             'qq' => 'QUOTEABLE -- TO BE DETERMINED',
748             'qr' => 'QUOTEABLE -- TO BE DETERMINED',
749             'quotemeta' => 'UNIOP',
750             'qw' => 'QUOTEABLE -- TO BE DETERMINED',
751             'qx' => 'QUOTEABLE -- TO BE DETERMINED',
752             'rand' => 'UNIOP',
753             'read' => 'LSTOP',
754             'readdir' => 'UNIOP',
755             'readline' => 'UNIOP',
756             'readlink' => 'UNIOP',
757             'readpipe' => 'UNIOP',
758             'recv' => 'LSTOP',
759             'redo' => 'LOOPEX',
760             'ref' => 'UNIOP',
761             'rename' => 'LSTOP',
762             'require' => 'REQUIRE',
763             'reset' => 'UNIOP',
764             'return' => 'LSTOP',
765             'reverse' => 'LSTOP',
766             'rewinddir' => 'UNIOP',
767             'rindex' => 'LSTOP',
768             'rmdir' => 'UNIOP',
769             's' => 'QUOTEABLE -- TO BE DETERMINED',
770             'say' => 'LSTOP',
771             'scalar' => 'UNIOP',
772             'seek' => 'LSTOP',
773             'seekdir' => 'LSTOP',
774             'select' => 'LSTOP',
775             'semctl' => 'LSTOP',
776             'semget' => 'LSTOP',
777             'semop' => 'LSTOP',
778             'send' => 'LSTOP',
779             'setgrent' => 'FUNC0',
780             'sethostent' => 'UNIOP',
781             'setnetent' => 'UNIOP',
782             'setpgrp' => 'LSTOP',
783             'setpriority' => 'LSTOP',
784             'setprotoent' => 'UNIOP',
785             'setpwent' => 'FUNC0',
786             'setservent' => 'UNIOP',
787             'setsockopt' => 'LSTOP',
788             'shift' => 'UNIOP',
789             'shmctl' => 'LSTOP',
790             'shmget' => 'LSTOP',
791             'shmread' => 'LSTOP',
792             'shmwrite' => 'LSTOP',
793             'shutdown' => 'LSTOP',
794             'sin' => 'UNIOP',
795             'sleep' => 'UNIOP',
796             'socket' => 'LSTOP',
797             'socketpair' => 'LSTOP',
798             'sort' => 'LSTOP',
799             'splice' => 'LSTOP',
800             'split' => 'LSTOP',
801             'sprintf' => 'LSTOP',
802             'sqrt' => 'UNIOP',
803             'srand' => 'UNIOP',
804             'stat' => 'UNIOP',
805             'state' => 'MY',
806             'study' => 'UNIOP',
807             'sub' => 'SUB',
808             'substr' => 'LSTOP',
809             'symlink' => 'LSTOP',
810             'syscall' => 'LSTOP',
811             'sysopen' => 'LSTOP',
812             'sysread' => 'LSTOP',
813             'sysseek' => 'LSTOP',
814             'system' => 'LSTOP',
815             'syswrite' => 'LSTOP',
816             'tell' => 'UNIOP',
817             'telldir' => 'UNIOP',
818             'tie' => 'LSTOP',
819             'tied' => 'UNIOP',
820             'time' => 'FUNC0',
821             'times' => 'FUNC0',
822             'tr' => 'QUOTEABLE -- TO BE DETERMINED',
823             'truncate' => 'LSTOP',
824             'uc' => 'UNIOP',
825             'ucfirst' => 'UNIOP',
826             'umask' => 'UNIOP',
827             'undef' => 'UNIOP',
828             'undef' => 'UNIOP',
829             'unless' => 'UNLESS',
830             'unlink' => 'LSTOP',
831             'unpack' => 'LSTOP',
832             'unshift' => 'LSTOP',
833             'untie' => 'UNIOP',
834             'until' => 'UNTIL',
835             'use' => 'USE',
836             'utime' => 'LSTOP',
837             'values' => 'UNIOP',
838             'vec' => 'LSTOP',
839             'wait' => 'FUNC0',
840             'waitpid' => 'LSTOP',
841             'wantarray' => 'FUNC0',
842             'warn' => 'LSTOP',
843             'when' => 'WHEN',
844             'while' => 'WHILE',
845             'write' => 'UNIOP',
846             'y' => 'QUOTEABLE -- TO BE DETERMINED',
847             );
848              
849             my %rule_rank = (
850             long_use => 2,
851             perl_version_use => 1,
852             short_use => 0,
853             );
854              
855             sub Marpa::R2::Perl::new {
856 5     5 0 930 my ( $class, $args ) = @_;
857 5   50     18 $args //= {};
858 5         11 my $gen_closure;
859 5         12 my $embedded = 0;
860              
861 5 50       19 die 'Closure argument to new must be HASH of named arguments'
862             if ref $args ne 'HASH';
863              
864 5         10 NAMED_ARG: for my $named_arg ( keys %{$args} ) {
  5         32  
865 6 100       25 if ( $named_arg eq 'closures' ) {
866 5         14 $gen_closure = $args->{$named_arg};
867 5         13 my $closure_type = ref $gen_closure;
868 5 50 66     41 if ( $closure_type ne 'HASH' and $closure_type ne 'CODE' ) {
869 0         0 die 'Closure argument to new must be HASH or CODE ref';
870             }
871 5         20 next NAMED_ARG;
872             } ## end if ( $named_arg eq 'closures' )
873 1 50       23 if ( $named_arg eq 'embedded' ) {
874 1 50       7 $embedded = $args->{$named_arg} ? 1 : 0;
875 1         5 next NAMED_ARG;
876             }
877 0         0 die qq{"Unknown named argument to new(): "$named_arg"};
878             } ## end NAMED_ARG: for my $named_arg ( keys %{$args} )
879              
880 5 50       360 die q{"closure" named argument is required}
881             if not defined $gen_closure;
882              
883 5         14 my %symbol = ();
884 5         14 my @rules;
885             my %closure;
886              
887             LINE:
888 5         458 for my $line ( split /\n/xms, $reference_grammar ) {
889 2140         2549 chomp $line;
890 2140         3226 $line =~ s/ [#] .* \z //xms;
891 2140         3644 $line =~ s/ [\/][*] .* \z //xms;
892 2140         2799 $line =~ s/ \A \s+ //xms;
893 2140 100       3320 next LINE if $line eq q{};
894 1130 50       2997 Carp::croak("Misformed line: $line")
895             if $line !~ / [:][:][=] .* [;] \s* \z /xms;
896 1130         3368 my ($rule_name) = ( $line =~ /\A (\w+) \s* [:] [^:] /gxms );
897 1130         7100 my ( $lhs, $rhs_string ) =
898             ( $line =~ / \s* (\w+) \s* [:][:][=] \s* (.*) [;] \s* \z/xms );
899 1130         1593 my @rhs = ();
900 1130         2566 RHS: for my $rhs_desc ( split q{ }, $rhs_string ) {
901              
902 2755 100       5022 if ( $rhs_desc =~ m/\A ['] ([^']*) ['] \z/xms ) {
903 645         1250 my $rhs_name = $symbol_name{$1};
904 645 50       914 die "No symbol name for $rhs_desc" if not defined $rhs_name;
905 645         898 push @rhs, $rhs_name;
906 645         961 next RHS;
907             } ## end if ( $rhs_desc =~ m/\A ['] ([^']*) ['] \z/xms )
908 2110         3371 push @rhs, $rhs_desc;
909             } ## end RHS: for my $rhs_desc ( split q{ }, $rhs_string )
910              
911 1130         1573 for my $symbol ( $lhs, @rhs ) {
912 3885   100     7827 $symbol{$symbol} //= 0;
913 3885 50       6464 if ( $symbol =~ /\W/xms ) {
914 0         0 Carp::croak("Misformed symbol: $symbol");
915             }
916             } ## end for my $symbol ( $lhs, @rhs )
917 1130         1275 $symbol{$lhs}++;
918              
919 1130         1223 my @additional_args = ();
920 1130         1483 my $closure_type = ref $gen_closure;
921 1130 100       1699 if ( $closure_type eq 'CODE' ) {
922 452   66     1278 $rule_name ||= q{!} . scalar @rules;
923 452         865 my ($action) = $gen_closure->( $lhs, \@rhs, $rule_name );
924 452 50       6377 if ( defined $action ) {
925 452         1205 $closure{"!$rule_name"} = $action;
926 452         928 push @additional_args, action => "!$rule_name";
927             }
928             } ## end if ( $closure_type eq 'CODE' )
929 1130 100       1606 if ( $closure_type eq 'HASH' ) {
930 678   66     1329 my $action_name = $rule_name // $lhs;
931 678         735 my $action = $gen_closure->{$action_name};
932 678 50       1023 if ( defined $action ) {
933 0         0 $closure{"!$action_name"} = $action;
934 0         0 push @additional_args, action => "!$action_name";
935             }
936             } ## end if ( $closure_type eq 'HASH' )
937 1130 100       1747 my $rank = defined $rule_name ? $rule_rank{$rule_name} : undef;
938 1130 100       1523 if ( defined $rank ) {
939 15         34 push @additional_args, rank => $rank;
940             }
941 1130         4467 push @rules,
942             {
943             lhs => $lhs,
944             rhs => \@rhs,
945             @additional_args, name => $rule_name
946             };
947              
948             } ## end LINE: for my $line ( split /\n/xms, $reference_grammar )
949              
950 5         175 my $start = 'prog';
951 5 100       37 if ($embedded) {
952 1         12 push @rules,
953             [ 'embedded_perl', [qw(target)] ],
954             [ 'embedded_perl', [qw(non_perl_prefix target)] ],
955             [ 'target', [qw(target_start_marker line non_trivial_target_end)] ],
956             [ 'target', [qw(target_start_marker decl non_trivial_target_end)] ],
957             [ 'target', [qw(target_start_marker prog target_end_marker)] ],
958             {
959             lhs => 'non_perl_prefix',
960             rhs => ['non_perl_token'],
961             min => 1,
962             };
963 1         4 $start = 'embedded_perl';
964             } ## end if ($embedded)
965              
966 5         67 my $grammar = Marpa::R2::Grammar->new(
967             { start => $start,
968             rules => \@rules,
969             }
970             );
971              
972 5         37 $grammar->precompute();
973              
974 5         34 my $self = bless { grammar => $grammar, closure => \%closure }, $class;
975 5 100       51 $self->{embedded} = $embedded ? 1 : 0;
976 5         711 return $self;
977              
978             } ## end sub Marpa::R2::Perl::new
979              
980             my @RECCE_NAMED_ARGUMENTS =
981             qw(trace_terminals trace_values trace_actions);
982              
983             sub token_not_accepted {
984 27     27   65 my ( $ppi_token, $token_name, $token_value, $length ) = @_;
985              
986 27         42 local $Data::Dumper::Maxdepth = 2;
987 27         53 local $Data::Dumper::Terse = 1;
988 27         31 my $perl_token_desc;
989 27 50       56 if ( not defined $token_name ) {
990 0         0 $perl_token_desc = 'Undefined Perl token was not accepted: ';
991             }
992             else {
993 27         62 $perl_token_desc = qq{Perl token "$token_name" was not accepted: };
994             }
995 27 50 66     66 if ( defined $length and $length != 1 ) {
996 0         0 $perl_token_desc .= ' length=' . $length;
997             }
998 27         74 $perl_token_desc .= Data::Dumper::Dumper($token_value);
999 27         1687 my $logical_filename = $ppi_token->logical_filename();
1000 27 50       550 $logical_filename = '[no file]' if not $logical_filename;
1001 27         114 my $error_string = join q{},
1002             "$perl_token_desc", 'PPI token is ',
1003             ( ref $ppi_token ), qq{: $logical_filename:},
1004             $ppi_token->logical_line_number(), q{:},
1005             $ppi_token->column_number(), q{, },
1006             q{content="}, $ppi_token->content(),
1007             q{"}
1008             ;
1009 27 50       881 if ($Marpa::R2::Perl::PARSER->{embedded}) {
1010 27         29 push @{$Marpa::R2::Perl::PARSER->{token_issues}}, $error_string;
  27         60  
1011 27 100       84 return if $Marpa::R2::Perl::PARSER->{in_prefix};
1012 4         44 die "TOKEN_NOT_ACCEPTED\n";
1013             }
1014 0         0 Carp::croak($error_string);
1015             } ## end sub token_not_accepted
1016              
1017             sub unknown_ppi_token {
1018 0     0   0 my ($ppi_token) = @_;
1019 0         0 my $issue = join q{}, 'Failed at Token: ', Data::Dumper::Dumper($ppi_token),
1020             'Marpa::R2::Perl did not know how to process token',
1021             Marpa::R2::Perl::default_show_location($ppi_token), "\n";
1022 0 0       0 if ($Marpa::R2::Perl::PARSER->{embedded}) {
1023 0         0 push @{$Marpa::R2::Perl::PARSER->{token_issues}}, $issue;
  0         0  
1024 0 0       0 return if $Marpa::R2::Perl::PARSER->{in_prefix};
1025 0         0 die "TOKEN_NOT_ACCEPTED\n";
1026             }
1027 0         0 die $issue;
1028             } ## end sub unknown_ppi_token
1029              
1030             sub Marpa::R2::Perl::tokens {
1031 18     18 0 55 my ( $parser, $input ) = @_;
1032             # We need to keep a reference to the document,
1033             # not just the tokens,
1034             # or bad things happen.
1035 18         133 my $document = $parser->{document} = PPI::Document->new($input);
1036 18         214260 $document->index_locations();
1037 18         43758 return $parser->{PPI_tokens} = [$document->tokens()];
1038             } ## end sub Marpa::R2::Perl::tokens
1039              
1040             sub Marpa::R2::Perl::clone_tokens {
1041 1     1 0 791 my ( $to_parser, $from_parser ) = @_;
1042 1         3 $to_parser->{document} = $from_parser->{document} ;
1043 1         4 $to_parser->{PPI_tokens} = $from_parser->{PPI_tokens} ;
1044             }
1045              
1046             sub Marpa::R2::Perl::read {
1047 17     17 0 2073 my ( $parser, $input ) = @_;
1048 17         68 $parser->tokens($input);
1049 17         6646 $parser->read_tokens();
1050             }
1051              
1052             sub Marpa::R2::Perl::read_tokens {
1053              
1054 21     21 0 507 my ( $parser, $first_token_ix, $last_token_ix, $hash_arg ) = @_;
1055              
1056 21   50     141 $hash_arg //= {};
1057              
1058 21         42 my @recce_args = ();
1059 21         73 HASH_ARG: for my $arg ( keys %{$hash_arg} ) {
  21         106  
1060 0         0 my $value = $hash_arg->{$arg};
1061 0 0       0 if ( grep { $_ eq $arg } @RECCE_NAMED_ARGUMENTS ) {
  0         0  
1062 0         0 push @recce_args, $arg, $value;
1063 0         0 next HASH_ARG;
1064             }
1065 0         0 Carp::croak("Unknown hash arg: $arg");
1066             } ## end HASH_ARG: for my $arg ( keys %{$hash_arg} )
1067              
1068 21         85 my $grammar = $parser->{grammar};
1069              
1070             my $recce = Marpa::R2::Recognizer->new(
1071             { grammar => $grammar,
1072             closures => $parser->{closure},
1073 21         233 ranking_method => 'high_rule_only',
1074             @recce_args
1075             }
1076             );
1077 21         1942 $parser->{recce} = $recce;
1078 21         121 $parser->{terminals_expected} = $recce->terminals_expected();
1079              
1080             # This is convenient for making the recognizer available to
1081             # error messages
1082 21         98 local $Marpa::R2::Perl::RECOGNIZER = $recce;
1083              
1084 21         62 my $PPI_tokens = $parser->{PPI_tokens};
1085 21         78 my $earleme_to_PPI_token = $parser->{earleme_to_PPI_token} = [];
1086              
1087             # For use by read_PPI_token
1088 21         45 local $Marpa::R2::Perl::LAST_PERL_TYPE = undef;
1089              
1090 21   100     120 $first_token_ix //= 0;
1091 21   66     77 $last_token_ix //= $#{$PPI_tokens};
  17         57  
1092 21         76 for my $PPI_token_ix ( $first_token_ix .. $last_token_ix ) {
1093 1202         2684 my $current_earleme = $recce->current_earleme();
1094 1202   100     4064 $earleme_to_PPI_token->[$current_earleme] //= $PPI_token_ix;
1095 1202         1694 read_PPI_token( $parser, $PPI_token_ix );
1096             }
1097              
1098 21         156 $recce->end_input();
1099 21         106 return $parser;
1100              
1101             } ## end sub Marpa::R2::Perl::read
1102              
1103             sub Marpa::R2::Perl::earleme_complete {
1104 1146     1146 0 1783 my ($parser) = @_;
1105              
1106 1146         1783 my $recce = $parser->{recce};
1107 1146         2369 my $recce_c = $recce->thin();
1108 1146         1447 my $grammar = $parser->{grammar};
1109 1146         2281 my $grammar_c = $grammar->thin();
1110              
1111 1146 100       1978 if ( $parser->{in_prefix} ) {
1112 135 50       150 if ( grep { $_ eq 'target_start_marker' }
  10175         11776  
1113 135         252 @{ $parser->{terminals_expected} } )
1114             {
1115 135         267 $recce->alternative('target_start_marker');
1116             }
1117 135         269 $recce->alternative('non_perl_token');
1118             } ## end if ( $parser->{in_prefix} )
1119 1146         35691 my $event_count = $recce_c->earleme_complete();
1120 1146         3581 $parser->{terminals_expected} = $recce->terminals_expected();
1121 1146         3987 EVENT: for my $event_ix ( 0 .. $event_count - 1 ) {
1122 0         0 my ( $event_type, $value ) = $grammar_c->event($event_ix);
1123 0 0       0 next EVENT if $event_type eq 'MARPA_EVENT_EXHAUSTED';
1124 0 0       0 if ( $event_type eq 'MARPA_EVENT_EARLEY_ITEM_THRESHOLD' ) {
1125             say {
1126 0 0       0 $recce->[Marpa::R2::Internal::Recognizer::TRACE_FILE_HANDLE] }
  0         0  
1127             "Earley item count ($value) exceeds warning threshold"
1128             or die "say: $ERRNO";
1129 0         0 next EVENT;
1130             } ## end if ( $event_type eq 'MARPA_EVENT_EARLEY_ITEM_THRESHOLD')
1131             Marpa::R2::exception(
1132 0         0 qq{Unknown earleme completion event; type="$event_type"});
1133             } ## end EVENT: for my $event_ix ( 0 .. $event_count - 1 )
1134              
1135 1146         1773 return $event_count;
1136              
1137             } ## end sub Marpa::R2::Perl::earleme_complete
1138              
1139             sub read_PPI_token {
1140 1495     1495   2043 my ( $parser, $token_ix ) = @_;
1141 1495         1863 my $recce = $parser->{recce};
1142 1495         1995 my $token = $parser->{PPI_tokens}->[$token_ix];
1143 1495         2347 my $PPI_type = ref $token;
1144 1495 100       2757 return 1 if $PPI_type eq 'PPI::Token::Whitespace';
1145 997 50       1477 return 1 if $PPI_type eq 'PPI::Token::Comment';
1146 997 50       1405 return 1 if $PPI_type eq 'PPI::Token::Pod';
1147              
1148 997         1302 my $perl_type = undef;
1149              
1150 997 100       1463 if ( $PPI_type eq 'PPI::Token::Symbol' ) {
1151             my ( $sigil, $word ) =
1152 72         559 ( $token->{content} =~ / \A ([&*\$@%]) ([':\w]*) \z /xms );
1153 72 50       195 if ( not defined $sigil ) {
1154 0         0 Carp::croak( 'Unknown symbol type: ',
1155             Data::Dumper::Dumper($token) );
1156 0         0 goto SUCCESS;
1157             }
1158 72         134 my $symbol_name = $symbol_name{$sigil};
1159 72 50       146 if ( not defined $symbol_name ) {
1160 0         0 Carp::croak( 'Unknown symbol type: ',
1161             Data::Dumper::Dumper($token) );
1162 0         0 goto SUCCESS;
1163             }
1164 72 50       224 defined $recce->alternative( $symbol_name, \$sigil )
1165             or token_not_accepted( $token, $symbol_name, $sigil );
1166 72         178 $parser->earleme_complete();
1167 72 50       193 defined $recce->alternative( 'WORD', \$word )
1168             or token_not_accepted( $token, 'WORD', $word );
1169 72         180 $parser->earleme_complete();
1170 72         550 goto SUCCESS;
1171             } ## end if ( $PPI_type eq 'PPI::Token::Symbol' )
1172              
1173 925 100       1445 if ( $PPI_type eq 'PPI::Token::Cast' ) {
1174 30         75 my $content = $token->{content};
1175 30         45 my $token_found;
1176 30         94 for my $cast ( split //xms, $content ) {
1177 30         62 $perl_type = $perl_type_by_cast{$content};
1178 30 50       61 defined $perl_type or unknown_ppi_token($token);
1179 30 50       64 if ( defined $perl_type ) {
1180 30         55 $token_found = 1;
1181 30 50       84 defined $recce->alternative( $perl_type, \$cast )
1182             or token_not_accepted( $token, $perl_type, $cast );
1183 30         95 $parser->earleme_complete();
1184             } ## end if ( defined $perl_type )
1185             } ## end for my $cast ( split //xms, $content )
1186 30 50       98 defined $token_found or unknown_ppi_token($token);
1187 30         173 goto SUCCESS;
1188             } ## end if ( $PPI_type eq 'PPI::Token::Cast' )
1189              
1190 895 100       1396 if ( $PPI_type eq 'PPI::Token::Word' ) {
1191 138         402 my $content = $token->{content};
1192 138   100     505 $perl_type = $perl_type_by_word{$content} // 'WORD';
1193 138 100       253 if ( $perl_type eq 'WORD' ) {
1194 93         107 my $token_found = 0;
1195 93         137 TYPE: for my $type (qw(WORD FUNC METHOD FUNCMETH)) {
1196 372 100       712 defined $recce->alternative( $type, \$content, 1 )
1197             and $token_found++;
1198             }
1199             $token_found
1200 93 100       216 or token_not_accepted( $token, 'WORD', $content, 1 );
1201 93         233 $parser->earleme_complete();
1202 93         726 goto SUCCESS;
1203             } ## end if ( $perl_type eq 'WORD' )
1204 45 50       88 if ( $perl_type eq 'PHASER' ) {
1205 0 0       0 defined $recce->alternative('SUB')
1206             or token_not_accepted( $token, 'PHASER', 'no value' );
1207 0         0 $parser->earleme_complete();
1208 0 0       0 defined $recce->alternative( 'WORD', \$content )
1209             or token_not_accepted( $token, 'WORD', $content );
1210 0         0 $parser->earleme_complete();
1211 0         0 goto SUCCESS;
1212             } ## end if ( $perl_type eq 'PHASER' )
1213 45 50       129 defined $recce->alternative( $perl_type, \$content )
1214             or token_not_accepted( $token, $perl_type, $content );
1215 45         141 $parser->earleme_complete();
1216 45         383 goto SUCCESS;
1217             } ## end if ( $PPI_type eq 'PPI::Token::Word' )
1218              
1219 757 100       1281 if ( $PPI_type eq 'PPI::Token::Label' ) {
1220 2         11 my $content = $token->{content};
1221 2 100       10 defined $recce->alternative( 'LABEL', \$content )
1222             or token_not_accepted( $token, 'LABEL', $content );
1223 2         9 $parser->earleme_complete();
1224 2         13 goto SUCCESS;
1225             } ## end if ( $PPI_type eq 'PPI::Token::Label' )
1226              
1227 755 100       1112 if ( $PPI_type eq 'PPI::Token::Operator' ) {
1228 171         364 my $content = $token->{content};
1229 171         356 $perl_type = $perl_type_by_op{$content};
1230 171 50       313 if (not defined $perl_type) {
1231 0         0 unknown_ppi_token($token);
1232 0         0 $parser->earleme_complete();
1233 0         0 goto SUCCESS;
1234             }
1235 171 100       288 if ( $perl_type eq 'PLUS' ) {
1236              
1237             # Apply the "ruby slippers"
1238             # Make the plus sign be whatever the parser
1239             # wishes it was
1240 3         11 my @potential_types = qw(ADDOP PLUS);
1241 3         7 my $expected_tokens = $parser->{terminals_expected};
1242 3         4 my $token_found;
1243 3         5 TYPE: for my $type (@potential_types) {
1244 6 100       10 next TYPE if not grep { $_ eq $type } @{$expected_tokens};
  362         431  
  6         10  
1245 3         5 $token_found = 1;
1246 3 50       11 defined $recce->alternative( $type, \$content, 1 )
1247             or token_not_accepted( $token, $type, $content, 1 );
1248             } ## end TYPE: for my $type (@potential_types)
1249 3 50       10 defined $token_found or unknown_ppi_token($token);
1250 3         9 $parser->earleme_complete();
1251 3         52 goto SUCCESS;
1252             } ## end if ( $perl_type eq 'PLUS' )
1253              
1254 168 50       312 if ( $perl_type eq 'MINUS' ) {
1255              
1256             # Apply the "ruby slippers"
1257             # Make the plus sign be whatever the parser
1258             # wishes it was
1259 0         0 my $expected_tokens = $parser->{terminals_expected};
1260 0         0 my @potential_types = qw(ADDOP UMINUS);
1261 0         0 my $token_found;
1262 0         0 TYPE: for my $type (@potential_types) {
1263 0 0       0 next TYPE if not grep { $_ eq $type } @{$expected_tokens};
  0         0  
  0         0  
1264 0         0 $token_found = 1;
1265 0 0       0 defined $recce->alternative( $type, \$content, 1 )
1266             or token_not_accepted( $token, $type, $content, 1 );
1267             } ## end TYPE: for my $type (@potential_types)
1268 0 0       0 defined $token_found or unknown_ppi_token($token);
1269 0         0 $parser->earleme_complete();
1270 0         0 goto SUCCESS;
1271             } ## end if ( $perl_type eq 'MINUS' )
1272 168 100       492 defined $recce->alternative( $perl_type, \$content )
1273             or token_not_accepted( $token, $perl_type, $content );
1274 166         434 $parser->earleme_complete();
1275 166         1869 goto SUCCESS;
1276             } ## end if ( $PPI_type eq 'PPI::Token::Operator' )
1277              
1278 584 100       930 if ( $PPI_type eq 'PPI::Token::Structure' ) {
1279 351         679 my $content = $token->{content};
1280 351         728 $perl_type = $perl_type_by_structure{$content};
1281 351         420 my $expected_tokens = $parser->{terminals_expected};
1282 351 50       664 if ( not defined $perl_type ) {
1283 0         0 unknown_ppi_token($token);
1284 0         0 $parser->earleme_complete();
1285 0         0 goto SUCCESS;
1286             }
1287 351 100       632 if ( $perl_type eq 'RCURLY' ) {
1288 81 50 66     303 if (( not defined $Marpa::R2::Perl::LAST_PERL_TYPE
      33        
1289             or $Marpa::R2::Perl::LAST_PERL_TYPE ne 'SEMI'
1290             )
1291 2517         3181 and ( grep { 'SEMI' eq $_ } @{$expected_tokens} )
  81         140  
1292             )
1293             {
1294 81 50       291 defined $recce->alternative( 'SEMI', \q{;} )
1295             or token_not_accepted( $token, 'SEMI', q{;} );
1296 81         210 $parser->earleme_complete();
1297             } ## end if ( ( not defined $Marpa::R2::Perl::LAST_PERL_TYPE ...))
1298 81 50       206 defined $recce->alternative( $perl_type, \$content )
1299             or token_not_accepted( $token, $perl_type, $content );
1300 81         204 $parser->earleme_complete();
1301 81         1011 goto SUCCESS;
1302             } ## end if ( $perl_type eq 'RCURLY' )
1303 270 100       454 if ( $perl_type eq 'LCURLY' ) {
1304 81         132 my @potential_types = ();
1305 81         165 push @potential_types, 'LCURLY';
1306 81 100 100     326 if ( not defined $Marpa::R2::Perl::LAST_PERL_TYPE
1307             or $Marpa::R2::Perl::LAST_PERL_TYPE ne 'DO' )
1308             {
1309 74         114 push @potential_types, 'HASHBRACK';
1310             }
1311 81         90 my $token_found;
1312 81         130 TYPE: for my $type (@potential_types) {
1313 155 100       162 next TYPE if not grep { $type eq $_ } @{$expected_tokens};
  5433         6472  
  155         249  
1314 102         150 $token_found = 1;
1315 102 50       290 defined $recce->alternative( $type, \$content, 1 )
1316             or token_not_accepted( $token, $type, $content, 1 );
1317             } ## end TYPE: for my $type (@potential_types)
1318 81 50       168 defined $token_found or unknown_ppi_token($token);
1319 81         210 $parser->earleme_complete();
1320 81         1172 goto SUCCESS;
1321             } ## end if ( $perl_type eq 'LCURLY' )
1322 189 50       467 defined $recce->alternative( $perl_type, \$content )
1323             or token_not_accepted( $token, $perl_type, $content );
1324 189         475 $parser->earleme_complete();
1325 189         2757 goto SUCCESS;
1326             } ## end if ( $PPI_type eq 'PPI::Token::Structure' )
1327              
1328 233 100 100     841 if ( $PPI_type eq 'PPI::Token::Number'
      66        
      100        
1329             or $PPI_type eq 'PPI::Token::Number::Float'
1330             or $PPI_type eq 'PPI::Token::Magic'
1331             or $PPI_type eq 'PPI::Token::Number::Version' )
1332             {
1333 179         513 my $content = $token->{content};
1334 179         226 my $token_found = 0;
1335 179         279 TYPE: for my $type (qw(THING VERSION)) {
1336 358 100       831 defined $recce->alternative( $type, \$content, 1 )
1337             and $token_found++;
1338             }
1339 179 100       326 $token_found or token_not_accepted( $token, 'THING', $content );
1340 177         387 $parser->earleme_complete();
1341 177         895 goto SUCCESS;
1342             } ## end if ( $PPI_type eq 'PPI::Token::Number' or $PPI_type ...)
1343              
1344 54 0 33     127 if ( $PPI_type eq 'PPI::Token::Quote::Single'
      33        
      0        
      0        
      0        
      0        
      0        
      0        
1345             or $PPI_type eq 'PPI::Token::Quote::Double'
1346             or $PPI_type eq 'PPI::Token::Quote::Literal'
1347             or $PPI_type eq 'PPI::Token::Quote::Interpolate'
1348             or $PPI_type eq 'PPI::Token::HereDoc'
1349             or $PPI_type eq 'PPI::Token::Regexp::Match'
1350             or $PPI_type eq 'PPI::Token::Regexp::Substitute'
1351             or $PPI_type eq 'PPI::Token::Regexp::Transliterate'
1352             or $PPI_type eq 'PPI::Token::Magic')
1353             {
1354 54         99 my $content = $token->{content};
1355 54 50       143 defined $recce->alternative( 'THING', \$content )
1356             or token_not_accepted( $token, 'THING', $content );
1357 54         155 $parser->earleme_complete();
1358 54         284 goto SUCCESS;
1359             } ## end if ( $PPI_type eq 'PPI::Token::Quote::Single' or $PPI_type...)
1360              
1361 0 0       0 if ( $PPI_type eq 'PPI::Token::QuoteLike::Words' ) {
1362 0         0 my $content = $token->{content};
1363 0         0 my $words = $token->literal();
1364 0 0       0 defined $recce->alternative( 'THING', \$words )
1365             or token_not_accepted( $token, 'THING', $words );
1366 0         0 $parser->earleme_complete();
1367 0         0 goto SUCCESS;
1368             } ## end if ( $PPI_type eq 'PPI::Token::QuoteLike::Words' )
1369              
1370 0         0 unknown_ppi_token($token);
1371              
1372 993         1398 SUCCESS:
1373             $Marpa::R2::Perl::LAST_PERL_TYPE = $perl_type;
1374 993         1841 return 1;
1375              
1376             } ## end sub read_PPI_token
1377              
1378             sub Marpa::R2::Perl::find_perl {
1379              
1380 5     5 0 3402 my ( $parser, $first_token_ix, $last_token_ix ) = @_;
1381              
1382 5         13 my $grammar = $parser->{grammar};
1383              
1384 5         46 my $recce = Marpa::R2::Recognizer->new(
1385             { grammar => $grammar,
1386             ranking_method => 'high_rule_only',
1387             }
1388             );
1389 5         264 $parser->{recce} = $recce;
1390 5         26 $parser->{terminals_expected} = $recce->terminals_expected();
1391 5         23 my $earleme_to_PPI_token = $parser->{earleme_to_PPI_token} = ();
1392              
1393             # This is convenient for making the recognizer available to
1394             # error messages
1395 5         9 local $Marpa::R2::Perl::PARSER = $parser;
1396              
1397 5         11 my $PPI_tokens = $parser->{PPI_tokens};
1398 5         11 my @PPI_token_to_earleme = ();
1399              
1400             # For use by read_PPI_token
1401 5         6 local $Marpa::R2::Perl::LAST_PERL_TYPE = undef;
1402 5 50       22 die 'find_perl requires embedded parser' if not $parser->{embedded};
1403 5         13 my $in_prefix = $parser->{in_prefix} = 1;
1404 5         10 my $last_end_marker_ix;
1405             my $last_end_marker_earleme;
1406              
1407 5   33     17 $last_token_ix //= $#{$PPI_tokens};
  5         16  
1408 5         7 my $PPI_token_ix;
1409             TOKEN:
1410 5   50     24 for (
1411             $PPI_token_ix = $first_token_ix // 0;
1412             $PPI_token_ix <= $last_token_ix;
1413             $PPI_token_ix++
1414             )
1415             {
1416 293 50       662 if ($recce->exhausted())
1417             {
1418 0 0       0 die 'Exhausted but no program found\?' if not defined $last_end_marker_ix;
1419 0         0 last TOKEN;
1420             }
1421 293         595 my $current_earleme = $recce->current_earleme();
1422 293   100     963 $earleme_to_PPI_token->[$current_earleme] //= $PPI_token_ix;
1423 293         440 $PPI_token_to_earleme[$PPI_token_ix] = $current_earleme;
1424 293         457 $parser->{token_issues} = [];
1425 293         345 eval { read_PPI_token( $parser, $PPI_token_ix ); };
  293         476  
1426 293 100       476 if ($EVAL_ERROR) {
1427 4 50       17 die $EVAL_ERROR if $EVAL_ERROR ne "TOKEN_NOT_ACCEPTED\n";
1428 4         10 last TOKEN;
1429             }
1430 289         365 my $terminals_expected = $parser->{terminals_expected};
1431 289 100       321 if ( grep { $_ eq 'non_trivial_target_end' } @{$terminals_expected} )
  20482         24326  
  289         467  
1432             {
1433 15         43 $in_prefix = $parser->{in_prefix} = 0;
1434 15         25 $last_end_marker_ix = $PPI_token_ix;
1435 15         39 $last_end_marker_earleme = $recce->current_earleme();
1436             } ## end if ( grep { $_ eq 'non_trivial_target_end' } @{...})
1437 289 100 100     765 if ( defined $last_end_marker_earleme
1438 3219         3875 && grep { $_ eq 'target_end_marker' } @{$terminals_expected} )
  72         107  
1439             {
1440 15         25 $last_end_marker_ix = $PPI_token_ix;
1441 15         32 $last_end_marker_earleme = $recce->current_earleme();
1442             } ## end if ( defined $last_end_marker_earleme && grep { $_ eq...})
1443             } ## end for ( $PPI_token_ix = $first_token_ix // 0; $PPI_token_ix...)
1444              
1445             # We are one past the last token successfully parsed
1446 5         5 $PPI_token_ix--;
1447              
1448 5         34 $recce->end_input();
1449              
1450 5 100       27 return (undef, $PPI_token_ix) if not defined $last_end_marker_earleme;
1451 4         24 my $report = $recce->progress($last_end_marker_earleme);
1452 4         8 my $start;
1453 4         8 ITEM: for my $item (@{$report}) {
  4         11  
1454 1200         1142 my ($rule_id, $dot_position, $origin) = @{$item};
  1200         1378  
1455 1200 100       1773 next ITEM if $dot_position >= 0;
1456 179 100       297 next ITEM if ($grammar->rule($rule_id))[0] ne 'prog';
1457 4   33     20 $start //= $origin;
1458 4 50       11 $start = $origin if $start > $origin;
1459             }
1460 4 50       29 die 'End marker, but no Perl prog?' if not defined $start;
1461 4         10 my $start_PPI_ix = $earleme_to_PPI_token->[$start];
1462 4         158 return ($start_PPI_ix, $last_end_marker_ix);
1463              
1464             } ## end sub Marpa::R2::Perl::find_perl
1465              
1466             sub Marpa::R2::Perl::eval {
1467 17     17 0 57 my ($parser) = @_;
1468 17         28 my $recce = $parser->{recce};
1469             local $Marpa::R2::Perl::Internal::CONTEXT =
1470 17         52 [ $parser->{PPI_tokens}, $parser->{earleme_to_PPI_token} ];
1471 17 100       49 if (wantarray) {
1472 4         9 my @values = ();
1473 4         12 while ( defined( my $value_ref = $recce->value() ) ) {
1474 5         11 push @values, ${$value_ref};
  5         22  
1475             }
1476 4         23 return @values;
1477             } ## end if (wantarray)
1478 13         85 my $value_ref = $recce->value();
1479 13         106 return $value_ref;
1480             } ## end sub Marpa::R2::Perl::eval
1481              
1482             sub Marpa::R2::Perl::parse {
1483 12     12 0 12565 my ( $parser, $input, $hash_arg ) = @_;
1484 12         66 $parser->Marpa::R2::Perl::read( $input, $hash_arg );
1485 12         58 return $parser->Marpa::R2::Perl::eval();
1486             }
1487              
1488             sub Marpa::R2::Perl::default_show_location {
1489 0     0 0   my ($token) = @_;
1490 0           my $file_name = $token->logical_filename();
1491 0 0         my $file_description = $file_name ? qq{ file "$file_name"} : q{};
1492             return
1493 0           "$file_description at line "
1494             . $token->logical_line_number()
1495             . q{, column }
1496             . $token->column_number();
1497             } ## end sub Marpa::R2::Perl::default_show_location
1498              
1499             1;
1500              
1501             # vim: set expandtab shiftwidth=4: