Skip to content

Commit bc56620

Browse files
psteinfeldpsteinfeld
committed
[flang] Implement checks for defined input/output procedures
Defined input/output procedures are specified in 12.6.4.8. There are different versions for read versus write and formatted versus unformatted, but they all share the same basic set of dummy arguments. I added several checking functions to check-declarations.cpp along with a test. In the process of implementing this, I noticed and fixed a typo in .../lib/Evaluate/characteristics.cpp. Differential Revision: https://reviews.llvm.org/D103045
1 parent 2f23f9e commit bc56620

File tree

3 files changed

+599
-4
lines changed

3 files changed

+599
-4
lines changed

‎flang/lib/Evaluate/characteristics.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -611,7 +611,7 @@ common::Intent DummyArgument::GetIntent() const {
611611
[](const DummyDataObject &data) { return data.intent; },
612612
[](const DummyProcedure &proc) { return proc.intent; },
613613
[](const AlternateReturn &) -> common::Intent {
614-
DIE("Alternate return have no intent");
614+
DIE("Alternate returns have no intent");
615615
},
616616
},
617617
u);

‎flang/lib/Semantics/check-declarations.cpp

Lines changed: 232 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -103,6 +103,21 @@ class CheckHelper {
103103
}
104104
bool IsResultOkToDiffer(const FunctionResult &);
105105
void CheckBindCName(const Symbol &);
106+
// Check functions for defined I/O procedures
107+
void CheckDefinedIoProc(
108+
const Symbol &, const GenericDetails &, GenericKind::DefinedIo);
109+
bool CheckDioDummyIsData(const Symbol &, const Symbol *, std::size_t);
110+
void CheckDioDummyIsDerived(const Symbol &, const Symbol &);
111+
void CheckDioDummyIsDefaultInteger(const Symbol &, const Symbol &);
112+
void CheckDioDummyIsScalar(const Symbol &, const Symbol &);
113+
void CheckDioDummyAttrs(const Symbol &, const Symbol &, Attr);
114+
void CheckDioDtvArg(const Symbol &, const Symbol *, GenericKind::DefinedIo);
115+
void CheckDefaultIntegerArg(const Symbol &, const Symbol *, Attr);
116+
void CheckDioAssumedLenCharacterArg(
117+
const Symbol &, const Symbol *, std::size_t, Attr);
118+
void CheckDioVlistArg(const Symbol &, const Symbol *, std::size_t);
119+
void CheckDioArgCount(
120+
const Symbol &, GenericKind::DefinedIo ioKind, std::size_t);
106121

107122
SemanticsContext &context_;
108123
evaluate::FoldingContext &foldingContext_{context_.foldingContext()};
@@ -657,7 +672,7 @@ void CheckHelper::CheckProcEntity(
657672
" may not have an INTENT attribute"_err_en_US);
658673
}
659674

660-
const Symbol *interface{details.interface().symbol()};
675+
const Symbol *interface { details.interface().symbol() };
661676
if (!symbol.attrs().test(Attr::INTRINSIC) &&
662677
(symbol.attrs().test(Attr::ELEMENTAL) ||
663678
(interface && !interface->attrs().test(Attr::INTRINSIC) &&
@@ -1021,6 +1036,13 @@ void CheckHelper::CheckHostAssoc(
10211036
void CheckHelper::CheckGeneric(
10221037
const Symbol &symbol, const GenericDetails &details) {
10231038
CheckSpecificsAreDistinguishable(symbol, details);
1039+
std::visit(common::visitors{
1040+
[&](const GenericKind::DefinedIo &io) {
1041+
CheckDefinedIoProc(symbol, details, io);
1042+
},
1043+
[](const auto &) {},
1044+
},
1045+
details.kind().u);
10241046
}
10251047

10261048
// Check that the specifics of this generic are distinguishable from each other
@@ -1255,7 +1277,7 @@ bool CheckHelper::CheckDefinedAssignmentArg(
12551277
bool CheckHelper::CheckConflicting(const Symbol &symbol, Attr a1, Attr a2) {
12561278
if (symbol.attrs().test(a1) && symbol.attrs().test(a2)) {
12571279
messages_.Say("'%s' may not have both the %s and %s attributes"_err_en_US,
1258-
symbol.name(), EnumToString(a1), EnumToString(a2));
1280+
symbol.name(), AttrToString(a1), AttrToString(a2));
12591281
return true;
12601282
} else {
12611283
return false;
@@ -1703,6 +1725,212 @@ void CheckHelper::CheckBindCName(const Symbol &symbol) {
17031725
}
17041726
}
17051727

1728+
bool CheckHelper::CheckDioDummyIsData(
1729+
const Symbol &subp, const Symbol *arg, std::size_t position) {
1730+
if (arg && arg->detailsIf<ObjectEntityDetails>()) {
1731+
return true;
1732+
} else {
1733+
if (arg) {
1734+
messages_.Say(arg->name(),
1735+
"Dummy argument '%s' must be a data object"_err_en_US, arg->name());
1736+
} else {
1737+
messages_.Say(subp.name(),
1738+
"Dummy argument %d of '%s' must be a data object"_err_en_US, position,
1739+
subp.name());
1740+
}
1741+
return false;
1742+
}
1743+
}
1744+
1745+
void CheckHelper::CheckDioDummyIsDerived(
1746+
const Symbol &subp, const Symbol &arg) {
1747+
if (const DeclTypeSpec * type{arg.GetType()}; type && type->AsDerived()) {
1748+
return;
1749+
}
1750+
messages_.Say(arg.name(),
1751+
"Dummy argument '%s' of a defined input/output procedure must have a"
1752+
" derived type"_err_en_US,
1753+
arg.name());
1754+
}
1755+
1756+
void CheckHelper::CheckDioDummyIsDefaultInteger(
1757+
const Symbol &subp, const Symbol &arg) {
1758+
if (const DeclTypeSpec * type{arg.GetType()};
1759+
type && type->IsNumeric(TypeCategory::Integer)) {
1760+
if (const auto kind{evaluate::ToInt64(type->numericTypeSpec().kind())};
1761+
kind && *kind == context_.GetDefaultKind(TypeCategory::Integer)) {
1762+
return;
1763+
}
1764+
}
1765+
messages_.Say(arg.name(),
1766+
"Dummy argument '%s' of a defined input/output procedure"
1767+
" must be an INTEGER of default KIND"_err_en_US,
1768+
arg.name());
1769+
}
1770+
1771+
void CheckHelper::CheckDioDummyIsScalar(const Symbol &subp, const Symbol &arg) {
1772+
if (arg.Rank() > 0 || arg.Corank() > 0) {
1773+
messages_.Say(arg.name(),
1774+
"Dummy argument '%s' of a defined input/output procedure"
1775+
" must be a scalar"_err_en_US,
1776+
arg.name());
1777+
}
1778+
}
1779+
1780+
void CheckHelper::CheckDioDtvArg(
1781+
const Symbol &subp, const Symbol *arg, GenericKind::DefinedIo ioKind) {
1782+
// Dtv argument looks like: dtv-type-spec, INTENT(INOUT) :: dtv
1783+
if (CheckDioDummyIsData(subp, arg, 0)) {
1784+
CheckDioDummyIsDerived(subp, *arg);
1785+
CheckDioDummyAttrs(subp, *arg,
1786+
ioKind == GenericKind::DefinedIo::ReadFormatted ||
1787+
ioKind == GenericKind::DefinedIo::ReadUnformatted
1788+
? Attr::INTENT_INOUT
1789+
: Attr::INTENT_IN);
1790+
}
1791+
}
1792+
1793+
void CheckHelper::CheckDefaultIntegerArg(
1794+
const Symbol &subp, const Symbol *arg, Attr intent) {
1795+
// Argument looks like: INTEGER, INTENT(intent) :: arg
1796+
if (CheckDioDummyIsData(subp, arg, 1)) {
1797+
CheckDioDummyIsDefaultInteger(subp, *arg);
1798+
CheckDioDummyIsScalar(subp, *arg);
1799+
CheckDioDummyAttrs(subp, *arg, intent);
1800+
}
1801+
}
1802+
1803+
void CheckHelper::CheckDioAssumedLenCharacterArg(const Symbol &subp,
1804+
const Symbol *arg, std::size_t argPosition, Attr intent) {
1805+
// Argument looks like: CHARACTER (LEN=*), INTENT(intent) :: (iotype OR iomsg)
1806+
if (CheckDioDummyIsData(subp, arg, argPosition)) {
1807+
CheckDioDummyAttrs(subp, *arg, intent);
1808+
if (!IsAssumedLengthCharacter(*arg)) {
1809+
messages_.Say(arg->name(),
1810+
"Dummy argument '%s' of a defined input/output procedure"
1811+
" must be assumed-length CHARACTER"_err_en_US,
1812+
arg->name());
1813+
}
1814+
}
1815+
}
1816+
1817+
void CheckHelper::CheckDioVlistArg(
1818+
const Symbol &subp, const Symbol *arg, std::size_t argPosition) {
1819+
// Vlist argument looks like: INTEGER, INTENT(IN) :: v_list(:)
1820+
if (CheckDioDummyIsData(subp, arg, argPosition)) {
1821+
CheckDioDummyIsDefaultInteger(subp, *arg);
1822+
CheckDioDummyAttrs(subp, *arg, Attr::INTENT_IN);
1823+
if (const auto *objectDetails{arg->detailsIf<ObjectEntityDetails>()}) {
1824+
if (objectDetails->shape().IsDeferredShape()) {
1825+
return;
1826+
}
1827+
}
1828+
messages_.Say(arg->name(),
1829+
"Dummy argument '%s' of a defined input/output procedure must be"
1830+
" deferred shape"_err_en_US,
1831+
arg->name());
1832+
}
1833+
}
1834+
1835+
void CheckHelper::CheckDioArgCount(
1836+
const Symbol &subp, GenericKind::DefinedIo ioKind, std::size_t argCount) {
1837+
const std::size_t requiredArgCount{
1838+
(std::size_t)(ioKind == GenericKind::DefinedIo::ReadFormatted ||
1839+
ioKind == GenericKind::DefinedIo::WriteFormatted
1840+
? 6
1841+
: 4)};
1842+
if (argCount != requiredArgCount) {
1843+
SayWithDeclaration(subp,
1844+
"Defined input/output procedure '%s' must have"
1845+
" %d dummy arguments rather than %d"_err_en_US,
1846+
subp.name(), requiredArgCount, argCount);
1847+
context_.SetError(subp);
1848+
}
1849+
}
1850+
1851+
void CheckHelper::CheckDioDummyAttrs(
1852+
const Symbol &subp, const Symbol &arg, Attr goodIntent) {
1853+
// Defined I/O procedures can't have attributes other than INTENT
1854+
Attrs attrs{arg.attrs()};
1855+
if (!attrs.test(goodIntent)) {
1856+
messages_.Say(arg.name(),
1857+
"Dummy argument '%s' of a defined input/output procedure"
1858+
" must have intent '%s'"_err_en_US,
1859+
arg.name(), AttrToString(goodIntent));
1860+
}
1861+
attrs = attrs - Attr::INTENT_IN - Attr::INTENT_OUT - Attr::INTENT_INOUT;
1862+
if (!attrs.empty()) {
1863+
messages_.Say(arg.name(),
1864+
"Dummy argument '%s' of a defined input/output procedure may not have"
1865+
" any attributes"_err_en_US,
1866+
arg.name());
1867+
}
1868+
}
1869+
1870+
// Enforce semantics for defined input/output procedures (12.6.4.8.2) and C777
1871+
void CheckHelper::CheckDefinedIoProc(const Symbol &symbol,
1872+
const GenericDetails &details, GenericKind::DefinedIo ioKind) {
1873+
for (auto ref : details.specificProcs()) {
1874+
const auto *binding{ref->detailsIf<ProcBindingDetails>()};
1875+
const Symbol &specific{*(binding ? &binding->symbol() : &*ref)};
1876+
if (ref->attrs().test(Attr::NOPASS)) { // C774
1877+
messages_.Say("Defined input/output procedure '%s' may not have NOPASS "
1878+
"attribute"_err_en_US,
1879+
ref->name());
1880+
context_.SetError(*ref);
1881+
}
1882+
if (const auto *subpDetails{specific.detailsIf<SubprogramDetails>()}) {
1883+
const std::vector<Symbol *> &dummyArgs{subpDetails->dummyArgs()};
1884+
CheckDioArgCount(specific, ioKind, dummyArgs.size());
1885+
int argCount{0};
1886+
for (auto *arg : dummyArgs) {
1887+
switch (argCount++) {
1888+
case 0:
1889+
// dtv-type-spec, INTENT(INOUT) :: dtv
1890+
CheckDioDtvArg(specific, arg, ioKind);
1891+
break;
1892+
case 1:
1893+
// INTEGER, INTENT(IN) :: unit
1894+
CheckDefaultIntegerArg(specific, arg, Attr::INTENT_IN);
1895+
break;
1896+
case 2:
1897+
if (ioKind == GenericKind::DefinedIo::ReadFormatted ||
1898+
ioKind == GenericKind::DefinedIo::WriteFormatted) {
1899+
// CHARACTER (LEN=*), INTENT(IN) :: iotype
1900+
CheckDioAssumedLenCharacterArg(
1901+
specific, arg, argCount, Attr::INTENT_IN);
1902+
} else {
1903+
// INTEGER, INTENT(OUT) :: iostat
1904+
CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
1905+
}
1906+
break;
1907+
case 3:
1908+
if (ioKind == GenericKind::DefinedIo::ReadFormatted ||
1909+
ioKind == GenericKind::DefinedIo::WriteFormatted) {
1910+
// INTEGER, INTENT(IN) :: v_list(:)
1911+
CheckDioVlistArg(specific, arg, argCount);
1912+
} else {
1913+
// CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
1914+
CheckDioAssumedLenCharacterArg(
1915+
specific, arg, argCount, Attr::INTENT_INOUT);
1916+
}
1917+
break;
1918+
case 4:
1919+
// INTEGER, INTENT(OUT) :: iostat
1920+
CheckDefaultIntegerArg(specific, arg, Attr::INTENT_OUT);
1921+
break;
1922+
case 5:
1923+
// CHARACTER (LEN=*), INTENT(INOUT) :: iomsg
1924+
CheckDioAssumedLenCharacterArg(
1925+
specific, arg, argCount, Attr::INTENT_INOUT);
1926+
break;
1927+
default:;
1928+
}
1929+
}
1930+
}
1931+
}
1932+
}
1933+
17061934
void SubprogramMatchHelper::Check(
17071935
const Symbol &symbol1, const Symbol &symbol2) {
17081936
const auto details1{symbol1.get<SubprogramDetails>()};
@@ -1962,7 +2190,8 @@ void DistinguishabilityHelper::SayNotDistinguishable(const Scope &scope,
19622190
MakeOpName(name), name1, name2);
19632191
} else {
19642192
msg = &context_.Say(*GetTopLevelUnitContaining(proc1).GetName(),
1965-
"USE-associated generic '%s' may not have specific procedures '%s' and"
2193+
"USE-associated generic '%s' may not have specific procedures '%s' "
2194+
"and"
19662195
" '%s' as their interfaces are not distinguishable"_err_en_US,
19672196
MakeOpName(name), name1, name2);
19682197
}

0 commit comments

Comments
 (0)