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 branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Build – NEMO

source: branches/2015/dev_r5803_UKMO_AGRIF_Vert_interp/NEMOGCM/EXTERNAL/fcm/lib/Fcm/Build/Fortran.pm @ 5819

Last change on this file since 5819 was 5819, checked in by timgraham, 8 years ago

Deleted fcm keywords

File size: 17.7 KB
Line 
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# ------------------------------------------------------------------------------
6use strict;
7use warnings;
8
9# ------------------------------------------------------------------------------
10package Fcm::Build::Fortran;
11
12use Text::Balanced qw{extract_bracketed extract_delimited};
13
14# Actions of this class
15my %ACTION_OF = (extract_interface => \&_extract_interface);
16
17# Regular expressions
18# Matches a variable attribute
19my $RE_ATTR = qr{
20    allocatable|dimension|external|intent|optional|parameter|pointer|save|target
21}imsx;
22# Matches a name
23my $RE_NAME = qr{[A-Za-z]\w*}imsx;
24# Matches a specification type
25my $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
29my $RE_UNIT_BASE = qr{block\s*data|module|program}imsx;
30# Matches the identifier of a program unit that has arguments
31my $RE_UNIT_CALL = qr{function|subroutine}imsx;
32# Matches the identifier of any program unit
33my $RE_UNIT      = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx;
34my %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
69my %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.
86sub 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.
101for 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.
108sub _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.
114sub _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;
133LINE:
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.
214sub _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
228sub _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.
316sub _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.
359sub _reduce_to_interface {
360    my ($ctx) = @_;
361    my (%token_set, @interface_statements);
362STATEMENT:
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.
480sub _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# ------------------------------------------------------------------------------
4901;
491__END__
492
493=head1 NAME
494
495Fcm::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
507A class to analyse Fortran source. Currently, it has a single method to extract
508the calling interfaces of top level subroutines and functions in a Fortran
509source.
510
511=head1 METHODS
512
513=over 4
514
515=item $class->new()
516
517Creates and returns an instance of this class.
518
519=item $instance->extract_interface($handle)
520
521Extracts the calling interfaces of top level subroutines and functions in a
522Fortran source that can be read from $handle. Returns an interface block as a
523list of lines.
524
525=back
526
527=head1 ACKNOWLEDGEMENT
528
529This module is inspired by the logic developed by the European Centre
530for Medium-Range Weather Forecasts (ECMWF).
531
532=head1 COPYRIGHT
533
534(C) Crown copyright Met Office. All rights reserved.
535
536=cut
Note: See TracBrowser for help on using the repository browser.