Sponsoring The Perl Toolchain Summit 2025: Help make this important event another success Learn more

# [[[ HEADER ]]]
use strict;
our $VERSION = 0.005_100;
# [[[ OO INHERITANCE ]]]
# [[[ CRITICS ]]]
## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator
## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils
# [[[ OO PROPERTIES ]]]
our hashref $properties = {};
# [[[ SUBROUTINES & OO METHODS ]]]
sub ast_to_rperl__generate {
{ my string_hashref::method $RETURN_TYPE };
( my object $self, my string_hashref $modes) = @ARG;
my string_hashref $rperl_source_group = { PMC => q{} };
my string_hashref $rperl_source_subgroup;
my string $self_class = ref $self;
# RPerl::diag( 'in VariableModification->ast_to_rperl__generate(), received $self = ', "\n", RPerl::Parser::rperl_ast__dump($self), "\n" );
# yes semicolon for Statement_176, no semicolon for SubExpressionOrVarMod_168, VariableModification_206, and VariableModification_207
my string $semicolon = q{};
if ( $self_class eq 'SubExpressionOrVarMod_168' ) { # SubExpressionOrVarMod -> VariableModification
# unwrap VariableModification_206 and VariableModification_207 from SubExpressionOrVarMod_168
$self = $self->{children}->[0];
$self_class = ref $self;
}
elsif ( $self_class eq 'Statement_176' ) { # Statement -> VariableModification ';'
# unwrap VariableModification_206 and VariableModification_207 from Statement_176; grab semicolon
$semicolon = $self->{children}->[1];
$self = $self->{children}->[0];
$self_class = ref $self;
}
if ( $self_class eq 'VariableModification_206' ) { # VariableModification -> Variable OP19_VARIABLE_ASSIGN SubExpressionOrInput
my object $variable = $self->{children}->[0];
my string $assign = $self->{children}->[1];
my object $subexpression_or_stdin = $self->{children}->[2];
$rperl_source_subgroup = $variable->ast_to_rperl__generate($modes);
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
$rperl_source_group->{PMC} .= q{ } . $assign . q{ };
$rperl_source_subgroup = $subexpression_or_stdin->ast_to_rperl__generate($modes);
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
}
elsif ( $self_class eq 'VariableModification_207' ) { # VariableModification -> Variable OP19_VARIABLE_ASSIGN_BY SubExpression
my object $variable = $self->{children}->[0];
my string $assign_by = $self->{children}->[1];
my object $subexpression = $self->{children}->[2];
$rperl_source_subgroup = $variable->ast_to_rperl__generate($modes);
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
$rperl_source_group->{PMC} .= q{ } . $assign_by . q{ };
$rperl_source_subgroup = $subexpression->ast_to_rperl__generate($modes);
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup );
}
else {
die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASRP000, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Grammar rule ' . $self_class .
' found where SubExpressionOrVarMod_168, Statement_176, VariableModification_206, or VariableModification_207 expected, dying' ) . "\n";
}
$rperl_source_group->{PMC} .= $semicolon . "\n";
# RPerl::diag( 'in VariableModification->ast_to_rperl__generate(), returning $rperl_source_group = ', "\n", RPerl::Parser::rperl_ast__dump($rperl_source_group), "\n" );
return $rperl_source_group;
}
sub ast_to_cpp__generate__CPPOPS_PERLTYPES {
{ my string_hashref::method $RETURN_TYPE };
( my object $self, my string_hashref $modes) = @ARG;
my string_hashref $cpp_source_group = { CPP => q{// <<< RP::O::S::VM __DUMMY_SOURCE_CODE CPPOPS_PERLTYPES >>>} . "\n" };
#...
return $cpp_source_group;
}
sub ast_to_cpp__generate__CPPOPS_CPPTYPES {
{ my string_hashref::method $RETURN_TYPE };
( my object $self, my string_hashref $modes) = @ARG;
my string_hashref $cpp_source_group = { CPP => q{} };
my string_hashref $cpp_source_subgroup;
my string $self_class = ref $self;
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), received $self = ', "\n", RPerl::Parser::rperl_ast__dump($self), "\n" );
# yes semicolon for Statement_176, no semicolon for SubExpressionOrVarMod_168, VariableModification_206, and VariableModification_207
my string $semicolon = undef;
if ( $self_class eq 'SubExpressionOrVarMod_168' ) { # SubExpressionOrVarMod -> VariableModification
# unwrap VariableModification_206 and VariableModification_207 from SubExpressionOrVarMod_168
$self = $self->{children}->[0];
$self_class = ref $self;
}
elsif ( $self_class eq 'Statement_176' ) { # Statement -> VariableModification ';'
# unwrap VariableModification_206 and VariableModification_207 from Statement_176; grab semicolon
$semicolon = $self->{children}->[1];
$self = $self->{children}->[0];
$self_class = ref $self;
}
if ( $self_class eq 'VariableModification_206' ) { # VariableModification -> Variable OP19_VARIABLE_ASSIGN SubExpressionOrInput
my object $variable = $self->{children}->[0];
my string $assign = $self->{children}->[1];
my object $subexpression_or_stdin = $self->{children}->[2];
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $variable = ', "\n", RPerl::Parser::rperl_ast__dump($variable), "\n" );
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $subexpression_or_stdin = ', "\n", RPerl::Parser::rperl_ast__dump($subexpression_or_stdin), "\n" );
# detect object constructor move semantics
# NEED ANSWER: do we also need to add detection of object constructor move semantics to VariableDeclaration?
# HARD-CODED EXAMPLE:
# $self->{foo}->{$bar} = Bat::Bax->new(); # Perl
# this->foo[bar] = new Bat__Bax; # C++, BAD
# Bat__Bax_ptr this__foo__bar{new Bat__Bax()}; this->foo[bar] = std::move(this__foo__bar); # C++, GOOD
my boolean $rhs_is_constructor_call = 0;
my boolean $lhs_is_variable_retrieval = 0;
# NEED UPGRADE: enable detection logic for non-trivial cases where ConstructorCall may be in parentheses or otherwise buried deeper in $subexpression_or_stdin
if (
((ref $subexpression_or_stdin) eq 'SubExpressionOrInput_164') and
(exists $subexpression_or_stdin->{children}) and
(defined $subexpression_or_stdin->{children}) and
(defined $subexpression_or_stdin->{children}->[0]) and
((ref $subexpression_or_stdin->{children}->[0]) eq 'SubExpression_155') and
(exists $subexpression_or_stdin->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}->[0]) and
((ref $subexpression_or_stdin->{children}->[0]->{children}->[0]) eq 'Expression_154') # ISA RPerl::Operation::Expression::SubroutineCall::MethodCall::ConstructorCall
) {
$rhs_is_constructor_call = 1;
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $rhs_is_constructor_call = ', $rhs_is_constructor_call, "\n" );
}
# NEED ANSWER: is the for() loop check for VariableRetrieval below correct? or does the VariableRetrieval need to be at the beginning and/or end of the LHS?
# NEED UPGRADE: enable detection logic for non-trivial cases where VariableRetrieval may be in parentheses or otherwise buried deeper in $variable
if (
$rhs_is_constructor_call and # short-circuit to skip $lhs_is_variable_retrieval if $rhs_is_constructor_call not detected
((ref $variable) eq 'Variable_198') and # Variable -> VariableSymbolOrSelf STAR-44
(exists $variable->{children}) and
(defined $variable->{children}) and
(defined $variable->{children}->[1]) and
((ref $variable->{children}->[1]) eq '_STAR_LIST') and
(exists $variable->{children}->[1]->{children}) and
(defined $variable->{children}->[1]->{children})
) {
foreach my object $lhs_object (@{$variable->{children}->[1]->{children}}) {
if (
((ref $lhs_object) eq 'VariableRetrieval_199') or # VariableRetrieval -> OP02_ARRAY_THINARROW SubExpression ']'
((ref $lhs_object) eq 'VariableRetrieval_200') or # VariableRetrieval -> OP02_HASH_THINARROW SubExpression '}'
((ref $lhs_object) eq 'VariableRetrieval_201') # VariableRetrieval -> OP02_HASH_THINARROW WORD '}'
) {
$lhs_is_variable_retrieval = 1;
}
}
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $lhs_is_variable_retrieval = ', $lhs_is_variable_retrieval, "\n" );
}
# detect array resize semantics: Perl '$a->[$i - 1] = undef;' becomes C++ 'a.resize(i);'
my boolean $rhs_is_undef = 0;
my boolean $lhs_is_array_retrieval_minus_one = 0;
# short-circuit to skip array resize semantics detection if object constructor move semantics detected
if (not ($rhs_is_constructor_call or $lhs_is_variable_retrieval)) {
# SubExpression_156 ISA RPerl::Operation::Expression::SubExpression::Literal::Undefined AKA undef
if (
((ref $subexpression_or_stdin) eq 'SubExpressionOrInput_164') and
(exists $subexpression_or_stdin->{children}) and
(defined $subexpression_or_stdin->{children}) and
(defined $subexpression_or_stdin->{children}->[0]) and
((ref $subexpression_or_stdin->{children}->[0]) eq 'SubExpression_156')
) {
$rhs_is_undef = 1;
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $rhs_is_undef = ', $rhs_is_undef, "\n" );
}
if (
$rhs_is_undef and # short-circuit to skip $lhs_is_array_retrieval_minus_one if $rhs_is_undef not detected
((ref $variable) eq 'Variable_198') and # Variable -> VariableSymbolOrSelf STAR-44
(exists $variable->{children}) and
(defined $variable->{children}) and
(defined $variable->{children}->[1]) and
((ref $variable->{children}->[1]) eq '_STAR_LIST') and
(exists $variable->{children}->[1]->{children}) and
(defined $variable->{children}->[1]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]) and
((ref $variable->{children}->[1]->{children}->[-1]) eq 'VariableRetrieval_199') and # VariableRetrieval -> OP02_ARRAY_THINARROW SubExpression ']'
(exists $variable->{children}->[1]->{children}->[-1]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]) and
((ref $variable->{children}->[1]->{children}->[-1]->{children}->[1]) eq 'SubExpression_155') and # SubExpression -> Expression
(exists $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]) and
((ref $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]) eq 'Expression_149') and # Expression -> Operator
(exists $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]) and
((ref $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]) eq 'Operator_113') and # Operator -> SubExpression OP08_MATH_ADD_SUB SubExpression
(exists $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[1]) and
( $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[1] eq '- ') and # subtraction
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]) and
((ref $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]) eq 'SubExpression_157') and # SubExpression -> Literal
(exists $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]) and
((ref $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]) eq 'Literal_255') and # Literal -> LITERAL_NUMBER
(exists $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]->{children}) and
(defined $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]->{children}->[0]) and
( $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[2]->{children}->[0]->{children}->[0] eq '1') # literal number 1
) {
$lhs_is_array_retrieval_minus_one = 1;
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $lhs_is_array_retrieval_minus_one = ', $lhs_is_array_retrieval_minus_one, "\n" );
}
}
# object constructor move semantics detected
if ($rhs_is_constructor_call and $lhs_is_variable_retrieval) {
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), object constructor move semantics detected', "\n" );
$cpp_source_subgroup = $variable->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
my string $lhs = $cpp_source_subgroup->{CPP};
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $lhs = ', q{'}, $lhs, q{'}, "\n" );
my string $lhs_underscores = $lhs;
$lhs_underscores =~ s/->/__/g; # replace -> w/ __
$lhs_underscores =~ s/\[(.*)\]/__$1/g; # replace [bar] w/ __bar
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $lhs_underscores = ', q{'}, $lhs_underscores, q{'}, "\n" );
my string $rhs_class_underscores;
if (
(exists $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]) and
( # class names w/ or w/out '::' scopes
((ref $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]) eq 'WordScoped_238') or # WordScoped -> WORD
((ref $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]) eq 'WordScoped_239') # WordScoped -> WORD_SCOPED
) and
(exists $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]->{children}) and
(defined $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]->{children}->[0])
) {
$rhs_class_underscores = $subexpression_or_stdin->{children}->[0]->{children}->[0]->{children}->[0]->{children}->[0];
$rhs_class_underscores =~ s/:/_/g;
}
else {
die 'ERROR ECOGEASCP089, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Object constructor move semantics detected, but RHS class name not found where expected, dying' . "\n";
}
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $rhs_class_underscores = ', q{'}, $rhs_class_underscores, q{'}, "\n" );
$cpp_source_group->{CPP} .= $rhs_class_underscores . '_ptr ' . $lhs_underscores . '{new ' . $rhs_class_underscores . '()}; ';
$cpp_source_group->{CPP} .= $lhs . ' = std::move(' . $lhs_underscores . ')';
}
# array resize semantics detected
elsif ($rhs_is_undef and $lhs_is_array_retrieval_minus_one) {
my unknown $size = $variable->{children}->[1]->{children}->[-1]->{children}->[1]->{children}->[0]->{children}->[0]->{children}->[0];
delete $variable->{children}->[1]->{children}->[-1]; # do not generate the final variable retrieval containing the size: ->[size - 1]
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have modified $variable = ', "\n", RPerl::Parser::rperl_ast__dump($variable), "\n" );
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $size = ', "\n", RPerl::Parser::rperl_ast__dump($size), "\n" );
$cpp_source_subgroup = $variable->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
$cpp_source_group->{CPP} .= '.resize(';
$cpp_source_subgroup = $size->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
$cpp_source_group->{CPP} .= ')';
}
else { # normal generate
$cpp_source_subgroup = $variable->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
$cpp_source_group->{CPP} .= q{ } . $assign . q{ };
$cpp_source_subgroup = $subexpression_or_stdin->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
}
}
elsif ( $self_class eq 'VariableModification_207' ) { # VariableModification -> Variable OP19_VARIABLE_ASSIGN_BY SubExpression
my object $variable = $self->{children}->[0];
my string $assign_by = $self->{children}->[1];
my object $subexpression = $self->{children}->[2];
$cpp_source_subgroup = $variable->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
$cpp_source_group->{CPP} .= q{ } . $assign_by . q{ };
$cpp_source_subgroup = $subexpression->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes);
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup );
}
else {
die RPerl::Parser::rperl_rule__replace( 'ERROR ECOGEASCP000, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Grammar rule ' . $self_class .
' found where SubExpressionOrVarMod_168, Statement_176, VariableModification_206, or VariableModification_207 expected, dying' ) . "\n";
}
if (defined $semicolon) {
$cpp_source_group->{CPP} .= $semicolon . "\n";
}
# RPerl::diag( 'in VariableModification->ast_to_cpp__generate__CPPOPS_CPPTYPES(), returning $cpp_source_group = ', "\n", RPerl::Parser::rperl_ast__dump($cpp_source_group), "\n" );
return $cpp_source_group;
}
1; # end of class