diff --git a/flang/test/Lower/associate-construct-2.f90 b/flang/test/Lower/associate-construct-2.f90 new file mode 100644 index 0000000000000..3fb34b39ea353 --- /dev/null +++ b/flang/test/Lower/associate-construct-2.f90 @@ -0,0 +1,50 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! CHECK-LABEL: func @_QPtest1( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>{{.*}}, %[[VAL_1:.*]]: !fir.ref{{.*}}, %[[VAL_2:.*]]: !fir.ref{{.*}}, %[[VAL_3:.*]]: !fir.ref{{.*}}) { +! CHECK: %[[VAL_4:.*]] = arith.constant 100 : index +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_1]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> i64 +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> index +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_3]] : !fir.ref +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> i64 +! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i64) -> index +! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_2]] : !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i32) -> i64 +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i64) -> index +! CHECK: %[[VAL_14:.*]] = fir.shape %[[VAL_4]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_15:.*]] = fir.slice %[[VAL_7]], %[[VAL_13]], %[[VAL_10]] : (index, index, index) -> !fir.slice<1> +! CHECK: %[[VAL_16:.*]] = fir.embox %[[VAL_0]](%[[VAL_14]]) {{\[}}%[[VAL_15]]] : (!fir.ref>, !fir.shape<1>, !fir.slice<1>) -> !fir.box> +! CHECK: fir.call @_QPbob(%[[VAL_16]]) : (!fir.box>) -> () +! CHECK: return +! CHECK: } + +subroutine test1(a,i,j,k) + + real a(100) + integer i, j, k + interface + subroutine bob(a) + real :: a(:) + end subroutine bob + end interface + + associate (name => a(i:j:k)) + call bob(name) + end associate +end subroutine test1 + +! CHECK-LABEL: func @_QPtest2( +! CHECK-SAME: %[[nadd:.*]]: !fir.ref{{.*}}) +subroutine test2(n) + integer :: n + integer, external :: foo + ! CHECK: %[[n:.*]] = fir.load %[[nadd]] : !fir.ref + ! CHECK: %[[n10:.*]] = arith.addi %[[n]], %c10{{.*}} : i32 + ! CHECK: fir.store %[[n10]] to %{{.*}} : !fir.ref + ! CHECK: %[[foo:.*]] = fir.call @_QPfoo(%{{.*}}) : (!fir.ref) -> i32 + ! CHECK: fir.store %[[foo]] to %{{.*}} : !fir.ref + associate (i => n, j => n + 10, k => foo(20)) + print *, i, j, k, n + end associate +end subroutine test2 diff --git a/flang/test/Lower/assumed-shape-callee.f90 b/flang/test/Lower/assumed-shape-callee.f90 new file mode 100644 index 0000000000000..9c90d1c7bd5e3 --- /dev/null +++ b/flang/test/Lower/assumed-shape-callee.f90 @@ -0,0 +1,100 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test assumed shape dummy argument on callee side + +! TODO: These tests rely on looking at how a new fir.box is made for an assumed shape +! to see if lowering lowered and mapped the assumed shape symbol properties. +! However, the argument fir.box of the assumed shape could also be used instead +! of making a new fir.box and this would break all these tests. In fact, for non +! contiguous arrays, this is the case. Find a better way to tests symbol lowering/mapping. + +! CHECK-LABEL: func @_QPtest_assumed_shape_1(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}) +subroutine test_assumed_shape_1(x) + integer, contiguous :: x(:) + ! CHECK: %[[addr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + ! CHECK: %[[c0:.*]] = arith.constant 0 : index + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %arg0, %[[c0]] : (!fir.box>, index) -> (index, index, index) + ! CHECK: %[[c1:.*]] = arith.constant 1 : index + + print *, x + ! Test extent/lower bound use in the IO statement + ! CHECK: %[[cookie:.*]] = fir.call @_FortranAioBeginExternalListOutput + ! CHECK: %[[shape:.*]] = fir.shape_shift %[[c1]], %[[dims]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: %[[newbox:.*]] = fir.embox %[[addr]](%[[shape]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box> + ! CHECK: %[[castedBox:.*]] = fir.convert %[[newbox]] : (!fir.box>) -> !fir.box + ! CHECK: fir.call @_FortranAioOutputDescriptor(%[[cookie]], %[[castedBox]]) : (!fir.ref, !fir.box) -> i1 +end subroutine + +! lower bounds all ones +! CHECK-LABEL: func @_QPtest_assumed_shape_2(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}) +subroutine test_assumed_shape_2(x) + real, contiguous :: x(1:, 1:) + ! CHECK: fir.box_addr + ! CHECK: %[[dims1:.*]]:3 = fir.box_dims + ! CHECK: %[[dims2:.*]]:3 = fir.box_dims + print *, x + ! CHECK: fir.call @_FortranAioBeginExternalListOutput + ! CHECK: fir.shape %[[dims1]]#1, %[[dims2]]#1 +end subroutine + +! explicit lower bounds different from 1 +! CHECK-LABEL: func @_QPtest_assumed_shape_3(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}) +subroutine test_assumed_shape_3(x) + integer, contiguous :: x(2:, 3:, 42:) + ! CHECK: fir.box_addr + ! CHECK: fir.box_dim + ! CHECK: %[[c2_i64:.*]] = arith.constant 2 : i64 + ! CHECK: %[[c2:.*]] = fir.convert %[[c2_i64]] : (i64) -> index + ! CHECK: fir.box_dim + ! CHECK: %[[c3_i64:.*]] = arith.constant 3 : i64 + ! CHECK: %[[c3:.*]] = fir.convert %[[c3_i64]] : (i64) -> index + ! CHECK: fir.box_dim + ! CHECK: %[[c42_i64:.*]] = arith.constant 42 : i64 + ! CHECK: %[[c42:.*]] = fir.convert %[[c42_i64]] : (i64) -> index + + print *, x + ! CHECK: fir.shape_shift %[[c2]], %{{.*}}, %[[c3]], %{{.*}}, %[[c42]], %{{.*}} : +end subroutine + +! Constant length +! func @_QPtest_assumed_shape_char(%arg0: !fir.box>> {fir.bindc_name = "c", fir.contiguous}) +subroutine test_assumed_shape_char(c) + character(10), contiguous :: c(:) + ! CHECK: %[[addr:.*]] = fir.box_addr %arg0 : (!fir.box>>) -> !fir.ref>> + + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %arg0, %c0 : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[c1:.*]] = arith.constant 1 : index + + print *, c + ! CHECK: %[[shape:.*]] = fir.shape_shift %[[c1]], %[[dims]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: fir.embox %[[addr]](%[[shape]]) : (!fir.ref>>, !fir.shapeshift<1>) -> !fir.box>> +end subroutine + +! Assumed length +! CHECK-LABEL: func @_QPtest_assumed_shape_char_2(%arg0: !fir.box>> {fir.bindc_name = "c", fir.contiguous}) +subroutine test_assumed_shape_char_2(c) + character(*), contiguous :: c(:) + ! CHECK: %[[addr:.*]] = fir.box_addr %arg0 : (!fir.box>>) -> !fir.ref>> + ! CHECK: %[[len:.*]] = fir.box_elesize %arg0 : (!fir.box>>) -> index + + ! CHECK: %[[dims:.*]]:3 = fir.box_dims %arg0, %c0 : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[c1:.*]] = arith.constant 1 : index + + print *, c + ! CHECK: %[[shape:.*]] = fir.shape_shift %[[c1]], %[[dims]]#1 : (index, index) -> !fir.shapeshift<1> + ! CHECK: fir.embox %[[addr]](%[[shape]]) typeparams %[[len]] : (!fir.ref>>, !fir.shapeshift<1>, index) -> !fir.box>> +end subroutine + + +! lower bounds all 1. +! CHECK: func @_QPtest_assumed_shape_char_3(%arg0: !fir.box>> {fir.bindc_name = "c", fir.contiguous}) +subroutine test_assumed_shape_char_3(c) + character(*), contiguous :: c(1:, 1:) + ! CHECK: fir.box_addr + ! CHECK: fir.box_elesize + ! CHECK: %[[dims1:.*]]:3 = fir.box_dims + ! CHECK: %[[dims2:.*]]:3 = fir.box_dims + print *, c + ! CHECK: fir.call @_FortranAioBeginExternalListOutput + ! CHECK: fir.shape %[[dims1]]#1, %[[dims2]]#1 +end subroutine diff --git a/flang/test/Lower/assumed-shape-caller.f90 b/flang/test/Lower/assumed-shape-caller.f90 new file mode 100644 index 0000000000000..cbc1a22c93e91 --- /dev/null +++ b/flang/test/Lower/assumed-shape-caller.f90 @@ -0,0 +1,97 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test passing arrays to assumed shape dummy arguments + +! CHECK-LABEL: func @_QPfoo() +subroutine foo() + interface + subroutine bar(x) + ! lbounds are meaningless on caller side, some are added + ! here to check they are ignored. + real :: x(1:, 10:, :) + end subroutine + end interface + real :: x(42, 55, 12) + ! CHECK-DAG: %[[c42:.*]] = arith.constant 42 : index + ! CHECK-DAG: %[[c55:.*]] = arith.constant 55 : index + ! CHECK-DAG: %[[c12:.*]] = arith.constant 12 : index + ! CHECK-DAG: %[[addr:.*]] = fir.alloca !fir.array<42x55x12xf32> {{{.*}}uniq_name = "_QFfooEx"} + + call bar(x) + ! CHECK: %[[shape:.*]] = fir.shape %[[c42]], %[[c55]], %[[c12]] : (index, index, index) -> !fir.shape<3> + ! CHECK: %[[embox:.*]] = fir.embox %[[addr]](%[[shape]]) : (!fir.ref>, !fir.shape<3>) -> !fir.box> + ! CHECK: %[[castedBox:.*]] = fir.convert %[[embox]] : (!fir.box>) -> !fir.box> + ! CHECK: fir.call @_QPbar(%[[castedBox]]) : (!fir.box>) -> () +end subroutine + + +! Test passing character array as assumed shape. +! CHECK-LABEL: func @_QPfoo_char(%arg0: !fir.boxchar<1>{{.*}}) +subroutine foo_char(x) + interface + subroutine bar_char(x) + character(*) :: x(1:, 10:, :) + end subroutine + end interface + character(*) :: x(42, 55, 12) + ! CHECK-DAG: %[[x:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref>, index) + ! CHECK-DAG: %[[addr:.*]] = fir.convert %[[x]]#0 : (!fir.ref>) -> !fir.ref>> + ! CHECK-DAG: %[[c42:.*]] = arith.constant 42 : index + ! CHECK-DAG: %[[c55:.*]] = arith.constant 55 : index + ! CHECK-DAG: %[[c12:.*]] = arith.constant 12 : index + + call bar_char(x) + ! CHECK: %[[shape:.*]] = fir.shape %[[c42]], %[[c55]], %[[c12]] : (index, index, index) -> !fir.shape<3> + ! CHECK: %[[embox:.*]] = fir.embox %[[addr]](%[[shape]]) typeparams %[[x]]#1 : (!fir.ref>>, !fir.shape<3>, index) -> !fir.box>> + ! CHECK: %[[castedBox:.*]] = fir.convert %[[embox]] : (!fir.box>>) -> !fir.box>> + ! CHECK: fir.call @_QPbar_char(%[[castedBox]]) : (!fir.box>>) -> () +end subroutine + +! CHECK-LABEL: func @_QPtest_vector_subcripted_section_to_box( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "v"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.box> {fir.bindc_name = "x"}) { +subroutine test_vector_subcripted_section_to_box(v, x) + ! Test that a copy is made when passing a vector subscripted variable to + ! an assumed shape argument. + interface + subroutine takes_box(y) + real :: y(:) + end subroutine + end interface + integer :: v(:) + real :: x(:) + call takes_box(x(v)) +! CHECK: %[[VAL_2:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_4:.*]]:3 = fir.box_dims %[[VAL_1]], %[[VAL_3]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_0]], %[[VAL_5]] : (!fir.box>, index) -> (index, index, index) +! CHECK: %[[VAL_7:.*]] = fir.array_load %[[VAL_0]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_8:.*]] = arith.cmpi sgt, %[[VAL_6]]#1, %[[VAL_4]]#1 : index +! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_8]], %[[VAL_4]]#1, %[[VAL_6]]#1 : index +! CHECK: %[[VAL_10:.*]] = fir.array_load %[[VAL_1]] : (!fir.box>) -> !fir.array +! CHECK: %[[VAL_11:.*]] = fir.allocmem !fir.array, %[[VAL_9]] {uniq_name = ".array.expr"} +! CHECK: %[[VAL_12:.*]] = fir.shape %[[VAL_9]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_13:.*]] = fir.array_load %[[VAL_11]](%[[VAL_12]]) : (!fir.heap>, !fir.shape<1>) -> !fir.array +! CHECK: %[[VAL_14:.*]] = arith.constant 1 : index +! CHECK: %[[VAL_15:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_16:.*]] = arith.subi %[[VAL_9]], %[[VAL_14]] : index +! CHECK: %[[VAL_17:.*]] = fir.do_loop %[[VAL_18:.*]] = %[[VAL_15]] to %[[VAL_16]] step %[[VAL_14]] unordered iter_args(%[[VAL_19:.*]] = %[[VAL_13]]) -> (!fir.array) { +! CHECK: %[[VAL_20:.*]] = fir.array_fetch %[[VAL_7]], %[[VAL_18]] : (!fir.array, index) -> i32 +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (i32) -> index +! CHECK: %[[VAL_22:.*]] = arith.subi %[[VAL_21]], %[[VAL_2]] : index +! CHECK: %[[VAL_23:.*]] = fir.array_fetch %[[VAL_10]], %[[VAL_22]] : (!fir.array, index) -> f32 +! CHECK: %[[VAL_24:.*]] = fir.array_update %[[VAL_19]], %[[VAL_23]], %[[VAL_18]] : (!fir.array, f32, index) -> !fir.array +! CHECK: fir.result %[[VAL_24]] : !fir.array +! CHECK: } +! CHECK: fir.array_merge_store %[[VAL_13]], %[[VAL_25:.*]] to %[[VAL_11]] : !fir.array, !fir.array, !fir.heap> +! CHECK: %[[VAL_26:.*]] = fir.shape %[[VAL_9]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_27:.*]] = fir.embox %[[VAL_11]](%[[VAL_26]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box> +! CHECK: fir.call @_QPtakes_box(%[[VAL_27]]) : (!fir.box>) -> () +! CHECK: fir.freemem %[[VAL_11]] +end subroutine + +! Test external function declarations + +! CHECK: func private @_QPbar(!fir.box>) +! CHECK: func private @_QPbar_char(!fir.box>>) diff --git a/flang/test/Lower/attributes.f90 b/flang/test/Lower/attributes.f90 new file mode 100644 index 0000000000000..16e42ab282dae --- /dev/null +++ b/flang/test/Lower/attributes.f90 @@ -0,0 +1,29 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test propagation of Fortran attributes to FIR. + + +! CHECK-LABEL: func @_QPfoo1( +! CHECK-SAME: %arg0: !fir.ref {fir.bindc_name = "x", fir.optional}, +! CHECK-SAME: %arg1: !fir.box> {fir.bindc_name = "y", fir.optional}, +! CHECK-SAME: %arg2: !fir.ref>>> {fir.bindc_name = "i", fir.optional}, +! CHECK-SAME: %arg3: !fir.boxchar<1> {fir.bindc_name = "c", fir.optional} +subroutine foo1(x, y, i, c) + real, optional :: x, y(:) + integer, allocatable, optional :: i(:) + character, optional :: c +end subroutine + +! CHECK-LABEL: func @_QPfoo2( +! CHECK-SAME: %arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, +! CHECK-SAME: %arg1: !fir.ref>>> {fir.bindc_name = "i", fir.contiguous} +subroutine foo2(x, i) + real, contiguous :: x(:) + integer, pointer, contiguous :: i(:) +end subroutine + +! CHECK-LABEL: func @_QPfoo3 +! CHECK-SAME: %arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous, fir.optional} +subroutine foo3(x) + real, optional, contiguous :: x(:) +end subroutine