#!/usr/bin/env perl
use
5.010;
my
$verbose
;
die
if
not Getopt::Long::GetOptions(
verbose
=> \
$verbose
);
my
$grammar
= <<
'=== GRAMMAR ==='
;
:
default
::=
action
=> [ name, value ]
lexeme
default
=
action
=> [ name, value ]
latm
=> 1
script ::= E+
separator
=> semi
action
=> [
values
]
E ::=
number
action
=> main::number
|| E (
'*'
) E
action
=> main::multiply
|| E (
'+'
) E
action
=> main::add
:discard ~ whitespace
whitespace ~ [\s]+
number ~ [\d]+
semi ~
';'
=== GRAMMAR ===
my
$g
= Marpa::R2::Scanless::G->new( {
source
=> \(
$grammar
) } );
my
@tests
= (
[
'1+2+3*4'
,
'15'
],
[
'1+2 3+4'
,
'3,7'
],
[
'0+42 21*2 3*7+21 3*7*2'
,
'42,42,42,42'
],
);
for
my
$test
(
@tests
) {
my
(
$string
,
$expected_result
) = @{
$test
};
my
$actual_result
= test(
$g
,
$string
);
say
"Input: $string"
;
Test::More::is(
$actual_result
,
$expected_result
,
qq{Result of "$string"}
);
}
sub
test {
my
(
$g
,
$string
) =
@_
;
my
@found
= ();
diag(
"Input: $string"
)
if
$verbose
;
my
$original_length
=
length
$string
;
my
$suffixed_string
=
$string
.
';'
;
my
$target_start
= 0;
state
$recce_debug_args
= {};
my
$recce
= Marpa::R2::Scanless::R->new(
{
grammar
=>
$g
,
rejection
=>
'event'
,
},
$recce_debug_args
);
my
$pos
=
$recce
->
read
( \
$suffixed_string
, 0,
$original_length
);
READ_LOOP:
while
(1) {
my
$rejection
= 0;
my
$pos
=
$recce
->
pos
();
EVENT:
for
my
$event
( @{
$recce
->events() } ) {
my
(
$name
) = @{
$event
};
if
(
$name
eq
q('rejected)
) {
$rejection
= 1;
diag(
"You fool! you forget the semi-colon at location $pos!"
)
if
$verbose
;
next
EVENT;
}
die
join
q{ }
,
"Spurious event at position $pos: '$name'"
;
}
last
READ_LOOP
if
not
$rejection
;
$recce
->resume(
$original_length
, 1 );
diag(
"I fixed it for you. Now you owe me."
)
if
$verbose
;
$recce
->resume(
$pos
,
$original_length
-
$pos
);
}
my
$ref_value
=
$recce
->value();
return
'No parse'
if
not
$ref_value
;
if
(
ref
$ref_value
ne
'REF'
) {
my
$ref_type
=
ref
$ref_value
;
my
$ref_description
=
$ref_type
?
"ref to $ref_type"
:
'not a ref'
;
return
"Got $ref_description -- want REF to REF to ARRAY"
;
}
return
join
q{,}
, @{ ${
$ref_value
} };
}
sub
number {
my
(
undef
,
$v1
) =
@_
;
return
$v1
->[1];
}
sub
add {
my
(
$undef
,
$v1
,
$v2
) =
@_
;
return
$v1
+
$v2
;
}
sub
multiply {
my
(
$undef
,
$v1
,
$v2
) =
@_
;
return
$v1
*
$v2
;
}