| 1 | # ------------------------------------------------------------------------------ |
|---|
| 2 | # (C) Crown copyright Met Office. All rights reserved. |
|---|
| 3 | # For further details please refer to the file COPYRIGHT.txt |
|---|
| 4 | # which you should have received as part of this distribution. |
|---|
| 5 | # ------------------------------------------------------------------------------ |
|---|
| 6 | use strict; |
|---|
| 7 | use warnings; |
|---|
| 8 | |
|---|
| 9 | # ------------------------------------------------------------------------------ |
|---|
| 10 | package Fcm::Build::Fortran; |
|---|
| 11 | |
|---|
| 12 | use Text::Balanced qw{extract_bracketed extract_delimited}; |
|---|
| 13 | |
|---|
| 14 | # Actions of this class |
|---|
| 15 | my %ACTION_OF = (extract_interface => \&_extract_interface); |
|---|
| 16 | |
|---|
| 17 | # Regular expressions |
|---|
| 18 | # Matches a variable attribute |
|---|
| 19 | my $RE_ATTR = qr{ |
|---|
| 20 | allocatable|dimension|external|intent|optional|parameter|pointer|save|target |
|---|
| 21 | }imsx; |
|---|
| 22 | # Matches a name |
|---|
| 23 | my $RE_NAME = qr{[A-Za-z]\w*}imsx; |
|---|
| 24 | # Matches a specification type |
|---|
| 25 | my $RE_SPEC = qr{ |
|---|
| 26 | character|complex|double\s*precision|integer|logical|real|type |
|---|
| 27 | }imsx; |
|---|
| 28 | # Matches the identifier of a program unit that does not have arguments |
|---|
| 29 | my $RE_UNIT_BASE = qr{block\s*data|module|program}imsx; |
|---|
| 30 | # Matches the identifier of a program unit that has arguments |
|---|
| 31 | my $RE_UNIT_CALL = qr{function|subroutine}imsx; |
|---|
| 32 | # Matches the identifier of any program unit |
|---|
| 33 | my $RE_UNIT = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx; |
|---|
| 34 | my %RE = ( |
|---|
| 35 | # A comment line |
|---|
| 36 | COMMENT => qr{\A\s*(?:!|\z)}msx, |
|---|
| 37 | # A trailing comment, capture the expression before the comment |
|---|
| 38 | COMMENT_END => qr{\A([^'"]*?)\s*!.*\z}msx, |
|---|
| 39 | # A contination marker, capture the expression before the marker |
|---|
| 40 | CONT => qr{\A(.*)&\s*\z}msx, |
|---|
| 41 | # A contination marker at the beginning of a line, capture the marker and |
|---|
| 42 | # the expression after the marker |
|---|
| 43 | CONT_LEAD => qr{\A(\s*&)(.*)\z}msx, |
|---|
| 44 | # Capture a variable identifier, removing any type component expression |
|---|
| 45 | NAME_COMP => qr{\b($RE_NAME)(?:\s*\%\s*$RE_NAME)*\b}msx, |
|---|
| 46 | # Matches the first identifier in a line |
|---|
| 47 | NAME_LEAD => qr{\A\s*$RE_NAME\s*}msx, |
|---|
| 48 | # Captures a name identifier after a comma, and the expression after |
|---|
| 49 | NAME_LIST => qr{\A(?:.*?)\s*,\s*($RE_NAME)\b(.*)\z}msx, |
|---|
| 50 | # Captures the next quote character |
|---|
| 51 | QUOTE => qr{\A[^'"]*(['"])}msx, |
|---|
| 52 | # Matches an attribute declaration |
|---|
| 53 | TYPE_ATTR => qr{\A\s*($RE_ATTR)\b}msx, |
|---|
| 54 | # Matches a type declaration |
|---|
| 55 | TYPE_SPEC => qr{\A\s*($RE_SPEC)\b}msx, |
|---|
| 56 | # Captures the expression after one or more program unit attributes |
|---|
| 57 | UNIT_ATTR => qr{\A\s*(?:(?:elemental|recursive|pure)\s+)+(.*)\z}imsx, |
|---|
| 58 | # Captures the identifier and the symbol of a program unit with no arguments |
|---|
| 59 | UNIT_BASE => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\s*\z}imsx, |
|---|
| 60 | # Captures the identifier and the symbol of a program unit with arguments |
|---|
| 61 | UNIT_CALL => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx, |
|---|
| 62 | # Captures the end of a program unit, its identifier and its symbol |
|---|
| 63 | UNIT_END => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\s*\z}imsx, |
|---|
| 64 | # Captures the expression after a program unit type specification |
|---|
| 65 | UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx, |
|---|
| 66 | ); |
|---|
| 67 | |
|---|
| 68 | # Keywords in type declaration statements |
|---|
| 69 | my %TYPE_DECL_KEYWORD_SET = map { ($_, 1) } qw{ |
|---|
| 70 | allocatable |
|---|
| 71 | dimension |
|---|
| 72 | in |
|---|
| 73 | inout |
|---|
| 74 | intent |
|---|
| 75 | kind |
|---|
| 76 | len |
|---|
| 77 | optional |
|---|
| 78 | out |
|---|
| 79 | parameter |
|---|
| 80 | pointer |
|---|
| 81 | save |
|---|
| 82 | target |
|---|
| 83 | }; |
|---|
| 84 | |
|---|
| 85 | # Creates and returns an instance of this class. |
|---|
| 86 | sub new { |
|---|
| 87 | my ($class) = @_; |
|---|
| 88 | bless( |
|---|
| 89 | sub { |
|---|
| 90 | my $key = shift(); |
|---|
| 91 | if (!exists($ACTION_OF{$key})) { |
|---|
| 92 | return; |
|---|
| 93 | } |
|---|
| 94 | $ACTION_OF{$key}->(@_); |
|---|
| 95 | }, |
|---|
| 96 | $class, |
|---|
| 97 | ); |
|---|
| 98 | } |
|---|
| 99 | |
|---|
| 100 | # Methods. |
|---|
| 101 | for my $key (keys(%ACTION_OF)) { |
|---|
| 102 | no strict qw{refs}; |
|---|
| 103 | *{$key} = sub { my $self = shift(); $self->($key, @_) }; |
|---|
| 104 | } |
|---|
| 105 | |
|---|
| 106 | # Extracts the calling interfaces of top level subroutines and functions from |
|---|
| 107 | # the $handle for reading Fortran sources. |
|---|
| 108 | sub _extract_interface { |
|---|
| 109 | my ($handle) = @_; |
|---|
| 110 | map { _present_line($_) } @{_reduce_to_interface(_load($handle))}; |
|---|
| 111 | } |
|---|
| 112 | |
|---|
| 113 | # Reads $handle for the next Fortran statement, handling continuations. |
|---|
| 114 | sub _load { |
|---|
| 115 | my ($handle) = @_; |
|---|
| 116 | my $ctx = {signature_token_set_of => {}, statements => []}; |
|---|
| 117 | my $state = { |
|---|
| 118 | in_contains => undef, # in a "contains" section of a program unit |
|---|
| 119 | in_interface => undef, # in an "interface" block |
|---|
| 120 | in_quote => undef, # in a multi-line quote |
|---|
| 121 | stack => [], # program unit stack |
|---|
| 122 | }; |
|---|
| 123 | my $NEW_STATEMENT = sub { |
|---|
| 124 | { name => q{}, # statement name, e.g. function, integer, ... |
|---|
| 125 | lines => [], # original lines in the statement |
|---|
| 126 | line_number => 0, # line number (start) in the original source |
|---|
| 127 | symbol => q{}, # name of a program unit (signature, end) |
|---|
| 128 | type => q{}, # e.g. signature, use, type, attr, end |
|---|
| 129 | value => q{}, # the actual value of the statement |
|---|
| 130 | }; |
|---|
| 131 | }; |
|---|
| 132 | my $statement; |
|---|
| 133 | LINE: |
|---|
| 134 | while (my $line = readline($handle)) { |
|---|
| 135 | if (!defined($statement)) { |
|---|
| 136 | $statement = $NEW_STATEMENT->(); |
|---|
| 137 | } |
|---|
| 138 | my $value = $line; |
|---|
| 139 | chomp($value); |
|---|
| 140 | # Pre-processor directives and continuation |
|---|
| 141 | if (!$statement->{line_number} && index($value, '#') == 0) { |
|---|
| 142 | $statement->{line_number} = $.; |
|---|
| 143 | $statement->{name} = 'cpp'; |
|---|
| 144 | } |
|---|
| 145 | if ($statement->{name} eq 'cpp') { |
|---|
| 146 | push(@{$statement->{lines}}, $line); |
|---|
| 147 | $statement->{value} .= $value; |
|---|
| 148 | if (rindex($value, '\\') != length($value) - 1) { |
|---|
| 149 | $statement = undef; |
|---|
| 150 | } |
|---|
| 151 | next LINE; |
|---|
| 152 | } |
|---|
| 153 | # Normal Fortran |
|---|
| 154 | if ($value =~ $RE{COMMENT}) { |
|---|
| 155 | next LINE; |
|---|
| 156 | } |
|---|
| 157 | if (!$statement->{line_number}) { |
|---|
| 158 | $statement->{line_number} = $.; |
|---|
| 159 | } |
|---|
| 160 | my ($cont_head, $cont_tail); |
|---|
| 161 | if ($statement->{line_number} != $.) { # is a continuation |
|---|
| 162 | ($cont_head, $cont_tail) = $value =~ $RE{CONT_LEAD}; |
|---|
| 163 | if ($cont_head) { |
|---|
| 164 | $value = $cont_tail; |
|---|
| 165 | } |
|---|
| 166 | } |
|---|
| 167 | # Correctly handle ! and & in quotes |
|---|
| 168 | my ($head, $tail) = (q{}, $value); |
|---|
| 169 | if ($state->{in_quote} && index($value, $state->{in_quote}) >= 0) { |
|---|
| 170 | my $index = index($value, $state->{in_quote}); |
|---|
| 171 | $head = substr($value, 0, $index + 1); |
|---|
| 172 | $tail |
|---|
| 173 | = length($value) > $index + 1 |
|---|
| 174 | ? substr($value, $index + 2) |
|---|
| 175 | : q{}; |
|---|
| 176 | $state->{in_quote} = undef; |
|---|
| 177 | } |
|---|
| 178 | if (!$state->{in_quote}) { |
|---|
| 179 | while ($tail) { |
|---|
| 180 | if (index($tail, q{!}) >= 0) { |
|---|
| 181 | if (!($tail =~ s/$RE{COMMENT_END}/$1/)) { |
|---|
| 182 | ($head, $tail, $state->{in_quote}) |
|---|
| 183 | = _load_extract_quote($head, $tail); |
|---|
| 184 | } |
|---|
| 185 | } |
|---|
| 186 | else { |
|---|
| 187 | while (index($tail, q{'}) > 0 |
|---|
| 188 | || index($tail, q{"}) > 0) |
|---|
| 189 | { |
|---|
| 190 | ($head, $tail, $state->{in_quote}) |
|---|
| 191 | = _load_extract_quote($head, $tail); |
|---|
| 192 | } |
|---|
| 193 | $head .= $tail; |
|---|
| 194 | $tail = q{}; |
|---|
| 195 | } |
|---|
| 196 | } |
|---|
| 197 | } |
|---|
| 198 | $cont_head ||= q{}; |
|---|
| 199 | push(@{$statement->{lines}}, $cont_head . $head . $tail . "\n"); |
|---|
| 200 | $statement->{value} .= $head . $tail; |
|---|
| 201 | # Process a statement only if it is marked with a continuation |
|---|
| 202 | if (!($statement->{value} =~ s/$RE{CONT}/$1/)) { |
|---|
| 203 | $statement->{value} =~ s{\s+\z}{}msx; |
|---|
| 204 | if (_process($statement, $ctx, $state)) { |
|---|
| 205 | push(@{$ctx->{statements}}, $statement); |
|---|
| 206 | } |
|---|
| 207 | $statement = undef; |
|---|
| 208 | } |
|---|
| 209 | } |
|---|
| 210 | return $ctx; |
|---|
| 211 | } |
|---|
| 212 | |
|---|
| 213 | # Helper, removes a quoted string from $tail. |
|---|
| 214 | sub _load_extract_quote { |
|---|
| 215 | my ($head, $tail) = @_; |
|---|
| 216 | my ($extracted, $remainder, $prefix) |
|---|
| 217 | = extract_delimited($tail, q{'"}, qr{[^'"]*}msx, q{}); |
|---|
| 218 | if ($extracted) { |
|---|
| 219 | return ($head . $prefix . $extracted, $remainder); |
|---|
| 220 | } |
|---|
| 221 | else { |
|---|
| 222 | my ($quote) = $tail =~ $RE{QUOTE}; |
|---|
| 223 | return ($head . $tail, q{}, $quote); |
|---|
| 224 | } |
|---|
| 225 | } |
|---|
| 226 | |
|---|
| 227 | # Study statements and put attributes into array $statements |
|---|
| 228 | sub _process { |
|---|
| 229 | my ($statement, $ctx, $state) = @_; |
|---|
| 230 | my $name; |
|---|
| 231 | |
|---|
| 232 | # End Interface |
|---|
| 233 | if ($state->{in_interface}) { |
|---|
| 234 | if ($statement->{value} =~ qr{\A\s*end\s*interface\b}imsx) { |
|---|
| 235 | $state->{in_interface} = 0; |
|---|
| 236 | } |
|---|
| 237 | return; |
|---|
| 238 | } |
|---|
| 239 | |
|---|
| 240 | # End Program Unit |
|---|
| 241 | if (@{$state->{stack}} && $statement->{value} =~ qr{\A\s*end\b}imsx) { |
|---|
| 242 | my ($end, $type, $symbol) = lc($statement->{value}) =~ $RE{UNIT_END}; |
|---|
| 243 | if (!$end) { |
|---|
| 244 | return; |
|---|
| 245 | } |
|---|
| 246 | my ($top_type, $top_symbol) = @{$state->{stack}->[-1]}; |
|---|
| 247 | if (!$type |
|---|
| 248 | || $top_type eq $type && (!$symbol || $top_symbol eq $symbol)) |
|---|
| 249 | { |
|---|
| 250 | pop(@{$state->{stack}}); |
|---|
| 251 | if ($state->{in_contains} && !@{$state->{stack}}) { |
|---|
| 252 | $state->{in_contains} = 0; |
|---|
| 253 | } |
|---|
| 254 | if (!$state->{in_contains}) { |
|---|
| 255 | $statement->{name} = $top_type; |
|---|
| 256 | $statement->{symbol} = $top_symbol; |
|---|
| 257 | $statement->{type} = 'end'; |
|---|
| 258 | return $statement; |
|---|
| 259 | } |
|---|
| 260 | } |
|---|
| 261 | return; |
|---|
| 262 | } |
|---|
| 263 | |
|---|
| 264 | # Interface/Contains |
|---|
| 265 | ($name) = $statement->{value} =~ qr{\A\s*(contains|interface)\b}imsx; |
|---|
| 266 | if ($name) { |
|---|
| 267 | $state->{'in_' . lc($name)} = 1; |
|---|
| 268 | return; |
|---|
| 269 | } |
|---|
| 270 | |
|---|
| 271 | # Program Unit |
|---|
| 272 | my ($type, $symbol, @tokens) = _process_prog_unit($statement->{value}); |
|---|
| 273 | if ($type) { |
|---|
| 274 | push(@{$state->{stack}}, [$type, $symbol]); |
|---|
| 275 | if ($state->{in_contains}) { |
|---|
| 276 | return; |
|---|
| 277 | } |
|---|
| 278 | $statement->{name} = lc($type); |
|---|
| 279 | $statement->{type} = 'signature'; |
|---|
| 280 | $statement->{symbol} = lc($symbol); |
|---|
| 281 | $ctx->{signature_token_set_of}{$symbol} |
|---|
| 282 | = {map { (lc($_) => 1) } @tokens}; |
|---|
| 283 | return $statement; |
|---|
| 284 | } |
|---|
| 285 | if ($state->{in_contains}) { |
|---|
| 286 | return; |
|---|
| 287 | } |
|---|
| 288 | |
|---|
| 289 | # Use |
|---|
| 290 | if ($statement->{value} =~ qr{\A\s*(use)\b}imsx) { |
|---|
| 291 | $statement->{name} = 'use'; |
|---|
| 292 | $statement->{type} = 'use'; |
|---|
| 293 | return $statement; |
|---|
| 294 | } |
|---|
| 295 | |
|---|
| 296 | # Type Declarations |
|---|
| 297 | ($name) = $statement->{value} =~ $RE{TYPE_SPEC}; |
|---|
| 298 | if ($name) { |
|---|
| 299 | $name =~ s{\s}{}gmsx; |
|---|
| 300 | $statement->{name} = lc($name); |
|---|
| 301 | $statement->{type} = 'type'; |
|---|
| 302 | return $statement; |
|---|
| 303 | } |
|---|
| 304 | |
|---|
| 305 | # Attribute Statements |
|---|
| 306 | ($name) = $statement->{value} =~ $RE{TYPE_ATTR}; |
|---|
| 307 | if ($name) { |
|---|
| 308 | $statement->{name} = $name; |
|---|
| 309 | $statement->{type} = 'attr'; |
|---|
| 310 | return $statement; |
|---|
| 311 | } |
|---|
| 312 | } |
|---|
| 313 | |
|---|
| 314 | # Parse a statement for program unit header. Returns a list containing the type, |
|---|
| 315 | # the symbol and the signature tokens of the program unit. |
|---|
| 316 | sub _process_prog_unit { |
|---|
| 317 | my ($string) = @_; |
|---|
| 318 | my ($type, $symbol, @args) = (q{}, q{}); |
|---|
| 319 | # Is it a blockdata, module or program? |
|---|
| 320 | ($type, $symbol) = $string =~ $RE{UNIT_BASE}; |
|---|
| 321 | if ($type) { |
|---|
| 322 | $type = lc($type); |
|---|
| 323 | $type =~ s{\s*}{}gmsx; |
|---|
| 324 | return ($type, $symbol); |
|---|
| 325 | } |
|---|
| 326 | # Remove the attribute and type declaration of a procedure |
|---|
| 327 | $string =~ s/$RE{UNIT_ATTR}/$1/; |
|---|
| 328 | my ($match) = $string =~ $RE{UNIT_SPEC}; |
|---|
| 329 | if ($match) { |
|---|
| 330 | $string = $match; |
|---|
| 331 | extract_bracketed($string); |
|---|
| 332 | } |
|---|
| 333 | # Is it a function or subroutine? |
|---|
| 334 | ($type, $symbol) = lc($string) =~ $RE{UNIT_CALL}; |
|---|
| 335 | if (!$type) { |
|---|
| 336 | return; |
|---|
| 337 | } |
|---|
| 338 | my $extracted = extract_bracketed($string, q{()}, qr{[^(]*}msx); |
|---|
| 339 | |
|---|
| 340 | # Get signature tokens from SUBROUTINE/FUNCTION |
|---|
| 341 | if ($extracted) { |
|---|
| 342 | $extracted =~ s{\s}{}gmsx; |
|---|
| 343 | @args = split(q{,}, substr($extracted, 1, length($extracted) - 2)); |
|---|
| 344 | if ($type eq 'function') { |
|---|
| 345 | my $result = extract_bracketed($string, q{()}, qr{[^(]*}msx); |
|---|
| 346 | if ($result) { |
|---|
| 347 | $result =~ s{\A\(\s*(.*?)\s*\)\z}{$1}msx; # remove braces |
|---|
| 348 | push(@args, $result); |
|---|
| 349 | } |
|---|
| 350 | else { |
|---|
| 351 | push(@args, $symbol); |
|---|
| 352 | } |
|---|
| 353 | } |
|---|
| 354 | } |
|---|
| 355 | return (lc($type), lc($symbol), map { lc($_) } @args); |
|---|
| 356 | } |
|---|
| 357 | |
|---|
| 358 | # Reduces the list of statements to contain only the interface block. |
|---|
| 359 | sub _reduce_to_interface { |
|---|
| 360 | my ($ctx) = @_; |
|---|
| 361 | my (%token_set, @interface_statements); |
|---|
| 362 | STATEMENT: |
|---|
| 363 | for my $statement (reverse(@{$ctx->{statements}})) { |
|---|
| 364 | if ($statement->{type} eq 'end' |
|---|
| 365 | && grep { $_ eq $statement->{name} } qw{subroutine function}) |
|---|
| 366 | { |
|---|
| 367 | push(@interface_statements, $statement); |
|---|
| 368 | %token_set |
|---|
| 369 | = %{$ctx->{signature_token_set_of}{$statement->{symbol}}}; |
|---|
| 370 | next STATEMENT; |
|---|
| 371 | } |
|---|
| 372 | if ($statement->{type} eq 'signature' |
|---|
| 373 | && grep { $_ eq $statement->{name} } qw{subroutine function}) |
|---|
| 374 | { |
|---|
| 375 | push(@interface_statements, $statement); |
|---|
| 376 | %token_set = (); |
|---|
| 377 | next STATEMENT; |
|---|
| 378 | } |
|---|
| 379 | if ($statement->{type} eq 'use') { |
|---|
| 380 | my ($head, $tail) |
|---|
| 381 | = split(qr{\s*:\s*}msx, lc($statement->{value}), 2); |
|---|
| 382 | if ($tail) { |
|---|
| 383 | my @imports = map { [split(qr{\s*=>\s*}msx, $_, 2)] } |
|---|
| 384 | split(qr{\s*,\s*}msx, $tail); |
|---|
| 385 | my @useful_imports |
|---|
| 386 | = grep { exists($token_set{$_->[0]}) } @imports; |
|---|
| 387 | if (!@useful_imports) { |
|---|
| 388 | next STATEMENT; |
|---|
| 389 | } |
|---|
| 390 | if (@imports != @useful_imports) { |
|---|
| 391 | my @token_strings |
|---|
| 392 | = map { $_->[0] . ($_->[1] ? ' => ' . $_->[1] : q{}) } |
|---|
| 393 | @useful_imports; |
|---|
| 394 | my ($last, @rest) = reverse(@token_strings); |
|---|
| 395 | my @token_lines |
|---|
| 396 | = (reverse(map { $_ . q{,&} } @rest), $last); |
|---|
| 397 | push( |
|---|
| 398 | @interface_statements, |
|---|
| 399 | { lines => [ |
|---|
| 400 | sprintf("%s:&\n", $head), |
|---|
| 401 | (map { sprintf(" & %s\n", $_) } @token_lines), |
|---|
| 402 | ] |
|---|
| 403 | }, |
|---|
| 404 | ); |
|---|
| 405 | next STATEMENT; |
|---|
| 406 | } |
|---|
| 407 | } |
|---|
| 408 | push(@interface_statements, $statement); |
|---|
| 409 | next STATEMENT; |
|---|
| 410 | } |
|---|
| 411 | if ($statement->{type} eq 'attr') { |
|---|
| 412 | my ($spec, @tokens) = ($statement->{value} =~ /$RE{NAME_COMP}/g); |
|---|
| 413 | if (grep { exists($token_set{$_}) } @tokens) { |
|---|
| 414 | for my $token (@tokens) { |
|---|
| 415 | $token_set{$token} = 1; |
|---|
| 416 | } |
|---|
| 417 | push(@interface_statements, $statement); |
|---|
| 418 | next STATEMENT; |
|---|
| 419 | } |
|---|
| 420 | } |
|---|
| 421 | if ($statement->{type} eq 'type') { |
|---|
| 422 | my ($variable_string, $spec_string) |
|---|
| 423 | = reverse(split('::', lc($statement->{value}), 2)); |
|---|
| 424 | if ($spec_string) { |
|---|
| 425 | $spec_string =~ s{$RE{NAME_LEAD}}{}msx; |
|---|
| 426 | } |
|---|
| 427 | else { |
|---|
| 428 | # The first expression in the statement is the type + attrib |
|---|
| 429 | $variable_string =~ s{$RE{NAME_LEAD}}{}msx; |
|---|
| 430 | $spec_string = extract_bracketed($variable_string, '()', |
|---|
| 431 | qr{[\s\*]*}msx); |
|---|
| 432 | } |
|---|
| 433 | # Useful tokens are those that comes after a comma |
|---|
| 434 | my $tail = q{,} . lc($variable_string); |
|---|
| 435 | my @tokens; |
|---|
| 436 | while ($tail) { |
|---|
| 437 | if ($tail =~ qr{\A\s*['"]}msx) { |
|---|
| 438 | extract_delimited($tail, q{'"}, qr{\A[^'"]*}msx, q{}); |
|---|
| 439 | } |
|---|
| 440 | elsif ($tail =~ qr{\A\s*\(}msx) { |
|---|
| 441 | extract_bracketed($tail, '()', qr{\A[^(]*}msx); |
|---|
| 442 | } |
|---|
| 443 | else { |
|---|
| 444 | my $token; |
|---|
| 445 | ($token, $tail) = $tail =~ $RE{NAME_LIST}; |
|---|
| 446 | if ($token && $token_set{$token}) { |
|---|
| 447 | @tokens = ($variable_string =~ /$RE{NAME_COMP}/g); |
|---|
| 448 | $tail = q{}; |
|---|
| 449 | } |
|---|
| 450 | } |
|---|
| 451 | } |
|---|
| 452 | if (@tokens && $spec_string) { |
|---|
| 453 | my @spec_tokens = (lc($spec_string) =~ /$RE{NAME_COMP}/g); |
|---|
| 454 | push( |
|---|
| 455 | @tokens, |
|---|
| 456 | ( grep { !exists($TYPE_DECL_KEYWORD_SET{$_}) } |
|---|
| 457 | @spec_tokens |
|---|
| 458 | ), |
|---|
| 459 | ); |
|---|
| 460 | } |
|---|
| 461 | if (grep { exists($token_set{$_}) } @tokens) { |
|---|
| 462 | for my $token (@tokens) { |
|---|
| 463 | $token_set{$token} = 1; |
|---|
| 464 | } |
|---|
| 465 | push(@interface_statements, $statement); |
|---|
| 466 | next STATEMENT; |
|---|
| 467 | } |
|---|
| 468 | } |
|---|
| 469 | } |
|---|
| 470 | if (!@interface_statements) { |
|---|
| 471 | return []; |
|---|
| 472 | } |
|---|
| 473 | [ {lines => ["interface\n"]}, |
|---|
| 474 | reverse(@interface_statements), |
|---|
| 475 | {lines => ["end interface\n"]}, |
|---|
| 476 | ]; |
|---|
| 477 | } |
|---|
| 478 | |
|---|
| 479 | # Processes and returns the line of the statement. |
|---|
| 480 | sub _present_line { |
|---|
| 481 | my ($statement) = @_; |
|---|
| 482 | map { |
|---|
| 483 | s{\s+}{ }gmsx; # collapse multiple spaces |
|---|
| 484 | s{\s+\z}{\n}msx; # remove trailing spaces |
|---|
| 485 | $_; |
|---|
| 486 | } @{$statement->{lines}}; |
|---|
| 487 | } |
|---|
| 488 | |
|---|
| 489 | # ------------------------------------------------------------------------------ |
|---|
| 490 | 1; |
|---|
| 491 | __END__ |
|---|
| 492 | |
|---|
| 493 | =head1 NAME |
|---|
| 494 | |
|---|
| 495 | Fcm::Build::Fortran |
|---|
| 496 | |
|---|
| 497 | =head1 SYNOPSIS |
|---|
| 498 | |
|---|
| 499 | use Fcm::Build::Fortran; |
|---|
| 500 | my $fortran_util = Fcm::Build::Fortran->new(); |
|---|
| 501 | open(my($handle), '<', $path_to_a_fortran_source_file); |
|---|
| 502 | print($fortran_util->extract_interface($handle)); # prints interface |
|---|
| 503 | close($handle); |
|---|
| 504 | |
|---|
| 505 | =head1 DESCRIPTION |
|---|
| 506 | |
|---|
| 507 | A class to analyse Fortran source. Currently, it has a single method to extract |
|---|
| 508 | the calling interfaces of top level subroutines and functions in a Fortran |
|---|
| 509 | source. |
|---|
| 510 | |
|---|
| 511 | =head1 METHODS |
|---|
| 512 | |
|---|
| 513 | =over 4 |
|---|
| 514 | |
|---|
| 515 | =item $class->new() |
|---|
| 516 | |
|---|
| 517 | Creates and returns an instance of this class. |
|---|
| 518 | |
|---|
| 519 | =item $instance->extract_interface($handle) |
|---|
| 520 | |
|---|
| 521 | Extracts the calling interfaces of top level subroutines and functions in a |
|---|
| 522 | Fortran source that can be read from $handle. Returns an interface block as a |
|---|
| 523 | list of lines. |
|---|
| 524 | |
|---|
| 525 | =back |
|---|
| 526 | |
|---|
| 527 | =head1 ACKNOWLEDGEMENT |
|---|
| 528 | |
|---|
| 529 | This module is inspired by the logic developed by the European Centre |
|---|
| 530 | for Medium-Range Weather Forecasts (ECMWF). |
|---|
| 531 | |
|---|
| 532 | =head1 COPYRIGHT |
|---|
| 533 | |
|---|
| 534 | (C) Crown copyright Met Office. All rights reserved. |
|---|
| 535 | |
|---|
| 536 | =cut |
|---|
