use
5.010;
no
warnings
qw(recursion qw)
;
use
vars
qw($VERSION $STRING_VERSION)
;
$VERSION
=
'2.096000'
;
$STRING_VERSION
=
$VERSION
;
$VERSION
=
eval
$VERSION
;
our
%DEFAULT_SYMBOLS_RESERVED
;
%DEFAULT_SYMBOLS_RESERVED
=
map
{ (
$_
, 1) }
split
//xms,
'}]>)'
;
sub
Marpa::R2::uncaught_error {
my
(
$error
) =
@_
;
Carp::croak(
"libmarpa reported an error which Marpa::R2 did not catch\n"
,
$error
);
}
sub
Marpa::R2::Grammar::new {
my
(
$class
,
@arg_hashes
) =
@_
;
my
$grammar
= [];
bless
$grammar
,
$class
;
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE] =
*STDERR
;
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_RULES] = 0;
$grammar
->[Marpa::R2::Internal::Grammar::WARNINGS] = 1;
$grammar
->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK] = {};
$grammar
->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] = {};
$grammar
->[Marpa::R2::Internal::Grammar::INFINITE_ACTION] =
'fatal'
;
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS] = [];
$grammar
->[Marpa::R2::Internal::Grammar::RULES] = [];
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C] =
Marpa::R2::Thin::G->new( {
if
=> 1 } );
$grammar
->[Marpa::R2::Internal::Grammar::TRACER] =
Marpa::R2::Thin::Trace->new(
$grammar_c
);
$grammar
->set(
@arg_hashes
);
return
$grammar
;
}
sub
Marpa::R2::Grammar::tracer {
return
$_
[0]->[Marpa::R2::Internal::Grammar::TRACER];
}
sub
Marpa::R2::Grammar::thin {
return
$_
[0]->[Marpa::R2::Internal::Grammar::C];
}
sub
Marpa::R2::Grammar::thin_symbol {
my
(
$grammar
,
$symbol_name
) =
@_
;
return
$grammar
->[Marpa::R2::Internal::Grammar::TRACER]
->symbol_by_name(
$symbol_name
);
}
sub
Marpa::R2::Grammar::set {
my
(
$grammar
,
@arg_hashes
) =
@_
;
my
$trace_fh
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE];
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
for
my
$args
(
@arg_hashes
) {
my
$ref_type
=
ref
$args
;
if
( not
$ref_type
) {
Carp::croak(
'Marpa::R2::Grammar expects args as ref to HASH; arg was non-reference'
);
}
if
(
$ref_type
ne
'HASH'
) {
Carp::croak(
"Marpa::R2::Grammar expects args as ref to HASH, got ref to $ref_type instead"
);
}
state
$grammar_options
= {
map
{ (
$_
, 1 ) }
qw{ _internal_
action_object
actions
bless_package
infinite_action
default_action
default_empty_action
default_rank
inaccessible_ok
rules
source
start
symbols
terminals
trace_file_handle
unproductive_ok
warnings
}
};
if
(
my
@bad_options
=
grep
{ not
exists
$grammar_options
->{
$_
} }
keys
%{
$args
}
)
{
Carp::croak(
'Unknown option(s) for Marpa::R2::Grammar: '
,
join
q{ }
,
@bad_options
);
}
if
(
defined
(
my
$value
=
$args
->{
'_internal_'
} ) ) {
$grammar
->[Marpa::R2::Internal::Grammar::INTERNAL] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'trace_file_handle'
} ) ) {
$trace_fh
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'default_rank'
} ) ) {
Marpa::R2::exception(
'default_rank option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
$grammar_c
->default_rank_set(
$value
);
}
if
(
defined
(
my
$value
=
$args
->{
'symbols'
} ) ) {
Marpa::R2::exception(
'symbols option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
Marpa::R2::exception(
'symbols value must be REF to HASH'
)
if
ref
$value
ne
'HASH'
;
for
my
$symbol
(
sort
keys
%{
$value
} ) {
my
$properties
=
$value
->{
$symbol
};
assign_user_symbol(
$grammar
,
$symbol
,
$properties
);
}
}
if
(
defined
(
my
$value
=
$args
->{
'terminals'
} ) ) {
Marpa::R2::exception(
'terminals option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
Marpa::R2::exception(
'terminals value must be REF to ARRAY'
)
if
ref
$value
ne
'ARRAY'
;
for
my
$symbol
( @{
$value
} ) {
assign_user_symbol(
$grammar
,
$symbol
, {
terminal
=> 1 } );
}
}
if
(
defined
(
my
$value
=
$args
->{
'start'
} ) ) {
Marpa::R2::exception(
'start option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME] =
$value
;
}
my
$stuifzand_source
;
my
$deprecated_source
;
if
(
defined
(
my
$value
=
$args
->{
'source'
} ) ) {
Marpa::R2::exception(
'source option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
Marpa::R2::exception(
q{"source" named argument must be string or ref to SCALAR}
)
if
ref
$value
ne
'SCALAR'
;
$stuifzand_source
=
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'rules'
} ) ) {
Marpa::R2::exception(
'rules option not allowed after grammar is precomputed'
)
if
$grammar_c
->is_precomputed();
DO_RULES: {
if
(
ref
$value
eq
'ARRAY'
and
scalar
@{
$value
} == 1
and not
ref
$value
->[0] )
{
$value
=
$value
->[0];
}
if
( not
ref
$value
) {
$deprecated_source
= \
$value
;
}
if
(
defined
$deprecated_source
and
defined
$stuifzand_source
) {
Marpa::R2::exception(
qq{Attempt to specify BNF via both 'rules' and 'source' named arguments\n}
,
q{ You must use one or the other}
,
)
}
if
(
defined
$deprecated_source
) {
$stuifzand_source
=
$deprecated_source
;
last
DO_RULES;
}
Marpa::R2::exception(
q{"rules" named argument must be string or ref to ARRAY}
)
if
ref
$value
ne
'ARRAY'
;
$grammar
->[Marpa::R2::Internal::Grammar::INTERFACE] //=
'standard'
;
Marpa::R2::exception(
qq{Attempt to use the standard interface with a grammar that is already using the BNF interface\n}
,
q{ Mixing the BNF and standard interface is not allowed}
)
if
$grammar
->[Marpa::R2::Internal::Grammar::INTERFACE] ne
'standard'
;
add_user_rules(
$grammar
,
$value
);
}
}
if
(
defined
$stuifzand_source
) {
$grammar
->[Marpa::R2::Internal::Grammar::INTERFACE] //=
'stuifzand'
;
Marpa::R2::exception(
qq{Attempt to use the standard interface with a grammar that is already using the BNF interface\n}
,
q{ Mixing the BNF and standard interface is not allowed}
)
if
$grammar
->[Marpa::R2::Internal::Grammar::INTERFACE] ne
'stuifzand'
;
my
$parse_result
=
Marpa::R2::Internal::Stuifzand::parse_rules(
$stuifzand_source
);
for
my
$rule
( @{
$parse_result
->{rules} } ) {
add_user_rule(
$grammar
,
$rule
);
}
}
if
(
exists
$args
->{
'default_empty_action'
} ) {
my
$value
=
$args
->{
'default_empty_action'
};
$grammar
->[Marpa::R2::Internal::Grammar::DEFAULT_EMPTY_ACTION] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'actions'
} ) ) {
$grammar
->[Marpa::R2::Internal::Grammar::ACTIONS] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'bless_package'
} ) ) {
$grammar
->[Marpa::R2::Internal::Grammar::BLESS_PACKAGE] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'action_object'
} ) ) {
$grammar
->[Marpa::R2::Internal::Grammar::ACTION_OBJECT] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'default_action'
} ) ) {
$grammar
->[Marpa::R2::Internal::Grammar::DEFAULT_ACTION] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'infinite_action'
} ) ) {
if
(
$value
&&
$grammar_c
->is_precomputed() ) {
say
{
$trace_fh
}
'"infinite_action" option is useless after grammar is precomputed'
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
state
$allowed_values
=
{
map
{ (
$_
, 1 ) }
qw(warn quiet fatal)
};
Marpa::R2::exception(
q{infinite_action must be 'warn', 'quiet' or 'fatal'}
)
if
not
exists
$allowed_values
->{
$value
};
$grammar
->[Marpa::R2::Internal::Grammar::INFINITE_ACTION] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'warnings'
} ) ) {
if
(
$value
&&
$grammar_c
->is_precomputed() ) {
say
{
$trace_fh
}
q{"warnings" option is useless after grammar is precomputed}
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
$grammar
->[Marpa::R2::Internal::Grammar::WARNINGS] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'inaccessible_ok'
} ) ) {
if
(
$value
&&
$grammar_c
->is_precomputed() ) {
say
{
$trace_fh
}
q{"inaccessible_ok" option is useless after grammar is precomputed}
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
GIVEN_REF_VALUE: {
my
$ref_value
=
ref
$value
;
if
(
$ref_value
eq
q{}
) {
$value
//= {};
last
GIVEN_REF_VALUE;
}
if
(
$ref_value
eq
'ARRAY'
) {
$value
= {
map
{ (
$_
, 1 ) } @{
$value
} };
last
GIVEN_REF_VALUE;
}
Marpa::R2::exception(
'value of inaccessible_ok option must be boolean or an array ref'
);
}
$grammar
->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK] =
$value
;
}
if
(
defined
(
my
$value
=
$args
->{
'unproductive_ok'
} ) ) {
if
(
$value
&&
$grammar_c
->is_precomputed() ) {
say
{
$trace_fh
}
q{"unproductive_ok" option is useless after grammar is precomputed}
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
GIVEN_REF_VALUE: {
my
$ref_value
=
ref
$value
;
if
(
$ref_value
eq
q{}
) {
$value
//= {};
last
GIVEN_REF_VALUE;
}
if
(
$ref_value
eq
'ARRAY'
) {
$value
= {
map
{ (
$_
, 1 ) } @{
$value
} };
last
GIVEN_REF_VALUE;
}
Marpa::R2::exception(
'value of unproductive_ok option must be boolean or an array ref'
);
}
$grammar
->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK] =
$value
;
}
}
return
1;
}
sub
Marpa::R2::Grammar::symbol_reserved_set {
my
(
$grammar
,
$final_character
,
$boolean
) =
@_
;
if
(
length
$final_character
!= 1 ) {
Marpa::R2::exception(
'symbol_reserved_set(): "'
,
$final_character
,
'" is not a symbol'
);
}
if
(
$final_character
eq
']'
) {
return
if
$boolean
;
Marpa::R2::exception(
q{symbol_reserved_set(): Attempt to unreserve ']'; this is not allowed}
);
}
if
( not
exists
$DEFAULT_SYMBOLS_RESERVED
{
$final_character
} ) {
Marpa::R2::exception(
qq{symbol_reserved_set(): "$final_character" is not a reservable symbol}
);
}
return
$DEFAULT_SYMBOLS_RESERVED
{
$final_character
} =
$boolean
? 1 : 0;
}
sub
Marpa::R2::Grammar::precompute {
my
$grammar
=
shift
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$trace_fh
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE];
my
$problems
=
$grammar
->[Marpa::R2::Internal::Grammar::PROBLEMS];
if
(
$problems
) {
Marpa::R2::exception(
Marpa::R2::Grammar::show_problems(
$grammar
),
"Second attempt to precompute grammar with fatal problems\n"
,
'Marpa::R2 cannot proceed'
);
}
return
$grammar
if
$grammar_c
->is_precomputed();
set_start_symbol(
$grammar
);
my
$precompute_error_code
=
$Marpa::R2::Error::NONE
;
$grammar_c
->throw_set(0);
my
$precompute_result
=
$grammar_c
->precompute();
$grammar_c
->throw_set(1);
if
(
$precompute_result
< 0 ) {
(
$precompute_error_code
) =
$grammar_c
->error();
if
( not
defined
$precompute_error_code
) {
Marpa::R2::exception(
'libmarpa error, but no error code returned'
);
}
return
$grammar
if
$precompute_error_code
==
$Marpa::R2::Error::PRECOMPUTED
;
$precompute_error_code
=
$Marpa::R2::Error::NONE
if
$precompute_error_code
==
$Marpa::R2::Error::GRAMMAR_HAS_CYCLE
;
}
if
(
$precompute_error_code
!=
$Marpa::R2::Error::NONE
) {
if
(
$precompute_error_code
==
$Marpa::R2::Error::NO_RULES
) {
Marpa::R2::exception(
'Attempted to precompute grammar with no rules'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::NULLING_TERMINAL
) {
my
@nulling_terminals
= ();
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
eq
'MARPA_EVENT_NULLING_TERMINAL'
) {
push
@nulling_terminals
,
$grammar
->symbol_name(
$value
);
}
}
my
@nulling_terminal_messages
=
map
{
qq{Nulling symbol "$_" is also a terminal\n}
}
@nulling_terminals
;
Marpa::R2::exception(
@nulling_terminal_messages
,
'A terminal symbol cannot also be a nulling symbol'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::COUNTED_NULLABLE
) {
my
@counted_nullables
= ();
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
eq
'MARPA_EVENT_COUNTED_NULLABLE'
) {
push
@counted_nullables
,
$grammar
->symbol_name(
$value
);
}
}
my
@counted_nullable_messages
=
map
{
q{Nullable symbol "}
.
$_
.
qq{" is on rhs of counted rule\n}
}
@counted_nullables
;
Marpa::R2::exception(
@counted_nullable_messages
,
'Counted nullables confuse Marpa -- please rewrite the grammar'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::NO_START_SYMBOL
) {
Marpa::R2::exception(
'No start symbol'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::START_NOT_LHS
) {
my
$name
=
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME];
Marpa::R2::exception(
qq{Start symbol "$name" not on LHS of any rule}
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::UNPRODUCTIVE_START
)
{
my
$name
=
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME];
Marpa::R2::exception(
qq{Unproductive start symbol: "$name"}
);
}
Marpa::R2::uncaught_error(
scalar
$grammar_c
->error() );
}
{
my
$highest_rule_id
=
$grammar_c
->highest_rule_id();
RULE:
for
(
my
$rule_id
= 0;
$rule_id
<=
$highest_rule_id
;
$rule_id
++ ) {
next
RULE
if
defined
$rules
->[
$rule_id
];
shadow_rule(
$grammar
,
$rule_id
);
}
}
my
$infinite_action
=
$grammar
->[Marpa::R2::Internal::Grammar::INFINITE_ACTION];
my
$loop_rule_count
= 0;
{
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
ne
'MARPA_EVENT_LOOP_RULES'
) {
Marpa::R2::exception(
qq{Unknown grammar precomputation event; type="$event_type"}
);
}
$loop_rule_count
=
$value
;
}
}
if
(
$loop_rule_count
and
$infinite_action
ne
'quiet'
) {
my
@loop_rules
=
grep
{
$grammar_c
->rule_is_loop(
$_
) } ( 0 .. $
for
my
$rule_id
(
@loop_rules
) {
print
{
$trace_fh
}
'Cycle found involving rule: '
,
$grammar
->brief_rule(
$rule_id
),
"\n"
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
Marpa::R2::exception(
'Cycles in grammar, fatal error'
)
if
$infinite_action
eq
'fatal'
;
}
if
(
$grammar
->[Marpa::R2::Internal::Grammar::WARNINGS]
and
ref
(
my
$ok
=
$grammar
->[Marpa::R2::Internal::Grammar::INACCESSIBLE_OK]
) eq
'HASH'
)
{
SYMBOL:
for
my
$symbol
(
@{ Marpa::R2::Grammar::inaccessible_symbols(
$grammar
) } )
{
next
SYMBOL
if
$symbol
=~ /\]/xms;
next
SYMBOL
if
$ok
->{
$symbol
};
say
{
$trace_fh
}
"Inaccessible symbol: $symbol"
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
}
if
(
$grammar
->[Marpa::R2::Internal::Grammar::WARNINGS]
and
ref
(
my
$ok
=
$grammar
->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK]
) eq
'HASH'
)
{
SYMBOL:
for
my
$symbol
(
@{ Marpa::R2::Grammar::unproductive_symbols(
$grammar
) } )
{
next
SYMBOL
if
$symbol
=~ /\]/xms;
next
SYMBOL
if
$ok
->{
$symbol
};
say
{
$trace_fh
}
"Unproductive symbol: $symbol"
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
}
Marpa::R2::exception(
"Internal error; precompute called for SLIF grammar"
)
if
$grammar
->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES];
return
$grammar
;
}
sub
Marpa::R2::Internal::Grammar::slif_precompute {
my
$grammar
=
shift
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$trace_fh
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACE_FILE_HANDLE];
my
$problems
=
$grammar
->[Marpa::R2::Internal::Grammar::PROBLEMS];
if
(
$problems
) {
Marpa::R2::exception(
Marpa::R2::Grammar::show_problems(
$grammar
),
"Second attempt to precompute grammar with fatal problems\n"
,
'Marpa::R2 cannot proceed'
);
}
return
if
$grammar_c
->is_precomputed();
if
(
$grammar_c
->force_valued() < 0) {
Marpa::R2::uncaught_error(
scalar
$grammar_c
->error() );
}
set_start_symbol(
$grammar
);
my
$precompute_error_code
=
$Marpa::R2::Error::NONE
;
$grammar_c
->throw_set(0);
my
$precompute_result
=
$grammar_c
->precompute();
$grammar_c
->throw_set(1);
if
(
$precompute_result
< 0 ) {
(
$precompute_error_code
) =
$grammar_c
->error();
if
( not
defined
$precompute_error_code
) {
Marpa::R2::exception(
'libmarpa error, but no error code returned'
);
}
return
$precompute_error_code
if
$precompute_error_code
==
$Marpa::R2::Error::PRECOMPUTED
;
$precompute_error_code
=
$Marpa::R2::Error::NONE
if
$precompute_error_code
==
$Marpa::R2::Error::GRAMMAR_HAS_CYCLE
;
}
if
(
$precompute_error_code
!=
$Marpa::R2::Error::NONE
) {
if
(
$precompute_error_code
==
$Marpa::R2::Error::NO_RULES
) {
Marpa::R2::exception(
'Attempted to precompute grammar with no rules'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::NULLING_TERMINAL
) {
my
@nulling_terminals
= ();
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
eq
'MARPA_EVENT_NULLING_TERMINAL'
) {
push
@nulling_terminals
,
$grammar
->symbol_name(
$value
);
}
}
my
@nulling_terminal_messages
=
map
{
qq{Nulling symbol "$_" is also a terminal\n}
}
@nulling_terminals
;
Marpa::R2::exception(
@nulling_terminal_messages
,
'A terminal symbol cannot also be a nulling symbol'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::COUNTED_NULLABLE
) {
my
@counted_nullables
= ();
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
eq
'MARPA_EVENT_COUNTED_NULLABLE'
) {
push
@counted_nullables
,
$grammar
->symbol_name(
$value
);
}
}
my
@counted_nullable_messages
=
map
{
q{Nullable symbol "}
.
$_
.
qq{" is on rhs of counted rule\n}
}
@counted_nullables
;
Marpa::R2::exception(
@counted_nullable_messages
,
'Counted nullables confuse Marpa -- please rewrite the grammar'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::NO_START_SYMBOL
) {
Marpa::R2::exception(
'No start symbol'
);
}
if
(
$precompute_error_code
==
$Marpa::R2::Error::START_NOT_LHS
) {
my
$name
=
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME];
Marpa::R2::exception(
qq{Start symbol "$name" not on LHS of any rule}
);
}
return
$precompute_error_code
if
$precompute_error_code
==
$Marpa::R2::Error::UNPRODUCTIVE_START
;
Marpa::R2::uncaught_error(
scalar
$grammar_c
->error() );
}
{
my
$highest_rule_id
=
$grammar_c
->highest_rule_id();
RULE:
for
(
my
$rule_id
= 0;
$rule_id
<=
$highest_rule_id
;
$rule_id
++ ) {
next
RULE
if
defined
$rules
->[
$rule_id
];
shadow_rule(
$grammar
,
$rule_id
);
}
}
my
$infinite_action
=
$grammar
->[Marpa::R2::Internal::Grammar::INFINITE_ACTION];
my
$loop_rule_count
= 0;
{
my
$event_count
=
$grammar_c
->event_count();
EVENT:
for
(
my
$event_ix
= 0;
$event_ix
<
$event_count
;
$event_ix
++ ) {
my
(
$event_type
,
$value
) =
$grammar_c
->event(
$event_ix
);
if
(
$event_type
ne
'MARPA_EVENT_LOOP_RULES'
) {
Marpa::R2::exception(
qq{Unknown grammar precomputation event; type="$event_type"}
);
}
$loop_rule_count
=
$value
;
}
}
if
(
$loop_rule_count
and
$infinite_action
ne
'quiet'
) {
my
@loop_rules
=
grep
{
$grammar_c
->rule_is_loop(
$_
) } ( 0 .. $
for
my
$rule_id
(
@loop_rules
) {
print
{
$trace_fh
}
'Cycle found involving rule: '
,
$grammar
->brief_rule(
$rule_id
),
"\n"
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
Marpa::R2::exception(
'Cycles in grammar, fatal error'
)
if
$infinite_action
eq
'fatal'
;
}
my
$default_if_inaccessible
=
$grammar
->[Marpa::R2::Internal::Grammar::INTERNAL]->{if_inaccessible}
//
'warn'
;
SYMBOL:
for
my
$symbol_id
(
grep
{ !
$grammar_c
->symbol_is_accessible(
$_
) }
( 0 .. $
{
my
$symbol
=
$symbols
->[
$symbol_id
];
my
$symbol_name
=
$grammar
->symbol_name(
$symbol_id
);
next
SYMBOL
if
$symbol_name
=~ /\]/xms;
my
$treatment
=
$symbol
->[Marpa::R2::Internal::Symbol::IF_INACCESSIBLE] //
$default_if_inaccessible
;
next
SYMBOL
if
$treatment
eq
'ok'
;
my
$message
=
"Inaccessible symbol: $symbol_name"
;
Marpa::R2::exception(
$message
)
if
$treatment
eq
'fatal'
;
say
{
$trace_fh
}
$message
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
if
(
$grammar
->[Marpa::R2::Internal::Grammar::WARNINGS]
and
ref
(
my
$ok
=
$grammar
->[Marpa::R2::Internal::Grammar::UNPRODUCTIVE_OK]
) eq
'HASH'
)
{
SYMBOL:
for
my
$symbol
(
@{ Marpa::R2::Grammar::unproductive_symbols(
$grammar
) } )
{
next
SYMBOL
if
$symbol
=~ /\]/xms;
next
SYMBOL
if
$ok
->{
$symbol
};
say
{
$trace_fh
}
"Unproductive symbol: $symbol"
or Marpa::R2::exception(
"Could not print: $ERRNO"
);
}
}
my
$cc_hash
=
$grammar
->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES];
if
(
defined
$cc_hash
) {
my
$class_table
=
$grammar
->[Marpa::R2::Internal::Grammar::CHARACTER_CLASS_TABLE] =
[];
for
my
$cc_symbol
(
sort
keys
%{
$cc_hash
} ) {
my
$cc_components
=
$cc_hash
->{
$cc_symbol
};
push
@{
$class_table
},
[
$grammar
->thin_symbol(
$cc_symbol
),
$cc_components
];
}
}
$grammar
->[Marpa::R2::Internal::Grammar::CHARACTER_CLASSES] =
undef
;
return
;
}
sub
Marpa::R2::Grammar::show_problems {
my
(
$grammar
) =
@_
;
my
$problems
=
$grammar
->[Marpa::R2::Internal::Grammar::PROBLEMS];
if
(
$problems
) {
my
$problem_count
=
scalar
@{
$problems
};
return
"Grammar has $problem_count problems:\n"
. (
join
"\n"
, @{
$problems
} ) .
"\n"
;
}
return
"Grammar has no problems\n"
;
}
sub
Marpa::R2::Grammar::symbol_dsl_form {
my
(
$grammar
,
$symbol_id
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$symbol
=
$symbols
->[
$symbol_id
];
return
$symbol
->[Marpa::R2::Internal::Symbol::DSL_FORM];
}
sub
Marpa::R2::Grammar::symbol_description {
my
(
$grammar
,
$symbol_id
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$symbol
=
$symbols
->[
$symbol_id
];
return
$symbol
->[Marpa::R2::Internal::Symbol::DESCRIPTION];
}
sub
Marpa::R2::Grammar::symbol_in_display_form {
my
(
$grammar
,
$symbol_id
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$symbol
=
$symbols
->[
$symbol_id
];
return
"<!No symbol with ID $symbol_id!>"
if
not
defined
$symbol
;
my
$text
=
$symbol
->[Marpa::R2::Internal::Symbol::DISPLAY_FORM];
return
$text
if
defined
$text
;
$text
=
$symbol
->[Marpa::R2::Internal::Symbol::DSL_FORM] //
$grammar
->symbol_name(
$symbol_id
);
return
(
$text
=~ m/\s/xms) ?
"<$text>"
:
$text
;
}
sub
Marpa::R2::Grammar::show_symbol {
my
(
$grammar
,
$symbol
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$text
=
q{}
;
my
$symbol_id
=
$symbol
->[Marpa::R2::Internal::Symbol::ID];
my
$name
=
$grammar
->symbol_name(
$symbol_id
);
$text
.=
"$symbol_id: $name"
;
my
@tag_list
= ();
$grammar_c
->symbol_is_productive(
$symbol_id
)
or
push
@tag_list
,
'unproductive'
;
$grammar_c
->symbol_is_accessible(
$symbol_id
)
or
push
@tag_list
,
'inaccessible'
;
$grammar_c
->symbol_is_nulling(
$symbol_id
) and
push
@tag_list
,
'nulling'
;
$grammar_c
->symbol_is_terminal(
$symbol_id
) and
push
@tag_list
,
'terminal'
;
$text
.=
join
q{ }
,
q{,}
,
@tag_list
if
scalar
@tag_list
;
$text
.=
"\n"
;
return
$text
;
}
sub
Marpa::R2::Grammar::show_symbols {
my
(
$grammar
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$text
=
q{}
;
for
my
$symbol_ref
( @{
$symbols
} ) {
$text
.=
$grammar
->show_symbol(
$symbol_ref
);
}
return
$text
;
}
sub
Marpa::R2::Grammar::show_nulling_symbols {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
join
q{ }
,
sort
map
{
$grammar
->symbol_name(
$_
) }
grep
{
$grammar_c
->symbol_is_nulling(
$_
) } ( 0 .. $
}
sub
Marpa::R2::Grammar::show_productive_symbols {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
join
q{ }
,
sort
map
{
$grammar
->symbol_name(
$_
) }
grep
{
$grammar_c
->symbol_is_productive(
$_
) } ( 0 .. $
}
sub
Marpa::R2::Grammar::show_accessible_symbols {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
join
q{ }
,
sort
map
{
$grammar
->symbol_name(
$_
) }
grep
{
$grammar_c
->symbol_is_accessible(
$_
) } ( 0 .. $
}
sub
Marpa::R2::Grammar::inaccessible_symbols {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
[
sort
map
{
$grammar
->symbol_name(
$_
) }
grep
{ !
$grammar_c
->symbol_is_accessible(
$_
) }
( 0 .. $
];
}
sub
Marpa::R2::Grammar::unproductive_symbols {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
[
sort
map
{
$grammar
->symbol_name(
$_
) }
grep
{ !
$grammar_c
->symbol_is_productive(
$_
) }
( 0 .. $
];
}
sub
Marpa::R2::Grammar::start_symbol {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
return
$grammar_c
->start_symbol();
}
sub
Marpa::R2::Grammar::rule_name {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$rule
=
$rules
->[
$rule_id
];
return
"Non-existent rule $rule_id"
if
not
defined
$rule
;
my
$name
=
$rule
->[Marpa::R2::Internal::Rule::NAME];
return
$name
if
defined
$name
;
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
(
$lhs_id
) =
$tracer
->rule_expand(
$rule_id
);
return
$grammar
->symbol_name(
$lhs_id
);
}
sub
Marpa::R2::Grammar::brief_rule {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
(
$lhs
,
@rhs
) =
$grammar
->rule(
$rule_id
);
my
$minimum
=
$grammar_c
->sequence_min(
$rule_id
);
my
$quantifier
=
defined
$minimum
?
$minimum
<= 0 ?
q{*}
:
q{+}
:
q{}
;
return
(
join
q{ }
,
"$rule_id:"
,
$lhs
,
'->'
,
@rhs
) .
$quantifier
;
}
sub
Marpa::R2::Grammar::show_rule {
my
(
$grammar
,
$rule
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$rule_id
=
$rule
->[Marpa::R2::Internal::Rule::ID];
my
@comment
= ();
$grammar_c
->rule_length(
$rule_id
) == 0 and
push
@comment
,
'empty'
;
$grammar
->rule_is_used(
$rule_id
) or
push
@comment
,
'!used'
;
$grammar_c
->rule_is_productive(
$rule_id
) or
push
@comment
,
'unproductive'
;
$grammar_c
->rule_is_accessible(
$rule_id
) or
push
@comment
,
'inaccessible'
;
$rule
->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION]
and
push
@comment
,
'discard_sep'
;
my
$text
=
$grammar
->brief_rule(
$rule_id
);
if
(
@comment
) {
$text
.=
q{ }
. (
join
q{ }
,
q{/*}
,
@comment
,
q{*/}
);
}
return
$text
.=
"\n"
;
}
sub
Marpa::R2::Grammar::show_rules {
my
(
$grammar
) =
@_
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$text
;
for
my
$rule
( @{
$rules
} ) {
$text
.=
$grammar
->show_rule(
$rule
);
}
return
$text
;
}
sub
Marpa::R2::Grammar::rule_ids {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
return
0 ..
$grammar_c
->highest_rule_id();
}
sub
Marpa::R2::Grammar::symbol_ids {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
return
0 ..
$grammar_c
->highest_symbol_id();
}
sub
Marpa::R2::Grammar::rule {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
@symbol_names
= ();
my
@symbols
=
$tracer
->rule_expand(
$rule_id
);
SYMBOL_ID:
for
my
$symbol_id
(
@symbols
) {
my
$name
=
$symbols
->[
$symbol_id
]->[Marpa::R2::Internal::Symbol::LEGACY_NAME]
//
$grammar
->symbol_name(
$symbol_id
);
push
@symbol_names
,
$name
;
}
return
@symbol_names
;
}
sub
Marpa::R2::Grammar::_rule_mask {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$rule
=
$rules
->[
$rule_id
];
return
$rule
->[Marpa::R2::Internal::Rule::MASK];
}
sub
Marpa::R2::Grammar::bnf_rule {
goto
&Marpa::R2::Grammar::rule
;
}
sub
Marpa::R2::Grammar::show_dotted_rule {
my
(
$grammar
,
$rule_id
,
$dot_position
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
(
$lhs
,
@rhs
) =
$grammar
->rule(
$rule_id
);
my
$minimum
=
$grammar_c
->sequence_min(
$rule_id
);
if
(
defined
$minimum
) {
my
$quantifier
=
$minimum
<= 0 ?
q{*}
:
q{+}
;
$rhs
[0] .=
$quantifier
;
}
$dot_position
= 0
if
$dot_position
< 0;
splice
@rhs
,
$dot_position
, 0,
q{.}
;
return
join
q{ }
,
$lhs
,
q{->}
,
@rhs
;
}
sub
Marpa::R2::Grammar::check_terminal {
my
(
$grammar
,
$name
) =
@_
;
return
0
if
not
defined
$name
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$symbol_id
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER]
->symbol_by_name(
$name
);
return
0
if
not
defined
$symbol_id
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$symbol
=
$symbols
->[
$symbol_id
];
return
$grammar_c
->symbol_is_terminal(
$symbol_id
) ? 1 : 0;
}
sub
Marpa::R2::Grammar::symbol_name {
my
(
$grammar
,
$id
) =
@_
;
my
$symbol_name
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER]->symbol_name(
$id
);
return
defined
$symbol_name
?
$symbol_name
:
'[SYMBOL#'
.
$id
.
']'
;
}
sub
shadow_symbol {
my
(
$grammar
,
$symbol_id
) =
@_
;
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
my
$symbol
=
$symbols
->[
$symbol_id
] = [];
$symbol
->[Marpa::R2::Internal::Symbol::ID] =
$symbol_id
;
return
$symbol
;
}
sub
shadow_rule {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$new_rule
=
$rules
->[
$rule_id
] = [];
$new_rule
->[Marpa::R2::Internal::Rule::ID] =
$rule_id
;
return
$new_rule
;
}
sub
assign_symbol {
my
(
$grammar
,
$name
,
$options
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
$symbol_id
=
$tracer
->symbol_by_name(
$name
);
if
(
defined
$symbol_id
) {
my
$symbols
=
$grammar
->[Marpa::R2::Internal::Grammar::SYMBOLS];
return
$symbols
->[
$symbol_id
];
}
$symbol_id
=
$tracer
->symbol_new(
$name
);
my
$symbol
= shadow_symbol(
$grammar
,
$symbol_id
);
PROPERTY:
for
my
$property
(
sort
keys
%{
$options
} ) {
if
(
$property
eq
'semantics'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::LEXEME_SEMANTICS] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'bless'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::BLESSING] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'terminal'
) {
my
$value
=
$options
->{
$property
};
$grammar_c
->symbol_is_terminal_set(
$symbol_id
,
$value
);
next
PROPERTY;
}
if
(
$property
eq
'rank'
) {
my
$value
=
$options
->{
$property
};
Marpa::R2::exception(
qq{Symbol "$name": rank must be an integer}
)
if
not Scalar::Util::looks_like_number(
$value
)
or
int
(
$value
) !=
$value
;
$grammar_c
->symbol_rank_set(
$symbol_id
) =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'description'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::DESCRIPTION] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'dsl_form'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::DSL_FORM] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'legacy_name'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::LEGACY_NAME] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'display_form'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::DISPLAY_FORM] =
$value
;
next
PROPERTY;
}
if
(
$property
eq
'if_inaccessible'
) {
my
$value
=
$options
->{
$property
};
$symbol
->[Marpa::R2::Internal::Symbol::IF_INACCESSIBLE] =
$value
;
next
PROPERTY;
}
Marpa::R2::exception(
qq{Unknown symbol property "$property"}
);
}
return
$symbol
;
}
sub
assign_user_symbol {
my
$grammar
=
shift
;
my
$name
=
shift
;
my
$options
=
shift
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
if
(
my
$type
=
ref
$name
) {
Marpa::R2::exception(
"Symbol name was ref to $type; it must be a scalar string"
);
}
if
( not
$grammar
->[Marpa::R2::Internal::Grammar::INTERNAL] ) {
my
$final_symbol
=
substr
$name
, -1;
if
(
$DEFAULT_SYMBOLS_RESERVED
{
$final_symbol
} ) {
Marpa::R2::exception(
qq{Symbol name $name ends in "$final_symbol": that's not allowed}
);
}
}
my
$symbol
= assign_symbol(
$grammar
,
$name
,
$options
);
return
$symbol
;
}
sub
add_user_rules {
my
(
$grammar
,
$rules
) =
@_
;
my
@hash_rules
= ();
RULE:
for
my
$rule
( @{
$rules
} ) {
my
$ref_rule
=
ref
$rule
;
if
(
$ref_rule
eq
'HASH'
) {
push
@hash_rules
,
$rule
;
next
RULE;
}
if
(
$ref_rule
eq
'ARRAY'
) {
my
$arg_count
= @{
$rule
};
if
(
$arg_count
> 4 or
$arg_count
< 1 ) {
Marpa::R2::exception(
"Rule has $arg_count arguments: "
.
join
(
', '
,
map
{
defined
$_
?
$_
:
'undef'
} @{
$rule
} )
.
"\n"
.
'Rule must have from 1 to 4 arguments'
);
}
my
(
$lhs
,
$rhs
,
$action
) = @{
$rule
};
push
@hash_rules
,
{
lhs
=>
$lhs
,
rhs
=>
$rhs
,
action
=>
$action
,
};
next
RULE;
}
Marpa::R2::exception(
'Invalid rule: '
,
Data::Dumper->new( [
$rule
], [
'Invalid_Rule'
] )->Indent(2)
->Terse(1)->Maxdepth(2)->Dump,
'Rule must be ref to HASH or ARRAY'
);
}
for
my
$hash_rule
(
@hash_rules
) {
add_user_rule(
$grammar
,
$hash_rule
);
}
return
;
}
sub
add_user_rule {
my
(
$grammar
,
$options
) =
@_
;
Marpa::R2::exception(
'Missing argument to add_user_rule'
)
if
not
defined
$grammar
or not
defined
$options
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
$rules
=
$grammar
->[Marpa::R2::Internal::Grammar::RULES];
my
$default_rank
=
$grammar_c
->default_rank();
my
(
$lhs_name
,
$rhs_names
,
$action
,
$blessing
);
my
(
$min
,
$separator_name
);
my
$rank
;
my
$null_ranking
;
my
$rule_name
;
my
$mask
;
my
$proper_separation
= 0;
my
$keep_separation
= 0;
my
$description
;
OPTION:
for
my
$option
(
keys
%{
$options
} ) {
my
$value
=
$options
->{
$option
};
if
(
$option
eq
'name'
) {
$rule_name
=
$value
;
next
OPTION; }
if
(
$option
eq
'rhs'
) {
$rhs_names
=
$value
;
next
OPTION }
if
(
$option
eq
'lhs'
) {
$lhs_name
=
$value
;
next
OPTION }
if
(
$option
eq
'action'
) {
$action
=
$value
;
next
OPTION }
if
(
$option
eq
'bless'
) {
$blessing
=
$value
;
next
OPTION }
if
(
$option
eq
'rank'
) {
$rank
=
$value
;
next
OPTION }
if
(
$option
eq
'null_ranking'
) {
$null_ranking
=
$value
;
next
OPTION;
}
if
(
$option
eq
'min'
) {
$min
=
$value
;
next
OPTION }
if
(
$option
eq
'separator'
) {
$separator_name
=
$value
;
next
OPTION;
}
if
(
$option
eq
'proper'
) {
$proper_separation
=
$value
;
next
OPTION;
}
if
(
$option
eq
'keep'
) {
$keep_separation
=
$value
;
next
OPTION }
if
(
$option
eq
'mask'
) {
$mask
=
$value
;
next
OPTION }
if
(
$option
eq
'description'
) {
$description
=
$value
;
next
OPTION }
Marpa::R2::exception(
"Unknown user rule option: $option"
);
}
if
(
defined
$min
and not Scalar::Util::looks_like_number(
$min
) ) {
Marpa::R2::exception(
q{"min" must be undefined or a valid Perl number}
);
}
my
$stuifzand_interface
=
$grammar
->[Marpa::R2::Internal::Grammar::INTERFACE] eq
'stuifzand'
;
my
$grammar_is_internal
=
$stuifzand_interface
||
$grammar
->[Marpa::R2::Internal::Grammar::INTERNAL];
my
$lhs
=
$grammar_is_internal
? assign_symbol(
$grammar
,
$lhs_name
)
: assign_user_symbol(
$grammar
,
$lhs_name
);
$rhs_names
//= [];
my
@rule_problems
= ();
my
$rhs_ref_type
=
ref
$rhs_names
;
if
( not
$rhs_ref_type
or
$rhs_ref_type
ne
'ARRAY'
) {
my
$problem
=
"RHS is not ref to ARRAY\n"
.
' Type of rhs is '
. (
$rhs_ref_type
?
$rhs_ref_type
:
'not a ref'
) .
"\n"
;
my
$d
= Data::Dumper->new( [
$rhs_names
], [
'rhs'
] );
$problem
.=
$d
->Dump();
push
@rule_problems
,
$problem
;
}
if
( not
defined
$lhs_name
) {
push
@rule_problems
,
"Missing LHS\n"
;
}
if
(
defined
$rank
and
( not Scalar::Util::looks_like_number(
$rank
) or
int
(
$rank
) !=
$rank
)
)
{
push
@rule_problems
,
"Rank must be undefined or an integer\n"
;
}
$rank
//=
$default_rank
;
$null_ranking
//=
'low'
;
if
(
$null_ranking
ne
'high'
and
$null_ranking
ne
'low'
) {
push
@rule_problems
,
"Null Ranking must be undefined, 'high' or 'low'\n"
;
}
if
(
scalar
@rule_problems
) {
my
%dump_options
= %{
$options
};
delete
$dump_options
{grammar};
my
$msg
= (
scalar
@rule_problems
)
.
" problem(s) in the following rule:\n"
;
my
$d
= Data::Dumper->new( [ \
%dump_options
], [
'rule'
] );
$msg
.=
$d
->Dump();
for
my
$problem_number
( 0 ..
$#rule_problems
) {
$msg
.=
'Problem '
. (
$problem_number
+ 1 ) .
q{: }
.
$rule_problems
[
$problem_number
] .
"\n"
;
}
Marpa::R2::exception(
$msg
);
}
my
$rhs
= [
map
{
$grammar_is_internal
? assign_symbol(
$grammar
,
$_
)
: assign_user_symbol(
$grammar
,
$_
);
} @{
$rhs_names
}
];
my
$is_ordinary_rule
=
scalar
@{
$rhs_names
} == 0 || !
defined
$min
;
if
(
defined
$separator_name
and
$is_ordinary_rule
) {
if
(
defined
$separator_name
) {
Marpa::R2::exception(
'separator defined for rule without repetitions'
);
}
}
my
@rhs_ids
=
map
{
$_
->[Marpa::R2::Internal::Symbol::ID] } @{
$rhs
};
my
$lhs_id
=
$lhs
->[Marpa::R2::Internal::Symbol::ID];
if
(
$is_ordinary_rule
) {
$grammar_c
->throw_set(0);
my
$ordinary_rule_id
=
$grammar_c
->rule_new(
$lhs_id
, \
@rhs_ids
);
$grammar_c
->throw_set(1);
if
(
$ordinary_rule_id
< 0 ) {
my
$rule_description
= rule_describe(
$lhs_name
,
$rhs_names
);
my
(
$error_code
,
$error_string
) =
$grammar_c
->error();
$error_code
//= -1;
my
$problem_description
=
$error_code
==
$Marpa::R2::Error::DUPLICATE_RULE
?
'Duplicate rule'
:
$error_string
;
Marpa::R2::exception(
"$problem_description: $rule_description"
);
}
shadow_rule(
$grammar
,
$ordinary_rule_id
);
my
$ordinary_rule
=
$rules
->[
$ordinary_rule_id
];
if
( not
defined
$mask
or not
$grammar_is_internal
) {
$mask
= [ (1) x
scalar
@rhs_ids
];
}
$ordinary_rule
->[Marpa::R2::Internal::Rule::MASK] =
$mask
;
$ordinary_rule
->[Marpa::R2::Internal::Rule::ACTION_NAME] =
$action
;
if
(
defined
$rank
) {
$grammar_c
->rule_rank_set(
$ordinary_rule_id
,
$rank
);
}
$grammar_c
->rule_null_high_set(
$ordinary_rule_id
,
(
$null_ranking
eq
'high'
? 1 : 0 ) );
if
(
defined
$rule_name
) {
$ordinary_rule
->[Marpa::R2::Internal::Rule::NAME] =
$rule_name
;
}
if
(
defined
$blessing
) {
$ordinary_rule
->[Marpa::R2::Internal::Rule::BLESSING] =
$blessing
;
}
if
(
defined
$description
) {
$ordinary_rule
->[Marpa::R2::Internal::Rule::DESCRIPTION] =
$description
;
}
return
;
}
Marpa::R2::exception(
'Only one rhs symbol allowed for counted rule'
)
if
scalar
@{
$rhs_names
} != 1;
my
$separator
;
my
$separator_id
= -1;
if
(
defined
$separator_name
) {
$separator
=
$grammar_is_internal
? assign_symbol(
$grammar
,
$separator_name
)
: assign_user_symbol(
$grammar
,
$separator_name
);
$separator_id
=
$separator
->[Marpa::R2::Internal::Symbol::ID];
}
$grammar_c
->throw_set(0);
my
$original_rule_id
=
$grammar_c
->sequence_new(
$lhs_id
,
$rhs_ids
[0],
{
separator
=>
$separator_id
,
proper
=>
$proper_separation
,
min
=>
$min
,
}
);
$grammar_c
->throw_set(1);
if
( not
defined
$original_rule_id
or
$original_rule_id
< 0) {
my
$rule_description
= rule_describe(
$lhs_name
,
$rhs_names
);
my
(
$error_code
,
$error_string
) =
$grammar_c
->error();
$error_code
//= -1;
my
$problem_description
=
$error_code
==
$Marpa::R2::Error::DUPLICATE_RULE
?
'Duplicate rule'
:
$error_string
;
Marpa::R2::exception(
"$problem_description: $rule_description"
);
}
shadow_rule(
$grammar
,
$original_rule_id
);
my
$original_rule
=
$rules
->[
$original_rule_id
];
$original_rule
->[Marpa::R2::Internal::Rule::ACTION_NAME] =
$action
;
$original_rule
->[Marpa::R2::Internal::Rule::DISCARD_SEPARATION] =
$separator_id
>= 0 && !
$keep_separation
;
$grammar_c
->rule_null_high_set(
$original_rule_id
,
(
$null_ranking
eq
'high'
? 1 : 0 ) );
$grammar_c
->rule_rank_set(
$original_rule_id
,
$rank
);
if
(
defined
$rule_name
) {
$original_rule
->[Marpa::R2::Internal::Rule::NAME] =
$rule_name
;
}
if
(
defined
$blessing
) {
$original_rule
->[Marpa::R2::Internal::Rule::BLESSING] =
$blessing
;
}
if
(
defined
$description
) {
$original_rule
->[Marpa::R2::Internal::Rule::DESCRIPTION] =
$description
;
}
return
;
}
sub
rule_describe {
my
(
$lhs_name
,
$rhs_names
) =
@_
;
$lhs_name
=
"<$lhs_name>"
if
$lhs_name
=~ / /;
return
"$lhs_name -> "
. (
join
q{ }
,
map
{ / / ?
"<$_>"
:
$_
} @{
$rhs_names
} );
}
sub
set_start_symbol {
my
$grammar
=
shift
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
state
$default_start_name
=
'[:start]'
;
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
$default_start_id
=
$tracer
->symbol_by_name(
$default_start_name
);
my
$start_id
;
VALIDATE_START_NAME: {
my
$named_arg_start_name
=
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME];
if
(
defined
$named_arg_start_name
and
defined
$start_id
) {
Marpa::R2::exception(
qq{Start symbol specified as '[:start]', but also with named argument\n}
,
qq{ You must use one or the other\n}
);
}
if
(
defined
$named_arg_start_name
) {
$start_id
=
$tracer
->symbol_by_name(
$named_arg_start_name
);
Marpa::R2::exception(
qq{Start symbol "$named_arg_start_name" not in grammar}
)
if
not
defined
$start_id
;
last
VALIDATE_START_NAME;
}
if
(
defined
$default_start_id
) {
$start_id
=
$default_start_id
;
$grammar
->[Marpa::R2::Internal::Grammar::START_NAME] =
$named_arg_start_name
;
last
VALIDATE_START_NAME;
}
Marpa::R2::exception(
qq{No start symbol specified in grammar\n}
);
}
if
( not
defined
$grammar_c
->start_symbol_set(
$start_id
) ) {
Marpa::R2::uncaught_error(
$grammar_c
->error() );
}
return
1;
}
sub
Marpa::R2::Grammar::error {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
return
$grammar_c
->error();
}
sub
Marpa::R2::Grammar::show_isy {
my
(
$grammar
,
$isy_id
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
$text
=
q{}
;
my
$name
=
$tracer
->isy_name(
$isy_id
);
$text
.=
"$isy_id: $name"
;
my
@tag_list
= ();
$grammar_c
->_marpa_g_nsy_is_nulling(
$isy_id
)
and
push
@tag_list
,
'nulling'
;
$text
.=
join
q{ }
,
q{,}
,
@tag_list
if
scalar
@tag_list
;
$text
.=
"\n"
;
return
$text
;
}
sub
Marpa::R2::Grammar::show_isys {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$text
=
q{}
;
for
my
$isy_id
( 0 ..
$grammar_c
->_marpa_g_nsy_count() - 1 ) {
$text
.=
$grammar
->show_isy(
$isy_id
);
}
return
$text
;
}
sub
Marpa::R2::Grammar::brief_irl {
my
(
$grammar
,
$irl_id
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$tracer
=
$grammar
->[Marpa::R2::Internal::Grammar::TRACER];
my
$lhs_id
=
$grammar_c
->_marpa_g_irl_lhs(
$irl_id
);
my
$text
=
$irl_id
.
': '
.
$tracer
->isy_name(
$lhs_id
) .
' ->'
;
if
(
my
$rh_length
=
$grammar_c
->_marpa_g_irl_length(
$irl_id
) ) {
my
@rhs_ids
= ();
for
my
$ix
( 0 ..
$rh_length
- 1 ) {
push
@rhs_ids
,
$grammar_c
->_marpa_g_irl_rhs(
$irl_id
,
$ix
);
}
$text
.=
q{ }
. (
join
q{ }
,
map
{
$tracer
->isy_name(
$_
) }
@rhs_ids
);
}
return
$text
;
}
sub
Marpa::R2::Grammar::show_irls {
my
(
$grammar
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
my
$text
=
q{}
;
for
my
$irl_id
( 0 ..
$grammar_c
->_marpa_g_irl_count() - 1 ) {
$text
.=
$grammar
->brief_irl(
$irl_id
) .
"\n"
;
}
return
$text
;
}
sub
Marpa::R2::Grammar::rule_is_used {
my
(
$grammar
,
$rule_id
) =
@_
;
my
$grammar_c
=
$grammar
->[Marpa::R2::Internal::Grammar::C];
return
$grammar_c
->_marpa_g_rule_is_used(
$rule_id
);
}
sub
Marpa::R2::Grammar::show_ahms {
my
(
$grammar
,
$verbose
) =
@_
;
return
$grammar
->[Marpa::R2::Internal::Grammar::TRACER]
->show_ahms(
$verbose
);
}
1;