Index: flang/include/flang/Semantics/expression.h =================================================================== --- flang/include/flang/Semantics/expression.h +++ flang/include/flang/Semantics/expression.h @@ -111,6 +111,8 @@ semantics::SemanticsContext &context() const { return context_; } bool inWhereBody() const { return inWhereBody_; } void set_inWhereBody(bool yes = true) { inWhereBody_ = yes; } + bool inDataStmtObject() const { return inDataStmtObject_; } + void set_inDataStmtObject(bool yes = true) { inDataStmtObject_ = yes; } FoldingContext &GetFoldingContext() const { return foldingContext_; } @@ -329,6 +331,7 @@ DataRef &&, const Symbol &, const semantics::Scope &); MaybeExpr CompleteSubscripts(ArrayRef &&); MaybeExpr ApplySubscripts(DataRef &&, std::vector &&); + void CheckConstantSubscripts(ArrayRef &); bool CheckRanks(const DataRef &); // Return false if error exists. bool CheckPolymorphic(const DataRef &); // ditto bool CheckDataRef(const DataRef &); // ditto @@ -385,6 +388,7 @@ bool isNullPointerOk_{false}; bool useSavedTypedExprs_{true}; bool inWhereBody_{false}; + bool inDataStmtObject_{false}; bool inDataStmtConstant_{false}; bool inStmtFunctionDefinition_{false}; friend class ArgumentAnalyzer; @@ -457,6 +461,8 @@ exprAnalyzer_.Analyze(x); return false; } + bool Pre(const parser::DataStmtObject &); + void Post(const parser::DataStmtObject &); bool Pre(const parser::DataImpliedDo &); bool Pre(const parser::CallStmt &x) { Index: flang/lib/Semantics/data-to-inits.cpp =================================================================== --- flang/lib/Semantics/data-to-inits.cpp +++ flang/lib/Semantics/data-to-inits.cpp @@ -160,7 +160,14 @@ template bool DataInitializationCompiler::Scan( const parser::Designator &designator) { - if (auto expr{exprAnalyzer_.Analyze(designator)}) { + MaybeExpr expr; + { // The out-of-range subscript errors from the designator folder are a + // more specific than the default ones from expression semantics, so + // disable those to avoid piling on. + auto restorer{exprAnalyzer_.GetContextualMessages().DiscardMessages()}; + expr = exprAnalyzer_.Analyze(designator); + } + if (expr) { parser::CharBlock at{parser::FindSourceLocation(designator)}; exprAnalyzer_.GetFoldingContext().messages().SetLocation(at); scope_ = &exprAnalyzer_.context().FindScope(at); Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -276,6 +276,12 @@ // SELECT TYPE/RANK or ASSOCIATE. CHECK(symbol.has()); } + if (!semantics::IsNamedConstant(symbol) && !inDataStmtObject_) { + // Subscripts of named constants are checked in folding. + // Subscripts of DATA statement objects are checked in data statement + // conversion to initializers. + CheckConstantSubscripts(ref); + } return Designate(DataRef{std::move(ref)}); } @@ -302,6 +308,111 @@ std::move(dataRef.u)); } +void ExpressionAnalyzer::CheckConstantSubscripts(ArrayRef &ref) { + // Fold subscript expressions and check for an empty triplet. + Shape lb{GetLBOUNDs(foldingContext_, ref.base())}; + Shape ub{GetUBOUNDs(foldingContext_, ref.base())}; + bool anyPossiblyEmptyDim{false}; + int dim{0}; + for (Subscript &ss : ref.subscript()) { + if (Triplet * triplet{std::get_if(&ss.u)}) { + auto expr{Fold(triplet->stride())}; + auto stride{ToInt64(expr)}; + triplet->set_stride(std::move(expr)); + if (stride) { + if (*stride == 0) { + Say("Stride of triplet must not be zero"_err_en_US); + return; + } + std::optional lower, upper; + if (auto expr{triplet->lower()}) { + *expr = Fold(std::move(*expr)); + lower = ToInt64(*expr); + triplet->set_lower(std::move(*expr)); + } else { + lower = ToInt64(lb[dim]); + } + if (auto expr{triplet->upper()}) { + *expr = Fold(std::move(*expr)); + upper = ToInt64(*expr); + triplet->set_upper(std::move(*expr)); + } else { + upper = ToInt64(ub[dim]); + } + if (lower && upper) { + if (*stride > 0) { + anyPossiblyEmptyDim |= *lower > *upper; + } else { + anyPossiblyEmptyDim |= *lower < *upper; + } + } else { + anyPossiblyEmptyDim = true; + } + } else { + anyPossiblyEmptyDim = true; + } + } else { // not triplet + auto &expr{std::get(ss.u).value()}; + expr = Fold(std::move(expr)); + anyPossiblyEmptyDim |= expr.Rank() > 0; // vector subscript + } + ++dim; + } + if (anyPossiblyEmptyDim) { + return; + } + dim = 0; + for (Subscript &ss : ref.subscript()) { + auto dimLB{ToInt64(lb[dim])}; + auto dimUB{ToInt64(ub[dim])}; + std::optional val[2]; + int vals{0}; + if (auto *triplet{std::get_if(&ss.u)}) { + auto stride{ToInt64(triplet->stride())}; + std::optional lower, upper; + if (const auto *lowerExpr{triplet->GetLower()}) { + lower = ToInt64(*lowerExpr); + } else if (lb[dim]) { + lower = ToInt64(*lb[dim]); + } + if (const auto *upperExpr{triplet->GetUpper()}) { + upper = ToInt64(*upperExpr); + } else if (ub[dim]) { + upper = ToInt64(*ub[dim]); + } + if (stride && *stride != 0 && lower && upper) { + // Normalize upper bound for non-unit stride + // 1:10:2 -> 1:9:2, 10:1:-2 -> 10:2:-2 + *upper = *lower + *stride * ((*upper - *lower) / *stride); + val[vals++] = lower; + val[vals++] = upper; + } + } else { + val[vals++] = + ToInt64(std::get(ss.u).value()); + } + for (int j{0}; j < vals; ++j) { + if (val[j]) { + if (dimLB && *val[j] < *dimLB) { + AttachDeclaration( + Say("Subscript %jd is less than lower bound %jd for dimension %d of array"_err_en_US, + static_cast(*val[j]), + static_cast(*dimLB), dim + 1), + ref.base().GetLastSymbol()); + } + if (dimUB && *val[j] > *dimUB) { + AttachDeclaration( + Say("Subscript %jd is greater than upper bound %jd for dimension %d of array"_err_en_US, + static_cast(*val[j]), + static_cast(*dimUB), dim + 1), + ref.base().GetLastSymbol()); + } + } + } + ++dim; + } +} + // C919a - only one part-ref of a data-ref may have rank > 0 bool ExpressionAnalyzer::CheckRanks(const DataRef &dataRef) { return common::visit( @@ -4102,6 +4213,15 @@ ExprChecker::ExprChecker(SemanticsContext &context) : context_{context} {} +bool ExprChecker::Pre(const parser::DataStmtObject &obj) { + exprAnalyzer_.set_inDataStmtObject(true); + return true; +} + +void ExprChecker::Post(const parser::DataStmtObject &obj) { + exprAnalyzer_.set_inDataStmtObject(false); +} + bool ExprChecker::Pre(const parser::DataImpliedDo &ido) { parser::Walk(std::get(ido.t), *this); const auto &bounds{std::get(ido.t)}; Index: flang/lib/Semantics/type.cpp =================================================================== --- flang/lib/Semantics/type.cpp +++ flang/lib/Semantics/type.cpp @@ -325,28 +325,33 @@ const SourceName &name{symbol.name()}; if (typeScope.find(symbol.name()) != typeScope.end()) { // This type parameter belongs to the derived type itself, not to - // one of its ancestors. Put the type parameter expression value - // into the new scope as the initialization value for the parameter. + // one of its ancestors. Put the type parameter expression value, + // when there is one, into the new scope as the initialization value + // for the parameter. And when there is no explicit value, add an + // uninitialized type parameter to forestall use of any default. if (ParamValue * paramValue{FindParameter(name)}) { const TypeParamDetails &details{symbol.get()}; paramValue->set_attr(details.attr()); + TypeParamDetails instanceDetails{details.attr()}; + if (const DeclTypeSpec * type{details.type()}) { + instanceDetails.set_type(*type); + } + desc += sep; + desc += name.ToString(); + desc += '='; + sep = ','; if (MaybeIntExpr expr{paramValue->GetExplicit()}) { if (auto folded{evaluate::NonPointerInitializationExpr(symbol, SomeExpr{std::move(*expr)}, foldingContext, &newScope)}) { - desc += sep; - desc += name.ToString(); - desc += '='; desc += folded->AsFortran(); - sep = ','; - TypeParamDetails instanceDetails{details.attr()}; - if (const DeclTypeSpec * type{details.type()}) { - instanceDetails.set_type(*type); - } instanceDetails.set_init( std::move(DEREF(evaluate::UnwrapExpr(*folded)))); - newScope.try_emplace(name, std::move(instanceDetails)); } } + if (!instanceDetails.init()) { + desc += '*'; + } + newScope.try_emplace(name, std::move(instanceDetails)); } } } Index: flang/test/Lower/OpenACC/acc-data-operands.f90 =================================================================== --- flang/test/Lower/OpenACC/acc-data-operands.f90 +++ flang/test/Lower/OpenACC/acc-data-operands.f90 @@ -21,12 +21,11 @@ !CHECK: %[[ARR:.*]] = fir.alloca !fir.array<100xf32> - !CHECK: %[[C1:.*]] = fir.convert %c1_i32 : (i32) -> i64 + !CHECK: %[[C1:.*]] = arith.constant 1 : i64 !CHECK: %[[LB1:.*]] = fir.convert %[[C1]] : (i64) -> index !CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 !CHECK: %[[STEP1:.*]] = fir.convert %[[C1_I64]] : (i64) -> index - !CHECK: %[[C50:.*]] = arith.constant 50 : i32 - !CHECK: %[[C50_I64:.*]] = fir.convert %[[C50]] : (i32) -> i64 + !CHECK: %[[C50_I64:.*]] = arith.constant 50 : i64 !CHECK: %[[UB1:.*]] = fir.convert %[[C50_I64]] : (i64) -> index !CHECK: %[[SHAPE1:.*]] = fir.shape %{{.*}} : (index) -> !fir.shape<1> !CHECK: %[[SLICE1:.*]] = fir.slice %[[LB1]], %[[UB1]], %[[STEP1]] : (index, index, index) -> !fir.slice<1> @@ -34,13 +33,11 @@ !CHECK: %[[MEM1:.*]] = fir.alloca !fir.box> !CHECK: fir.store %[[ARR_SECTION1]] to %[[MEM1]] : !fir.ref>> - !CHECK: %[[C51:.*]] = arith.constant 51 : i32 - !CHECK: %[[C51_I64:.*]] = fir.convert %[[C51]] : (i32) -> i64 + !CHECK: %[[C51_I64:.*]] = arith.constant 51 : i64 !CHECK: %[[LB2:.*]] = fir.convert %[[C51_I64]] : (i64) -> index !CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 !CHECK: %[[STEP2:.*]] = fir.convert %[[C1_I64]] : (i64) -> index - !CHECK: %[[C100:.*]] = arith.constant 100 : i32 - !CHECK: %[[C100_I64:.*]] = fir.convert %[[C100]] : (i32) -> i64 + !CHECK: %[[C100_I64:.*]] = arith.constant 100 : i64 !CHECK: %[[UB2:.*]] = fir.convert %[[C100_I64]] : (i64) -> index !CHECK: %[[SHAPE2:.*]] = fir.shape %{{.*}} : (index) -> !fir.shape<1> !CHECK: %[[SLICE2:.*]] = fir.slice %[[LB2]], %[[UB2]], %[[STEP2]] : (index, index, index) -> !fir.slice<1> @@ -64,13 +61,11 @@ !CHECK: %[[W:.*]] = fir.alloca !fir.type<_QMacc_data_operandTwrapper{data:!fir.array<100xf32>}> !CHECK: %[[FIELD_INDEX:.*]] = fir.field_index data, !fir.type<_QMacc_data_operandTwrapper{data:!fir.array<100xf32>}> !CHECK: %[[DATA_COORD:.*]] = fir.coordinate_of %[[W]], %[[FIELD_INDEX]] : (!fir.ref}>>, !fir.field) -> !fir.ref> - !CHECK: %[[C1:.*]] = arith.constant 1 : i32 - !CHECK: %[[C1_I64:.*]] = fir.convert %[[C1]] : (i32) -> i64 - !CHECK: %[[LB:.*]] = fir.convert %3 : (i64) -> index - !CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 - !CHECK: %[[STEP:.*]] = fir.convert %[[C1_I64]] : (i64) -> index - !CHECK: %[[C20:.*]] = arith.constant 20 : i32 - !CHECK: %[[C20_I64:.*]] = fir.convert %[[C20]] : (i32) -> i64 + !CHECK: %[[C1_I64_1:.*]] = arith.constant 1 : i64 + !CHECK: %[[LB:.*]] = fir.convert %[[C1_I64_1]] : (i64) -> index + !CHECK: %[[C1_I64_2:.*]] = arith.constant 1 : i64 + !CHECK: %[[STEP:.*]] = fir.convert %[[C1_I64_2]] : (i64) -> index + !CHECK: %[[C20_I64:.*]] = arith.constant 20 : i64 !CHECK: %[[UB:.*]] = fir.convert %[[C20_I64]] : (i64) -> index !CHECK: %[[SHAPE:.*]] = fir.shape %{{.*}} : (index) -> !fir.shape<1> !CHECK: %[[SLICE:.*]] = fir.slice %[[LB]], %[[UB]], %[[STEP]] : (index, index, index) -> !fir.slice<1> @@ -105,7 +100,9 @@ !CHECK-LABEL: func.func @_QMacc_data_operandPacc_operand_array_derived_type_component !CHECK: %[[W:.*]] = fir.alloca !fir.array<10x!fir.type<_QMacc_data_operandTwrapper{data:!fir.array<100xf32>}>> - !CHECK: %[[IDX:.*]] = arith.subi %{{.*}}, %c1_i64 : i64 + !CHECK: %[[C1_I64_1:.*]] = arith.constant 1 : i64 + !CHECK: %[[C1_I64_2:.*]] = arith.constant 1 : i64 + !CHECK: %[[IDX:.*]] = arith.subi %[[C1_I64_1]], %[[C1_I64_2]] : i64 !CHECK: %[[COORD1:.*]] = fir.coordinate_of %[[W]], %[[IDX]] : (!fir.ref}>>>, i64) -> !fir.ref}>> !CHECK: %[[COORD2:.*]] = fir.field_index data, !fir.type<_QMacc_data_operandTwrapper{data:!fir.array<100xf32>}> !CHECK: %[[COORD_OF:.*]] = fir.coordinate_of %[[COORD1]], %[[COORD2]] : (!fir.ref}>>, !fir.field) -> !fir.ref> @@ -125,13 +122,11 @@ !CHECK: %[[ARR_HEAP:.*]] = fir.alloca !fir.heap> {uniq_name = "_QMacc_data_operandFacc_operand_array_section_allocatableEa.addr"} !CHECK: %[[LOAD_ARR0:.*]] = fir.load %[[ARR_HEAP]] : !fir.ref>> - !CHECK: %[[C1_I32:.*]] = arith.constant 1 : i32 - !CHECK: %[[C1_I64:.*]] = fir.convert %[[C1_I32]] : (i32) -> i64 + !CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 !CHECK: %[[LB0:.*]] = fir.convert %[[C1_I64]] : (i64) -> index !CHECK: %[[C1_STEP:.*]] = arith.constant 1 : i64 !CHECK: %[[STEP0:.*]] = fir.convert %[[C1_STEP]] : (i64) -> index - !CHECK: %[[C50_I32:.*]] = arith.constant 50 : i32 - !CHECK: %[[C50_I64:.*]] = fir.convert %[[C50_I32]] : (i32) -> i64 + !CHECK: %[[C50_I64:.*]] = arith.constant 50 : i64 !CHECK: %[[UB0:.*]] = fir.convert %[[C50_I64]] : (i64) -> index !CHECK: %[[SHAPE_SHIFT0:.*]] = fir.shape_shift %{{.*}}, %{{.*}} : (index, index) -> !fir.shapeshift<1> !CHECK: %[[SLICE0:.*]] = fir.slice %[[LB0]], %[[UB0]], %[[STEP0]] : (index, index, index) -> !fir.slice<1> @@ -140,13 +135,11 @@ !CHECK: fir.store %[[ARR_SECTION0]] to %[[MEM0]] : !fir.ref>> !CHECK: %[[LOAD_ARR1:.*]] = fir.load %[[ARR_HEAP]] : !fir.ref>> - !CHECK: %[[C51_I32:.*]] = arith.constant 51 : i32 - !CHECK: %[[C51_I64:.*]] = fir.convert %[[C51_I32]] : (i32) -> i64 + !CHECK: %[[C51_I64:.*]] = arith.constant 51 : i64 !CHECK: %[[LB1:.*]] = fir.convert %[[C51_I64]] : (i64) -> index !CHECK: %[[C1_STEP:.*]] = arith.constant 1 : i64 !CHECK: %[[STEP1:.*]] = fir.convert %[[C1_STEP]] : (i64) -> index - !CHECK: %[[C100_I32:.*]] = arith.constant 100 : i32 - !CHECK: %[[C100_I64:.*]] = fir.convert %[[C100_I32]] : (i32) -> i64 + !CHECK: %[[C100_I64:.*]] = arith.constant 100 : i64 !CHECK: %[[UB1:.*]] = fir.convert %[[C100_I64]] : (i64) -> index !CHECK: %[[SHAPE_SHIFT1:.*]] = fir.shape_shift %{{.*}}, %{{.*}} : (index, index) -> !fir.shapeshift<1> !CHECK: %[[SLICE1:.*]] = fir.slice %[[LB1]], %[[UB1]], %[[STEP1]] : (index, index, index) -> !fir.slice<1> @@ -179,13 +172,11 @@ !CHECK: %[[PTR_LOAD:.*]] = fir.load %[[PTR]] : !fir.ref>>> !CHECK: %[[C0:.*]] = arith.constant 0 : index !CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %[[PTR_LOAD]], %[[C0]] : (!fir.box>>, index) -> (index, index, index) - !CHECK: %[[C1_I32:.*]] = arith.constant 1 : i32 - !CHECK: %[[C1_I64:.*]] = fir.convert %[[C1_I32]] : (i32) -> i64 + !CHECK: %[[C1_I64:.*]] = arith.constant 1 : i64 !CHECK: %[[LB0:.*]] = fir.convert %[[C1_I64]] : (i64) -> index !CHECK: %[[C1_STEP:.*]] = arith.constant 1 : i64 !CHECK: %[[STEP0:.*]] = fir.convert %[[C1_STEP]] : (i64) -> index - !CHECK: %[[C50_I32:.*]] = arith.constant 50 : i32 - !CHECK: %[[C50_I64:.*]] = fir.convert %[[C50_I32]] : (i32) -> i64 + !CHECK: %[[C50_I64:.*]] = arith.constant 50 : i64 !CHECK: %[[UB0:.*]] = fir.convert %[[C50_I64]] : (i64) -> index !CHECK: %[[SHIFT0:.*]] = fir.shift %[[BOX_DIMS]]#0 : (index) -> !fir.shift<1> !CHECK: %[[SLICE0:.*]] = fir.slice %[[LB0]], %[[UB0]], %[[STEP0]] : (index, index, index) -> !fir.slice<1> Index: flang/test/Lower/explicit-interface-results.f90 =================================================================== --- flang/test/Lower/explicit-interface-results.f90 +++ flang/test/Lower/explicit-interface-results.f90 @@ -383,9 +383,9 @@ ! CHECK: fir.alloca !fir.array, {{.*}}some_local ! CHECK-NOT: fir.alloca !fir.array integer :: some_local(n) - some_local(0) = n + 64 + some_local(1) = n + 64 if (n.eq.1) then - res = char(some_local(0)) + res = char(some_local(1)) ! CHECK: else else ! CHECK-NOT: fir.alloca !fir.array @@ -407,7 +407,7 @@ ! CHECK-NOT: fir.alloca !fir.array ! CHECK: fir.call @_QPtest_recursion(%[[tmp]], {{.*}} - res = char(some_local(0)) // test_recursion(n-1) + res = char(some_local(1)) // test_recursion(n-1) ! Verify that symbol n was not remapped to the actual argument passed ! to n in the call (that the temporary mapping was cleaned-up). Index: flang/test/Semantics/allocate10.f90 =================================================================== --- flang/test/Semantics/allocate10.f90 +++ flang/test/Semantics/allocate10.f90 @@ -96,7 +96,7 @@ ! Test the check is not influenced by SOURCE !ERROR: The number of shape specifications, when they appear, must match the rank of allocatable object - allocate(a1%x(5, 4, 3), SOURCE=xsrc2a(1:5, 1:4, 1:3)) + allocate(a1%x(5, 4, 3), SOURCE=xsrc2a(4:8, 1:4, 1:3)) !ERROR: The number of shape specifications, when they appear, must match the rank of allocatable object allocate(x2(5), MOLD=xsrc1a(1:5)) !ERROR: The number of shape specifications, when they appear, must match the rank of allocatable object Index: flang/test/Semantics/allocate11.f90 =================================================================== --- flang/test/Semantics/allocate11.f90 +++ flang/test/Semantics/allocate11.f90 @@ -146,7 +146,7 @@ !ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray allocate(var[5:*], SOURCE=ptr) !ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray - allocate(varok, var[5:*], MOLD=ptr2(1)) + allocate(varok, var[5:*], MOLD=ptr2(2)) !ERROR: SOURCE or MOLD expression type must not be C_PTR or C_FUNPTR from ISO_C_BINDING when an allocatable object is a coarray allocate(var[5:*], MOLD=fptr) !ERROR: SOURCE or MOLD expression type must not be TEAM_TYPE from ISO_FORTRAN_ENV when an allocatable object is a coarray Index: flang/test/Semantics/data04.f90 =================================================================== --- flang/test/Semantics/data04.f90 +++ flang/test/Semantics/data04.f90 @@ -36,7 +36,7 @@ DATA a /1/ !C876 !ERROR: Automatic variable 'b' must not be initialized in a DATA statement - DATA b(0) /1/ + DATA b(1) /1/ !C876 !Ok: As charPtr is a pointer, it is not an automatic object DATA charPtr / NULL() / Index: flang/test/Semantics/expr-errors06.f90 =================================================================== --- /dev/null +++ flang/test/Semantics/expr-errors06.f90 @@ -0,0 +1,29 @@ +! RUN: %python %S/test_errors.py %s %flang_fc1 -Werror +! Check out-of-range subscripts +real a(10) +integer, parameter :: n(2) = [1, 2] +!ERROR: DATA statement designator 'a(0_8)' is out of range +!ERROR: DATA statement designator 'a(11_8)' is out of range +data a(0)/0./, a(10+1)/0./ +!ERROR: Subscript 0 is less than lower bound 1 for dimension 1 of array +print *, a(0) +!ERROR: Subscript 0 is less than lower bound 1 for dimension 1 of array +print *, a(1-1) +!ERROR: Subscript 11 is greater than upper bound 10 for dimension 1 of array +print *, a(11) +!ERROR: Subscript 11 is greater than upper bound 10 for dimension 1 of array +print *, a(10+1) +!ERROR: Subscript value (0) is out of range on dimension 1 in reference to a constant array value +print *, n(0) +!ERROR: Subscript value (3) is out of range on dimension 1 in reference to a constant array value +print *, n(4-1) +print *, a(1:12:3) ! ok +!ERROR: Subscript 13 is greater than upper bound 10 for dimension 1 of array +print *, a(1:13:3) +print *, a(10:-1:-3) ! ok +!ERROR: Subscript -2 is less than lower bound 1 for dimension 1 of array +print *, a(10:-2:-3) +print *, a(-1:-2) ! empty section is ok +print *, a(0:11:-1) ! empty section is ok +end +