use
5.010001;
use
vars
qw($VERSION $STRING_VERSION)
;
$VERSION
=
'11.004_000'
;
$STRING_VERSION
=
$VERSION
;
$VERSION
=
eval
$VERSION
;
sub
new {
my
(
$class
,
$p_rules_source
) =
@_
;
my
$meta_recce
= Marpa::R2::Internal::Scanless::meta_recce();
eval
{
$meta_recce
->
read
(
$p_rules_source
) }
or Marpa::R2::exception(
"Parse of BNF/Scanless source failed\n"
,
$EVAL_ERROR
);
if
(
my
$ambiguity_status
=
$meta_recce
->ambiguous() ) {
Marpa::R2::exception(
"Parse of BNF/Scanless source failed:\n"
,
$ambiguity_status
);
}
my
$value_ref
=
$meta_recce
->value();
Marpa::R2::exception(
'Parse of BNF/Scanless source failed'
)
if
not
defined
$value_ref
;
my
$ast
= {
meta_recce
=>
$meta_recce
,
top_node
=> ${
$value_ref
} };
return
bless
$ast
,
$class
;
}
sub
Marpa::R2::Internal::MetaAST::Parse::substring {
my
(
$parse
,
$start
,
$length
) =
@_
;
my
$meta_slr
=
$parse
->{meta_recce};
my
$thin_meta_slr
=
$meta_slr
->[Marpa::R2::Internal::Scanless::R::C];
my
$string
=
$thin_meta_slr
->substring(
$start
,
$length
);
chomp
$string
;
return
$string
;
}
sub
ast_to_hash {
my
(
$ast
) =
@_
;
my
$hashed_ast
= {};
$hashed_ast
->{meta_recce} =
$ast
->{meta_recce};
bless
$hashed_ast
,
'Marpa::R2::Internal::MetaAST::Parse'
;
$hashed_ast
->{current_lexer} =
'L0'
;
$hashed_ast
->{rules}->{G1} = [];
my
$g1_symbols
=
$hashed_ast
->{symbols}->{G1} = {};
my
(
undef
,
undef
,
@statements
) = @{
$ast
->{top_node} };
my
$eval_ok
=
eval
{
local
$Marpa::R2::JUST_DIE
= 1;
$_
->evaluate(
$hashed_ast
)
for
@statements
;
1;
};
Marpa::R2::exception(
$EVAL_ERROR
)
if
not
$eval_ok
;
my
%grammars
= ();
$grammars
{
$_
} = 1
for
keys
%{
$hashed_ast
->{rules} };
my
@lexers
=
grep
{ (
substr
$_
, 0, 1 ) eq
'L'
}
keys
%grammars
;
for
my
$lexer
(
@lexers
) {
my
$lexer_name
=
$lexer
;
NAME_LEXER: {
if
(
$lexer
eq
'L0'
) {
$lexer_name
=
"L0 (the default)"
;
last
NAME_LEXER;
}
last
NAME_LEXER
if
(
substr
$lexer_name
, 0, 2 ) ne
'L-'
;
$lexer_name
=
substr
$lexer_name
, 2;
}
}
my
%stripped_character_classes
= ();
{
my
$character_classes
=
$hashed_ast
->{character_classes};
for
my
$symbol_name
(
sort
keys
%{
$character_classes
} ) {
my
(
$re
) = @{
$character_classes
->{
$symbol_name
} };
$stripped_character_classes
{
$symbol_name
} =
$re
;
}
}
$hashed_ast
->{character_classes} = \
%stripped_character_classes
;
return
$hashed_ast
;
}
sub
Marpa::R2::Internal::MetaAST::Parse::start_rule_setup {
my
(
$ast
) =
@_
;
my
$start_lhs
=
$ast
->{
'start_lhs'
} //
$ast
->{
'first_lhs'
};
Marpa::R2::exception(
'No rules in SLIF grammar'
)
if
not
defined
$start_lhs
;
Marpa::R2::Internal::MetaAST::start_rule_create(
$ast
,
$start_lhs
);
}
my
$PROTO_ALTERNATIVE
=
'Marpa::R2::Internal::MetaAST::Proto_Alternative'
;
sub
Marpa::R2::Internal::MetaAST::Proto_Alternative::combine {
my
(
$class
,
@hashes
) =
@_
;
my
$self
=
bless
{},
$class
;
for
my
$hash_to_add
(
@hashes
) {
for
my
$key
(
keys
%{
$hash_to_add
} ) {
die
qq{A Marpa rule contained a duplicate key\n}
,
qq{ The key was "$key"\n}
if
exists
$self
->{
$key
};
$self
->{
$key
} =
$hash_to_add
->{
$key
};
}
}
return
$self
;
}
sub
Marpa::R2::Internal::MetaAST::Parse::bless_hash_rule {
my
(
$parse
,
$hash_rule
,
$blessing
,
$naming
,
$original_lhs
) =
@_
;
return
if
(
substr
$Marpa::R2::Internal::SUBGRAMMAR
, 0, 1) eq
'L'
;
$naming
//=
$original_lhs
;
$hash_rule
->{name} =
$naming
;
return
if
not
defined
$blessing
;
FIND_BLESSING: {
last
FIND_BLESSING
if
$blessing
=~ /\A [\w] /xms;
return
if
$blessing
eq
'::undef'
;
if
(
$blessing
eq
'::lhs'
) {
$blessing
=
$original_lhs
;
if
(
$blessing
=~ / [^ [:alnum:]] /xms ) {
Marpa::R2::exception(
qq{"::lhs" blessing only allowed if LHS is whitespace and alphanumerics\n}
,
qq{ LHS was <$original_lhs>\n}
);
}
$blessing
=~ s/[ ]/_/gxms;
last
FIND_BLESSING;
}
Marpa::R2::exception(
qq{Unknown blessing "$blessing"\n}
);
}
$hash_rule
->{
bless
} =
$blessing
;
return
1;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::bare_name::name {
return
$_
[0]->[2] }
sub
Marpa::R2::Internal::MetaAST_Nodes::reserved_action_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::reserved_event_name::name {
my
(
$self
,
$parse
) =
@_
;
my
$name
=
$self
->[2];
$name
=~ s/\A : /'/xms;
return
$name
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::action_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::alternative_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::event_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::lexer_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::array_descriptor::name {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::reserved_blessing_name::name {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::blessing_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::standard_name::name {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::Perl_name::name {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::lhs::name {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
$symbol
->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::lhs::evaluate {
my
(
$values
,
$parse
) =
@_
;
return
$values
->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::quantifier::evaluate {
my
(
$data
) =
@_
;
return
$data
->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::op_declare::op {
my
(
$values
) =
@_
;
return
$values
->[2]->op();
}
sub
Marpa::R2::Internal::MetaAST_Nodes::op_declare_match::op {
my
(
$values
) =
@_
;
return
$values
->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::op_declare_bnf::op {
my
(
$values
) =
@_
;
return
$values
->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::bracketed_name::name {
my
(
$values
) =
@_
;
my
(
undef
,
undef
,
$bracketed_name
) = @{
$values
};
$bracketed_name
=~ s/\A [<] \s*//xms;
$bracketed_name
=~ s/ \s* [>] \z//xms;
$bracketed_name
=~ s/ \s+ / /gxms;
return
$bracketed_name
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_quoted_name::name {
my
(
$values
) =
@_
;
my
(
undef
,
undef
,
$single_quoted_name
) = @{
$values
};
$single_quoted_name
=~ s/\A ['] \s*//xms;
$single_quoted_name
=~ s/ \s* ['] \z//xms;
$single_quoted_name
=~ s/ \s+ / /gxms;
return
$single_quoted_name
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::parenthesized_rhs_primary_list::evaluate
{
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
@values
) = @{
$data
};
my
@symbol_lists
=
map
{
$_
->evaluate(
$parse
); }
@values
;
my
$flattened_list
=
Marpa::R2::Internal::MetaAST::Symbol_List->combine(
@symbol_lists
);
$flattened_list
->mask_set(0);
return
$flattened_list
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::rhs::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
$start
,
$length
,
@values
) = @{
$data
};
my
$rhs
=
eval
{
my
@symbol_lists
=
map
{
$_
->evaluate(
$parse
) }
@values
;
my
$flattened_list
=
Marpa::R2::Internal::MetaAST::Symbol_List->combine(
@symbol_lists
);
bless
{
rhs
=>
$flattened_list
->names(
$parse
),
mask
=>
$flattened_list
->mask()
},
$PROTO_ALTERNATIVE
;
};
if
( not
$rhs
) {
my
$eval_error
=
$EVAL_ERROR
;
chomp
$eval_error
;
Marpa::R2::exception(
qq{$eval_error\n}
,
q{ RHS involved was }
,
$parse
->substring(
$start
,
$length
)
);
}
return
$rhs
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::rhs_primary::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
@values
) = @{
$data
};
my
@symbol_lists
=
map
{
$_
->evaluate(
$parse
) }
@values
;
return
Marpa::R2::Internal::MetaAST::Symbol_List->combine(
@symbol_lists
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::rhs_primary_list::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
@values
) = @{
$data
};
my
@symbol_lists
=
map
{
$_
->evaluate(
$parse
) }
@values
;
return
Marpa::R2::Internal::MetaAST::Symbol_List->combine(
@symbol_lists
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::action::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$child
) = @{
$values
};
return
bless
{
action
=>
$child
->name(
$parse
) },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::blessing::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$child
) = @{
$values
};
return
bless
{
bless
=>
$child
->name(
$parse
) },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::naming::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$child
) = @{
$values
};
return
bless
{
name
=>
$child
->name(
$parse
) },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::right_association::evaluate {
my
(
$values
) =
@_
;
return
bless
{
assoc
=>
'R'
},
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::left_association::evaluate {
my
(
$values
) =
@_
;
return
bless
{
assoc
=>
'L'
},
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::group_association::evaluate {
my
(
$values
) =
@_
;
return
bless
{
assoc
=>
'G'
},
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::event_specification::evaluate {
my
(
$values
) =
@_
;
return
bless
{
event
=> (
$values
->[2]->event() ) },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::event_initialization::event {
my
(
$values
) =
@_
;
my
$event_name
=
$values
->[2];
my
$event_initializer
=
$values
->[3];
return
[
$event_name
->name(),
$event_initializer
->on_or_off()],
}
sub
Marpa::R2::Internal::MetaAST_Nodes::proper_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
proper
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::latm_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
latm
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::pause_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
pause
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::priority_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
priority
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::rank_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
rank
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::null_ranking_specification::evaluate {
my
(
$values
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
null_ranking
=>
$child
->value() },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::null_ranking_constant::value {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::before_or_after::value {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::event_initializer::on_or_off
{
my
(
$values
) =
@_
;
my
$is_activated
=
$values
->[2];
return
1
if
not
defined
$is_activated
;
return
$is_activated
->value();
}
sub
Marpa::R2::Internal::MetaAST_Nodes::on_or_off::value {
return
$_
[0]->[2] eq
'off'
? 0 : 1;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::boolean::value {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::signed_integer::value {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::separator_specification::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
$child
=
$values
->[2];
return
bless
{
separator
=>
$child
->name(
$parse
) },
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::adverb_item::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
$child
=
$values
->[2]->evaluate(
$parse
);
return
bless
$child
,
$PROTO_ALTERNATIVE
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::default_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
undef
,
$op_declare
,
$raw_adverb_list
) = @{
$values
};
my
$subgrammar
=
$op_declare
->op() eq
q{::=}
?
'G1'
:
$parse
->{current_lexer};
my
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
my
%default_adverbs
= ();
$parse
->{default_adverbs}->{
$subgrammar
} = \
%default_adverbs
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
and
$subgrammar
eq
'G1'
) {
$default_adverbs
{
$key
} =
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'bless'
and
$subgrammar
eq
'G1'
) {
$default_adverbs
{
$key
} =
$adverb_list
->{
$key
};
next
ADVERB;
}
die
qq{Adverb "$key" not allowed in $subgrammar default rule\n}
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::discard_default_statement::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_adverb_list
) = @{
$data
};
local
$Marpa::R2::Internal::SUBGRAMMAR
=
'G1'
;
my
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
if
(
exists
$parse
->{discard_default_adverbs} ) {
my
$problem_rule
=
$parse
->substring(
$start
,
$length
);
Marpa::R2::exception(
qq{More than one discard default statement is not allowed\n}
,
qq{ This was the rule that caused the problem:\n}
,
qq{ $problem_rule\n}
);
}
$parse
->{discard_default_adverbs} = {};
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'event'
and
defined
$value
) {
$parse
->{discard_default_adverbs}->{
$key
} =
$value
;
next
ADVERB;
}
Marpa::R2::exception(
qq{"$key" adverb not allowed as discard default"}
);
}
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::lexeme_default_statement::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_adverb_list
) = @{
$data
};
local
$Marpa::R2::Internal::SUBGRAMMAR
=
'G1'
;
my
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
if
(
exists
$parse
->{lexeme_default_adverbs} ) {
my
$problem_rule
=
$parse
->substring(
$start
,
$length
);
Marpa::R2::exception(
qq{More than one lexeme default statement is not allowed\n}
,
qq{ This was the rule that caused the problem:\n}
,
qq{ $problem_rule\n}
);
}
$parse
->{lexeme_default_adverbs} = {};
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
) {
$parse
->{lexeme_default_adverbs}->{
$key
} =
$value
;
next
ADVERB;
}
if
(
$key
eq
'bless'
) {
$parse
->{lexeme_default_adverbs}->{
$key
} =
$value
;
next
ADVERB;
}
if
(
$key
eq
'latm'
) {
$parse
->{lexeme_default_adverbs}->{
$key
} =
$value
;
next
ADVERB;
}
Marpa::R2::exception(
qq{"$key" adverb not allowed as lexeme default"}
);
}
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::inaccessible_statement::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$inaccessible_treatment
) = @{
$data
};
local
$Marpa::R2::Internal::SUBGRAMMAR
=
'G1'
;
if
(
exists
$parse
->{defaults}->{if_inaccessible} ) {
my
$problem_rule
=
$parse
->substring(
$start
,
$length
);
Marpa::R2::exception(
qq{More than one inaccessible default statement is not allowed\n}
,
qq{ This was the rule that caused the problem:\n}
,
qq{ $problem_rule\n}
);
}
$parse
->{defaults}->{if_inaccessible} =
$inaccessible_treatment
->value();
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::inaccessible_treatment::value {
return
$_
[0]->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::priority_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_lhs
,
$op_declare
,
$raw_priorities
) =
@{
$values
};
my
$current_lexer
=
$parse
->{current_lexer};
my
$subgrammar
;
if
(
$op_declare
->op() eq
q{::=}
) {
if
(
$current_lexer
ne
'L0'
) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
"G1 rules currently allowed only when L0 is current lexer\n"
,
qq{ A prioritized rule was found when "$current_lexer" was the current lexer\n"}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$subgrammar
=
'G1'
;
}
else
{
$subgrammar
=
$current_lexer
;
}
my
$lhs
=
$raw_lhs
->name(
$parse
);
$parse
->{
'first_lhs'
} //=
$lhs
if
$subgrammar
eq
'G1'
;
local
$Marpa::R2::Internal::SUBGRAMMAR
=
$subgrammar
;
my
(
undef
,
undef
,
@priorities
) = @{
$raw_priorities
};
my
$priority_count
=
scalar
@priorities
;
my
@working_rules
= ();
$parse
->{rules}->{
$subgrammar
} //= [];
my
$rules
=
$parse
->{rules}->{
$subgrammar
};
my
$default_adverbs
=
$parse
->{default_adverbs}->{
$subgrammar
};
if
(
$priority_count
<= 1 ) {
my
(
undef
,
undef
,
@alternatives
) = @{
$priorities
[0] };
for
my
$alternative
(
@alternatives
) {
my
(
$alternative_start
,
$alternative_end
,
$raw_rhs
,
$raw_adverb_list
) = @{
$alternative
};
my
(
$proto_rule
,
$adverb_list
);
my
$eval_ok
=
eval
{
$proto_rule
=
$raw_rhs
->evaluate(
$parse
);
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
1;
};
if
( not
$eval_ok
) {
my
$eval_error
=
$EVAL_ERROR
;
chomp
$eval_error
;
Marpa::R2::exception(
qq{$eval_error\n}
,
qq{ The problem was in this RHS alternative:\n}
,
q{ }
,
$parse
->substring(
$alternative_start
,
$alternative_end
),
"\n"
);
}
my
@rhs_names
= @{
$proto_rule
->{rhs} };
my
@mask
= @{
$proto_rule
->{mask} };
if
( (
substr
$subgrammar
, 0, 1 ) eq
'L'
and
grep
{ !
$_
}
@mask
)
{
Marpa::R2::exception(
qq{hidden symbols are not allowed in lexical rules (rule's LHS was "$lhs")}
);
}
my
%hash_rule
=
(
lhs
=>
$lhs
,
rhs
=> \
@rhs_names
,
mask
=> \
@mask
);
my
$action
;
my
$blessing
;
my
$naming
;
my
$null_ranking
;
my
$rank
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
) {
$action
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'assoc'
) {
next
ADVERB;
}
if
(
$key
eq
'bless'
) {
$blessing
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'name'
) {
$naming
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'null_ranking'
) {
$null_ranking
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'rank'
) {
$rank
=
$adverb_list
->{
$key
};
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Adverb "$key" not allowed in an prioritized rule\n}
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$action
//=
$default_adverbs
->{action};
if
(
defined
$action
) {
Marpa::R2::exception(
qq{actions not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$hash_rule
{action} =
$action
;
}
$rank
//=
$default_adverbs
->{rank};
if
(
defined
$rank
) {
Marpa::R2::exception(
qq{ranks not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$hash_rule
{rank} =
$rank
;
}
$null_ranking
//=
$default_adverbs
->{null_ranking};
if
(
defined
$null_ranking
) {
Marpa::R2::exception(
qq{null-ranking allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$hash_rule
{null_ranking} =
$null_ranking
;
}
$blessing
//=
$default_adverbs
->{
bless
};
if
(
defined
$blessing
and
(
substr
$subgrammar
, 0, 1 ) eq
'L'
)
{
Marpa::R2::exception(
'bless option not allowed in lexical rules (rules LHS was "'
,
$lhs
,
'")'
);
}
$parse
->bless_hash_rule( \
%hash_rule
,
$blessing
,
$naming
,
$lhs
);
push
@{
$rules
}, \
%hash_rule
;
}
return
undef
;
}
for
my
$priority_ix
( 0 ..
$priority_count
- 1 ) {
my
$priority
=
$priority_count
- (
$priority_ix
+ 1 );
my
(
undef
,
undef
,
@alternatives
) = @{
$priorities
[
$priority_ix
] };
for
my
$alternative
(
@alternatives
) {
my
(
$alternative_start
,
$alternative_end
,
$raw_rhs
,
$raw_adverb_list
) = @{
$alternative
};
my
(
$adverb_list
,
$rhs
);
my
$eval_ok
=
eval
{
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
$rhs
=
$raw_rhs
->evaluate(
$parse
);
1;
};
if
( not
$eval_ok
) {
my
$eval_error
=
$EVAL_ERROR
;
chomp
$eval_error
;
Marpa::R2::exception(
qq{$eval_error\n}
,
qq{ The problem was in this RHS alternative:\n}
,
q{ }
,
$parse
->substring(
$alternative_start
,
$alternative_end
),
"\n"
);
}
push
@working_rules
, [
$priority
,
$rhs
,
$adverb_list
];
}
}
my
@arg0_action
= ();
@arg0_action
= (
action
=>
'::first'
)
if
$subgrammar
eq
'G1'
;
push
@{
$rules
},
{
lhs
=>
$lhs
,
rhs
=> [
$parse
->prioritized_symbol(
$lhs
, 0 ) ],
@arg0_action
,
description
=>
qq{Internal rule top priority rule for <$lhs>}
,
},
(
map
{
;
{
lhs
=>
$parse
->prioritized_symbol(
$lhs
,
$_
- 1 ),
rhs
=> [
$parse
->prioritized_symbol(
$lhs
,
$_
) ],
description
=> (
qq{Internal rule for symbol <$lhs> priority transition from }
. (
$_
- 1 )
.
qq{ to $_}
),
@arg0_action
}
} 1 ..
$priority_count
- 1
);
RULE:
for
my
$working_rule
(
@working_rules
) {
my
(
$priority
,
$rhs
,
$adverb_list
) = @{
$working_rule
};
my
@new_rhs
= @{
$rhs
->{rhs} };
my
@arity
=
grep
{
$new_rhs
[
$_
] eq
$lhs
} 0 ..
$#new_rhs
;
my
$rhs_length
=
scalar
@new_rhs
;
my
$current_exp
=
$parse
->prioritized_symbol(
$lhs
,
$priority
);
my
@mask
= @{
$rhs
->{mask} };
if
( (
substr
$subgrammar
, 0, 1 ) eq
'L'
and
grep
{ !
$_
}
@mask
)
{
Marpa::R2::exception(
'hidden symbols are not allowed in lexical rules (rules LHS was "'
,
$lhs
,
'")'
);
}
my
%new_xs_rule
= (
lhs
=>
$current_exp
);
$new_xs_rule
{mask} = \
@mask
;
my
$action
;
my
$assoc
;
my
$blessing
;
my
$naming
;
my
$rank
;
my
$null_ranking
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
) {
$action
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'assoc'
) {
$assoc
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'bless'
) {
$blessing
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'name'
) {
$naming
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'null_ranking'
) {
$null_ranking
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'rank'
) {
$rank
=
$adverb_list
->{
$key
};
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Adverb "$key" not allowed in a prioritized rule\n}
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$assoc
//=
'L'
;
$action
//=
$default_adverbs
->{action};
if
(
defined
$action
) {
Marpa::R2::exception(
qq{actions not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$new_xs_rule
{action} =
$action
;
}
$null_ranking
//=
$default_adverbs
->{null_ranking};
if
(
defined
$null_ranking
) {
Marpa::R2::exception(
qq{null-ranking not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$new_xs_rule
{null_ranking} =
$null_ranking
;
}
$rank
//=
$default_adverbs
->{rank};
if
(
defined
$rank
) {
Marpa::R2::exception(
qq{ranks not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$new_xs_rule
{rank} =
$rank
;
}
$blessing
//=
$default_adverbs
->{
bless
};
if
(
defined
$blessing
and (
substr
$subgrammar
, 0, 1 ) eq
'L'
)
{
Marpa::R2::exception(
'bless option not allowed in lexical rules (rules LHS was "'
,
$lhs
,
'")'
);
}
$parse
->bless_hash_rule( \
%new_xs_rule
,
$blessing
,
$naming
,
$lhs
);
my
$next_priority
=
$priority
+ 1;
$next_priority
= 0
if
$next_priority
>=
$priority_count
;
my
$next_exp
=
$parse
->prioritized_symbol(
$lhs
,
$next_priority
);
if
( not
scalar
@arity
) {
$new_xs_rule
{rhs} = \
@new_rhs
;
push
@{
$rules
}, \
%new_xs_rule
;
next
RULE;
}
if
(
scalar
@arity
== 1 ) {
die
'Unnecessary unit rule in priority rule'
if
$rhs_length
== 1;
$new_rhs
[
$arity
[0] ] =
$current_exp
;
}
DO_ASSOCIATION: {
if
(
$assoc
eq
'L'
) {
$new_rhs
[
$arity
[0] ] =
$current_exp
;
for
my
$rhs_ix
(
@arity
[ 1 ..
$#arity
] ) {
$new_rhs
[
$rhs_ix
] =
$next_exp
;
}
last
DO_ASSOCIATION;
}
if
(
$assoc
eq
'R'
) {
$new_rhs
[
$arity
[-1] ] =
$current_exp
;
for
my
$rhs_ix
(
@arity
[ 0 ..
$#arity
- 1 ] ) {
$new_rhs
[
$rhs_ix
] =
$next_exp
;
}
last
DO_ASSOCIATION;
}
if
(
$assoc
eq
'G'
) {
for
my
$rhs_ix
(
@arity
[ 0 ..
$#arity
] ) {
$new_rhs
[
$rhs_ix
] =
$parse
->prioritized_symbol(
$lhs
, 0 );
}
last
DO_ASSOCIATION;
}
die
qq{Unknown association type: "$assoc"}
;
}
$new_xs_rule
{rhs} = \
@new_rhs
;
push
@{
$rules
}, \
%new_xs_rule
;
}
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::empty_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_lhs
,
$op_declare
,
$raw_adverb_list
) =
@{
$values
};
my
$current_lexer
=
$parse
->{current_lexer};
my
$subgrammar
;
if
(
$op_declare
->op() eq
q{::=}
) {
if
(
$current_lexer
ne
'L0'
) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
"G1 rules currently allowed only when L0 is current lexer\n"
,
qq{ An empty rule was found when "$current_lexer" was the current lexer\n"}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$subgrammar
=
'G1'
;
}
else
{
$subgrammar
=
$current_lexer
;
}
my
$lhs
=
$raw_lhs
->name(
$parse
);
$parse
->{
'first_lhs'
} //=
$lhs
if
$subgrammar
eq
'G1'
;
local
$Marpa::R2::Internal::SUBGRAMMAR
=
$subgrammar
;
my
%rule
= (
lhs
=>
$lhs
,
description
=>
qq{Empty rule for <$lhs>}
,
rhs
=> [] );
my
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
my
$default_adverbs
=
$parse
->{default_adverbs}->{
$subgrammar
};
my
$action
;
my
$blessing
;
my
$naming
;
my
$rank
;
my
$null_ranking
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
) {
$action
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'bless'
) {
$blessing
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'name'
) {
$naming
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'null_ranking'
) {
$null_ranking
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'rank'
) {
$rank
=
$adverb_list
->{
$key
};
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Adverb "$key" not allowed in an empty rule\n}
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$action
//=
$default_adverbs
->{action};
if
(
defined
$action
) {
Marpa::R2::exception(
qq{actions not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$rule
{action} =
$action
;
}
$null_ranking
//=
$default_adverbs
->{null_ranking};
if
(
defined
$null_ranking
) {
Marpa::R2::exception(
qq{null-ranking not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$rule
{null_ranking} =
$null_ranking
;
}
$rank
//=
$default_adverbs
->{rank};
if
(
defined
$rank
) {
Marpa::R2::exception(
qq{ranks not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$rule
{rank} =
$rank
;
}
$blessing
//=
$default_adverbs
->{
bless
};
if
(
defined
$blessing
and (
substr
$subgrammar
, 0, 1 ) eq
'L'
)
{
Marpa::R2::exception(
qq{bless option not allowed in lexical rules (rule's LHS was "$lhs")}
);
}
$parse
->bless_hash_rule( \
%rule
,
$blessing
,
$naming
,
$lhs
);
push
@{
$parse
->{rules}->{
$subgrammar
} }, \
%rule
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::lexeme_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$symbol
,
$unevaluated_adverb_list
) = @{
$values
};
my
$symbol_name
=
$symbol
->name();
my
$declarations
=
$parse
->{lexeme_declarations}->{
$symbol_name
};
if
(
defined
$declarations
) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
"Duplicate lexeme rule for <$symbol_name>\n"
,
" Only one lexeme rule is allowed for each symbol\n"
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
my
$adverb_list
=
$unevaluated_adverb_list
->evaluate();
my
%declarations
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$raw_value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'priority'
) {
$declarations
{
$key
} =
$raw_value
+ 0;
next
ADVERB;
}
if
(
$key
eq
'pause'
) {
if
(
$raw_value
eq
'before'
) {
$declarations
{
$key
} = -1;
next
ADVERB;
}
if
(
$raw_value
eq
'after'
) {
$declarations
{
$key
} = 1;
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Bad value for "pause" adverb: "$raw_value"}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
if
(
$key
eq
'event'
) {
$declarations
{
$key
} =
$raw_value
;
next
ADVERB;
}
if
(
$key
eq
'latm'
) {
$declarations
{
$key
} =
$raw_value
;
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{"$key" adverb not allowed in lexeme rule"\n}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
if
(
exists
$declarations
{
'event'
} and not
exists
$declarations
{
'pause'
} )
{
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{"event" adverb not allowed without "pause" adverb in lexeme rule"\n}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$parse
->{lexeme_declarations}->{
$symbol_name
} = \
%declarations
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::statements::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
@statement_list
) = @{
$data
};
map
{
$_
->evaluate(
$parse
) }
@statement_list
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::statement::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$child
) = @{
$data
};
$child
->evaluate(
$parse
);
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::null_statement::evaluate {
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::statement_group::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$statements
) = @{
$data
};
$statements
->evaluate(
$parse
);
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST::start_rule_create {
my
(
$parse
,
$symbol_name
) =
@_
;
my
$start_lhs
=
'[:start]'
;
$parse
->{
'default_g1_start_action'
} =
$parse
->{
'default_adverbs'
}->{
'G1'
}->{
'action'
};
$parse
->{
'symbols'
}->{
'G1'
}->{
$start_lhs
} = {
display_form
=>
':start'
,
description
=>
'Internal G1 start symbol'
};
push
@{
$parse
->{rules}->{G1} },
{
lhs
=>
$start_lhs
,
rhs
=> [
$symbol_name
],
action
=>
'::first'
};
}
sub
Marpa::R2::Internal::MetaAST_Nodes::start_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$symbol
) = @{
$values
};
if
(
defined
$parse
->{
'start_lhs'
} ) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{There are two start rules\n}
,
qq{ That is not allowed\n}
,
' The second start rule is '
,
$parse
->substring(
$start
,
$length
),
"\n"
,
" Problem occurred at line $line, column $column\n"
;
}
$parse
->{
'start_lhs'
} =
$symbol
->name(
$parse
);
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::discard_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$symbol
,
$raw_adverb_list
) = @{
$values
};
my
$lexer_name
=
$parse
->{current_lexer};
local
$Marpa::R2::Internal::SUBGRAMMAR
=
$lexer_name
;
my
$discard_lhs
=
'[:discard]'
;
$parse
->symbol_names_set(
$discard_lhs
,
'L'
,
{
display_form
=>
':discard'
,
description
=>
qq{Internal LHS for lexer "$lexer_name" discard}
}
);
my
$rhs
=
$symbol
->names(
$parse
);
my
$rhs_as_event
=
$symbol
->event_name(
$parse
);
my
$adverb_list
=
$raw_adverb_list
->evaluate(
$parse
);
my
$event
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'event'
) {
$event
=
$value
;
next
ADVERB;
}
Marpa::R2::exception(
qq{"$key" adverb not allowed as discard default"}
);
}
my
%rule_hash
= (
description
=> (
"Discard rule for "
.
join
q{ }
,
map
{
'<'
.
$_
.
'>'
} @{
$rhs
}
),
lhs
=>
$discard_lhs
,
rhs
=>
$rhs
,
symbol_as_event
=>
$rhs_as_event
);
$rule_hash
{event} =
$event
if
defined
$event
;
push
@{
$parse
->{rules}->{
$lexer_name
} }, \
%rule_hash
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::quantified_rule::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$lhs
,
$op_declare
,
$rhs
,
$quantifier
,
$proto_adverb_list
)
= @{
$values
};
my
$subgrammar
;
my
$current_lexer
=
$parse
->{current_lexer};
if
(
$op_declare
->op() eq
q{::=}
) {
if
(
$current_lexer
ne
'L0'
) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
"G1 rules currently allowed only when L0 is current lexer\n"
,
qq{ A quantified rule was found when "$current_lexer" was the current lexer\n"}
,
" Location was line $line, column $column\n"
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$subgrammar
=
'G1'
;
}
else
{
$subgrammar
=
$current_lexer
;
}
my
$lhs_name
=
$lhs
->name(
$parse
);
$parse
->{
'first_lhs'
} //=
$lhs_name
if
$subgrammar
eq
'G1'
;
local
$Marpa::R2::Internal::SUBGRAMMAR
=
$subgrammar
;
my
$adverb_list
=
$proto_adverb_list
->evaluate(
$parse
);
my
$default_adverbs
=
$parse
->{default_adverbs}->{
$subgrammar
};
my
%sequence_rule
= (
rhs
=> [
$rhs
->name(
$parse
) ],
min
=> (
$quantifier
->evaluate(
$parse
) eq
q{+}
? 1 : 0 )
);
my
@rules
= ( \
%sequence_rule
);
my
$action
;
my
$blessing
;
my
$naming
;
my
$separator
;
my
$proper
;
my
$rank
;
my
$null_ranking
;
ADVERB:
for
my
$key
(
keys
%{
$adverb_list
} ) {
my
$value
=
$adverb_list
->{
$key
};
if
(
$key
eq
'action'
) {
$action
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'bless'
) {
$blessing
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'name'
) {
$naming
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'proper'
) {
$proper
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'rank'
) {
$rank
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'null_ranking'
) {
$null_ranking
=
$adverb_list
->{
$key
};
next
ADVERB;
}
if
(
$key
eq
'separator'
) {
$separator
=
$adverb_list
->{
$key
};
next
ADVERB;
}
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Adverb "$key" not allowed in quantified rule\n}
,
' Rule was '
,
$parse
->substring(
$start
,
$length
),
"\n"
;
}
$sequence_rule
{lhs} =
$lhs_name
;
$sequence_rule
{separator} =
$separator
if
defined
$separator
;
$sequence_rule
{proper} =
$proper
if
defined
$proper
;
$action
//=
$default_adverbs
->{action};
if
(
defined
$action
) {
Marpa::R2::exception(
qq{actions not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$sequence_rule
{action} =
$action
;
}
$null_ranking
//=
$default_adverbs
->{null_ranking};
if
(
defined
$null_ranking
) {
Marpa::R2::exception(
qq{null-ranking not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$sequence_rule
{null_ranking} =
$null_ranking
;
}
$rank
//=
$default_adverbs
->{rank};
if
(
defined
$rank
) {
Marpa::R2::exception(
qq{ranks not allowed in lexical rules (rule's LHS was "$lhs")}
)
if
(
substr
$subgrammar
, 0, 1 ) eq
'L'
;
$sequence_rule
{rank} =
$rank
;
}
$blessing
//=
$default_adverbs
->{
bless
};
if
(
defined
$blessing
and (
substr
$subgrammar
, 0, 1 ) eq
'L'
)
{
Marpa::R2::exception(
qq{bless option not allowed in lexical rules (rule's LHS was "$lhs")}
);
}
$parse
->bless_hash_rule( \
%sequence_rule
,
$blessing
,
$naming
,
$lhs_name
);
push
@{
$parse
->{rules}->{
$subgrammar
} },
@rules
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::completion_event_declaration::evaluate
{
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_event
,
$raw_symbol_name
) = @{
$values
};
my
$symbol_name
=
$raw_symbol_name
->name();
my
$completion_events
=
$parse
->{completion_events} //= {};
if
(
defined
$completion_events
->{
$symbol_name
} ) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Completion event for symbol "$symbol_name" declared twice\n}
,
qq{ That is not allowed\n}
,
' Second declaration was '
,
$parse
->substring(
$start
,
$length
),
"\n"
,
" Problem occurred at line $line, column $column\n"
;
}
$completion_events
->{
$symbol_name
} =
$raw_event
->event();
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::nulled_event_declaration::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_event
,
$raw_symbol_name
) = @{
$values
};
my
$symbol_name
=
$raw_symbol_name
->name();
my
$nulled_events
=
$parse
->{nulled_events} //= {};
if
(
defined
$nulled_events
->{
$symbol_name
} ) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{nulled event for symbol "$symbol_name" declared twice\n}
,
qq{ That is not allowed\n}
,
' Second declaration was '
,
$parse
->substring(
$start
,
$length
),
"\n"
,
" Problem occurred at line $line, column $column\n"
;
}
$nulled_events
->{
$symbol_name
} =
$raw_event
->event();
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::prediction_event_declaration::evaluate
{
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$raw_event
,
$raw_symbol_name
) = @{
$values
};
my
$symbol_name
=
$raw_symbol_name
->name();
my
$prediction_events
=
$parse
->{prediction_events} //= {};
if
(
defined
$prediction_events
->{
$symbol_name
} ) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{prediction event for symbol "$symbol_name" declared twice\n}
,
qq{ That is not allowed\n}
,
' Second declaration was '
,
$parse
->substring(
$start
,
$length
),
"\n"
,
" Problem occurred at line $line, column $column\n"
;
}
$prediction_events
->{
$symbol_name
} =
$raw_event
->event();
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::current_lexer_statement::evaluate
{
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$lexer_name_object
) = @{
$values
};
my
$raw_lexer_name
=
$lexer_name_object
->name();
if
(
$raw_lexer_name
eq
'L0'
) {
$parse
->{current_lexer} =
$raw_lexer_name
;
return
undef
;
}
if
(
$raw_lexer_name
=~ m/\A [[:upper:]] [[:digit:]]+ \z/xms) {
my
(
$line
,
$column
) =
$parse
->{meta_recce}->line_column(
$start
);
die
qq{Attempt to name a new lexer "$raw_lexer_name"\n}
,
qq{ Lexer names of the form [A-Z][0-9]+ are reserved\n}
,
qq{ Please choose another name\n}
,
" Problem occurred at line $line, column $column\n"
;
}
my
$lexer_name
.=
'L-'
.
$raw_lexer_name
;
$parse
->{current_lexer} =
$lexer_name
;
return
undef
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::alternatives::evaluate {
my
(
$values
,
$parse
) =
@_
;
return
bless
[
map
{
$_
->evaluate(
$_
,
$parse
) } @{
$values
} ],
ref
$values
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::alternative::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
,
$rhs
,
$adverbs
) = @{
$values
};
my
$alternative
=
eval
{
Marpa::R2::Internal::MetaAST::Proto_Alternative->combine(
map
{
$_
->evaluate(
$parse
) }
$rhs
,
$adverbs
);
};
if
( not
$alternative
) {
Marpa::R2::exception(
$EVAL_ERROR
,
"\n"
,
q{ Alternative involved was }
,
$parse
->substring(
$start
,
$length
)
);
}
return
$alternative
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_symbol::names {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
$symbol
->names(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_symbol::name {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
$symbol
->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_symbol::event_name {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
$symbol
->event_name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_symbol::literal {
my
(
$values
,
$parse
) =
@_
;
my
(
$start
,
$length
) = @{
$values
};
return
$parse
->substring(
$start
,
$length
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_symbol::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
Marpa::R2::Internal::MetaAST::Symbol_List->new(
$symbol
->name(
$parse
) );
}
sub
Marpa::R2::Internal::MetaAST_Nodes::Symbol::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$symbol
) = @{
$values
};
return
$symbol
->evaluate(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol::event_name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol::names {
my
(
$self
,
$parse
) =
@_
;
return
$self
->[2]->names(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol_name::evaluate {
my
(
$self
) =
@_
;
return
$self
->[2];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol_name::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->evaluate(
$parse
)->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::symbol_name::names {
my
(
$self
,
$parse
) =
@_
;
return
[
$self
->name(
$parse
) ];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::adverb_list::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$adverb_list_items
) = @{
$data
};
return
undef
if
not
defined
$adverb_list_items
;
return
$adverb_list_items
->evaluate(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::null_adverb::evaluate {
return
{};
}
sub
Marpa::R2::Internal::MetaAST_Nodes::adverb_list_items::evaluate {
my
(
$data
,
$parse
) =
@_
;
my
(
undef
,
undef
,
@raw_items
) = @{
$data
};
my
(
@adverb_items
) =
map
{
$_
->evaluate(
$parse
) }
@raw_items
;
return
Marpa::R2::Internal::MetaAST::Proto_Alternative->combine(
@adverb_items
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::character_class::event_name {
my
(
$data
,
$parse
) =
@_
;
my
(
$start
,
$length
) = @{
$data
};
return
$parse
->substring(
$start
,
$length
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::character_class::names {
my
(
$self
,
$parse
) =
@_
;
return
[
$self
->name(
$parse
) ];
}
sub
Marpa::R2::Internal::MetaAST_Nodes::character_class::name {
my
(
$self
,
$parse
) =
@_
;
return
$self
->evaluate(
$parse
)->name(
$parse
);
}
sub
Marpa::R2::Internal::MetaAST_Nodes::character_class::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
$character_class
=
$values
->[2];
my
$subgrammar
=
$Marpa::R2::Internal::SUBGRAMMAR
;
if
((
substr
$subgrammar
, 0, 1 ) eq
'L'
) {
return
Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol(
$parse
,
$character_class
);
}
my
$lexer_symbol
=
do
{
local
$Marpa::R2::Internal::SUBGRAMMAR
=
'L0'
;
Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol(
$parse
,
$character_class
);
};
my
$lexical_lhs
=
$parse
->internal_lexeme(
$character_class
);
my
$lexical_rhs
=
$lexer_symbol
->names(
$parse
);
my
%lexical_rule
= (
lhs
=>
$lexical_lhs
,
rhs
=>
$lexical_rhs
,
mask
=> [1],
);
push
@{
$parse
->{rules}->{L0} }, \
%lexical_rule
;
my
$g1_symbol
=
Marpa::R2::Internal::MetaAST::Symbol_List->new(
$lexical_lhs
);
return
$g1_symbol
;
}
sub
Marpa::R2::Internal::MetaAST_Nodes::single_quoted_string::evaluate {
my
(
$values
,
$parse
) =
@_
;
my
(
undef
,
undef
,
$string
) = @{
$values
};
my
@symbols
= ();
my
$end_of_string
=
rindex
$string
,
q{'}
;
my
$unmodified_string
=
substr
$string
, 0,
$end_of_string
+1;
my
$raw_flags
=
substr
$string
,
$end_of_string
+1;
my
$flags
= Marpa::R2::Internal::MetaAST::flag_string_to_flags(
$raw_flags
);
my
$subgrammar
=
$Marpa::R2::Internal::SUBGRAMMAR
;
my
$lexical_grammar
=
$subgrammar
eq
'G1'
?
'L0'
:
$subgrammar
;
for
my
$char_class
(
map
{
'['
. (
quotemeta
$_
) .
']'
.
$flags
}
split
//xms,
substr
$unmodified_string
,
1, -1
)
{
local
$Marpa::R2::Internal::SUBGRAMMAR
=
$lexical_grammar
;
my
$symbol
=
Marpa::R2::Internal::MetaAST::Symbol_List->char_class_to_symbol(
$parse
,
$char_class
);
push
@symbols
,
$symbol
;
}
my
$list
= Marpa::R2::Internal::MetaAST::Symbol_List->combine(
@symbols
);
return
$list
if
$Marpa::R2::Internal::SUBGRAMMAR
ne
'G1'
;
my
$lexical_lhs
=
$parse
->internal_lexeme(
$string
);
my
$lexical_rhs
=
$list
->names(
$parse
);
my
%lexical_rule
= (
lhs
=>
$lexical_lhs
,
rhs
=>
$lexical_rhs
,
description
=>
"Internal rule for single-quoted string $string"
,
mask
=> [
map
{ ; 1 } @{
$lexical_rhs
} ],
);
push
@{
$parse
->{rules}->{
$lexical_grammar
} }, \
%lexical_rule
;
my
$g1_symbol
=
Marpa::R2::Internal::MetaAST::Symbol_List->new(
$lexical_lhs
);
return
$g1_symbol
;
}
sub
new {
my
(
$class
,
$name
) =
@_
;
return
bless
{
names
=> [
q{}
.
$name
],
mask
=> [1] },
$class
;
}
sub
combine {
my
(
$class
,
@lists
) =
@_
;
my
$self
= {};
$self
->{names} = [
map
{ @{
$_
->names() } }
@lists
];
$self
->{mask} = [
map
{ @{
$_
->mask() } }
@lists
];
return
bless
$self
,
$class
;
}
sub
Marpa::R2::Internal::MetaAST::char_class_to_re {
my
(
$cc_components
) =
@_
;
die
if
ref
$cc_components
ne
'ARRAY'
;
my
(
$char_class
,
$flags
) = @{
$cc_components
};
$flags
=
$flags
?
'('
.
q{?}
.
$flags
.
')'
:
q{}
;
my
$regex
;
my
$error
;
if
( not
defined
eval
{
$regex
=
qr/$flags$char_class/
xms; 1; } ) {
$error
=
qq{Problem in evaluating character class: "$char_class"\n}
;
$error
.=
qq{ Flags were "$flags"\n}
if
$flags
;
$error
.=
$EVAL_ERROR
;
}
return
$regex
,
$error
;
}
sub
Marpa::R2::Internal::MetaAST::flag_string_to_flags {
my
(
$raw_flag_string
) =
@_
;
return
q{}
if
not
$raw_flag_string
;
my
@raw_flags
=
split
m/:/xms,
$raw_flag_string
;
my
%flags
= ();
RAW_FLAG:
for
my
$raw_flag
(
@raw_flags
) {
next
RAW_FLAG
if
not
$raw_flag
;
if
(
$raw_flag
eq
'i'
) {
$flags
{
'i'
} = 1;
next
RAW_FLAG;
}
if
(
$raw_flag
eq
'ic'
) {
$flags
{
'i'
} = 1;
next
RAW_FLAG;
}
Carp::croak(
qq{Bad flag for character class\n}
,
qq{ Flag string was $raw_flag_string\n}
,
qq{ Bad flag was $raw_flag\n}
);
}
my
$cooked_flags
=
join
q{}
,
sort
keys
%flags
;
return
$cooked_flags
;
}
sub
char_class_to_symbol {
my
(
$class
,
$parse
,
$char_class
) =
@_
;
my
$end_of_char_class
=
rindex
$char_class
,
q{]}
;
my
$unmodified_char_class
=
substr
$char_class
, 0,
$end_of_char_class
+1;
my
$raw_flags
=
substr
$char_class
,
$end_of_char_class
+1;
my
$flags
= Marpa::R2::Internal::MetaAST::flag_string_to_flags(
$raw_flags
);
my
$subgrammar
=
$Marpa::R2::Internal::SUBGRAMMAR
;
my
$symbol_name
=
'['
.
$unmodified_char_class
.
$flags
.
']'
;
$parse
->{character_classes} //= {};
my
$cc_hash
=
$parse
->{character_classes};
my
(
undef
,
$symbol
) =
$cc_hash
->{
$symbol_name
};
if
( not
defined
$symbol
) {
my
$cc_components
= [
$unmodified_char_class
,
$flags
];
my
(
$regex
,
$eval_error
) =
Marpa::R2::Internal::MetaAST::char_class_to_re(
$cc_components
);
Carp::croak(
'Bad Character class: '
,
$char_class
,
"\n"
,
'Perl said '
,
$eval_error
)
if
not
$regex
;
$symbol
=
Marpa::R2::Internal::MetaAST::Symbol_List->new(
$symbol_name
);
$cc_hash
->{
$symbol_name
} = [
$cc_components
,
$symbol
];
$parse
->symbol_names_set(
$symbol_name
,
$subgrammar
,
{
dsl_form
=>
$char_class
,
display_form
=>
$char_class
,
description
=>
"Character class: $char_class"
}
);
}
return
$symbol
;
}
sub
Marpa::R2::Internal::MetaAST::Parse::symbol_names_set {
my
(
$parse
,
$symbol
,
$subgrammar
,
$args
) =
@_
;
my
$symbol_type
=
$subgrammar
eq
'G1'
?
'G1'
:
'L'
;
for
my
$arg_type
(
keys
%{
$args
}) {
my
$value
=
$args
->{
$arg_type
};
$parse
->{symbols}->{
$symbol_type
}->{
$symbol
}->{
$arg_type
} =
$value
;
}
}
sub
Marpa::R2::Internal::MetaAST::Parse::prioritized_symbol {
my
(
$parse
,
$base_symbol
,
$priority
) =
@_
;
my
$symbol_name
=
$base_symbol
.
'['
.
$priority
.
']'
;
my
$symbol_data
=
$parse
->{symbols}->{
$Marpa::R2::Internal::SUBGRAMMAR
eq
'G1'
?
'G1'
:
'L'
}->{
$symbol_name
};
return
$symbol_name
if
defined
$symbol_data
;
my
$display_form
=
(
$base_symbol
=~ m/\s/xms ) ?
"<$base_symbol>"
:
$base_symbol
;
$parse
->symbol_names_set(
$symbol_name
,
$Marpa::R2::Internal::SUBGRAMMAR
,
{
legacy_name
=>
$base_symbol
,
dsl_form
=>
$base_symbol
,
display_form
=>
$display_form
,
description
=>
"<$base_symbol> at priority $priority"
}
);
return
$symbol_name
;
}
sub
Marpa::R2::Internal::MetaAST::Parse::internal_lexeme {
my
(
$parse
,
$dsl_form
,
@grammars
) =
@_
;
my
$lexical_lhs_index
=
$parse
->{lexical_lhs_index}++;
my
$lexical_symbol
=
"[Lex-$lexical_lhs_index]"
;
my
%names
= (
dsl_form
=>
$dsl_form
,
display_form
=>
$dsl_form
,
description
=>
qq{Internal lexical symbol for "$dsl_form"}
);
$parse
->symbol_names_set(
$lexical_symbol
,
$_
, \
%names
)
for
qw(G1 L)
;
return
$lexical_symbol
;
}
sub
name {
my
(
$self
) =
@_
;
my
$names
=
$self
->{names};
Marpa::R2::exception(
'list->name() on symbol list of length '
,
scalar
@{
$names
} )
if
scalar
@{
$names
} != 1;
return
$self
->{names}->[0];
}
sub
names {
return
shift
->{names} }
sub
mask {
return
shift
->{mask} }
sub
mask_set {
my
(
$self
,
$mask
) =
@_
;
return
$self
->{mask} = [
map
{
$mask
} @{
$self
->{mask} } ];
}
1;