Index: flang/lib/Semantics/expression.cpp =================================================================== --- flang/lib/Semantics/expression.cpp +++ flang/lib/Semantics/expression.cpp @@ -2266,6 +2266,7 @@ msg = Say("NON_RECURSIVE procedure '%s' cannot call itself"_err_en_US, callSite); } else if (IsAssumedLengthCharacter(proc) && IsExternal(proc)) { + // TODO: Also catch assumed PDT type parameters msg = Say( // 15.6.2.1(3) "Assumed-length CHARACTER(*) function '%s' cannot call itself"_err_en_US, callSite); @@ -2516,17 +2517,19 @@ DEREF(proc.GetSymbol()).name()); } // Checks for ASSOCIATED() are done in intrinsic table processing - bool procIsAssociated{false}; - if (const SpecificIntrinsic * - specificIntrinsic{proc.GetSpecificIntrinsic()}) { - if (specificIntrinsic->name == "associated") { - procIsAssociated = true; - } - } + const SpecificIntrinsic *specificIntrinsic{proc.GetSpecificIntrinsic()}; + bool procIsAssociated{ + specificIntrinsic && specificIntrinsic->name == "associated"}; if (!procIsAssociated) { + if (chars->functionResult && + chars->functionResult->IsAssumedLengthCharacter() && + !specificIntrinsic) { + Say(callSite, + "Assumed-length character function must be defined with a length to be called"_err_en_US); + } semantics::CheckArguments(*chars, arguments, GetFoldingContext(), context_.FindScope(callSite), treatExternalAsImplicit, - proc.GetSpecificIntrinsic()); + specificIntrinsic); const Symbol *procSymbol{proc.GetSymbol()}; if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * Index: flang/test/Evaluate/rewrite01.f90 =================================================================== --- flang/test/Evaluate/rewrite01.f90 +++ flang/test/Evaluate/rewrite01.f90 @@ -105,11 +105,9 @@ !CHECK: len_test subroutine len_test(a,b, c, d, e, n, m) character(*), intent(in) :: a - character(*) :: b + character(10) :: b external b character(10), intent(in) :: c - character(10) :: d - external d integer, intent(in) :: n, m character(n), intent(in) :: e @@ -117,9 +115,9 @@ print *, len(a, kind=8) !CHECK: PRINT *, 5_4 print *, len(a(1:5)) - !CHECK: PRINT *, len(b(a)) + !CHECK: PRINT *, 10_4 print *, len(b(a)) - !CHECK: PRINT *, len(b(a)//a) + !CHECK: PRINT *, int(10_8+int(a%len,kind=8),kind=4) print *, len(b(a) // a) !CHECK: PRINT *, 10_4 print *, len(c) @@ -128,14 +126,14 @@ !CHECK: PRINT *, 5_4 print *, len(c(1:5)) !CHECK: PRINT *, 10_4 - print *, len(d(c)) + print *, len(b(c)) !CHECK: PRINT *, 20_4 - print *, len(d(c) // c) + print *, len(b(c) // c) !CHECK: PRINT *, 0_4 print *, len(a(10:4)) !CHECK: PRINT *, int(max(0_8,int(m,kind=8)-int(n,kind=8)+1_8),kind=4) print *, len(a(n:m)) - !CHECK: PRINT *, len(b(a(int(n,kind=8):int(m,kind=8)))) + !CHECK: PRINT *, 10_4 print *, len(b(a(n:m))) !CHECK: PRINT *, int(max(0_8,max(0_8,int(n,kind=8))-4_8+1_8),kind=4) print *, len(e(4:)) Index: flang/test/Lower/dummy-procedure-character.f90 =================================================================== --- flang/test/Lower/dummy-procedure-character.f90 +++ flang/test/Lower/dummy-procedure-character.f90 @@ -143,21 +143,6 @@ ! Test calling character dummy function ! ----------------------------------------------------------------------------- -! CHECK-LABEL: func @_QPcall_assumed_length -! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { -subroutine call_assumed_length(bar8) - character(*) :: bar8 - external :: bar8 -! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> -! CHECK: %[[WAL_2:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ()) -! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple ()>, i64>) -> i64 -! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_4]] : i64) {bindc_name = ".result"} -! CHECK: %[[VAL_7:.*]] = fir.convert %[[WAL_2]] : (() -> ()) -> ((!fir.ref>, index, !fir.ref) -> !fir.boxchar<1>) -! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_4]] : (i64) -> index -! CHECK: fir.call %[[VAL_7]](%[[VAL_6]], %[[VAL_8]], %{{.*}}) : (!fir.ref>, index, !fir.ref) -> !fir.boxchar<1> - call test(bar8(42)) -end subroutine - ! CHECK-LABEL: func @_QPcall_explicit_length ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) { subroutine call_explicit_length(bar9) @@ -196,34 +181,6 @@ call test(bar10(42_8)) end subroutine - -! CHECK-LABEL: func @_QPhost( -! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> -subroutine host(f) - character*(*) :: f - external :: f - ! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1:.*]], %{{.*}} : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> - ! CHECK: fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref ()>, i64>> - ! CHECK: fir.call @_QFhostPintern(%[[VAL_1]]) - call intern() -contains -! CHECK-LABEL: func @_QFhostPintern( -! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref ()>, i64>>> {fir.host_assoc}) - subroutine intern() -! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 -! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref ()>, i64>>>, i32) -> !fir.ref ()>, i64>> -! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref ()>, i64>> -! CHECK: %[[VAL_4:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> -! CHECK: %[[WAL_1:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ()) -! CHECK: %[[VAL_5:.*]] = fir.extract_value %[[VAL_3]], [1 : index] : (tuple ()>, i64>) -> i64 -! CHECK: %[[VAL_7:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_5]] : i64) {bindc_name = ".result"} -! CHECK: %[[VAL_8:.*]] = fir.convert %[[WAL_1]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) -! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_5]] : (i64) -> index -! CHECK: fir.call %[[VAL_8]](%[[VAL_7]], %[[VAL_9]]) : (!fir.ref>, index) -> !fir.boxchar<1> - call test(f()) - end subroutine -end subroutine - ! CHECK-LABEL: func @_QPhost2( ! CHECK-SAME: %[[VAL_0:.*]]: tuple ()>, i64> {fir.char_proc}) subroutine host2(f) Index: flang/test/Lower/host-associated.f90 =================================================================== --- flang/test/Lower/host-associated.f90 +++ flang/test/Lower/host-associated.f90 @@ -579,57 +579,50 @@ ! CHECK: %[[VAL_10:.*]] = fir.address_of(@_QQcl.{{.*}}) : !fir.ref> ! CHECK: %[[VAL_11:.*]] = fir.extract_value %[[VAL_2]], [0 : index] : (tuple ()>, i64>) -> !fir.boxproc<() -> ()> ! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ()) -! CHECK: %[[VAL_13:.*]] = fir.extract_value %[[VAL_2]], [1 : index] : (tuple ()>, i64>) -> i64 -! CHECK: %[[VAL_14:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref -! CHECK: %[[VAL_15:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_13]] : i64) {bindc_name = ".result"} -! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) -! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_13]] : (i64) -> index -! CHECK: %[[VAL_18:.*]] = fir.call %[[VAL_16]](%[[VAL_15]], %[[VAL_17]]) : (!fir.ref>, index) -> !fir.boxchar<1> -! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_4]] : index -! CHECK: %[[VAL_20:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_19]] : index) {bindc_name = ".chrtmp"} -! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_4]] : (index) -> i64 -! CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>) -> !fir.ref -! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_10]] : (!fir.ref>) -> !fir.ref -! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_22]], %[[VAL_23]], %[[VAL_21]], %[[VAL_5]]) : (!fir.ref, !fir.ref, i64, i1) -> () -! CHECK: br ^bb1(%[[VAL_4]], %[[VAL_17]] : index, index) -! CHECK: ^bb1(%[[VAL_24:.*]]: index, %[[VAL_25:.*]]: index): -! CHECK: %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_25]], %[[VAL_8]] : index -! CHECK: cond_br %[[VAL_26]], ^bb2, ^bb3 -! CHECK: ^bb2: -! CHECK: %[[VAL_27:.*]] = arith.subi %[[VAL_24]], %[[VAL_4]] : index -! CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_15]] : (!fir.ref>) -> !fir.ref>> -! CHECK: %[[VAL_29:.*]] = fir.coordinate_of %[[VAL_28]], %[[VAL_27]] : (!fir.ref>>, index) -> !fir.ref> -! CHECK: %[[VAL_30:.*]] = fir.load %[[VAL_29]] : !fir.ref> -! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_20]] : (!fir.ref>) -> !fir.ref>> -! CHECK: %[[VAL_32:.*]] = fir.coordinate_of %[[VAL_31]], %[[VAL_24]] : (!fir.ref>>, index) -> !fir.ref> -! CHECK: fir.store %[[VAL_30]] to %[[VAL_32]] : !fir.ref> -! CHECK: %[[VAL_33:.*]] = arith.addi %[[VAL_24]], %[[VAL_6]] : index -! CHECK: %[[VAL_34:.*]] = arith.subi %[[VAL_25]], %[[VAL_6]] : index -! CHECK: br ^bb1(%[[VAL_33]], %[[VAL_34]] : index, index) -! CHECK: ^bb3: -! CHECK: %[[VAL_35:.*]] = arith.cmpi slt, %[[VAL_3]], %[[VAL_19]] : index -! CHECK: %[[VAL_36:.*]] = arith.select %[[VAL_35]], %[[VAL_3]], %[[VAL_19]] : index -! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_36]] : (index) -> i64 -! CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref -! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_38]], %[[VAL_22]], %[[VAL_37]], %[[VAL_5]]) : (!fir.ref, !fir.ref, i64, i1) -> () -! CHECK: %[[VAL_39:.*]] = fir.undefined !fir.char<1> -! CHECK: %[[VAL_40:.*]] = fir.insert_value %[[VAL_39]], %[[VAL_7]], [0 : index] : (!fir.char<1>, i8) -> !fir.char<1> -! CHECK: %[[VAL_41:.*]] = arith.subi %[[VAL_3]], %[[VAL_36]] : index -! CHECK: br ^bb4(%[[VAL_36]], %[[VAL_41]] : index, index) -! CHECK: ^bb4(%[[VAL_42:.*]]: index, %[[VAL_43:.*]]: index): -! CHECK: %[[VAL_44:.*]] = arith.cmpi sgt, %[[VAL_43]], %[[VAL_8]] : index -! CHECK: cond_br %[[VAL_44]], ^bb5, ^bb6 -! CHECK: ^bb5: -! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_9]] : (!fir.ref>) -> !fir.ref>> -! CHECK: %[[VAL_46:.*]] = fir.coordinate_of %[[VAL_45]], %[[VAL_42]] : (!fir.ref>>, index) -> !fir.ref> -! CHECK: fir.store %[[VAL_40]] to %[[VAL_46]] : !fir.ref> -! CHECK: %[[VAL_47:.*]] = arith.addi %[[VAL_42]], %[[VAL_6]] : index -! CHECK: %[[VAL_48:.*]] = arith.subi %[[VAL_43]], %[[VAL_6]] : index -! CHECK: br ^bb4(%[[VAL_47]], %[[VAL_48]] : index, index) -! CHECK: ^bb6: -! CHECK: fir.call @llvm.stackrestore(%[[VAL_14]]) : (!fir.ref) -> () -! CHECK: %[[VAL_49:.*]] = fir.emboxchar %[[VAL_9]], %[[VAL_3]] : (!fir.ref>, index) -> !fir.boxchar<1> -! CHECK: return %[[VAL_49]] : !fir.boxchar<1> +! CHECK: %[[VAL_13:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref +! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> ((!fir.ref>, index) -> !fir.boxchar<1>) +! CHECK: %[[VAL_15:.*]] = fir.call %[[VAL_14]](%0, %c10) : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_16:.*]] = fir.alloca !fir.char<1,?>(%c22 : index) {bindc_name = ".chrtmp"} +! CHECK: %[[VAL_17:.*]] = fir.convert %c12 : (index) -> i64 +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_16]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_19:.*]] = fir.convert %2 : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_18]], %[[VAL_19]], %[[VAL_17]], %false) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: cf.br ^bb1(%c12, %c10 : index, index) +! CHECK: ^bb1(%[[VAL_20:.*]]: index, %[[VAL_21:.*]]: index): // 2 preds: ^bb0, ^bb2 +! CHECK: %[[VAL_22:.*]] = arith.cmpi sgt, %[[VAL_21]], %c0 : index +! CHECK: cf.cond_br %[[VAL_22]], ^bb2, ^bb3 +! CHECK: ^bb2: // pred: ^bb1 +! CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_20]], %c12 : index +! CHECK: %[[VAL_24:.*]] = fir.convert %0 : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_25:.*]] = fir.coordinate_of %[[VAL_24]], %[[VAL_23]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_25]] : !fir.ref> +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_16]] : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_28:.*]] = fir.coordinate_of %[[VAL_27]], %[[VAL_20]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_26]] to %[[VAL_28]] : !fir.ref> +! CHECK: %[[VAL_29:.*]] = arith.addi %[[VAL_20]], %c1 : index +! CHECK: %[[VAL_30:.*]] = arith.subi %[[VAL_21]], %c1 : index +! CHECK: cf.br ^bb1(%[[VAL_29]], %[[VAL_30]] : index, index) +! CHECK: ^bb3: // pred: ^bb1 +! CHECK: %[[VAL_31:.*]] = fir.convert %c22 : (index) -> i64 +! CHECK: %[[VAL_32:.*]] = fir.convert %1 : (!fir.ref>) -> !fir.ref +! CHECK: fir.call @llvm.memmove.p0i8.p0i8.i64(%[[VAL_32]], %[[VAL_18]], %[[VAL_31]], %false) : (!fir.ref, !fir.ref, i64, i1) -> () +! CHECK: %[[VAL_33:.*]] = fir.undefined !fir.char<1> +! CHECK: %[[VAL_34:.*]] = fir.insert_value %[[VAL_33]], %c32_i8, [0 : index] : (!fir.char<1>, i8) -> !fir.char<1> +! CHECK: cf.br ^bb4(%c22, %c18 : index, index) +! CHECK: ^bb4(%[[VAL_35:.*]]: index, %[[VAL_36:.*]]: index): // 2 preds: ^bb3, ^bb5 +! CHECK: %[[VAL_37:.*]] = arith.cmpi sgt, %[[VAL_36]], %c0 : index +! CHECK: cf.cond_br %[[VAL_37]], ^bb5, ^bb6 +! CHECK: ^bb5: // pred: ^bb4 +! CHECK: %[[VAL_38:.*]] = fir.convert %1 : (!fir.ref>) -> !fir.ref>> +! CHECK: %[[VAL_39:.*]] = fir.coordinate_of %[[VAL_38]], %[[VAL_35]] : (!fir.ref>>, index) -> !fir.ref> +! CHECK: fir.store %[[VAL_34]] to %[[VAL_39]] : !fir.ref> +! CHECK: %[[VAL_40:.*]] = arith.addi %[[VAL_35]], %c1 : index +! CHECK: %[[VAL_41:.*]] = arith.subi %[[VAL_36]], %c1 : index +! CHECK: cf.br ^bb4(%[[VAL_40]], %[[VAL_41]] : index, index) +! CHECK: ^bb6: // pred: ^bb4 +! CHECK: fir.call @llvm.stackrestore(%[[VAL_13]]) : (!fir.ref) -> () +! CHECK: %[[VAL_42:.*]] = fir.emboxchar %1, %c40 : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: return %[[VAL_42]] : !fir.boxchar<1> ! CHECK: } subroutine test_proc_dummy_char @@ -647,8 +640,8 @@ function get_message(a) character(40) :: get_message - character(*) :: a - get_message = "message is: " // a() + character(10) :: a + get_message = "message is: " // a() end function get_message ! CHECK-LABEL: func @_QPtest_11a() { Index: flang/test/Semantics/call01.f90 =================================================================== --- flang/test/Semantics/call01.f90 +++ flang/test/Semantics/call01.f90 @@ -97,6 +97,7 @@ res = '' else !ERROR: Assumed-length CHARACTER(*) function 'f13' cannot call itself + !ERROR: Assumed-length character function must be defined with a length to be called res = f13(n-1) ! 15.6.2.1(3) end if end function @@ -112,6 +113,32 @@ contains character(1) function nested !ERROR: Assumed-length CHARACTER(*) function 'f14' cannot call itself + !ERROR: Assumed-length character function must be defined with a length to be called nested = f14(n-1) ! 15.6.2.1(3) end function nested end function + +subroutine s01(f1, f2, fp1, fp2) + character*(*) :: f1, f3, fp1 + external :: f1, f3 + pointer :: fp1 + procedure(character*(*)), pointer :: fp2 + interface + character*(*) function f2() + end function + character*(*) function f4() + end function + end interface + !ERROR: Assumed-length character function must be defined with a length to be called + print *, f1() + !ERROR: Assumed-length character function must be defined with a length to be called + print *, f2() + !ERROR: Assumed-length character function must be defined with a length to be called + print *, f3() + !ERROR: Assumed-length character function must be defined with a length to be called + print *, f4() + !ERROR: Assumed-length character function must be defined with a length to be called + print *, fp1() + !ERROR: Assumed-length character function must be defined with a length to be called + print *, fp2() +end subroutine