New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Fortran.pm in vendors/lib/FCM1/Build – NEMO

source: vendors/lib/FCM1/Build/Fortran.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing

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