# ------------------------------------------------------------------------------
# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
#
# This file is part of FCM, tools for managing and building source code.
#
# FCM is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# FCM is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with FCM. If not, see .
# ------------------------------------------------------------------------------
use strict;
use warnings;
# ------------------------------------------------------------------------------
package FCM::System::Make::Build::FileType::Fortran;
use base qw{FCM::System::Make::Build::FileType};
use FCM::Context::Make::Build; # for FCM::Context::Make::Build::Target
use FCM::System::Make::Build::Task::Compile::Fortran;
use FCM::System::Make::Build::Task::ExtractInterface;
use FCM::System::Make::Build::Task::Install;
use FCM::System::Make::Build::Task::Link::Fortran;
use File::Basename qw{basename};
use Text::Balanced qw{extract_bracketed extract_delimited};
# Recommended file extensions of this utility
our $FILE_EXT = '.F .F90 .F95 .FOR .FTN .f .f90 .f95 .for .ftn .inc';
# List of Fortran intrinsic modules
our @INTRINSIC_MODULES = qw{
ieee_arithmetic
ieee_exceptions
ieee_features
iso_c_binding
iso_fortran_env
omp_lib
omp_lib_kinds
};
# Prefix for dependency name that is only applicable under OMP
our $OMP_PREFIX = '!$';
# Regular expressions
my $RE_FILE = qr{[\w\-+.]+}imsx;
my $RE_NAME = qr{[A-Za-z]\w*}imsx;
my $RE_SPEC = qr{
character|class|complex|double\s*complex|double\s*precision|integer|
logical|procedure|real|type
}imsx;
my $RE_UNIT_BASE = qr{
block\s*data|
module(?!\s*(?:function|subroutine|procedure)\s+)|
program|
}imsx;
my $RE_UNIT_CALL = qr{subroutine|function}imsx;
my %RE = (
DEP_O => qr{\A\s*!\s*depends\s*on\s*:\s*($RE_FILE)}imsx,
DEP_USE => qr{\A\s*use\s+($RE_NAME)}imsx,
DEP_SUBM => qr{\A\s*submodule\s+\(($RE_NAME)\)}imsx,
INCLUDE => qr{\#?\s*include\s*}imsx,
OMP_SENT => qr{\A(\s*!\$\s+)?(.*)\z}imsx,
UNIT_ATTR => qr{\A\s*(?:(?:(?:impure\s+)?elemental|recursive|pure)\s+)+(.*)\z}imsx,
UNIT_BASE => qr{\A\s*($RE_UNIT_BASE)\s+($RE_NAME)\b}imsx,
UNIT_SUBM => qr{\A\s*(submodule)\s*\(($RE_NAME)\)\s*($RE_NAME)\b}imsx,
UNIT_CALL => qr{\A\s*($RE_UNIT_CALL)\s+($RE_NAME)\b}imsx,
UNIT_END => qr{\A\s*(end)(?:\s+($RE_NAME)(?:\s+($RE_NAME))?)?\b}imsx,
UNIT_SPEC => qr{\A\s*$RE_SPEC\b(.*)\z}imsx,
);
# Dependency types and extractors
my %SOURCE_ANALYSE_DEP_OF = (
'f.module' => \&_source_analyse_dep_module,
'include' => \&_source_analyse_dep_include,
'o' => sub { lc($_[0]) =~ $RE{DEP_O} }, # lc required for legacy
'o.special' => sub {},
);
# Alias
my $TARGET = 'FCM::Context::Make::Build::Target';
# Classes for tasks used by targets of this file type
my %TASK_CLASS_OF = (
'compile' => 'FCM::System::Make::Build::Task::Compile::Fortran',
'compile+' => 'FCM::System::Make::Build::Task::Compile::Fortran::Extra',
'ext-iface' => 'FCM::System::Make::Build::Task::ExtractInterface',
'install' => 'FCM::System::Make::Build::Task::Install',
'link' => 'FCM::System::Make::Build::Task::Link::Fortran',
);
# Property suffices of output file extensions
my %TARGET_EXT_OF = (
'bin' => '.exe',
'f90-interface' => '.interface',
'f90-mod' => '.mod',
'o' => '.o',
);
sub new {
my ($class, $attrib_ref) = @_;
bless(
FCM::System::Make::Build::FileType->new({
id => 'fortran',
file_ext => $FILE_EXT,
source_analyse_always => 1,
source_analyse_dep_of => {%SOURCE_ANALYSE_DEP_OF},
source_analyse_more => \&_source_analyse_more,
source_analyse_more_init => \&_source_analyse_more_init,
source_to_targets => \&_source_to_targets,
target_deps_filter => \&_target_deps_filter,
target_file_ext_of => {%TARGET_EXT_OF},
target_file_name_option_of => {'f90-mod' => q{}},
task_class_of => {%TASK_CLASS_OF},
%{$attrib_ref},
}),
$class,
);
}
sub _source_analyse_more {
my ($line, $info_hash_ref, $state) = @_;
# End Interface
if ($state->{in_interface}) {
if ($line =~ qr{\A\s*end\s*interface\b}imsx) {
$state->{in_interface} = 0;
}
return 1;
}
# End Program Unit
if (@{$state->{stack}} && $line =~ qr{\A\s*end\b}imsx) {
my ($end, $type, $symbol) = lc($line) =~ $RE{UNIT_END};
if (!$end) {
return 1;
}
my ($top_type, $top_symbol) = @{$state->{stack}->[-1]};
if (!$type
|| $top_type eq $type && (!$symbol || $top_symbol eq $symbol))
{
pop(@{$state->{stack}});
if ($state->{in_contains} && !@{$state->{stack}}) {
$state->{in_contains} = 0;
}
}
return 1;
}
# Interface/Contains
if ($line =~ qr{\A\s*contains\b}imsx) {
$state->{'in_contains'} = 1;
return 1;
}
if ($line =~ qr{\A\s*(?:abstract\s+)?interface\b}imsx) {
$state->{'in_interface'} = 1;
return 1;
}
# Program Unit
my ($type, $symbol, @extras) = _process_prog_unit($line);
if ($type) {
if (!@{$state->{stack}}) {
if ($type eq 'program') {
$info_hash_ref->{main} = 1;
}
$info_hash_ref->{symbols} ||= [];
push(@{$info_hash_ref->{symbols}}, [$type, $symbol, @extras]);
}
push(@{$state->{stack}}, [$type, $symbol]);
return 1;
}
return;
}
sub _source_analyse_more_init {
my ($info_ref, $state) = @_;
%{$info_ref} = (main => 0, symbols => []);
%{$state} = (in_contains => undef, in_interface => undef, stack => []);
}
# Reads information: extract an include dependency.
sub _source_analyse_dep_include {
my ($line) = @_;
my ($omp_sentinel, $extracted);
($omp_sentinel, $line) = $line =~ $RE{OMP_SENT};
($extracted) = extract_delimited($line, q{'"}, $RE{INCLUDE});
if (!$extracted) {
return;
}
$extracted = substr($extracted, 1, length($extracted) - 2);
if ($omp_sentinel) {
$extracted = $OMP_PREFIX . $extracted;
}
$extracted;
}
# Reads information: extract a module dependency.
sub _source_analyse_dep_module {
my ($line) = @_;
my ($omp_sentinel, $extracted, $can_analyse_more);
($omp_sentinel, $line) = $line =~ $RE{OMP_SENT};
($extracted) = lc($line) =~ $RE{DEP_USE};
if (!$extracted) {
($extracted) = lc($line) =~ $RE{DEP_SUBM};
$can_analyse_more = 1;
}
if (!$extracted || grep {$_ eq $extracted} @INTRINSIC_MODULES) {
return;
}
if ($omp_sentinel) {
$extracted = $OMP_PREFIX . $extracted;
}
($extracted, $can_analyse_more);
}
# Parse a statement for program unit header. Returns a list containing the type,
# the symbol and the signature tokens of the program unit.
sub _process_prog_unit {
my ($string) = @_;
my ($type, $symbol, $symbol_parent) = (q{}, q{}, q{});
($type, $symbol) = lc($string) =~ $RE{UNIT_BASE};
if ($type) {
$type =~ s{\s*}{}gmsx;
return ($type, $symbol);
}
($type, $symbol_parent, $symbol) = lc($string) =~ $RE{UNIT_SUBM};
if ($type) {
return ($type, $symbol, $symbol_parent);
}
$string =~ s/$RE{UNIT_ATTR}/$1/;
my ($match) = $string =~ $RE{UNIT_SPEC};
if ($match) {
$string = $match;
if ($string =~ qr{\A \s* \(}msx) {
extract_bracketed($string);
}
elsif ($string =~ qr{\A \s* \*}msx) {
$string =~ s{\A \s* \* \d+ \s*}{}msx;
}
}
($type, $symbol) = lc($string) =~ $RE{UNIT_CALL};
if (!$type) {
return;
}
return (lc($type), lc($symbol));
}
# Returns a list of targets for a given build source.
sub _source_to_targets {
my ($attrib_ref, $source, $ext_hash_ref, $option_hash_ref) = @_;
my $key = basename($source->get_path());
my $TARGET_OF = sub {
my ($symbol, $type) = @_;
if (exists($option_hash_ref->{$type})) {
my $is_upper = index($option_hash_ref->{$type}, 'case=upper') >= 0;
$symbol = $is_upper ? uc($symbol) : lc($symbol);
}
$symbol . $ext_hash_ref->{$type};
};
my @deps = map {
my ($k, $type) = @{$_};
my $ext = $attrib_ref->{util}->file_ext($k);
$type eq 'f.module' ? [$TARGET_OF->($k, 'f90-mod'), 'include', 1]
: $type eq 'o' && !$ext ? [$TARGET_OF->($k, 'o'), $type]
: [$k, $type]
} @{$source->get_deps()};
# All source files can be used as include files
my @targets = (
$TARGET->new(
{ category => $TARGET->CT_INCLUDE,
deps => [@deps],
dep_policy_of => {'include' => $TARGET->POLICY_CAPTURE},
key => $key,
status_of => {'include' => $TARGET->ST_UNKNOWN},
task => 'install',
}
),
);
my ($ext, $root) = $attrib_ref->{util}->file_ext($key);
# @{$symbols_ref} contains a list of [$type, $symbol, $symbol_parent]
# where $type is the program unit type
# $symbol is the program unit symbol
# $symbol_parent is the parent program unit symbol, e.g. name of
# parent module of a submodule
my $symbols_ref = $source->get_info_of()->{symbols};
# FIXME: hard code the handling of "*.inc" files as include files
if (!defined($symbols_ref) || !@{$symbols_ref} || $ext eq 'inc') {
return @targets;
}
my $key_of_o = $TARGET_OF->($symbols_ref->[0][1], 'o');
my @keys_of_mod;
for (grep {$_->[0] eq 'module'} @{$symbols_ref}) {
my ($type, $symbol) = @{$_};
my $key_of_mod = $TARGET_OF->($symbol, 'f90-mod');
my @include_deps = grep {$_->[1] eq 'include'} @deps;
push(
@targets,
$TARGET->new(
{ category => $TARGET->CT_INCLUDE,
deps => [[$key_of_o, 'o']],
dep_policy_of => {
'include' => $TARGET->POLICY_CAPTURE,
'o' => $TARGET->POLICY_FILTER_IMMEDIATE,
},
key => $key_of_mod,
task => 'compile+',
}
)
);
push(@keys_of_mod, $key_of_mod);
}
my @symbol_parents = map {
scalar(@{$_}) > 2 ? $TARGET_OF->($_->[2], 'o') : ();
} @{$symbols_ref};
push(
@targets,
$TARGET->new(
{ category => $TARGET->CT_O,
deps => [@deps],
dep_policy_of => {'include' => $TARGET->POLICY_CAPTURE},
info_of => {paths => [], parents => \@symbol_parents},
key => $key_of_o,
task => 'compile',
triggers => \@keys_of_mod,
}
),
);
if (grep {$_->[0] eq 'subroutine' || $_->[0] eq 'function'} @{$symbols_ref}) {
my $target_key = $root . $ext_hash_ref->{'f90-interface'};
push(
@targets,
$TARGET->new(
{ category => $TARGET->CT_INCLUDE,
deps => [[$key_of_o, 'o'], grep {exists($_->[2])} @deps],
dep_policy_of => {
'include' => $TARGET->POLICY_FILTER_IMMEDIATE,
},
key => $target_key,
task => 'ext-iface',
}
)
);
}
if ($source->get_info_of()->{main}) {
my @link_deps = grep {$_->[1] eq 'o' || $_->[1] eq 'o.special'} @deps;
push(
@targets,
$TARGET->new(
{ category => $TARGET->CT_BIN,
deps => [[$key_of_o, 'o'], @link_deps],
dep_policy_of => {
'o' => $TARGET->POLICY_CAPTURE,
'o.special' => $TARGET->POLICY_CAPTURE,
},
info_of => {
paths => [], deps => {o => [], 'o.special' => []},
},
key => $root . $ext_hash_ref->{bin},
task => 'link',
}
)
);
}
return @targets;
}
# If target's fc.flag-omp property is empty, remove !$OMP dependencies.
# Otherwise, remove !$OMP sentinels from the dependencies.
sub _target_deps_filter {
my ($attrib_ref, $target) = @_;
if ($target->get_prop_of()->{'fc.flag-omp'}) {
for my $dep_ref (@{$target->get_deps()}) {
if (index($dep_ref->[0], $OMP_PREFIX) == 0) {
substr($dep_ref->[0], 0, length($OMP_PREFIX), q{});
}
}
}
else {
$target->set_deps(
[grep {index($_->[0], $OMP_PREFIX) == -1} @{$target->get_deps()}],
);
}
}
# ------------------------------------------------------------------------------
1;
__END__
=head1 NAME
FCM::System::Make::Build::FileType::Fortran
=head1 SYNOPSIS
use FCM::System::Make::Build::FileType::Fortran;
my $file_type_util = FCM::System::Make::Build::FileType::Fortran->new();
$file_type_util->source_analyse($source);
my @targets = $file_type_util->source_to_targets($m_ctx, $ctx, $source);
=head1 DESCRIPTION
A wrapper of
L with
configurations to work with Fortran source files.
=head1 TODO
Combine the code with FCM::System::Make::Build::Task::ExtractInterface.
=head1 COPYRIGHT
Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
=cut