diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -2528,16 +2528,17 @@ bool procIsAssociated{ specificIntrinsic && specificIntrinsic->name == "associated"}; if (!procIsAssociated) { + const Symbol *procSymbol{proc.GetSymbol()}; + bool procIsDummy{procSymbol && IsDummy(*procSymbol)}; if (chars->functionResult && chars->functionResult->IsAssumedLengthCharacter() && - !specificIntrinsic) { + !specificIntrinsic && !procIsDummy) { 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, specificIntrinsic); - const Symbol *procSymbol{proc.GetSymbol()}; if (procSymbol && !IsPureProcedure(*procSymbol)) { if (const semantics::Scope * pure{semantics::FindPureProcedureContaining( diff --git a/flang/test/Evaluate/rewrite01.f90 b/flang/test/Evaluate/rewrite01.f90 --- a/flang/test/Evaluate/rewrite01.f90 +++ b/flang/test/Evaluate/rewrite01.f90 @@ -105,9 +105,11 @@ !CHECK: len_test subroutine len_test(a,b, c, d, e, n, m) character(*), intent(in) :: a - character(10) :: b + character(*) :: b external b character(10), intent(in) :: c + character(10) :: d + external d integer, intent(in) :: n, m character(n), intent(in) :: e @@ -115,9 +117,9 @@ print *, len(a, kind=8) !CHECK: PRINT *, 5_4 print *, len(a(1:5)) - !CHECK: PRINT *, 10_4 + !CHECK: PRINT *, len(b(a)) print *, len(b(a)) - !CHECK: PRINT *, int(10_8+int(a%len,kind=8),kind=4) + !CHECK: PRINT *, len(b(a)//a) print *, len(b(a) // a) !CHECK: PRINT *, 10_4 print *, len(c) @@ -126,14 +128,14 @@ !CHECK: PRINT *, 5_4 print *, len(c(1:5)) !CHECK: PRINT *, 10_4 - print *, len(b(c)) + print *, len(d(c)) !CHECK: PRINT *, 20_4 - print *, len(b(c) // c) + print *, len(d(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 *, 10_4 + !CHECK: PRINT *, len(b(a(int(n,kind=8):int(m,kind=8)))) 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:)) diff --git a/flang/test/Lower/dummy-procedure-character.f90 b/flang/test/Lower/dummy-procedure-character.f90 --- a/flang/test/Lower/dummy-procedure-character.f90 +++ b/flang/test/Lower/dummy-procedure-character.f90 @@ -143,6 +143,21 @@ ! 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) @@ -181,6 +196,34 @@ 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) diff --git a/flang/test/Lower/host-associated.f90 b/flang/test/Lower/host-associated.f90 --- a/flang/test/Lower/host-associated.f90 +++ b/flang/test/Lower/host-associated.f90 @@ -579,50 +579,57 @@ ! 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.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: %[[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: } subroutine test_proc_dummy_char @@ -640,8 +647,8 @@ function get_message(a) character(40) :: get_message - character(10) :: a - get_message = "message is: " // a() + character(*) :: a + get_message = "message is: " // a() end function get_message ! CHECK-LABEL: func @_QPtest_11a() { diff --git a/flang/test/Semantics/call01.f90 b/flang/test/Semantics/call01.f90 --- a/flang/test/Semantics/call01.f90 +++ b/flang/test/Semantics/call01.f90 @@ -129,16 +129,12 @@ 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