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.
ExtractInterface.pm in vendors/lib/FCM/System/Make/Build/Task – NEMO

source: vendors/lib/FCM/System/Make/Build/Task/ExtractInterface.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: 17.1 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 FCM::System::Make::Build::Task::ExtractInterface;
24use base qw{FCM::Class::CODE};
25
26use FCM::System::Exception;
27use Text::Balanced qw{extract_bracketed extract_delimited};
28use Text::ParseWords qw{shellwords};
29
30# Alias
31my $E = 'FCM::System::Exception';
32
33# Regular expressions
34my $RE_ATTR = qr{
35    allocatable|dimension|external|intent|optional|parameter|pointer|save|target
36}imsx;
37my $RE_FILE = qr{[\w\-+.]+}imsx;
38my $RE_NAME = qr{[A-Za-z]\w*}imsx;
39my $RE_SPEC = qr{
40    character|class|complex|double\s*complex|double\s*precision|integer|
41    logical|procedure|real|type
42}imsx;
43my $RE_UNIT_BASE = qr{block\s*data|module|program|submodule}imsx;
44my $RE_UNIT_CALL = qr{function|subroutine}imsx;
45my $RE_UNIT      = qr{$RE_UNIT_BASE|$RE_UNIT_CALL}msx;
46my %RE           = (
47    COMMENT     => qr{\A\s*(?:!|\z)}msx,
48    COMMENT_END => qr{\A([^'"]*?)\s*!.*\z}msx,
49    CONT        => qr{\A(.*)&\s*\z}msx,
50    CONT_LEAD   => qr{\A(\s*&)(.*)\z}msx,
51    INCLUDE     => qr{(?:\#|\s*)include\s*}imsx,
52    NAME_COMP   => qr{\b($RE_NAME)(?:\s*\%\s*$RE_NAME)*\b}msx,
53    NAME_LEAD   => qr{\A\s*$RE_NAME\s*}msx,
54    NAME_LIST   => qr{\A(?:.*?)\s*,\s*($RE_NAME)\b(.*)\z}msx,
55    QUOTE       => qr{\A[^'"]*(['"])}msx,
56    TYPE_ATTR   => qr{\A\s*($RE_ATTR)\b}msx,
57    TYPE_SPEC   => qr{\A\s*($RE_SPEC)\b}msx,
58    UNIT_ATTR   => qr{\A\s*(?:(?:(?:impure\s+)?elemental|recursive|pure)\s+)+(.*)\z}imsx,
59    UNIT_BASE   => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\s*\z}imsx,
60    UNIT_CALL   => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx,
61    UNIT_END  => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\s*\z}imsx,
62    UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx,
63);
64
65# Keywords in type declaration statements
66my %TYPE_DECL_KEYWORD_SET = map { ($_, 1) } qw{
67    allocatable
68    asynchronous
69    contiguous
70    dimension
71    external
72    in
73    inout
74    intent
75    kind
76    len
77    optional
78    out
79    parameter
80    pointer
81    save
82    target
83    value
84    volatile
85};
86
87__PACKAGE__->class({util => '&'}, {action_of => {main => \&_main}});
88
89sub _main {
90    my ($attrib_ref, $target) = @_;
91    my $handle
92        = $attrib_ref->{util}->file_load_handle($target->get_path_of_source());
93    eval {
94        $attrib_ref->{util}->file_save(
95            $target->get_path(),
96            [   map { s{\s+}{ }gmsx; s{\s+\z}{\n}msx; $_ }
97                    map { @{$_->{lines}} }
98                    @{_reduce_to_interface(_extract_statements($handle))}
99            ],
100        );
101    };
102    if ($@) {
103        my $e = $@;
104        if ($E->caught($e) && $e->get_code() eq $E->BUILD_SOURCE_SYN) {
105            unshift(@{$e->get_ctx()}, $target->get_path_of_source());
106        }
107        die($e);
108    }
109    close($handle);
110    $target;
111}
112
113# Reads $handle for the next Fortran statement, handling continuations.
114sub _extract_statements {
115    my ($handle) = @_;
116    my $context = {signature_token_set_of => {}, statements => []};
117    my $state = {
118        in_contains  => undef,
119        in_interface => undef,
120        in_quote     => undef,
121        in_type      => undef,
122        stack        => [],
123    };
124    my $NEW_STATEMENT = sub {
125        {   name        => q{},
126            lines       => [],
127            line_number => 0,
128            symbol      => q{},
129            type        => q{},
130            value       => q{},
131        };
132    };
133    my $statement;
134LINE:
135    while (my $line = readline($handle)) {
136        if (!defined($statement)) {
137            $statement = $NEW_STATEMENT->();
138        }
139        my $value = $line;
140        chomp($value);
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                #push(@{$context->{statements}}, $statement);
150                $statement = undef;
151            }
152            next LINE;
153        }
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        my ($head, $tail) = (q{}, $value);
168        if ($state->{in_quote} && index($value, $state->{in_quote}) >= 0) {
169            my $index = index($value, $state->{in_quote});
170            $head = substr($value, 0, $index + 1);
171            $tail
172                = length($value) > $index + 1
173                ? substr($value, $index + 2)
174                : q{};
175            $state->{in_quote} = undef;
176        }
177        if (!$state->{in_quote}) {
178            while ($tail) {
179                if (index($tail, q{!}) >= 0) {
180                    if (!($tail =~ s/$RE{COMMENT_END}/$1/)) {
181                        ($head, $tail, $state->{in_quote})
182                            = _extract_statement_quote($head, $tail);
183                    }
184                }
185                else {
186                    while (index($tail, q{'}) > 0
187                        || index($tail, q{"}) > 0)
188                    {
189                        ($head, $tail, $state->{in_quote})
190                            = _extract_statement_quote($head, $tail);
191                    }
192                    $head .= $tail;
193                    $tail = q{};
194                }
195            }
196        }
197        $cont_head ||= q{};
198        push(@{$statement->{lines}}, $cont_head . $head . $tail . "\n");
199        $statement->{value} .= $head . $tail;
200        if (!($statement->{value} =~ s/$RE{CONT}/$1/)) {
201            $statement->{value} =~ s{\s+\z}{}msx;
202            if (_process($statement, $context, $state)) {
203                push(@{$context->{statements}}, $statement);
204            }
205            $statement = undef;
206        }
207    }
208    return $context;
209}
210
211# Helper, removes a quoted string from $tail.
212sub _extract_statement_quote {
213    my ($head, $tail) = @_;
214    my ($extracted, $remainder, $prefix)
215        = extract_delimited($tail, q{'"}, qr{[^'"]*}msx, q{});
216    if ($extracted) {
217        return ($head . $prefix . $extracted, $remainder);
218    }
219    else {
220        my ($quote) = $tail =~ $RE{QUOTE};
221        return ($head . $tail, q{}, $quote);
222    }
223}
224
225# Read a statement and put attributes into $statement
226sub _process {
227    my ($statement, $context, $state) = @_;
228    my $name;
229
230    # End Interface
231    if ($state->{in_interface}) {
232        if ($statement->{value} =~ qr{\A\s*end\s*interface\b}imsx) {
233            $state->{in_interface} = 0;
234        }
235        return;
236    }
237
238    # End Program Unit
239    if (@{$state->{stack}} && $statement->{value} =~ qr{\A\s*end\b}imsx) {
240        my ($end, $type, $symbol) = lc($statement->{value}) =~ $RE{UNIT_END};
241        if (!$end) {
242            return;
243        }
244        my ($top_type, $top_symbol) = @{$state->{stack}->[-1]};
245        if (!$type
246            || $top_type eq $type && (!$symbol || $top_symbol eq $symbol))
247        {
248            pop(@{$state->{stack}});
249            if ($state->{in_contains} && !@{$state->{stack}}) {
250                $state->{in_contains} = 0;
251            }
252            if (!$state->{in_contains}) {
253                $statement->{name}   = $top_type;
254                $statement->{symbol} = $top_symbol;
255                $statement->{type}   = 'end';
256                return $statement;
257            }
258        }
259        return;
260    }
261
262    # Interface/Contains
263    if ($statement->{value} =~ qr{\A\s*contains\b}imsx) {
264        $state->{'in_contains'} = 1;
265        return;
266    }
267    if ($statement->{value} =~ qr{\A\s*(?:abstract\s+)?interface\b}imsx) {
268        $state->{'in_interface'} = 1;
269        return;
270    }
271
272    # Program Unit
273    my ($type, $symbol, @tokens) = _process_prog_unit($statement->{value});
274    if ($type) {
275        push(@{$state->{stack}}, [$type, $symbol]);
276        if ($state->{in_contains}) {
277            return;
278        }
279        $statement->{name}   = lc($type);
280        $statement->{type}   = 'signature';
281        $statement->{symbol} = lc($symbol);
282        $context->{signature_token_set_of}{$symbol}
283            = {map { (lc($_) => 1) } @tokens};
284        return $statement;
285    }
286    if ($state->{in_contains}) {
287        return;
288    }
289
290    # Use
291    if ($statement->{value} =~ qr{\A\s*(use)\b}imsx) {
292        $statement->{name} = 'use';
293        $statement->{type} = 'use';
294        return $statement;
295    }
296
297    # Type Declarations
298    ($name) = $statement->{value} =~ $RE{TYPE_SPEC};
299    if ($name) {
300        $name =~ s{\s}{}gmsx;
301        $statement->{name} = lc($name);
302        $statement->{type} = 'type';
303        return $statement;
304    }
305
306    # Attribute Statements
307    ($name) = $statement->{value} =~ $RE{TYPE_ATTR};
308    if ($name) {
309        $statement->{name} = lc($name);
310        $statement->{type} = 'attr';
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    ($type, $symbol) = $string =~ $RE{UNIT_BASE};
320    if ($type) {
321        $type = lc($type);
322        $type =~ s{\s*}{}gmsx;
323        return ($type, $symbol);
324    }
325    $string =~ s/$RE{UNIT_ATTR}/$1/;
326    my ($match) = $string =~ $RE{UNIT_SPEC};
327    if ($match) {
328        $string = $match;
329        extract_bracketed($string);
330    }
331    ($type, $symbol) = lc($string) =~ $RE{UNIT_CALL};
332    if (!$type) {
333        return;
334    }
335    my $extracted = extract_bracketed($string, q{()}, qr{[^(]*}msx);
336
337    # Get arguments/keywords from SUBROUTINE/FUNCTION
338    if ($extracted) {
339        $extracted =~ s{\s}{}gmsx;
340        @args = split(q{,}, substr($extracted, 1, length($extracted) - 2));
341        if ($type eq 'function') {
342            my $result = extract_bracketed($string, q{()}, qr{[^(]*}msx);
343            if ($result) {
344                $result =~ s{\A\(\s*(.*?)\s*\)\z}{$1}msx;    # remove braces
345                push(@args, $result);
346            }
347            else {
348                push(@args, $symbol);
349            }
350        }
351    }
352    return (lc($type), lc($symbol), map { lc($_) } @args);
353}
354
355# Reduces the list of statements to contain only the interface block.
356sub _reduce_to_interface {
357    my ($context) = @_;
358    my (%token_set, @interface_statements);
359STATEMENT:
360    for my $statement (reverse(@{$context->{statements}})) {
361        if ($statement->{type} eq 'end'
362            && grep { $_ eq $statement->{name} } qw{subroutine function})
363        {
364            push(@interface_statements, $statement);
365            %token_set
366                = %{$context->{signature_token_set_of}{$statement->{symbol}}};
367            next STATEMENT;
368        }
369        if ($statement->{type} eq 'signature'
370            && grep { $_ eq $statement->{name} } qw{subroutine function})
371        {
372            push(@interface_statements, $statement);
373            %token_set = ();
374            next STATEMENT;
375        }
376        if ($statement->{type} eq 'use') {
377            my ($head, $tail)
378                = split(qr{,\s*only\s*:\s*}msx, lc($statement->{value}), 2);
379            if ($tail) {
380                my @imports = map { [split(qr{\s*=>\s*}msx, $_, 2)] }
381                    split(qr{\s*,\s*}msx, $tail);
382                my @useful_imports
383                    = grep { exists($token_set{$_->[0]}) } @imports;
384                if (!@useful_imports) {
385                    next STATEMENT;
386                }
387                if (@imports != @useful_imports) {
388                    my @token_strings
389                        = map { $_->[0] . ($_->[1] ? ' => ' . $_->[1] : q{}) }
390                        @useful_imports;
391                    my ($last, @rest) = reverse(@token_strings);
392                    my @token_lines
393                        = (reverse(map { $_ . q{,&} } @rest), $last);
394                    push(
395                        @interface_statements,
396                        {   lines => [
397                                sprintf("%s, only:&\n", $head),
398                                (map { sprintf(" & %s\n", $_) } @token_lines),
399                            ]
400                        },
401                    );
402                    next STATEMENT;
403                }
404            }
405            push(@interface_statements, $statement);
406            next STATEMENT;
407        }
408        if ($statement->{type} eq 'attr') {
409            my ($spec, @tokens) = ($statement->{value} =~ /$RE{NAME_COMP}/g);
410            if (grep { exists($token_set{lc($_)}) } @tokens) {
411                for my $token (@tokens) {
412                    $token_set{$token} = 1;
413                }
414                push(@interface_statements, $statement);
415                next STATEMENT;
416            }
417        }
418        if ($statement->{type} eq 'type') {
419            my ($variable_string, $spec_string)
420                = reverse(split('::', lc($statement->{value}), 2));
421            if ($spec_string) {
422                $spec_string =~ s{$RE{NAME_LEAD}}{}msx;
423            }
424            else {
425                $variable_string =~ s{$RE{NAME_LEAD}}{}msx;
426                $spec_string = extract_bracketed($variable_string, '()',
427                    qr{[\s\*]*}msx);
428            }
429            my $tail = q{,} . lc($variable_string);
430            my @tokens;
431            while ($tail) {
432                if ($tail =~ qr{\A\s*['"]}msx) {
433                    my $old_tail = $tail;
434                    extract_delimited($tail, q{'"}, qr{\A[^'"]*}msx, q{});
435                    if ($old_tail eq $tail) {
436                        return $E->throw(
437                            $E->BUILD_SOURCE_SYN, [$statement->{line_number}]);
438                    }
439                }
440                elsif ($tail =~ qr{\A\s*\(}msx) {
441                    my $old_tail = $tail;
442                    extract_bracketed($tail, '()', qr{\A[^(]*}msx);
443                    if ($old_tail eq $tail) {
444                        return $E->throw(
445                            $E->BUILD_SOURCE_SYN, [$statement->{line_number}]);
446                    }
447                }
448                else {
449                    my $token;
450                    ($token, $tail) = $tail =~ $RE{NAME_LIST};
451                    if ($token && $token_set{$token}) {
452                        @tokens = ($variable_string =~ /$RE{NAME_COMP}/g);
453                        $tail = q{};
454                    }
455                }
456            }
457            if (@tokens && $spec_string) {
458                my @spec_tokens = (lc($spec_string) =~ /$RE{NAME_COMP}/g);
459                push(
460                    @tokens,
461                    (   grep { !exists($TYPE_DECL_KEYWORD_SET{$_}) }
462                            @spec_tokens
463                    ),
464                );
465            }
466            if (grep { exists($token_set{$_}) } @tokens) {
467                for my $token (@tokens) {
468                    $token_set{$token} = 1;
469                }
470                push(@interface_statements, $statement);
471                next STATEMENT;
472            }
473        }
474    }
475    if (!@interface_statements) {
476        return [];
477    }
478    [   {lines => ["interface\n"]},
479        reverse(@interface_statements),
480        {lines => ["end interface\n"]},
481    ];
482}
483
484# ------------------------------------------------------------------------------
4851;
486__END__
487
488=head1 NAME
489
490FCM::System::Make::Build::Task::ExtractInterface
491
492=head1 SYNOPSIS
493
494    use FCM::System::Make::Build::Task::ExtractInterface;
495    my $task = FCM::System::Make::Build::Task::ExtractInterface->new(\%attrib);
496    $task->main($target);
497
498=head1 DESCRIPTION
499
500Extracts the calling interfaces of top level functions and subroutines in the
501Fortran source file of the target.
502
503=head1 METHODS
504
505=over 4
506
507=item $class->new(\%attrib)
508
509Creates and returns a new instance. %attrib should contain:
510
511=over 4
512
513=item {util}
514
515An instance of L<FCM::Util|FCM::Util>.
516
517=back
518
519=item $instance->main($target)
520
521Extracts the calling interfaces of top level functions and subroutines in the
522Fortran source file of the target, and writes the results to the path of the
523target.
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.