line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# [[[ HEADER ]]] |
2
|
|
|
|
|
|
|
package RPerl::CodeBlock::Subroutine; |
3
|
7
|
|
|
7
|
|
2136
|
use strict; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
161
|
|
4
|
7
|
|
|
7
|
|
32
|
use warnings; |
|
7
|
|
|
|
|
20
|
|
|
7
|
|
|
|
|
159
|
|
5
|
7
|
|
|
7
|
|
39
|
use RPerl::AfterSubclass; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
929
|
|
6
|
|
|
|
|
|
|
our $VERSION = 0.021_000; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
## no critic qw(ProhibitUselessNoCritic ProhibitMagicNumbers RequireCheckedSyscalls) # USER DEFAULT 1: allow numeric values & print operator |
9
|
|
|
|
|
|
|
## no critic qw(RequireInterpolationOfMetachars) # USER DEFAULT 2: allow single-quoted control characters & sigils |
10
|
|
|
|
|
|
|
## no critic qw(Capitalization ProhibitMultiplePackages ProhibitReusedNames) # SYSTEM DEFAULT 3: allow multiple & lower case package names |
11
|
|
|
|
|
|
|
BEGIN { |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
package # hide from PAUSE indexing |
14
|
|
|
|
|
|
|
string_hashref::method; |
15
|
7
|
|
|
7
|
|
42
|
use strict; |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
144
|
|
16
|
7
|
|
|
7
|
|
29
|
use warnings; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
221
|
|
17
|
7
|
|
|
7
|
|
19
|
1; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
package # hide from PAUSE indexing |
20
|
|
|
|
|
|
|
string::method; |
21
|
7
|
|
|
7
|
|
31
|
use strict; |
|
7
|
|
|
|
|
12
|
|
|
7
|
|
|
|
|
116
|
|
22
|
7
|
|
|
7
|
|
28
|
use warnings; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
176
|
|
23
|
7
|
|
|
|
|
13
|
1; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp003: method types reside in Subroutine.pm, which is a sub-type of Subroutine.pm, causing the need to have this special BEGIN block |
26
|
|
|
|
|
|
|
# to enable the *::method types, and Class.pm's INIT block symbol table entry generator needs us to switch back into the primary package so we have |
27
|
|
|
|
|
|
|
# that happen in the following line, which furthermore triggers the need to avoid re-defining class accessor/mutator methods; how to fix? |
28
|
|
|
|
|
|
|
package RPerl::CodeBlock::Subroutine; |
29
|
7
|
|
|
7
|
|
27
|
use strict; |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
107
|
|
30
|
7
|
|
|
7
|
|
32
|
use warnings; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
128
|
|
31
|
7
|
|
|
|
|
117
|
1; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# [[[ OO INHERITANCE ]]] |
35
|
7
|
|
|
7
|
|
34
|
use parent qw(RPerl::CodeBlock); |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
42
|
|
36
|
7
|
|
|
7
|
|
214
|
use RPerl::CodeBlock; |
|
7
|
|
|
|
|
51
|
|
|
7
|
|
|
|
|
132
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# [[[ INCLUDES ]]] |
39
|
7
|
|
|
7
|
|
2800
|
use perlapinames_generated; |
|
7
|
|
|
|
|
58
|
|
|
7
|
|
|
|
|
11081
|
|
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# [[[ OO PROPERTIES ]]] |
42
|
|
|
|
|
|
|
our hashref $properties = {}; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
# [[[ SUBROUTINES & OO METHODS ]]] |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub ast_to_rperl__generate { |
47
|
288
|
|
|
288
|
|
926
|
{ my string_hashref::method $RETURN_TYPE }; |
|
288
|
|
|
|
|
669
|
|
48
|
288
|
|
|
|
|
851
|
( my object $self, my string_hashref $modes) = @ARG; |
49
|
288
|
|
|
|
|
1421
|
my string_hashref $rperl_source_group = { PMC => q{} }; |
50
|
288
|
|
|
|
|
731
|
my string_hashref $rperl_source_subgroup; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_rperl__generate(), received $self = ' . "\n" . RPerl::Parser::rperl_ast__dump($self) . "\n" ); |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# unwrap Subroutine_57 from SubroutineOrMethod_87, only if needed |
55
|
288
|
100
|
|
|
|
1400
|
if ((ref $self) eq 'SubroutineOrMethod_87') { $self = $self->{children}->[0]; } |
|
46
|
|
|
|
|
167
|
|
56
|
|
|
|
|
|
|
|
57
|
288
|
50
|
|
|
|
1361
|
if ( ( ref $self ) ne 'Subroutine_57' ) { |
58
|
0
|
|
|
|
|
0
|
die RPerl::Parser::rperl_rule__replace( |
59
|
|
|
|
|
|
|
'ERROR ECOGEASRP00, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Grammar rule ' . ( ref $self ) . ' found where Subroutine_57 expected, dying' ) |
60
|
|
|
|
|
|
|
. "\n"; |
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_rperl__generate(), have possibly-unwrapped $self = ' . "\n" . RPerl::Parser::rperl_ast__dump($self) . "\n" ); |
64
|
|
|
|
|
|
|
|
65
|
288
|
|
|
|
|
1411
|
my string $sub = $self->{children}->[0]; |
66
|
288
|
|
|
|
|
1093
|
my string $name = $self->{children}->[1]; |
67
|
288
|
|
|
|
|
1368
|
my string $left_brace = $self->{children}->[2]; |
68
|
288
|
|
|
|
|
882
|
my string $return_type_left_brace = $self->{children}->[3]; |
69
|
288
|
|
|
|
|
873
|
my string $return_type_my = $self->{children}->[4]; |
70
|
288
|
|
|
|
|
928
|
my string $return_type = $self->{children}->[5]->{children}->[0]; |
71
|
288
|
|
|
|
|
784
|
my string $return_type_var = $self->{children}->[6]; |
72
|
288
|
|
|
|
|
950
|
my string $return_type_right_brace = $self->{children}->[7]; |
73
|
288
|
|
|
|
|
1107
|
my string $return_type_semicolon = $self->{children}->[8]; |
74
|
288
|
|
|
|
|
633
|
my object $arguments_optional = $self->{children}->[9]; |
75
|
288
|
|
|
|
|
767
|
my object $operations_star = $self->{children}->[10]; |
76
|
288
|
|
|
|
|
983
|
my string $right_brace = $self->{children}->[11]; |
77
|
|
|
|
|
|
|
|
78
|
288
|
50
|
|
|
|
1385
|
if ((substr $name, 0, 1) eq '_') { |
79
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEASRP08, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: subroutine name ' . ($name) |
80
|
|
|
|
|
|
|
. ' must not start with underscore, dying' . "\n"; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
288
|
100
|
100
|
|
|
4594
|
if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$name}) or |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
84
|
|
|
|
|
|
|
(exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$name}) or |
85
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$name}) or |
86
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$name})) { |
87
|
4
|
|
|
|
|
85
|
die 'ERROR ECOGEASRP44, CODE GENERATOR, ABSTRACT SYNTAX TO RPERL: Perl API name conflict, subroutine name ' . q{'} |
88
|
|
|
|
|
|
|
. $name . q{'} |
89
|
|
|
|
|
|
|
. ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n"; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# CREATE SYMBOL TABLE ENTRY |
93
|
284
|
|
|
|
|
932
|
$modes->{_symbol_table}->{_subroutine} = $name; # set current subroutine/method |
94
|
284
|
|
|
|
|
2705
|
$modes->{_symbol_table}->{$modes->{_symbol_table}->{_namespace}}->{_global}->{$name} = {isa => 'RPerl::CodeBlock::Subroutine', type => $return_type}; # create individual symtab entry |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# NEED UPGRADE, CORRELATION #rp035: allow multi-line subroutines & other code blocks, where they would be less than 160 chars if on a single line |
97
|
|
|
|
|
|
|
# DEV NOTE: no newline appended in the next line, all newlines removed from subroutine body via regex replacement after foreach loop below, |
98
|
|
|
|
|
|
|
# thus allowing for single-line subroutines as well as multi-line subroutines, at the control of Perl::Tidy |
99
|
|
|
|
|
|
|
$rperl_source_group->{PMC} .= |
100
|
284
|
|
|
|
|
2209
|
$sub . q{ } . $name . q{ } . $left_brace . q{ } . |
101
|
|
|
|
|
|
|
$return_type_left_brace . q{ } . $return_type_my . q{ } . $return_type . q{ } . $return_type_var . q{ } . |
102
|
|
|
|
|
|
|
$return_type_right_brace . q{ } . $return_type_semicolon; |
103
|
|
|
|
|
|
|
|
104
|
284
|
100
|
|
|
|
1217
|
if ( exists $arguments_optional->{children}->[0] ) { |
105
|
98
|
|
|
|
|
2819
|
$rperl_source_subgroup = $arguments_optional->{children}->[0]->ast_to_rperl__generate($modes); |
106
|
98
|
|
|
|
|
2162
|
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup ); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
284
|
|
|
|
|
544
|
foreach my object $operation ( @{ $operations_star->{children} } ) { |
|
284
|
|
|
|
|
1267
|
|
110
|
423
|
|
|
|
|
10718
|
$rperl_source_subgroup = $operation->ast_to_rperl__generate($modes); |
111
|
399
|
|
|
|
|
8379
|
RPerl::Generator::source_group_append( $rperl_source_group, $rperl_source_subgroup ); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
260
|
|
|
|
|
2090
|
$rperl_source_group->{PMC} =~ s/\n/\ /gxms; |
115
|
|
|
|
|
|
|
|
116
|
260
|
|
|
|
|
1035
|
$rperl_source_group->{PMC} .= $right_brace . "\n\n"; |
117
|
260
|
|
|
|
|
16032
|
return $rperl_source_group; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub ast_to_cpp__generate__CPPOPS_PERLTYPES { |
121
|
0
|
|
|
0
|
|
0
|
{ my string_hashref::method $RETURN_TYPE }; |
|
0
|
|
|
|
|
0
|
|
122
|
0
|
|
|
|
|
0
|
( my object $self, my string_hashref $modes) = @ARG; |
123
|
0
|
|
|
|
|
0
|
my string_hashref $cpp_source_group = { CPP => q{// <<< RP::CB::S __DUMMY_SOURCE_CODE CPPOPS_PERLTYPES >>>} . "\n" }; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
#... |
126
|
0
|
|
|
|
|
0
|
return $cpp_source_group; |
127
|
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES { |
130
|
8
|
|
|
8
|
|
19
|
{ my string_hashref::method $RETURN_TYPE }; |
|
8
|
|
|
|
|
18
|
|
131
|
8
|
|
|
|
|
22
|
( my object $self, my string_hashref $modes) = @ARG; |
132
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), received $modes->{_symbol_table} = ' . "\n" . Dumper($modes->{_symbol_table}) . "\n"); |
133
|
|
|
|
|
|
|
|
134
|
8
|
|
|
|
|
26
|
my string_hashref $cpp_source_group = { H => q{} }; |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# unwrap Subroutine_57 from SubroutineOrMethod_87, only if needed |
137
|
8
|
50
|
|
|
|
31
|
if ((ref $self) eq 'SubroutineOrMethod_87') { $self = $self->{children}->[0]; } |
|
8
|
|
|
|
|
36
|
|
138
|
|
|
|
|
|
|
|
139
|
8
|
|
|
|
|
31
|
my string $name = $self->{children}->[1]; |
140
|
8
|
|
|
|
|
28
|
my string $return_type = $self->{children}->[5]->{children}->[0]; |
141
|
8
|
|
|
|
|
19
|
my object $arguments_optional = $self->{children}->[9]; |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $arguments_optional = ' . "\n" . RPerl::Parser::rperl_ast__dump($arguments_optional) . "\n" ); |
144
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $return_type = ' . "\n" . RPerl::Parser::rperl_ast__dump($return_type) . "\n" ); |
145
|
|
|
|
|
|
|
|
146
|
8
|
|
|
|
|
15
|
my string_arrayref $arguments = []; |
147
|
|
|
|
|
|
|
|
148
|
8
|
50
|
|
|
|
31
|
if ((substr $name, 0, 1) eq '_') { |
149
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEASCP08, CODE GENERATOR, ABSTRACT SYNTAX TO C++: subroutine name ' . ($name) |
150
|
|
|
|
|
|
|
. ' must not start with underscore, dying' . "\n"; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
8
|
50
|
33
|
|
|
84
|
if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$name}) or |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
154
|
|
|
|
|
|
|
(exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$name}) or |
155
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$name}) or |
156
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$name})) { |
157
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEASCP44, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Perl API name conflict, subroutine name ' . q{'} |
158
|
|
|
|
|
|
|
. $name . q{'} |
159
|
|
|
|
|
|
|
. ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n"; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# CREATE SYMBOL TABLE ENTRY |
163
|
8
|
|
|
|
|
18
|
$modes->{_symbol_table}->{_subroutine} = $name; # set current subroutine/method |
164
|
8
|
|
|
|
|
41
|
$modes->{_symbol_table}->{$modes->{_symbol_table}->{_namespace}}->{_global}->{$name} = {isa => 'RPerl::CodeBlock::Subroutine', type => $return_type}; # create individual symtab entry |
165
|
|
|
|
|
|
|
|
166
|
8
|
|
|
|
|
171
|
$return_type = RPerl::Generator::type_convert_perl_to_cpp($return_type, 1); # $pointerify_classes = 1 |
167
|
8
|
|
|
|
|
24
|
$modes->{_symbol_table}->{$modes->{_symbol_table}->{_namespace}}->{_global}->{$name}->{type_cpp} = $return_type; # add converted C++ type to symtab entry |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp022: must prefix subroutine names with namespace-underscores to simulate Perl's behavior of not exporting subroutines by default |
170
|
8
|
|
|
|
|
17
|
my string $namespace_underscores = q{}; |
171
|
8
|
50
|
33
|
|
|
43
|
if ((exists $modes->{_symbol_table}->{_namespace}) and (defined $modes->{_symbol_table}->{_namespace})) { |
172
|
8
|
|
|
|
|
14
|
$namespace_underscores = $modes->{_symbol_table}->{_namespace}; |
173
|
8
|
|
|
|
|
44
|
$namespace_underscores =~ s/:/_/gxms; |
174
|
|
|
|
|
|
|
} |
175
|
8
|
|
|
|
|
28
|
$cpp_source_group->{H} .= $return_type . q{ } . $namespace_underscores . $name . '('; |
176
|
|
|
|
|
|
|
|
177
|
8
|
100
|
|
|
|
26
|
if ( exists $arguments_optional->{children}->[0] ) { |
178
|
3
|
|
|
|
|
68
|
my object $cpp_source_subgroup = $arguments_optional->{children}->[0]->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes); |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $cpp_source_subgroup = ' . "\n" . RPerl::Parser::rperl_ast__dump($cpp_source_subgroup) . "\n" ); |
181
|
|
|
|
|
|
|
# DEV NOTE: don't use RPerl::Generator::source_group_append() due to cross-wiring H-from-CPP below |
182
|
3
|
|
|
|
|
8
|
$cpp_source_group->{H} .= $cpp_source_subgroup->{CPP}; |
183
|
3
|
50
|
33
|
|
|
15
|
if ( ( exists $cpp_source_subgroup->{H_INCLUDES} ) and ( defined $cpp_source_subgroup->{H_INCLUDES} ) ) { |
184
|
0
|
|
|
|
|
0
|
$cpp_source_group->{H_INCLUDES} .= $cpp_source_subgroup->{H_INCLUDES}; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
8
|
|
|
|
|
15
|
$cpp_source_group->{H} .= ');'; |
189
|
8
|
|
|
|
|
133
|
return $cpp_source_group; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub ast_to_cpp__generate__CPPOPS_CPPTYPES { |
193
|
9
|
|
|
9
|
|
13
|
{ my string_hashref::method $RETURN_TYPE }; |
|
9
|
|
|
|
|
14
|
|
194
|
9
|
|
|
|
|
26
|
( my object $self, my string_hashref $modes) = @ARG; |
195
|
9
|
|
|
|
|
24
|
my string_hashref $cpp_source_group = { CPP => q{} }; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# unwrap Subroutine_57 from SubroutineOrMethod_87, only if needed |
198
|
9
|
100
|
|
|
|
32
|
if ((ref $self) eq 'SubroutineOrMethod_87') { $self = $self->{children}->[0]; } |
|
8
|
|
|
|
|
20
|
|
199
|
|
|
|
|
|
|
|
200
|
9
|
|
|
|
|
23
|
my string $name = $self->{children}->[1]; |
201
|
9
|
|
|
|
|
25
|
my string $return_type = $self->{children}->[5]->{children}->[0]; |
202
|
9
|
|
|
|
|
19
|
my object $arguments_optional = $self->{children}->[9]; |
203
|
9
|
|
|
|
|
19
|
my object $operations_star = $self->{children}->[10]; |
204
|
|
|
|
|
|
|
|
205
|
9
|
50
|
33
|
|
|
106
|
if ((exists $perlapinames_generated::FUNCTIONS_DOCUMENTED->{$name}) or |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
206
|
|
|
|
|
|
|
(exists $perlapinames_generated::FUNCTIONS_UNDOCUMENTED->{$name}) or |
207
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_DOCUMENTED->{$name}) or |
208
|
|
|
|
|
|
|
(exists $perlapinames_generated::VARIABLES_UNDOCUMENTED->{$name})) { |
209
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEASCP44, CODE GENERATOR, ABSTRACT SYNTAX TO C++: Perl API name conflict, subroutine name ' . q{'} |
210
|
|
|
|
|
|
|
. $name . q{'} |
211
|
|
|
|
|
|
|
. ' is the same as a protected function or variable name in the Perl API, please choose a different name, dying' . "\n"; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
9
|
|
|
|
|
20
|
my string_arrayref $arguments = []; |
215
|
9
|
|
|
|
|
17
|
my object $cpp_source_subgroup; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $arguments_optional = ' . "\n" . RPerl::Parser::rperl_ast__dump($arguments_optional) . "\n" ); |
218
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $return_type = ' . "\n" . RPerl::Parser::rperl_ast__dump($return_type) . "\n" ); |
219
|
|
|
|
|
|
|
|
220
|
9
|
|
|
|
|
168
|
$return_type = RPerl::Generator::type_convert_perl_to_cpp($return_type, 1); # $pointerify_classes = 1 |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# DEV NOTE: must prefix subroutine names with namespace-underscores to simulate Perl's behavior of not exporting subroutines by default |
223
|
9
|
|
|
|
|
19
|
my string $namespace_underscores = q{}; |
224
|
9
|
50
|
33
|
|
|
57
|
if ((exists $modes->{_symbol_table}->{_namespace}) and (defined $modes->{_symbol_table}->{_namespace})) { |
225
|
9
|
|
|
|
|
19
|
$namespace_underscores = $modes->{_symbol_table}->{_namespace}; |
226
|
9
|
|
|
|
|
31
|
$namespace_underscores =~ s/:/_/gxms; |
227
|
|
|
|
|
|
|
} |
228
|
9
|
|
|
|
|
35
|
$cpp_source_group->{CPP} .= $return_type . q{ } . $namespace_underscores . $name . '('; |
229
|
|
|
|
|
|
|
|
230
|
9
|
100
|
|
|
|
25
|
if ( exists $arguments_optional->{children}->[0] ) { |
231
|
3
|
|
|
|
|
55
|
$cpp_source_subgroup = $arguments_optional->{children}->[0]->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes); |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $cpp_source_subgroup = ' . "\n" . RPerl::Parser::rperl_ast__dump($cpp_source_subgroup) . "\n" ); |
234
|
3
|
|
|
|
|
78
|
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup ); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
9
|
|
|
|
|
21
|
$cpp_source_group->{CPP} .= ') {' . "\n"; |
238
|
9
|
|
|
|
|
24
|
my string $CPP_saved = $cpp_source_group->{CPP}; |
239
|
9
|
|
|
|
|
17
|
$cpp_source_group->{CPP} = q{}; |
240
|
|
|
|
|
|
|
|
241
|
9
|
|
|
|
|
17
|
foreach my object $operation ( @{ $operations_star->{children} } ) { |
|
9
|
|
|
|
|
31
|
|
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate_declaration__CPPOPS_CPPTYPES(), have $operation = ' . "\n" . RPerl::Parser::rperl_ast__dump($operation) . "\n" ); |
244
|
|
|
|
|
|
|
# disable *_CHECK() and *_CHECKTRACE() data checking routines in CPPOPS_CPPTYPES mode, this is instead handled in xs_unpack_*() called by typemap.rperl |
245
|
21
|
50
|
33
|
|
|
209
|
if (( exists $operation->{children}->[0]->{children}->[0]->{children}->[0] ) |
|
|
|
33
|
|
|
|
|
246
|
|
|
|
|
|
|
and ( ( ( substr $operation->{children}->[0]->{children}->[0]->{children}->[0], -6, 6 ) eq '_CHECK' ) |
247
|
|
|
|
|
|
|
or ( ( substr $operation->{children}->[0]->{children}->[0]->{children}->[0], -11, 11 ) eq '_CHECKTRACE' ) ) |
248
|
|
|
|
|
|
|
) |
249
|
|
|
|
|
|
|
{ |
250
|
0
|
|
|
|
|
0
|
next; |
251
|
|
|
|
|
|
|
} |
252
|
21
|
|
|
|
|
469
|
$cpp_source_subgroup = $operation->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate__CPPOPS_CPPTYPES(), have $cpp_source_subgroup = ' . "\n" . RPerl::Parser::rperl_ast__dump($cpp_source_subgroup) . "\n" ); |
255
|
21
|
|
|
|
|
428
|
RPerl::Generator::source_group_append( $cpp_source_group, $cpp_source_subgroup ); |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
# COMPILE-TIME OPTIMIZATION #02: declare all loop iterators at top of subroutine/method to avoid re-declarations in nested loops |
259
|
9
|
50
|
33
|
|
|
37
|
if ((exists $modes->{_loop_iterators}) and (defined $modes->{_loop_iterators})) { |
260
|
0
|
|
|
|
|
0
|
foreach my string $loop_iterator_symbol (sort keys %{$modes->{_loop_iterators}}) { |
|
0
|
|
|
|
|
0
|
|
261
|
0
|
|
|
|
|
0
|
$CPP_saved .= $modes->{_loop_iterators}->{$loop_iterator_symbol} . q{ } . $loop_iterator_symbol . ';' . "\n"; |
262
|
|
|
|
|
|
|
} |
263
|
0
|
|
|
|
|
0
|
delete $modes->{_loop_iterators}; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
9
|
|
|
|
|
24
|
$CPP_saved .= $cpp_source_group->{CPP}; |
267
|
9
|
|
|
|
|
22
|
$cpp_source_group->{CPP} = $CPP_saved; |
268
|
|
|
|
|
|
|
|
269
|
9
|
|
|
|
|
21
|
$cpp_source_group->{CPP} .= '}'; |
270
|
9
|
|
|
|
|
192
|
return $cpp_source_group; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub ast_to_cpp__generate_shims__CPPOPS_CPPTYPES { |
274
|
8
|
|
|
8
|
|
21
|
{ my string_hashref::method $RETURN_TYPE }; |
|
8
|
|
|
|
|
12
|
|
275
|
8
|
|
|
|
|
21
|
( my object $self, my string_hashref $modes) = @ARG; |
276
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate_shims__CPPOPS_CPPTYPES(), received $modes->{_symbol_table} = ' . "\n" . Dumper($modes->{_symbol_table}) . "\n"); |
277
|
|
|
|
|
|
|
|
278
|
8
|
|
|
|
|
27
|
my string_hashref $cpp_source_group = { CPP => q{} }; |
279
|
8
|
|
|
|
|
15
|
my object $cpp_source_subgroup = undef; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
# unwrap Subroutine_57 from SubroutineOrMethod_87, only if needed |
282
|
8
|
50
|
|
|
|
26
|
if ((ref $self) eq 'SubroutineOrMethod_87') { $self = $self->{children}->[0]; } |
|
8
|
|
|
|
|
19
|
|
283
|
|
|
|
|
|
|
|
284
|
8
|
|
|
|
|
18
|
my string $name = $self->{children}->[1]; |
285
|
|
|
|
|
|
|
# my string $return_type = $self->{children}->[5]->{children}->[0]; # SHIM SUBS DEPRECATED IN FAVOR OF MACROS |
286
|
8
|
|
|
|
|
15
|
my object $arguments_optional = $self->{children}->[9]; |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_shims__CPPOPS_CPPTYPES(), have $arguments_optional = ' . "\n" . RPerl::Parser::rperl_ast__dump($arguments_optional) . "\n" ); |
289
|
|
|
|
|
|
|
#RPerl::diag( 'in Subroutine->ast_to_cpp__generate_shims__CPPOPS_CPPTYPES(), have $return_type = ' . "\n" . RPerl::Parser::rperl_ast__dump($return_type) . "\n" ); |
290
|
|
|
|
|
|
|
|
291
|
8
|
50
|
|
|
|
25
|
if ((substr $name, 0, 1) eq '_') { |
292
|
0
|
|
|
|
|
0
|
die 'ERROR ECOGEASCP08, CODE GENERATOR, ABSTRACT SYNTAX TO C++: subroutine name ' . ($name) |
293
|
|
|
|
|
|
|
. ' must not start with underscore, dying' . "\n"; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
# DEV NOTE, CORRELATION #rp022: must create shims to un-prefix subroutine names with namespace-underscores to un-simulate Perl's behavior of not exporting subroutines by default |
297
|
8
|
|
|
|
|
17
|
my string $namespace_colons = q{}; |
298
|
8
|
|
|
|
|
16
|
my string $namespace_underscores = q{}; |
299
|
8
|
50
|
33
|
|
|
57
|
if ((exists $modes->{_symbol_table}->{_namespace}) and (defined $modes->{_symbol_table}->{_namespace})) { |
300
|
8
|
|
|
|
|
15
|
$namespace_colons = $modes->{_symbol_table}->{_namespace}; |
301
|
8
|
|
|
|
|
19
|
$namespace_underscores = $namespace_colons; |
302
|
8
|
|
|
|
|
67
|
$namespace_underscores =~ s/:/_/gxms; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# DEV NOTE: only generate PMC output file in dynamic (default) subcompile mode |
306
|
8
|
50
|
|
|
|
34
|
if ($modes->{subcompile} eq 'DYNAMIC') { |
307
|
|
|
|
|
|
|
# hard-coded example, PMC subroutine |
308
|
|
|
|
|
|
|
#undef &RPerl::Algorithm::Sort::Bubble::integer_bubblesort; |
309
|
|
|
|
|
|
|
#*RPerl::Algorithm::Sort::Bubble::integer_bubblesort = sub { return main::RPerl__Algorithm__Sort__Bubble__integer_bubblesort(@ARG); }; |
310
|
8
|
|
|
|
|
30
|
$cpp_source_group->{PMC} = 'undef &' . $namespace_colons . $name . ';'. "\n"; |
311
|
8
|
|
|
|
|
32
|
$cpp_source_group->{PMC} .= '*' . $namespace_colons . $name . ' = sub { return main::' . $namespace_underscores . $name . '(@ARG); };'; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
=DEPRECATED IN FAVOR OF MACROS |
315
|
|
|
|
|
|
|
# hard-coded example, CPP subroutine |
316
|
|
|
|
|
|
|
# void display_pi_digits(integer n) { return MathPerl__Geometry__PiDigits__display_pi_digits(n); } |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
$cpp_source_group->{CPP} .= $return_type . q{ } . $name . '('; |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
if ( exists $arguments_optional->{children}->[0] ) { |
321
|
|
|
|
|
|
|
$cpp_source_subgroup = $arguments_optional->{children}->[0]->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes); |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
# RPerl::diag( 'in Subroutine->ast_to_cpp__generate_shims__CPPOPS_CPPTYPES(), have $cpp_source_subgroup = ' . "\n" . RPerl::Parser::rperl_ast__dump($cpp_source_subgroup) . "\n" ); |
324
|
|
|
|
|
|
|
$cpp_source_group->{CPP} .= $cpp_source_subgroup->{CPP}; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
$cpp_source_group->{CPP} .= ') ' . ' { return ' . $namespace_underscores . $name . '('; |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# remove type declarations from arguments when passing from shim to real subroutine |
330
|
|
|
|
|
|
|
if (defined $cpp_source_subgroup) { |
331
|
|
|
|
|
|
|
# split on commas, split again on space, discard types, join names on space, join again on commas, append |
332
|
|
|
|
|
|
|
my string_arrayref $split_arguments = [ split ', ', $cpp_source_subgroup->{CPP} ]; |
333
|
|
|
|
|
|
|
my string_arrayref $typeless_arguments = []; |
334
|
|
|
|
|
|
|
foreach my string $argument (@{$split_arguments}) { |
335
|
|
|
|
|
|
|
my string_arrayref $split_argument = [ split /[ ]/xms, $argument ]; |
336
|
|
|
|
|
|
|
push @{$typeless_arguments}, $split_argument->[1]; |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
$cpp_source_group->{CPP} .= ( join ', ', @{$typeless_arguments} ); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
$cpp_source_group->{CPP} .= '); }'; |
342
|
|
|
|
|
|
|
=cut |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
# hard-coded example, CPP macro |
345
|
|
|
|
|
|
|
# #define display_pi_digits(n) MathPerl__Geometry__PiDigits__display_pi_digits(n) |
346
|
8
|
|
|
|
|
22
|
$cpp_source_group->{CPP} .= '#define ' . $name . '('; |
347
|
|
|
|
|
|
|
|
348
|
8
|
100
|
|
|
|
24
|
if ( exists $arguments_optional->{children}->[0] ) { |
349
|
3
|
|
|
|
|
67
|
$cpp_source_subgroup = $arguments_optional->{children}->[0]->ast_to_cpp__generate__CPPOPS_CPPTYPES($modes); |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
# remove type declarations from arguments |
353
|
8
|
|
|
|
|
14
|
my string $typeless_arguments_joined = q{}; |
354
|
8
|
100
|
|
|
|
20
|
if (defined $cpp_source_subgroup) { |
355
|
|
|
|
|
|
|
# split on commas, split again on space, discard types, join names on space, join again on commas, append |
356
|
3
|
|
|
|
|
19
|
my string_arrayref $split_arguments = [ split ', ', $cpp_source_subgroup->{CPP} ]; |
357
|
3
|
|
|
|
|
8
|
my string_arrayref $typeless_arguments = []; |
358
|
3
|
|
|
|
|
7
|
foreach my string $argument (@{$split_arguments}) { |
|
3
|
|
|
|
|
10
|
|
359
|
7
|
|
|
|
|
18
|
my string_arrayref $split_argument = [ split /[ ]/xms, $argument ]; |
360
|
7
|
|
|
|
|
18
|
push @{$typeless_arguments}, $split_argument->[1]; |
|
7
|
|
|
|
|
20
|
|
361
|
|
|
|
|
|
|
} |
362
|
3
|
|
|
|
|
7
|
$typeless_arguments_joined = ( join ', ', @{$typeless_arguments} ); |
|
3
|
|
|
|
|
12
|
|
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
8
|
|
|
|
|
26
|
$cpp_source_group->{CPP} .= $typeless_arguments_joined . ') ' . $namespace_underscores . $name . '(' . $typeless_arguments_joined . ')'; |
366
|
8
|
|
|
|
|
116
|
return $cpp_source_group; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
1; # end of class |