Index: Fortran/gfortran/regression/analyzer/analyzer.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/analyzer.exp @@ -0,0 +1,55 @@ +# Copyright (C) 2020-2023 Free Software Foundation, Inc. + +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 3, or (at your option) any later +# version. +# +# GCC is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp +load_lib gfortran.exp + +# If the analyzer has not been enabled, bail. +if { ![check_effective_target_analyzer] } { + return +} + +global DEFAULT_FFLAGS +if [info exists DEFAULT_FFLAGS] then { + set save_default_fflags $DEFAULT_FFLAGS +} + +# If a testcase doesn't have special options, use these. +set DEFAULT_FFLAGS "-fanalyzer -Wanalyzer-too-complex -fanalyzer-call-summaries" + +# Initialize `dg'. +dg-init + +# Main loop. + +gfortran_init + +gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "" $DEFAULT_FFLAGS + +# All done. +dg-finish + +if [info exists save_default_fflags] { + set DEFAULT_FFLAGS $save_default_fflags +} else { + unset DEFAULT_FFLAGS +} Index: Fortran/gfortran/regression/analyzer/deferred_character_25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/deferred_character_25.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-additional-options "-Wno-analyzer-too-complex" } + +! Copy of gfortran.dg/deferred_character_25.f90 +! as a regression test for ICE with -fanalyzer (PR analyzer/93774) + +PROGRAM TEST + IMPLICIT NONE + INTEGER, PARAMETER :: I = 3 + character (len = i), parameter :: str(5) = ['abc','cde','fgh','ijk','lmn'] + + TYPE T + CHARACTER(LEN=:), ALLOCATABLE :: C(:) + END TYPE T + TYPE(T), TARGET :: S + CHARACTER (LEN=I), POINTER :: P(:) + + ALLOCATE ( CHARACTER(LEN=I) :: S%C(5) ) + s%c = str + +! This PR uncovered several problems associated with determining the +! element length and indexing. Test fairly thoroughly! + if (SIZE(S%C, 1) .ne. 5) stop 1 + if (LEN(S%C) .ne. 3) stop 2 + if (any (s%c .ne. str)) stop 3 + if (s%c(3) .ne. str(3)) stop 4 + P => S%C + if (SIZE(p, 1) .ne. 5) stop 5 + if (LEN(p) .ne. 3) stop 6 + if (any (p .ne. str)) stop 7 + if (p(5) .ne. str(5)) stop 8 +END PROGRAM TEST Index: Fortran/gfortran/regression/analyzer/malloc-example.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/malloc-example.f90 @@ -0,0 +1,21 @@ +! Example from GCC documentation +! { dg-do compile } +! { dg-additional-options "-fcray-pointer" } + +program test_malloc + implicit none + integer i + real*8 x(*), z + pointer(ptr_x,x) + + ptr_x = malloc(20*8) + do i = 1, 20 + x(i) = sqrt(1.0d0 / i) + end do + z = 0 + do i = 1, 20 + z = z + x(i) + print *, z + end do + call free(ptr_x) +end program test_malloc Index: Fortran/gfortran/regression/analyzer/malloc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/malloc.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-fcray-pointer -O0" } + +subroutine test_ok + real*8 x(*) + pointer(ptr_x,x) + + ptr_x = malloc(20*8) + call free(ptr_x) +end subroutine test_ok ! { dg-bogus "leak" } + +subroutine test_double_free + real*8 x(*) + pointer(ptr_x,x) + + ptr_x = malloc(20*8) + call free(ptr_x) + call free(ptr_x) ! { dg-warning "double-'free'" } +end subroutine test_double_free ! { dg-bogus "leak" } Index: Fortran/gfortran/regression/analyzer/pr107210.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr107210.f90 @@ -0,0 +1,16 @@ +! { dg-additional-options "-O1" } + +subroutine check_int (j) + INTEGER(4) :: i, ia(5), ib(5,4), ip, ipa(:) + target :: ib + POINTER :: ip, ipa + logical :: l(5) + + ipa=>ib(2:3,1) + + l = (/ sizeof(i) == 4, sizeof(ia) == 20, sizeof(ib) == 80, & + sizeof(ip) == 4, sizeof(ipa) == 8 /) + + if (any(.not.l)) STOP 4 + +end subroutine check_int Index: Fortran/gfortran/regression/analyzer/pr108065.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr108065.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-additional-options "-fcheck=bounds -Wno-analyzer-malloc-leak" } +! Copy of gfortran.dg/bounds_check_23.f90 +! as a regression test for ICE with -fanalyzer (PR analyzer/108065) + +program test + implicit none + call sub('Lorem ipsum') +contains + subroutine sub( text ) + character(len=*), intent(in) :: text + character(len=1), allocatable :: c(:) + integer :: i + c = [ ( text(i:i), i = 1, len(text) ) ] + if (c(1) /= 'L') stop 1 + end subroutine sub +end program test Index: Fortran/gfortran/regression/analyzer/pr88304-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr88304-2.f90 @@ -0,0 +1,29 @@ +! Copy of gfortran.fortran-torture/compile/pr88304-2.f90 +! as a regression test for ICE with -fanalyzer (PR analyzer/93779) + +module pr88304 + implicit none + integer :: p +contains + function foo (x, y, z, w) + integer, intent(in) :: x, y + character(*), optional, intent(out) :: z + integer, optional, intent(out) :: w + integer :: foo + foo = 1 + end function foo + subroutine bar () + integer :: s + s = baz (1) + contains + function baz (u) + integer, intent(in) :: u + integer :: baz + integer :: q + integer :: r (10) + r = 0 + baz = 1 + q = foo (p, r(u), w = baz) + end function baz + end subroutine bar +end module pr88304 Index: Fortran/gfortran/regression/analyzer/pr93405.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr93405.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +real a(10), b(10), c(10) +a = 0. +b = 1. +call sum(a, b, c, 10) +print *, c(5) +end +subroutine sum(a, b, c, n) +integer i, n +real a(n), b(n), c(n) +do i = 1, n + c(i) = a(i) + b(i) +enddo +end Index: Fortran/gfortran/regression/analyzer/pr93777.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr93777.f90 @@ -0,0 +1,22 @@ +! { dg-additional-options "-O0 -Wno-analyzer-possible-null-dereference -Wno-analyzer-null-dereference -Wno-analyzer-malloc-leak" } + +program cb + implicit none + type :: jn + real, allocatable :: ie + character(len = :), allocatable :: e5 + end type jn + real, parameter :: gm = 5.0 + + block + type(jn) :: r2 + + r2 = jn (gm, "") + call vz (r2%ie, gm) + end block +contains + subroutine vz (arg1, arg2) + real :: arg1, arg2 + if (arg1 .ne. arg2) STOP 1 + end subroutine vz +end program cb Index: Fortran/gfortran/regression/analyzer/pr93778.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr93778.f90 @@ -0,0 +1,11 @@ +program h0 + type bl + integer jq + end type bl + type qn + type (bl), dimension(3) :: xi + end type qn + type (qn) ro + namelist /i2/ ro + read(10, nml = i2) +end program h0 Index: Fortran/gfortran/regression/analyzer/pr93993.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr93993.f90 @@ -0,0 +1,33 @@ +module np + implicit none + integer, parameter :: za = selected_real_kind(15, 307) +end module np + +module gg + use np + + type et(real_kind) + integer, kind :: real_kind + end type et + +contains + + function hv (tm) result(ce) + type (et(real_kind=za)), allocatable, target :: tm + type (et(real_kind=za)), pointer :: ce + + allocate (tm) ! { dg-bogus "dereference of possibly-NULL" } + ce => tm + end function hv + +end module gg + +program a5 + use np + use gg + implicit none + type (et(real_kind=za)), allocatable :: qb + type (et(real_kind=za)), pointer :: vt + + vt => hv (qb) +end program a5 ! { dg-warning "leak of '.*qb'" } Index: Fortran/gfortran/regression/analyzer/pr96949.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr96949.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-additional-options "-Wno-analyzer-too-complex --param analyzer-max-svalue-depth=0" } + +program n6 + integer :: ck(2,2) + integer :: ac + + data ck /4 * 1/ + + call x9() + +contains + subroutine x9() + if (ck(2, 1) == 1) then + ac = 1 + else + ac = 0 + end if + end subroutine x9 +end program n6 Index: Fortran/gfortran/regression/analyzer/pr97668.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/pr97668.f @@ -0,0 +1,26 @@ +c { dg-additional-options "-std=legacy -Wno-analyzer-use-of-uninitialized-value -Wno-analyzer-too-complex" } + + SUBROUTINE PPADD (A, C, BH) + + COMPLEX DD, FP, FPP, R1, R2 + DIMENSION A(*), C(*), BH(*) + + DO 136 IG=IS,1 + FP = (0.,0.) + FPP = (0.,0.) + + DO 121 J=1,1 + DD = 1./2 + FP = DD + FPP = DD+1 + 121 CONTINUE + + R2 = -FP + IF (ABS(R1)-ABS(R2)) 129,129,133 + 129 R1 = R2/FPP + 133 IT = IT+1 + + 136 CONTINUE + + RETURN + END Index: Fortran/gfortran/regression/analyzer/uninit-pr63311.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/analyzer/uninit-pr63311.f90 @@ -0,0 +1,39 @@ +! { dg-additional-options "-O0" } + +MODULE M1 + IMPLICIT NONE +CONTAINS + INTEGER FUNCTION foo() + INTEGER, VOLATILE :: v=42 + foo=v + END FUNCTION + SUBROUTINE test(n,flag) + INTEGER :: n,i,j,k,l,tt + LOGICAL :: flag + REAL(KIND=8) :: v,t + IF (flag) THEN + t=42 + tt=foo() + ENDIF + v=0 + DO i=1,n + v=0 + IF (flag) THEN + IF (tt==i) v=MAX(v,t) + ENDIF + DO j=1,n + DO k=1,n + v=MAX(v,sin(REAL(j*k))) + ENDDO + ENDDO + ENDDO + END SUBROUTINE +END MODULE M1 + +USE M1 +INTEGER :: n +LOGICAL :: flag +n=4 +flag=.FALSE. +CALL test(n,flag) +END Index: Fortran/gfortran/regression/asan/asan.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/asan/asan.exp @@ -0,0 +1,40 @@ +# Copyright (C) 2020-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite for gfortran that checks for -fsanitize=address error. + +# Contributed by Thomas König, + +# Load support procs. +load_lib gfortran-dg.exp +load_lib asan-dg.exp + + +# Initialize `dg'. +dg-init +asan_init + +# Main loop. +if [check_effective_target_fsanitize_address] { + gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "-fsanitize=address" "" +} + +# All done. +asan_finish +dg-finish Index: Fortran/gfortran/regression/asan/associate_58.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/asan/associate_58.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-O0" } +! +! PR fortran/104228 +! The code generated code for the program below wrongly pushed the Y character +! length variable to both P and S scope, which was leading to an ICE when +! address sanitizer was in effect + +program p + character(:), save, allocatable :: x(:) + call s +contains + subroutine s + associate (y => x) + y = [x] + end associate + end +end + Index: Fortran/gfortran/regression/asan/associate_59.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/asan/associate_59.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-O0" } +! +! PR fortran/104228 +! The code generated code for the program below wrongly pushed the Y character +! length variable to both P and S scope, which was leading to an ICE when +! address sanitizer was in effect + +program p + character(:), allocatable :: x(:) + call s +contains + subroutine s + associate (y => x) + y = [x] + end associate + end +end + Index: Fortran/gfortran/regression/asan/pointer_assign_16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/asan/pointer_assign_16.f90 @@ -0,0 +1,304 @@ +! { dg-do run } +! PR fortran/94788 - this leads to a double free. +! Test case by Juergen Reuter. +module iso_varying_string + implicit none + integer, parameter, private :: GET_BUFFER_LEN = 1 + type, public :: varying_string + private + character(LEN=1), dimension(:), allocatable :: chars + end type varying_string + + interface assignment(=) + module procedure op_assign_CH_VS + module procedure op_assign_VS_CH + end interface assignment(=) + + interface char + module procedure char_auto + module procedure char_fixed + end interface char + + interface len + module procedure len_ + end interface len + + interface var_str + module procedure var_str_ + end interface var_str + + public :: assignment(=) + public :: char + public :: len + public :: var_str + + private :: op_assign_CH_VS + private :: op_assign_VS_CH + private :: op_eq_VS_VS + private :: op_eq_CH_VS + private :: op_eq_VS_CH + private :: char_auto + private :: char_fixed + private :: len_ + private :: var_str_ + +contains + + elemental function len_ (string) result (length) + type(varying_string), intent(in) :: string + integer :: length + if(ALLOCATED(string%chars)) then + length = SIZE(string%chars) + else + length = 0 + endif + end function len_ + + elemental subroutine op_assign_CH_VS (var, exp) + character(LEN=*), intent(out) :: var + type(varying_string), intent(in) :: exp + var = char(exp) + end subroutine op_assign_CH_VS + + elemental subroutine op_assign_VS_CH (var, exp) + type(varying_string), intent(out) :: var + character(LEN=*), intent(in) :: exp + var = var_str(exp) + end subroutine op_assign_VS_CH + + elemental function op_eq_VS_VS (string_a, string_b) result (op_eq) + type(varying_string), intent(in) :: string_a + type(varying_string), intent(in) :: string_b + logical :: op_eq + op_eq = char(string_a) == char(string_b) + end function op_eq_VS_VS + + elemental function op_eq_CH_VS (string_a, string_b) result (op_eq) + character(LEN=*), intent(in) :: string_a + type(varying_string), intent(in) :: string_b + logical :: op_eq + op_eq = string_a == char(string_b) + end function op_eq_CH_VS + + elemental function op_eq_VS_CH (string_a, string_b) result (op_eq) + type(varying_string), intent(in) :: string_a + character(LEN=*), intent(in) :: string_b + logical :: op_eq + op_eq = char(string_a) == string_b + end function op_eq_VS_CH + + + pure function char_auto (string) result (char_string) + type(varying_string), intent(in) :: string + character(LEN=len(string)) :: char_string + integer :: i_char + forall(i_char = 1:len(string)) + char_string(i_char:i_char) = string%chars(i_char) + end forall + + end function char_auto + + pure function char_fixed (string, length) result (char_string) + type(varying_string), intent(in) :: string + integer, intent(in) :: length + character(LEN=length) :: char_string + char_string = char(string) + end function char_fixed + + elemental function var_str_ (char) result (string) + character(LEN=*), intent(in) :: char + type(varying_string) :: string + integer :: length + integer :: i_char + length = LEN(char) + ALLOCATE(string%chars(length)) + forall(i_char = 1:length) + string%chars(i_char) = char(i_char:i_char) + end forall + end function var_str_ + +end module iso_varying_string + + +module parser + implicit none + private + public :: parse_node_t + public :: parse_tree_t + type :: parse_node_t + private + end type parse_node_t + + type :: parse_tree_t + private + type(parse_node_t), pointer :: root_node => null () + contains + procedure :: get_root_ptr => parse_tree_get_root_ptr + end type parse_tree_t + +contains + function parse_tree_get_root_ptr (parse_tree) result (node) + class(parse_tree_t), intent(in) :: parse_tree + type(parse_node_t), pointer :: node + node => parse_tree%root_node + end function parse_tree_get_root_ptr + +end module parser + + + +module rt_data + use iso_varying_string, string_t => varying_string + use parser, only: parse_node_t + implicit none + private + + public :: rt_data_t + + type :: rt_parse_nodes_t + type(parse_node_t), pointer :: weight_expr => null () + end type rt_parse_nodes_t + + type :: rt_data_t + type(rt_parse_nodes_t) :: pn + type(string_t) :: logfile + contains + procedure :: global_init => rt_data_global_init + procedure :: local_init => rt_data_local_init + procedure :: activate => rt_data_activate + end type rt_data_t + + +contains + + subroutine rt_data_global_init (global, logfile) + class(rt_data_t), intent(out), target :: global + type(string_t), intent(in), optional :: logfile + integer :: seed + if (present (logfile)) then + global%logfile = logfile + else + global%logfile = "" + end if + call system_clock (seed) + end subroutine rt_data_global_init + + subroutine rt_data_local_init (local, global, env) + class(rt_data_t), intent(inout), target :: local + type(rt_data_t), intent(in), target :: global + integer, intent(in), optional :: env + local%logfile = global%logfile + end subroutine rt_data_local_init + + subroutine rt_data_activate (local) + class(rt_data_t), intent(inout), target :: local + class(rt_data_t), pointer :: global + + ! global => local%context + ! if (associated (global)) then + ! local%logfile = global%logfile + ! local%pn = global%pn + ! end if + end subroutine rt_data_activate + +end module rt_data + +module events + implicit none + private + public :: event_t + + type :: event_config_t + end type event_config_t + + type :: event_t + type(event_config_t) :: config + end type event_t + +end module events + + +module simulations + use iso_varying_string, string_t => varying_string + use events + use rt_data + + implicit none + private + + public :: simulation_t + + type, extends (event_t) :: entry_t + private + type(entry_t), pointer :: next => null () + end type entry_t + + type, extends (entry_t) :: alt_entry_t + contains + procedure :: init_alt => alt_entry_init + end type alt_entry_t + + type :: simulation_t + private + type(rt_data_t), pointer :: local => null () + integer :: n_alt = 0 + type(entry_t), dimension(:), allocatable :: entry + type(alt_entry_t), dimension(:,:), allocatable :: alt_entry + contains + procedure :: init => simulation_init + end type simulation_t + + +contains + + subroutine alt_entry_init (entry, local) + class(alt_entry_t), intent(inout), target :: entry + type(rt_data_t), intent(inout), target :: local + integer :: i + end subroutine alt_entry_init + + subroutine simulation_init (simulation, & + integrate, generate, local, global, alt_env) + class(simulation_t), intent(out), target :: simulation + logical, intent(in) :: integrate, generate + type(rt_data_t), intent(inout), target :: local + type(rt_data_t), intent(inout), optional, target :: global + type(rt_data_t), dimension(:), intent(inout), optional, target :: alt_env + simulation%local => local + allocate (simulation%entry (1)) + if (present (alt_env)) then + simulation%n_alt = size (alt_env) + end if + end subroutine simulation_init + +end module simulations + + +program main_ut + use iso_varying_string, string_t => varying_string + use parser, only: parse_tree_t + use rt_data + use simulations + implicit none + call simulations_10 (6) + +contains + + subroutine simulations_10 (u) + integer, intent(in) :: u + type(rt_data_t), target :: global + type(rt_data_t), dimension(1), target :: alt_env + type(parse_tree_t) :: pt_weight + type(simulation_t), target :: simulation + + call global%global_init () + call alt_env(1)%local_init (global) + call alt_env(1)%activate () + + !!!! This causes the pointer hiccup + alt_env(1)%pn%weight_expr => pt_weight%get_root_ptr () + call simulation%init (.true., .true., global, alt_env=alt_env) + + end subroutine simulations_10 + +end program main_ut Index: Fortran/gfortran/regression/c-interop/allocatable-dummy-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocatable-dummy-c.c @@ -0,0 +1,54 @@ +#include +#include +#include + +#include +#include "dump-descriptors.h" + +struct t { + float xyz[3]; + int id; +}; + +extern void testit_f_bind_c (CFI_cdesc_t *a, float x, float y, float z); +extern void testit_c (CFI_cdesc_t *a, float x, float y, float z); + +void testit_c (CFI_cdesc_t *a, float x, float y, float z) +{ + struct t *tp; + + /* Check that the allocatable dummy is unallocated on entry and do + some other sanity checks. */ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->rank) + abort (); + if (a->base_addr) + abort (); + + /* Allocate and initialize the output argument. */ + CFI_allocate (a, NULL, NULL, 0); + if (!a->base_addr) + abort (); + tp = (struct t *) CFI_address (a, NULL); + tp->id = 42; + tp->xyz[0] = 0.0; + tp->xyz[1] = 0.0; + tp->xyz[2] = 0.0; + + /* Now call the Fortran function, which is supposed to automatically + deallocate the object we just created above and point the descriptor + at a different object. */ + testit_f_bind_c (a, x, y, z); + + /* Make sure we've got an allocated object, initialized as we + expect. */ + if (!a->base_addr) + abort (); + tp = (struct t *) CFI_address (a, NULL); + if (tp->id != -1) + abort (); + if (tp->xyz[0] != x || tp->xyz[1] != y || tp->xyz[2] != z) + abort (); +} Index: Fortran/gfortran/regression/c-interop/allocatable-dummy.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocatable-dummy.f90 @@ -0,0 +1,98 @@ +! PR 101308 +! PR 92621(?) +! { dg-do run } +! { dg-additional-sources "allocatable-dummy-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! TS 29113 +! 6.3 Argument association +! +! When a Fortran procedure that has an INTENT(OUT) allocatable dummy +! argument is invoked by a C function, and the actual argument in the C +! function is the address of a C descriptor that describes an allocated +! allocatable variable, the variable is deallocated on entry to the +! Fortran procedure. + +! When a C function is invoked from a Fortran procedure via an interface +! with an INTENT(OUT) allocatable dummy argument, and the actual +! argument in the reference to the C function is an allocated +! allocatable variable, the variable is deallocated on invocation +! (before execution of the C function begins). + +module m + use iso_c_binding + + type, bind (c) :: t + real(C_FLOAT) :: xyz(3) + integer(C_INT) :: id + end type + + interface + subroutine testit_c (a, x, y, z) bind (c) + use iso_c_binding + import :: t + type (t), allocatable, intent(out) :: a + real(C_FLOAT), value, intent(in) :: x, y, z + end subroutine + end interface + + contains + + subroutine testit_f (a, x, y, z) + type (t), allocatable, intent(out) :: a + real(C_FLOAT), value, intent(in) :: x, y, z + if (allocated (a)) stop 201 + allocate (a) + a%id = 69 + a%xyz(1) = x + a%xyz(2) = y + a%xyz(3) = z + end subroutine + + subroutine testit_f_bind_c (a, x, y, z) bind (c) + type (t), allocatable, intent(out) :: a + real(C_FLOAT), value, intent(in) :: x, y, z + if (allocated (a)) stop 301 + allocate (a) + a%id = -1 + a%xyz(1) = x + a%xyz(2) = y + a%xyz(3) = z + end subroutine + +end module + +program test + use iso_c_binding + use m + + type (t), allocatable :: b + + if (allocated (b)) stop 401 + + ! Try the regular Fortran test routine. + allocate (b) + call testit_f (b, 1.0, 2.0, 3.0) + if (.not. allocated (b)) stop 402 + deallocate (b) + if (allocated (b)) stop 403 + + ! Try the test routine written in Fortran with C binding. + allocate (b) + call testit_f_bind_c (b, 1.0, 2.0, 3.0) + if (.not. allocated (b)) stop 404 + deallocate (b) + if (allocated (b)) stop 405 + + ! Try the test routine written in C. This calls testit_f_bind_c + ! before returning, so make sure that's what we've got when returning. + allocate (b) + call testit_c (b, -1.0, -2.0, -3.0) + if (.not. allocated (b)) stop 406 + if (b%id .ne. -1) stop 407 + if (b%xyz(1) .ne. -1.0) stop 408 + if (b%xyz(2) .ne. -2.0) stop 408 + if (b%xyz(3) .ne. -3.0) stop 408 + deallocate (b) + +end program Index: Fortran/gfortran/regression/c-interop/allocatable-optional-pointer.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocatable-optional-pointer.f90 @@ -0,0 +1,23 @@ +! { dg-do compile} +! +! TS 29113 +! 5.3 ALLOCATABLE, OPTIONAL, and POINTER attributes +! The ALLOCATABLE, OPTIONAL, and POINTER attributes may be specified +! for a dummy argument in a procedure interface that has the BIND +! attribute. + +subroutine test (a, b, c) + integer, allocatable :: a + integer, optional :: b + integer, pointer :: c + + interface + subroutine ctest (aa, bb, cc) bind (c) + integer, allocatable :: aa + integer, optional :: bb + integer, pointer :: cc + end subroutine + end interface + + call ctest (a, b, c) +end subroutine Index: Fortran/gfortran/regression/c-interop/allocate-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocate-c.c @@ -0,0 +1,168 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +struct s { + int i; + double d; +}; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + CFI_CDESC_T(3) desc; + CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc; + CFI_index_t ex[3], lb[3], ub[3]; + CFI_index_t sm; + int i; + + /* Allocate and deallocate a scalar. */ + sm = sizeof (struct s); + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_allocatable, + CFI_type_struct, sm, + 0, NULL)); + check_CFI_status ("CFI_allocate", + CFI_allocate (dv, NULL, NULL, 69)); + dump_CFI_cdesc_t (dv); + if (dv->base_addr == NULL) + abort (); + /* The elem_len argument only overrides the initial value in the + descriptor for character types. */ + if (dv->elem_len != sm) + abort (); + check_CFI_status ("CFI_deallocate", + CFI_deallocate (dv)); + /* The base_addr member of the C descriptor becomes a null pointer. */ + if (dv->base_addr != NULL) + abort (); + + /* Try an array. We are going to test the requirement that: + The supplied lower and upper bounds override any current + dimension information in the C descriptor. + so we'll stuff different values in the descriptor to start with. */ + ex[0] = 3; + ex[1] = 4; + ex[2] = 5; + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_pointer, + CFI_type_double, 0, 3, ex)); + lb[0] = 1; + lb[1] = 2; + lb[2] = 3; + ub[0] = 10; + ub[1] = 5; + ub[2] = 10; + sm = sizeof (double); + check_CFI_status ("CFI_allocate", + CFI_allocate (dv, lb, ub, 20)); + dump_CFI_cdesc_t (dv); + if (dv->base_addr == NULL) + abort (); + /* The element sizes passed to both CFI_establish and CFI_allocate should + have been ignored in favor of using the constant size of the type. */ + if (dv->elem_len != sm) + abort (); + + /* Check extents and strides; we expect the allocated array to + be contiguous so the stride computation should be straightforward + no matter what the lower bound is. */ + for (i = 0; i < 3; i++) + { + CFI_index_t extent = ub[i] - lb[i] + 1; + if (dv->dim[i].lower_bound != lb[i]) + abort (); + if (dv->dim[i].extent != extent) + abort (); + /* pr93524 */ + if (dv->dim[i].sm != sm) + abort (); + sm *= extent; + } + check_CFI_status ("CFI_deallocate", + CFI_deallocate (dv)); + if (dv->base_addr != NULL) + abort (); + + /* Similarly for a character array, except that we expect the + elem_len provided to CFI_allocate to prevail. We set the elem_len + to the same size as the array element in the previous example, so + the bounds and strides should all be the same. */ + ex[0] = 3; + ex[1] = 4; + ex[2] = 5; + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_allocatable, + CFI_type_char, 4, 3, ex)); + lb[0] = 1; + lb[1] = 2; + lb[2] = 3; + ub[0] = 10; + ub[1] = 5; + ub[2] = 10; + sm = sizeof (double); + check_CFI_status ("CFI_allocate", + CFI_allocate (dv, lb, ub, sm)); + dump_CFI_cdesc_t (dv); + if (dv->base_addr == NULL) + abort (); + if (dv->elem_len != sm) + abort (); + + /* Check extents and strides; we expect the allocated array to + be contiguous so the stride computation should be straightforward + no matter what the lower bound is. */ + for (i = 0; i < 3; i++) + { + CFI_index_t extent = ub[i] - lb[i] + 1; + if (dv->dim[i].lower_bound != lb[i]) + abort (); + if (dv->dim[i].extent != extent) + abort (); + /* pr93524 */ + if (dv->dim[i].sm != sm) + abort (); + sm *= extent; + } + check_CFI_status ("CFI_deallocate", + CFI_deallocate (dv)); + if (dv->base_addr != NULL) + abort (); + + /* Signed char is not a Fortran character type. Here we expect it to + ignore the elem_len argument and use the size of the type. */ + ex[0] = 3; + ex[1] = 4; + ex[2] = 5; + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_allocatable, + CFI_type_signed_char, 4, 3, ex)); + lb[0] = 1; + lb[1] = 2; + lb[2] = 3; + ub[0] = 10; + ub[1] = 5; + ub[2] = 10; + sm = sizeof (double); + check_CFI_status ("CFI_allocate", + CFI_allocate (dv, lb, ub, sm)); + dump_CFI_cdesc_t (dv); + if (dv->base_addr == NULL) + abort (); + if (dv->elem_len != sizeof (signed char)) + abort (); + + check_CFI_status ("CFI_deallocate", + CFI_deallocate (dv)); + if (dv->base_addr != NULL) + abort (); + +} + Index: Fortran/gfortran/regression/c-interop/allocate-errors-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocate-errors-c.c @@ -0,0 +1,109 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +struct s { + int i; + double d; +}; + +static long buf[5][4][3]; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + int bad = 0; + int status; + CFI_CDESC_T(3) desc; + CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc; + CFI_index_t ex[3], lb[3], ub[3]; + CFI_index_t sm; + + /* On entry, the base_addr member of the C descriptor shall be a null + pointer. */ + sm = sizeof (struct s); + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_allocatable, + CFI_type_struct, sm, + 0, NULL)); + check_CFI_status ("CFI_allocate", + CFI_allocate (dv, NULL, NULL, 69)); + status = CFI_allocate (dv, NULL, NULL, 42); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_allocate of already-allocated object\n"); + bad ++; + } + check_CFI_status ("CFI_deallocate", + CFI_deallocate (dv)); + + /* The attribute member of the C descriptor shall have a value of + CFI_attribute_allocatable or CFI_attribute_pointer. */ + ex[0] = 3; + ex[1] = 4; + ex[2] = 5; + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_other, + CFI_type_long, 0, 3, ex)); + lb[0] = 1; + lb[1] = 2; + lb[2] = 3; + ub[0] = 10; + ub[1] = 5; + ub[2] = 10; + sm = sizeof (long); + status = CFI_allocate (dv, lb, ub, 20); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_allocate of CFI_attribute_other object\n"); + bad ++; + } + + /* dv shall be the address of a C descriptor describing the object. + It shall have been allocated using the same mechanism as the + Fortran ALLOCATE statement. */ + ex[0] = 3; + ex[1] = 4; + ex[2] = 5; + check_CFI_status ("CFI_establish", + CFI_establish (dv, NULL, CFI_attribute_pointer, + CFI_type_long, 0, 3, ex)); + status = CFI_deallocate (dv); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_deallocate with null pointer\n"); + bad ++; + } + + /* This variant is disabled. In theory it should be possible for + the memory allocator to easily check for pointers outside the + heap region, but libfortran just calls free() which has no provision + for returning an error, and there is no other standard C interface + to check the validity of a pointer in the C heap either. */ +#if 0 + check_CFI_status ("CFI_establish", + CFI_establish (dv, buf, CFI_attribute_pointer, + CFI_type_long, 0, 3, ex)); + status = CFI_deallocate (dv); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_deallocate with non-allocated pointer\n"); + bad ++; + } +#endif + + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/allocate-errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocate-errors.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-sources "allocate-errors-c.c dump-descriptors.c" } +! { dg-additional-options "-Wno-error -fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! This program tests that the CFI_allocate and CFI_deallocate functions +! properly detect invalid arguments. All the interesting things happen +! in the corresponding C code. +! +! The situation here seems to be that while TS29113 defines error codes for +! these functions, it doesn't actually require the implementation to detect +! those errors by saying the arguments "shall be" such-and-such, e.g. it is +! undefined behavior if they are not. In gfortran you can enable some +! run-time checking by building with -fcheck=all. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/allocate.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/allocate.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-additional-sources "allocate-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests the CFI_allocate and CFI_deallocate functions. +! All the interesting things happen in the corresponding C code. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-1.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. If the actual argument has rank zero, the dummy argument has +! rank zero; the shape is a zero-sized array and the LBOUND and UBOUND +! intrinsic functions, with no DIM argument, return zero-sized +! arrays. [...] + +program test + + call testit (42) + +contains + + subroutine testit (x0) + integer :: x0(..) + + ! expect to have rank 0 + if (rank (x0) .ne. 0) stop 101 + + ! expect shape to be a zero-sized array + if (size (shape (x0)) .ne. 0) stop 102 + + ! expect lbound and ubound functions to return zero-sized arrays + if (size (lbound (x0)) .ne. 0) stop 103 + if (size (ubound (x0)) .ne. 0) stop 104 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-2.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer :: a(3, 4, 5) + integer :: b(-3:3, 0:4, 2:5, 10:20) + + call testit (a, rank(a), shape(a), lbound(a), ubound(a)) + call testit (b, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) + integer :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. 1)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u - l + 1)) stop 107 + if (any (ubound (x) .ne. s)) stop 108 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-3.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer, target :: a(3, 4, 5) + integer, target :: b(-3:3, 0:4, 2:5, 10:20) + integer, pointer :: aa(:,:,:) + integer, pointer :: bb(:,:,:,:) + aa => a + bb => b + + call testit (aa, rank(a), shape(a), lbound(a), ubound(a)) + call testit (bb, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) + integer, pointer :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. l)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u)) stop 107 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-4.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer, allocatable :: a(:,:,:) + integer, allocatable :: b(:,:,:,:) + + allocate (a(3, 4, 5)) + allocate (b(-3:3, 0:4, 2:5, 10:20)) + + call testit (a, rank(a), shape(a), lbound(a), ubound(a)) + call testit (b, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) + integer, allocatable :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. l)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u)) stop 107 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-5.f90 @@ -0,0 +1,31 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. If the actual argument has rank zero, the dummy argument has +! rank zero; the shape is a zero-sized array and the LBOUND and UBOUND +! intrinsic functions, with no DIM argument, return zero-sized +! arrays. [...] + +program test + + call testit (42) + +contains + + subroutine testit (x0) bind (c) + integer :: x0(..) + + ! expect to have rank 0 + if (rank (x0) .ne. 0) stop 101 + + ! expect shape to be a zero-sized array + if (size (shape (x0)) .ne. 0) stop 102 + + ! expect lbound and ubound functions to return zero-sized arrays + if (size (lbound (x0)) .ne. 0) stop 103 + if (size (ubound (x0)) .ne. 0) stop 104 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-6.f90 @@ -0,0 +1,48 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer :: a(3, 4, 5) + integer :: b(-3:3, 0:4, 2:5, 10:20) + + call testit (a, rank(a), shape(a), lbound(a), ubound(a)) + call testit (b, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) bind (c) + integer :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. 1)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u - l + 1)) stop 107 + if (any (ubound (x) .ne. s)) stop 108 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-7.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer, target :: a(3, 4, 5) + integer, target :: b(-3:3, 0:4, 2:5, 10:20) + integer, pointer :: aa(:,:,:) + integer, pointer :: bb(:,:,:,:) + aa => a + bb => b + + call testit (aa, rank(a), shape(a), lbound(a), ubound(a)) + call testit (bb, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) bind (c) + integer, pointer :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. l)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u)) stop 107 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/argument-association-assumed-rank-8.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! TS 29113 +! 6.3 Argument association +! An assumed-rank dummy argument may correspond to an actual argument of +! any rank. [...] If the actual argument has rank greater than zero, the +! rank and extents of the dummy argument are assumed from the actual +! argument, including the lack of a final extent in the case of an +! assumed-size array. If the actual argument is an array and the dummy +! argument is allocatable or a pointer, the bounds of the dummy argument +! are assumed from the actual argument. + +program test + + integer, allocatable :: a(:,:,:) + integer, allocatable :: b(:,:,:,:) + + allocate (a(3, 4, 5)) + allocate (b(-3:3, 0:4, 2:5, 10:20)) + + call testit (a, rank(a), shape(a), lbound(a), ubound(a)) + call testit (b, rank(b), shape(b), lbound(b), ubound(b)) + +contains + + subroutine testit (x, r, s, l, u) bind (c) + integer, allocatable :: x(..) + integer :: r + integer :: s(r) + integer :: l(r) + integer :: u(r) + + ! expect rank to match + if (rank (x) .ne. r) stop 101 + + ! expect shape to match + if (size (shape (x)) .ne. r) stop 102 + if (any (shape (x) .ne. s)) stop 103 + + ! expect lbound and ubound functions to return rank-sized arrays. + ! for non-pointer/non-allocatable arrays, bounds are normalized + ! to be 1-based. + if (size (lbound (x)) .ne. r) stop 104 + if (any (lbound (x) .ne. l)) stop 105 + + if (size (ubound (x)) .ne. r) stop 106 + if (any (ubound (x) .ne. u)) stop 107 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/assumed-type-dummy.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/assumed-type-dummy.f90 @@ -0,0 +1,84 @@ +! PR 101319 +! { dg-do compile } +! +! TS 29113 +! 6.3 Argument association +! +! An assumed-type dummy argument shall not correspond to an actual argument +! that is of a derived type that has type parameters, type-bound procedures, +! or final subroutines. +! +! In the 2018 Fortran standard, this requirement appears as: +! +! 15.5.2.4 Ordinary dummy variables +! +! If the actual argument is of a derived type that has type parameters, +! type-bound procedures, or final subroutines, the dummy argument shall +! not be assumed-type. +! +! This file contains code that is expected to produce errors. + +module m + + ! basic derived type + type :: t1 + real*8 :: xyz (3) + end type + + ! derived type with type parameters + type t2 (k, l) + integer, kind :: k + integer, len :: l + real(k) :: a(l) + end type + + ! derived type with a type-bound procedure + type :: t3 + integer :: xyz(3) + contains + procedure, pass :: frob => frob_t3 + end type + + ! derived type with a final subroutine + type :: t4 + integer :: xyz(3) + contains + final :: final_t4 + end type + +contains + + ! implementation of the type-bound procedure for t3 above + subroutine frob_t3 (a) + class (t3) :: a + a%xyz = 0 + end subroutine + + ! implementation of the final subroutine for t4 above + subroutine final_t4 (a) + type (t4) :: a + a%xyz = 0 + end subroutine + + ! useless subroutine with an assumed-type dummy. + subroutine s1 (a) + type(*) :: a + end subroutine + + ! test procedure + subroutine testit + type(t1) :: a1 + type(t2(8,20)) :: a2 + type(t3) :: a3 + type(t4) :: a4 + + call s1 (a1) ! OK + call s1 (a2) ! { dg-error "assumed-type dummy" } + call s1 (a3) ! { dg-error "assumed-type dummy" } + call s1 (a4) ! { dg-error "assumed-type dummy" } + end subroutine + +end module + + + Index: Fortran/gfortran/regression/c-interop/c-interop.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c-interop.exp @@ -0,0 +1,57 @@ +# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +# Initialize `dg'. +dg-init + +global gfortran_test_path +global gfortran_aux_module_flags +set gfortran_test_path $srcdir/$subdir +set gfortran_aux_module_flags "-Werror -std=f2018" +proc dg-compile-aux-modules { args } { + global gfortran_test_path + global gfortran_aux_module_flags + if { [llength $args] != 2 } { + error "dg-compile-aux-modules: needs one argument" + return + } + + set level [info level] + if { [info procs dg-save-unknown] != [list] } { + rename dg-save-unknown dg-save-unknown-level-$level + } + + dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags + # cleanup-modules is intentionally not invoked here. + + if { [info procs dg-save-unknown-level-$level] != [list] } { + rename dg-save-unknown-level-$level dg-save-unknown + } +} + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-Werror" + +# All done. +dg-finish Index: Fortran/gfortran/regression/c-interop/c1255-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c1255-1.f90 @@ -0,0 +1,83 @@ +! PR92482 +! { dg-do compile } +! +! TS 29113 +! C1255 (R1230) If proc-language-binding-spec is specified for a procedure, +! each dummy argument shall be an interoperable procedure (15.3.7) +! or a variable that is interoperable (15.3.5, 15.3.6), assumed shape, +! assumed rank, assumed type, of assumed character length, or has the +! ALLOCATABLE or POINTER attribute. If proc-language-binding-spec is +! specified for a function, the function result shall be an interoperable +! scalar variable. + +module m + + interface + + ! dummy is interoperable procedure + subroutine s1 (x) bind (c) + use ISO_C_BINDING + implicit none + interface + function x (a, b) bind (c) + use ISO_C_BINDING + integer(C_INT) :: a, b + integer(C_INT) :: x + end function + end interface + end subroutine + + ! dummy is interoperable variable + subroutine s2 (x) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x + end subroutine + + ! dummy is assumed-shape array variable + subroutine s3 (x) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x(:) + end subroutine + + ! dummy is an assumed-rank array variable + subroutine s4 (x) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x(..) + end subroutine + + ! dummy is assumed-type variable + subroutine s5 (x) bind (c) + use ISO_C_BINDING + implicit none + type(*) :: x + end subroutine + + ! dummy is assumed length character variable + subroutine s6 (x) bind (c) + use ISO_C_BINDING + implicit none + character(len=*) :: x + end subroutine + + ! dummy has allocatable or pointer attribute + subroutine s7 (x, y) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT), allocatable :: x + integer(C_INT), pointer :: y + end subroutine + + ! function result shall be an interoperable scalar variable + function f (x) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x + integer(C_INT) :: f + end function + + end interface +end module + Index: Fortran/gfortran/regression/c-interop/c1255-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c1255-2.f90 @@ -0,0 +1,106 @@ +! { dg-do compile } +! +! TS 29113 +! C1255 (R1230) If proc-language-binding-spec is specified for a procedure, +! each dummy argument shall be an interoperable procedure (15.3.7) +! or a variable that is interoperable (15.3.5, 15.3.6), assumed shape, +! assumed rank, assumed type, of assumed character length, or has the +! ALLOCATABLE or POINTER attribute. If proc-language-binding-spec is +! specified for a function, the function result shall be an interoperable +! scalar variable. +! +! This file contains code that is expected to produce errors. + + +module m1 + ! type to use for examples below + type t + integer :: foo + real :: bar + end type +end module + +module m2 + + interface + + ! dummy is a procedure that is not interoperable + subroutine s1 (x) bind (c) + use ISO_C_BINDING + use m1 + implicit none + interface + function x (a, b) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + integer(C_INT) :: a + class(t) :: b ! + integer(C_INT) :: x + end function + end interface + end subroutine + + ! dummy is of a type that is not interoperable + subroutine s2 (x) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + implicit none + class(t) :: x + end subroutine + + ! dummy is an array that is not of interoperable type and not + ! assumed-shape or assumed-rank + subroutine s3 (x) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + implicit none + class(t) :: x(3, 3) + end subroutine + + subroutine s4 (n, x) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + implicit none + integer(C_INT) :: n + class(t) :: x(n) + end subroutine + + ! This fails with a bogus error even without C binding. + subroutine s5 (x) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + implicit none + class(t) :: x(*) ! { dg-bogus "not yet been implemented" "pr46991" } + ! { dg-bogus "has no IMPLICIT type" "pr46991" { target "*-*-*" } 68 } + end subroutine + + subroutine s5a (x) + use ISO_C_BINDING + use m1 + implicit none + class(t) :: x(*) ! { dg-bogus "not yet been implemented" "pr46991" } + ! { dg-bogus "has no IMPLICIT type" "pr46991" { target "*-*-*" } 76 } + end subroutine + + ! function result is not a scalar + function f (x) bind (c) ! { dg-error "not C interoperable" } + use ISO_C_BINDING + use m1 + implicit none + integer(C_INT) :: x + type(t) :: f + end function + + ! function result is a type that is not interoperable + function g (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use ISO_C_BINDING + use m1 + implicit none + integer(C_INT) :: x + integer(C_INT), allocatable :: g + end function + + end interface + +end module + Index: Fortran/gfortran/regression/c-interop/c1255a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c1255a.f90 @@ -0,0 +1,40 @@ +! { dg-do compile } +! +! TS 29113 +! C1255a (R1230) A dummy argument of a procedure that has a +! proc-language-binding-spec shall not have both the OPTIONAL and +! VALUE attributes. +! +! This file contains code that is expected to produce errors. + +module m + + interface + + ! This one is OK. + subroutine s1 (x, y) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x + integer(C_INT), optional :: y + end subroutine + + ! This one is OK too. + subroutine s2 (x, y) bind (c) + use ISO_C_BINDING + implicit none + integer(C_INT) :: x + integer(C_INT), value :: y + end subroutine + + ! This one is bad. + subroutine s3 (x, y) bind (c) ! { dg-error "BIND\\(C\\)" } + use ISO_C_BINDING + implicit none + integer(C_INT) :: x + integer(C_INT), optional, value :: y + end subroutine + + end interface + +end module Index: Fortran/gfortran/regression/c-interop/c407a-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c407a-1.f90 @@ -0,0 +1,55 @@ +! { dg-do compile} +! +! TS 29113 +! C407a An assumed-type entity shall be a dummy variable that does not +! have the ALLOCATABLE, CODIMENSION, INTENT(OUT), POINTER, or VALUE +! attribute and is not an explicit-shape array. +! +! This test file contains tests that are expected to all pass. + +! Check basic usage with no attributes. + +module m + interface + subroutine g (a, b) + implicit none + type(*) :: a + integer :: b + end subroutine + end interface +end module + +subroutine s0 (x) + use m + implicit none + type(*) :: x + + call g (x, 1) +end subroutine + +! Check that other attributes that can normally apply to dummy variables +! are allowed. + +subroutine s1 (a, b, c, d, e, f, g, h) + implicit none + type(*), asynchronous :: a + type(*), contiguous :: b(:,:) + type(*), dimension (:) :: c + type(*), intent(in) :: d + type(*), intent(inout) :: e + type(*), optional :: f + type(*), target :: g + type(*), volatile :: h + +end subroutine + +! Check that non-explicit-shape arrays are allowed. + +subroutine s2 (a, b, c) + implicit none + type(*) :: a(:) ! assumed-shape + type(*) :: b(*) ! assumed-size + type(*) :: c(..) ! assumed-rank + +end subroutine + Index: Fortran/gfortran/regression/c-interop/c407a-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c407a-2.f90 @@ -0,0 +1,88 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C407a An assumed-type entity shall be a dummy variable that does not +! have the ALLOCATABLE, CODIMENSION, INTENT(OUT), POINTER, or VALUE +! attribute and is not an explicit-shape array. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +! Check that diagnostics are issued when type(*) is used to declare things +! that are not dummy variables. + +subroutine s0 (a) + implicit none + integer :: a + + integer :: goodlocal + type(*) :: badlocal ! { dg-error "Assumed.type" } + + integer :: goodcommon + type(*) :: badcommon ! { dg-error "Assumed.type" } + common /frob/ goodcommon, badcommon + + integer :: goodstatic + type(*) :: badstatic ! { dg-error "Assumed.type" } + save goodstatic, badstatic + + block + integer :: goodlocal2 + type(*) :: badlocal2 ! { dg-error "Assumed.type" } + end block + +end subroutine + +module m + integer :: goodmodvar + type(*) :: badmodvar ! { dg-error "Assumed.type" } + save goodmodvar, badmodvar + + type :: t + integer :: goodcomponent + type(*) :: badcomponent ! { dg-error "Assumed.type" } + end type +end module + +! Check that diagnostics are issued when type(*) is used in combination +! with the forbidden attributes. + +subroutine s1 (a) ! { dg-error "Assumed.type" } + implicit none + type(*), allocatable :: a +end subroutine + +subroutine s2 (b) ! { dg-error "Assumed.type" } + implicit none + type(*), codimension[*] :: b(:,:) +end subroutine + +subroutine s3 (c) ! { dg-error "Assumed.type" } + implicit none + type(*), intent(out) :: c +end subroutine + +subroutine s4 (d) ! { dg-error "Assumed.type" } + implicit none + type(*), pointer :: d +end subroutine + +subroutine s5 (e) ! { dg-error "Assumed.type" } + implicit none + type(*), value :: e +end subroutine + +! Check that diagnostics are issued when type(*) is used to declare +! a dummy variable that is an explicit-shape array. + +subroutine s6 (n, f) ! { dg-error "Assumed.type" } + implicit none + integer n + type(*) :: f(n,n) +end subroutine + +subroutine s7 (g) ! { dg-error "Assumed.type" } + implicit none + type(*) :: g(10) +end subroutine Index: Fortran/gfortran/regression/c-interop/c407b-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c407b-1.f90 @@ -0,0 +1,107 @@ +! { dg-do compile} +! +! TS 29113 +! C407b An assumed-type variable name shall not appear in a designator +! or expression except as an actual argument corresponding to a dummy +! argument that is assumed-type, or as the first argument to any of +! the intrinsic and intrinsic module functions IS_CONTIGUOUS, LBOUND, +! PRESENT, RANK, SHAPE, SIZE, UBOUND, and C_LOC. +! +! This test file contains tests that are expected to all pass. + +! Check that passing an assumed-type variable as an actual argument +! corresponding to an assumed-type dummy works. + +module m + interface + subroutine g (a, b) + implicit none + type(*) :: a + integer :: b + end subroutine + end interface +end module + +subroutine s0 (x) + use m + implicit none + type(*) :: x + + call g (x, 1) +end subroutine + +! Check that calls to the permitted intrinsic functions work. + +function test_is_contiguous (a) + implicit none + type(*) :: a(*) + logical :: test_is_contiguous + + test_is_contiguous = is_contiguous (a) +end function + +function test_lbound (a) + implicit none + type(*) :: a(:) + integer :: test_lbound + + test_lbound = lbound (a, 1) +end function + +function test_present (a) + implicit none + type(*), optional :: a(*) + logical :: test_present + + test_present = present (a) +end function + +function test_rank (a) + implicit none + type(*) :: a(*) + integer :: test_rank + + test_rank = rank (a) +end function + +function test_shape (a) + implicit none + type(*) :: a(:) ! assumed-shape array so shape intrinsic works + integer :: test_shape + + integer :: temp, i + integer, dimension (rank (a)) :: ashape + + temp = 1 + ashape = shape (a) + do i = 1, rank (a) + temp = temp * ashape (i) + end do + test_shape = temp +end function + +function test_size (a) + implicit none + type(*) :: a(:) + integer :: test_size + + test_size = size (a) +end function + +function test_ubound (a) + implicit none + type(*) :: a(:) + integer :: test_ubound + + test_ubound = ubound (a, 1) +end function + +function test_c_loc (a) + use iso_c_binding + implicit none + type(*), target :: a(*) + type(c_ptr) :: test_c_loc + + test_c_loc = c_loc (a) +end function + Index: Fortran/gfortran/regression/c-interop/c407b-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c407b-2.f90 @@ -0,0 +1,150 @@ +! PR 101337 +! { dg-do compile} +! +! TS 29113 +! C407b An assumed-type variable name shall not appear in a designator +! or expression except as an actual argument corresponding to a dummy +! argument that is assumed-type, or as the first argument to any of +! the intrinsic and intrinsic module functions IS_CONTIGUOUS, LBOUND, +! PRESENT, RANK, SHAPE, SIZE, UBOUND, and C_LOC. +! +! This file contains tests that are expected to give diagnostics. + +! Check that passing an assumed-type variable as an actual argument +! corresponding to a non-assumed-type dummy gives a diagnostic. + +module m + interface + subroutine f (a, b) + implicit none + integer :: a + integer :: b + end subroutine + subroutine g (a, b) + implicit none + type(*) :: a + integer :: b + end subroutine + subroutine h (a, b) + implicit none + type(*) :: a(*) + integer :: b + end subroutine + end interface +end module + +subroutine s0 (x) + use m + implicit none + type(*) :: x + + call g (x, 1) + call f (x, 1) ! { dg-error "Type mismatch" } + call h (x, 1) ! Scalar to type(*),dimension(*): Invalid in TS29113 but valid since F2018 +end subroutine + +! Check that you can't use an assumed-type array variable in an array +! element or section designator. + +subroutine s1 (x, y) + use m + implicit none + integer :: x(*) + type(*) :: y(*) + + call f (x(1), 1) + call g (y(1), 1) ! { dg-error "Assumed.type" } + call h (y, 1) ! ok + call h (y(1:3:1), 1) ! { dg-error "Assumed.type" } +end subroutine + +! Check that you can't use an assumed-type array variable in other +! expressions. This is clearly not exhaustive since few operations +! are even plausible from a type perspective. + +subroutine s2 (x, y) + implicit none + type(*) :: x, y + integer :: i + + ! select type + select type (x) ! { dg-error "Assumed.type|Selector shall be polymorphic" } + type is (integer) + i = 0 + type is (real) + i = 1 + class default + i = -1 + end select + + ! relational operations + if (x & ! { dg-error "Assumed.type" "pr101337" } + .eq. y) then ! { dg-error "Assumed.type" } + return + end if + if (.not. (x & ! { dg-error "Assumed.type" "pr101337" } + .ne. y)) then ! { dg-error "Assumed.type" } + return + end if + if (.not. x) then ! { dg-error "Assumed.type" } + return + end if + + ! assignment + x & ! { dg-error "Assumed.type" } + = y ! { dg-error "Assumed.type" } + i = x ! { dg-error "Assumed.type" } + y = i ! { dg-error "Assumed.type" } + + ! arithmetic + i = x + 1 ! { dg-error "Assumed.type" } + i = -y ! { dg-error "Assumed.type" } + i = (x & ! { dg-error "Assumed.type" "pr101337" } + + y) ! { dg-error "Assumed.type" } + + ! computed go to + goto (10, 20, 30), x ! { dg-error "Assumed.type|must be a scalar integer" } +10 continue +20 continue +30 continue + + ! do loops + do i = 1, x ! { dg-error "Assumed.type" } + continue + end do + do x = 1, i ! { dg-error "Assumed.type" } + continue + end do + +end subroutine + +! Check that calls to disallowed intrinsic functions produce a diagnostic. +! Again, this isn't exhaustive, there are just too many intrinsics and +! hardly any of them are plausible. + +subroutine s3 (x, y) + implicit none + type(*) :: x, y + integer :: i + + i = bit_size (x) ! { dg-error "Assumed.type" } + i = exponent (x) ! { dg-error "Assumed.type" } + + if (extends_type_of (x, & ! { dg-error "Assumed.type" } + y)) then ! { dg-error "Assumed.type" "pr101337" } + return + end if + + if (same_type_as (x, & ! { dg-error "Assumed.type" } + y)) then ! { dg-error "Assumed.type" "pr101337" } + return + end if + + i = storage_size (x) ! { dg-error "Assumed.type" } + + i = iand (x, & ! { dg-error "Assumed.type" } + y) ! { dg-error "Assumed.type" "pr101337" } + + i = kind (x) ! { dg-error "Assumed.type" } + +end subroutine Index: Fortran/gfortran/regression/c-interop/c407c-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c407c-1.f90 @@ -0,0 +1,63 @@ +! PR101333 +! { dg-do compile} +! +! TS 29113 +! C407c An assumed-type actual argument that corresponds to an +! assumed-rank dummy argument shall be assumed-shape or assumed-rank. +! +! This constraint is renumbered C711 in the 2018 Fortran standard. + +module m + interface + subroutine g (a, b) + implicit none + type(*) :: a(..) + integer :: b + end subroutine + end interface +end module + +! Check that assumed-shape works. + +subroutine s0 (x) + use m + implicit none + type(*) :: x(:) + + call g (x, 1) +end subroutine + +! Check that assumed-rank works. + +subroutine s1 (x) + use m + implicit none + type(*) :: x(..) + + call g (x, 1) +end subroutine + +! Check that assumed-size gives an error. + +subroutine s2 (x) + use m + implicit none + type(*) :: x(*) + + call g (x, 1) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'a' must be assumed-shape or assumed-rank" } +end subroutine + +! Check that a scalar gives an error. +subroutine s3 (x) + use m + implicit none + type(*) :: x + + call g (x, 1) ! { dg-error "Assumed.type" } +end subroutine + +! Explicit-shape assumed-type actual arguments are forbidden implicitly +! by c407a (C709 in the 2018 standard). They're not allowed as dummy +! arguments, and assumed-type entities can only be declared as dummy +! arguments, so there is no other way to construct one to pass as an +! actual argument. Index: Fortran/gfortran/regression/c-interop/c516.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c516.f90 @@ -0,0 +1,109 @@ +! PR 101320 +! { dg-do compile } +! +! TS 29113 +! C516 The ALLOCATABLE or POINTER attribute shall not be specified for +! a default-initialized dummy argument of a procedure that has a +! proc-language-binding-spec. +! +! This file contains code that is expected to produce errors. + +module m1 + + type, bind(c) :: t1 + integer :: a + integer :: b + end type + + + type, bind(c) :: t2 + integer :: a = 0 + integer :: b = -1 + end type + +end module + +module m2 + + interface + + ! First test versions with optional attributes on the argument. + ! TS29113 removed the constraint disallowing optional arguments + ! that previously used to be in C516. + + ! good, no default initialization, no pointer/allocatable attribute + subroutine s1a (x) bind (c) + use m1 + type(t1), optional :: x + end subroutine + + ! good, no default initialization + subroutine s1b (x) bind (c) + use m1 + type(t1), allocatable, optional :: x + end subroutine + + ! good, no default initialization + subroutine s1c (x) bind (c) + use m1 + type(t1), pointer, optional :: x + end subroutine + + ! good, default initialization but no pointer/allocatable attribute + subroutine s2a (x) bind (c) + use m1 + type(t2), optional :: x + end subroutine + + ! bad, default initialization + allocatable + subroutine s2b (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use m1 + type(t2), allocatable, optional :: x + end subroutine + + ! bad, default initialization + pointer + subroutine s2c (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use m1 + type(t2), pointer, optional :: x + end subroutine + + ! Now do all the same tests without the optional attribute. + + ! good, no default initialization, no pointer/allocatable attribute + subroutine s3a (x) bind (c) + use m1 + type(t1) :: x + end subroutine + + ! good, no default initialization + subroutine s3b (x) bind (c) + use m1 + type(t1), allocatable :: x + end subroutine + + ! good, no default initialization + subroutine s3c (x) bind (c) + use m1 + type(t1), pointer :: x + end subroutine + + ! good, default initialization but no pointer/allocatable attribute + subroutine s4a (x) bind (c) + use m1 + type(t2) :: x + end subroutine + + ! bad, default initialization + allocatable + subroutine s4b (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use m1 + type(t2), allocatable :: x + end subroutine + + ! bad, default initialization + pointer + subroutine s4c (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use m1 + type(t2), pointer :: x + end subroutine + + end interface +end module Index: Fortran/gfortran/regression/c-interop/c524a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c524a.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C524a A coarray shall not be a dummy argument of a procedure that has +! a proc-language-binding-spec. +! +! This file contains code that is expected to produce errors. + +module m + + interface + + ! No C binding, this should be OK. + subroutine s1 (x) + use ISO_C_BINDING + implicit none + integer(C_INT), codimension[*] :: x(:,:) + end subroutine + + ! This one is bad. + subroutine s2 (x) bind (c) ! { dg-error "BIND\\(C\\)" } + use ISO_C_BINDING + implicit none + integer(C_INT), codimension[*] :: x(:,:) + end subroutine + + end interface +end module + Index: Fortran/gfortran/regression/c-interop/c535a-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535a-1.f90 @@ -0,0 +1,65 @@ +! { dg-do compile} +! +! TS 29113 +! C535a An assumed-rank entity shall be a dummy variable that does not +! have the CODIMENSION or VALUE attribute. +! An assumed-rank object may have the CONTIGUOUS attribute. +! +! This test file contains tests that are expected to all pass. + +! Check basic usage with no attributes. + +module m + type :: t + integer :: i + real :: f + end type +end module + +subroutine s0 (a, b, c, d) + use m + implicit none + integer :: a(..) + real :: b(..) + type(t) :: c(..) + type(*) :: d(..) +end subroutine + +! Likewise with dimension attribute. + +subroutine s1 (a, b, c, d) + use m + implicit none + integer, dimension(..) :: a + real, dimension(..) :: b + type(t), dimension(..) :: c + type(*), dimension(..) :: d +end subroutine + +! Likewise with dimension statement. + +subroutine s2 (a, b, c, d) + use m + implicit none + integer :: a + real :: b + type(t) :: c + type(*) :: d + dimension a(..), b(..), c(..), d(..) +end subroutine + +! Test that various other attributes are accepted. + +subroutine s3 (a, b, c, d, e, f, g, h, i, j) + implicit none + integer, allocatable :: a(..) + integer, asynchronous :: b(..) + integer, contiguous :: c(..) + integer, intent(in) :: d(..) + integer, intent(out) :: e(..) + integer, intent(inout) :: f(..) + integer, optional :: g(..) + integer, pointer :: h(..) + integer, target :: i(..) + integer, volatile :: j(..) +end subroutine Index: Fortran/gfortran/regression/c-interop/c535a-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535a-2.f90 @@ -0,0 +1,78 @@ +! { dg-do compile} +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C535a An assumed-rank entity shall be a dummy variable that does not +! have the CODIMENSION or VALUE attribute. +! An assumed-rank object may have the CONTIGUOUS attribute. +! + +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +! Check that diagnostics are issued when dimension(..) is used to declare +! things that are not dummy variables. + +subroutine s0 (a) + implicit none + integer :: a + + integer :: goodlocal + integer :: badlocal1(..) ! { dg-error "Assumed.rank" } + integer, dimension(..) :: badlocal2 ! { dg-error "Assumed.rank" } + integer :: badlocal3 ! { dg-error "Assumed.rank" } + dimension badlocal3(..) + + integer :: goodcommon + integer :: badcommon1(..) ! { dg-error "Assumed.rank" } + integer, dimension(..) :: badcommon2 ! { dg-error "Assumed.rank" } + integer :: badcommon3 ! { dg-error "Assumed.rank" } + dimension badcommon3(..) + common /frob/ goodcommon, badcommon1, badcommon2, badcommon3 + + integer :: goodstatic + integer :: badstatic1(..) ! { dg-error "Assumed.rank" } + integer, dimension(..) :: badstatic2 ! { dg-error "Assumed.rank" } + integer :: badstatic3 ! { dg-error "Assumed.rank" } + dimension badstatic3(..) + save goodstatic, badstatic1, badstatic2, badstatic3 + + block + integer :: goodblocklocal + integer :: badblocklocal1(..) ! { dg-error "Assumed.rank" } + integer, dimension(..) :: badblocklocal2 ! { dg-error "Assumed.rank" } + integer :: badblocklocal3 ! { dg-error "Assumed.rank" } + dimension badblocklocal3(..) + end block + +end subroutine + +module m + integer :: goodmodvar + integer :: badmodvar1(..) ! { dg-error "Assumed.rank" } + integer, dimension(..) :: badmodvar2 ! { dg-error "Assumed.rank" } + integer :: badmodvar3 ! { dg-error "Assumed.rank" } + dimension badmodvar3(..) + + save goodmodvar, badmodvar1, badmodvar2, badmodvar3 + + type :: t + integer :: goodcomponent + integer :: badcomponent1(..) ! { dg-error "must have an explicit shape" } + integer, dimension(..) :: badcomponent2 ! { dg-error "must have an explicit shape" } + end type +end module + +! Check that diagnostics are issued when dimension(..) is used in combination +! with the forbidden attributes. + +subroutine s2 (b) ! { dg-error "has no IMPLICIT type" } + implicit none + integer, codimension[*] :: b(..) ! { dg-error "assumed-rank array" } +end subroutine + +subroutine s5 (e) ! { dg-error "has no IMPLICIT type" } + implicit none + integer, value :: e(..) ! { dg-error "VALUE attribute conflicts with DIMENSION" } +end subroutine + Index: Fortran/gfortran/regression/c-interop/c535b-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535b-1.f90 @@ -0,0 +1,331 @@ +! { dg-do compile} +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C535b An assumed-rank variable name shall not appear in a designator +! or expression except as an actual argument corresponding to a dummy +! argument that is assumed-rank, the argument of the C_LOC function +! in the ISO_C_BINDING intrinsic module, or the first argument in a +! reference to an intrinsic inquiry function. +! +! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF +! and SELECT_RANK additionally added. +! +! This test file contains tests that are expected to all pass. + +! Check that passing an assumed-rank variable as an actual argument +! corresponding to an assumed-rank dummy works. + +module m + interface + subroutine g (a, b) + implicit none + real :: a(..) + integer :: b + end subroutine + end interface +end module + +subroutine s0 (x) + use m + implicit none + real :: x(..) + + call g (x, 1) +end subroutine + +! Check that calls to the permitted intrinsic functions work. + +function test_c_loc (a) + use iso_c_binding + implicit none + integer, target :: a(..) + type(c_ptr) :: test_c_loc + + test_c_loc = c_loc (a) +end function + +function test_allocated (a) + implicit none + integer, allocatable :: a(..) + logical :: test_allocated + + test_allocated = allocated (a) +end function + +! 2-argument forms of the associated intrinsic are tested in c535b-3.f90. +function test_associated (a) + implicit none + integer, pointer :: a(..) + logical :: test_associated + + test_associated = associated (a) +end function + +function test_bit_size (a) + implicit none + integer :: a(..) + integer :: test_bit_size + + test_bit_size = bit_size (a) +end function + +function test_digits (a) + implicit none + integer :: a(..) + integer :: test_digits + + test_digits = digits (a) +end function + +function test_epsilon (a) + implicit none + real :: a(..) + real :: test_epsilon + + test_epsilon = epsilon (a) +end function + +function test_huge (a) + implicit none + integer :: a(..) + integer :: test_huge + + test_huge = huge (a) +end function + +function test_is_contiguous (a) + implicit none + integer :: a(..) + logical :: test_is_contiguous + + test_is_contiguous = is_contiguous (a) +end function + +function test_kind (a) + implicit none + integer :: a(..) + integer :: test_kind + + test_kind = kind (a) +end function + +function test_lbound (a) + implicit none + integer :: a(..) + integer :: test_lbound + + test_lbound = lbound (a, 1) +end function + +function test_len1 (a) + implicit none + character(len=5) :: a(..) + integer :: test_len1 + + test_len1 = len (a) +end function + +function test_len2 (a) + implicit none + character(len=*) :: a(..) + integer :: test_len2 + + test_len2 = len (a) +end function + +function test_len3 (a) + implicit none + character(len=5), pointer :: a(..) + integer :: test_len3 + + test_len3 = len (a) +end function + +function test_len4 (a) + implicit none + character(len=*), pointer :: a(..) + integer :: test_len4 + + test_len4 = len (a) +end function + +function test_len5 (a) + implicit none + character(len=:), pointer :: a(..) + integer :: test_len5 + + test_len5 = len (a) +end function + +function test_len6 (a) + implicit none + character(len=5), allocatable :: a(..) + integer :: test_len6 + + test_len6 = len (a) +end function + +function test_len7 (a) + implicit none + character(len=*), allocatable :: a(..) + integer :: test_len7 + + test_len7 = len (a) +end function + +function test_len8 (a) + implicit none + character(len=:), allocatable :: a(..) + integer :: test_len8 + + test_len8 = len (a) +end function + +function test_maxexponent (a) + implicit none + real :: a(..) + integer :: test_maxexponent + + test_maxexponent = maxexponent (a) +end function + +function test_minexponent (a) + implicit none + real :: a(..) + integer :: test_minexponent + + test_minexponent = minexponent (a) +end function + +function test_new_line (a) + implicit none + character :: a(..) + character :: test_new_line + + test_new_line = new_line (a) +end function + +function test_precision (a) + implicit none + real :: a(..) + integer :: test_precision + + test_precision = precision (a) +end function + +function test_present (a, b, c) + implicit none + integer :: a, b + integer, optional :: c(..) + integer :: test_present + + if (present (c)) then + test_present = a + else + test_present = b + end if +end function + +function test_radix (a) + implicit none + real :: a(..) + integer :: test_radix + + test_radix = radix (a) +end function + +function test_range (a) + implicit none + real :: a(..) + integer :: test_range + + test_range = range (a) +end function + +function test_rank (a) + implicit none + integer :: a(..) + integer :: test_rank + + test_rank = rank (a) +end function + +function test_shape (a) + implicit none + integer :: a(..) + logical :: test_shape + + test_shape = (rank (a) .eq. size (shape (a))) +end function + +function test_size (a) + implicit none + integer :: a(..) + logical :: test_size + + test_size = (size (a) .eq. product (shape (a))) +end function + +function test_storage_size (a) + implicit none + integer :: a(..) + integer :: test_storage_size + + test_storage_size = storage_size (a) +end function + +function test_tiny (a) + implicit none + real :: a(..) + real :: test_tiny + + test_tiny = tiny (a) +end function + +function test_ubound (a) + implicit none + integer :: a(..) + integer :: test_ubound + + test_ubound = ubound (a, 1) +end function + +! Note: there are no tests for these inquiry functions that can't +! take an assumed-rank array argument for other reasons: +! +! coshape, lcobound, ucobound: requires CODIMENSION attribute, which is +! not permitted on an assumed-rank variable. +! + +! F2018 additionally permits the first arg to C_SIZEOF to be +! assumed-rank (C838). + +function test_c_sizeof (a) + use iso_c_binding + implicit none + integer :: a(..) + integer :: test_c_sizeof + + test_c_sizeof = c_sizeof (a) +end function + +! F2018 additionally permits an assumed-rank array as the selector +! in a SELECT RANK construct (C838). + +function test_select_rank (a) + implicit none + integer :: a(..) + integer :: test_select_rank + + select rank (a) + rank (0) + test_select_rank = 0 + rank (1) + test_select_rank = 1 + rank (2) + test_select_rank = 2 + rank default + test_select_rank = -1 + end select +end function Index: Fortran/gfortran/regression/c-interop/c535b-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535b-2.f90 @@ -0,0 +1,386 @@ +! PR 101334 +! PR 101337 +! { dg-do compile} +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C535b An assumed-rank variable name shall not appear in a designator +! or expression except as an actual argument corresponding to a dummy +! argument that is assumed-rank, the argument of the C_LOC function +! in the ISO_C_BINDING intrinsic module, or the first argument in a +! reference to an intrinsic inquiry function. +! +! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF +! and SELECT_RANK additionally added. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +! Check that passing an assumed-rank variable as an actual argument +! corresponding to a non-assumed-rank dummy gives a diagnostic. + +module m + interface + subroutine f (a, b) + implicit none + integer :: a + integer :: b + end subroutine + subroutine g (a, b) + implicit none + integer :: a(..) + integer :: b(..) + end subroutine + subroutine h (a, b) + implicit none + integer :: a(*) + integer :: b(*) + end subroutine + subroutine i (a, b) + implicit none + integer :: a(:) + integer :: b(:) + end subroutine + subroutine j (a, b) + implicit none + integer :: a(3,3) + integer :: b(3,3) + end subroutine + end interface +end module + +subroutine test_calls (x, y) + use m + implicit none + integer :: x(..), y(..) + + ! Make sure each invalid argument produces a diagnostic. + ! scalar dummies + call f (x, & ! { dg-error "(A|a)ssumed.rank" } + y) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + ! assumed-rank dummies + call g (x, y) ! OK + ! assumed-size dummies + call h (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" } + y) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + ! assumed-shape dummies + call i (x, & ! { dg-error "(A|a)ssumed.rank" } + y) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + ! fixed-size array dummies + call j (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" } + y) ! { dg-error "(A|a)ssumed.rank" "pr101337" } +end subroutine + +! Check that you can't use an assumed-rank array variable in an array +! element or section designator. + +subroutine test_designators (x) + use m + implicit none + integer :: x(..) + + call f (x(1), 1) ! { dg-error "(A|a)ssumed.rank" } + call g (x(1:3:1), & ! { dg-error "(A|a)ssumed.rank" } + x) +end subroutine + +! Check that you can't use an assumed-rank array variable in elemental +! expressions. Make sure binary operators produce the error for either or +! both operands. + +subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j) + implicit none + integer :: a(..), b(..), c(..) + logical :: l(..), m(..), n(..) + integer :: x(s), y(s), z(s) + logical :: p(s), q(s), r(s) + integer :: s + integer :: i + logical :: j + + ! Assignment + + z = x ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a ! { dg-error "(A|a)ssumed.rank" } + z = i ! OK + c = i ! { dg-error "(A|a)ssumed.rank" } + + r = p ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l ! { dg-error "(A|a)ssumed.rank" } + r = j ! OK + n = j ! { dg-error "(A|a)ssumed.rank" } + + ! Arithmetic + + z = -x ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = -a ! { dg-error "(A|a)ssumed.rank" } + z = -i ! OK + c = -i ! { dg-error "(A|a)ssumed.rank" } + + z = x + y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + + b ! { dg-error "(A|a)ssumed.rank" } + z = x + i ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a + i ! { dg-error "(A|a)ssumed.rank" } + z = i + y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = i + b ! { dg-error "(A|a)ssumed.rank" } + + z = x - y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + - b ! { dg-error "(A|a)ssumed.rank" } + z = x - i ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a - i ! { dg-error "(A|a)ssumed.rank" } + z = i - y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = i - b ! { dg-error "(A|a)ssumed.rank" } + + z = x * y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + * b ! { dg-error "(A|a)ssumed.rank" } + z = x * i ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a * i ! { dg-error "(A|a)ssumed.rank" } + z = i * y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = i * b ! { dg-error "(A|a)ssumed.rank" } + + z = x / y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + / b ! { dg-error "(A|a)ssumed.rank" } + z = x / i ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a / i ! { dg-error "(A|a)ssumed.rank" } + z = i / y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = i / b ! { dg-error "(A|a)ssumed.rank" } + + z = x ** y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + ** b ! { dg-error "(A|a)ssumed.rank" } + z = x ** i ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = a ** i ! { dg-error "(A|a)ssumed.rank" } + z = i ** y ! OK + c & ! { dg-error "(A|a)ssumed.rank" } + = i ** b ! { dg-error "(A|a)ssumed.rank" } + + ! Comparisons + + r = x .eq. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .eq. b ! { dg-error "(A|a)ssumed.rank" } + r = x .eq. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .eq. i ! { dg-error "(A|a)ssumed.rank" } + r = i .eq. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .eq. b ! { dg-error "(A|a)ssumed.rank" } + + r = x .ne. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .ne. b ! { dg-error "(A|a)ssumed.rank" } + r = x .ne. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .ne. i ! { dg-error "(A|a)ssumed.rank" } + r = i .ne. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .ne. b ! { dg-error "(A|a)ssumed.rank" } + + r = x .lt. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .lt. b ! { dg-error "(A|a)ssumed.rank" } + r = x .lt. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .lt. i ! { dg-error "(A|a)ssumed.rank" } + r = i .lt. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .lt. b ! { dg-error "(A|a)ssumed.rank" } + + r = x .le. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .le. b ! { dg-error "(A|a)ssumed.rank" } + r = x .le. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .le. i ! { dg-error "(A|a)ssumed.rank" } + r = i .le. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .le. b ! { dg-error "(A|a)ssumed.rank" } + + r = x .gt. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .gt. b ! { dg-error "(A|a)ssumed.rank" } + r = x .gt. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .gt. i ! { dg-error "(A|a)ssumed.rank" } + r = i .gt. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .gt. b ! { dg-error "(A|a)ssumed.rank" } + + r = x .ge. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .ge. b ! { dg-error "(A|a)ssumed.rank" } + r = x .ge. i ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = a .ge. i ! { dg-error "(A|a)ssumed.rank" } + r = i .ge. y ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = i .ge. b ! { dg-error "(A|a)ssumed.rank" } + + ! Logical operators + + r = .not. p ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = .not. l ! { dg-error "(A|a)ssumed.rank" } + r = .not. j ! OK + n = .not. j ! { dg-error "(A|a)ssumed.rank" } + + r = p .and. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .and. m ! { dg-error "(A|a)ssumed.rank" } + r = p .and. j ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l .and. j ! { dg-error "(A|a)ssumed.rank" } + r = j .and. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = j .and. m ! { dg-error "(A|a)ssumed.rank" } + + r = p .or. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .or. m ! { dg-error "(A|a)ssumed.rank" } + r = p .or. j ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l .or. j ! { dg-error "(A|a)ssumed.rank" } + r = j .or. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = j .or. m ! { dg-error "(A|a)ssumed.rank" } + + r = p .eqv. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .eqv. m ! { dg-error "(A|a)ssumed.rank" } + r = p .eqv. j ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l .eqv. j ! { dg-error "(A|a)ssumed.rank" } + r = j .eqv. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = j .eqv. m ! { dg-error "(A|a)ssumed.rank" } + + r = p .neqv. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l & ! { dg-error "(A|a)ssumed.rank" "pr101337" } + .neqv. m ! { dg-error "(A|a)ssumed.rank" } + r = p .neqv. j ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = l .neqv. j ! { dg-error "(A|a)ssumed.rank" } + r = j .neqv. q ! OK + n & ! { dg-error "(A|a)ssumed.rank" } + = j .neqv. m ! { dg-error "(A|a)ssumed.rank" } + +end subroutine + +! Check that calls to disallowed intrinsic functions produce a diagnostic. +! There are 100+ "elemental" intrinsics defined in the standard, and +! 25+ "transformational" intrinsics that accept array operands, and that +! doesn't include intrinsics in the standard modules. To keep the length of +! this test to something sane, check only a handful of these functions on +! the theory that related functions are probably implemented similarly and +! probably share the same argument-processing code. + +subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2) + implicit none + integer :: i1(..), i2(..) + real :: r1(..), r2(..) + complex :: c1(..), c2(..) + logical :: l1(..), l2(..) + character :: s1(..), s2(..) + + integer :: i + real :: r + logical :: l + + ! trig, hyperbolic, other math functions + r1 & ! { dg-error "(A|a)ssumed.rank" } + = atan2 (r1, & ! { dg-error "(A|a)ssumed.rank" } + r2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = atan (r2) ! { dg-error "(A|a)ssumed.rank" } + c1 & ! { dg-error "(A|a)ssumed.rank" } + = atan (c2) ! { dg-error "(A|a)ssumed.rank" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = cos (r2) ! { dg-error "(A|a)ssumed.rank" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = exp (r2) ! { dg-error "(A|a)ssumed.rank" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = sinh (r2) ! { dg-error "(A|a)ssumed.rank" } + + ! bit operations + l1 & ! { dg-error "(A|a)ssumed.rank" } + = blt (i1, & ! { dg-error "(A|a)ssumed.rank" } + i2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + l1 & ! { dg-error "(A|a)ssumed.rank" } + = btest (i1, 0) ! { dg-error "(A|a)ssumed.rank" } + i1 & ! { dg-error "(A|a)ssumed.rank" } + = not (i2) ! { dg-error "(A|a)ssumed.rank" } + i1 & ! { dg-error "(A|a)ssumed.rank" } + = popcnt (i2) ! { dg-error "(A|a)ssumed.rank" } + + ! type conversions + s1 & ! { dg-error "(A|a)ssumed.rank" } + = char (i1) ! { dg-error "(A|a)ssumed.rank" } + c1 & ! { dg-error "(A|a)ssumed.rank" } + = cmplx (r1, & ! { dg-error "(A|a)ssumed.rank" } + r2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + i1 & ! { dg-error "(A|a)ssumed.rank" } + = floor (r1) ! { dg-error "(A|a)ssumed.rank" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = real (c1) ! { dg-error "(A|a)ssumed.rank" } + + ! reductions + l = any (l2) ! { dg-error "(A|a)ssumed.rank" } + r = dot_product (r1, & ! { dg-error "(A|a)ssumed.rank" } + r2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + i = iall (i2, & ! { dg-error "(A|a)ssumed.rank" } + l2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + + ! string operations + s1 & ! { dg-error "(A|a)ssumed.rank" } + = adjustr (s2) ! { dg-error "(A|a)ssumed.rank" } + i1 & ! { dg-error "(A|a)ssumed.rank" } + = index (c1, & ! { dg-error "(A|a)ssumed.rank" } + c2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + + ! misc + i1 & ! { dg-error "(A|a)ssumed.rank" } + = cshift (i2, 4) ! { dg-error "(A|a)ssumed.rank" } + i = findloc (r1, 0.0) ! { dg-error "(A|a)ssumed.rank" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = matmul (r1, & ! { dg-error "(A|a)ssumed.rank" } + r2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + r1 & ! { dg-error "(A|a)ssumed.rank" } + = reshape (r2, [10, 3]) ! { dg-error "(A|a)ssumed.rank" } + i1 & ! { dg-error "(A|a)ssumed.rank" } + = sign (i1, & ! { dg-error "(A|a)ssumed.rank" } + i2) ! { dg-error "(A|a)ssumed.rank" "pr101337" } + s1 & ! { dg-error "(A|a)ssumed.rank" } + = transpose (s2) ! { dg-error "(A|a)ssumed.rank" } + +end subroutine Index: Fortran/gfortran/regression/c-interop/c535b-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535b-3.f90 @@ -0,0 +1,79 @@ +! PR 101334 +! { dg-do compile} +! { dg-additional-options "-fcoarray=single" } +! +! TS 29113 +! C535b An assumed-rank variable name shall not appear in a designator +! or expression except as an actual argument corresponding to a dummy +! argument that is assumed-rank, the argument of the C_LOC function +! in the ISO_C_BINDING intrinsic module, or the first argument in a +! reference to an intrinsic inquiry function. +! +! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF +! and SELECT_RANK additionally added. +! +! This tests various forms of the 2-argument associated intrinsic. + +function test_associated2 (a, b) + implicit none + integer, pointer :: a(..) + integer, target :: b(..) + logical :: test_associated2 + + test_associated2 = associated (a, b) ! { dg-error "Assumed.rank" } +end function + +function test_associated3 (a, b) + implicit none + integer, pointer :: a(..) + integer, target :: b + logical :: test_associated3 + + test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } +end function + +function test_associated4 (a, b) + implicit none + integer, pointer :: a(..) + integer, target :: b(:) + logical :: test_associated4 + + test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } +end function + +function test_associated5 (a, b) + implicit none + integer, pointer :: a(..) + integer, target :: b(20) + logical :: test_associated5 + + test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } +end function + +function test_associated6 (a, b) + implicit none + integer, pointer :: a(..) + integer, pointer :: b(..) + logical :: test_associated6 + + test_associated6 = associated (a, b) ! { dg-error "Assumed.rank" } +end function + +function test_associated7 (a, b) + implicit none + integer, pointer :: a(..) + integer, pointer :: b + logical :: test_associated7 + + test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } +end function + +function test_associated8 (a, b) + implicit none + integer, pointer :: a(..) + integer, pointer :: b(:) + logical :: test_associated8 + + test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" } +end function + Index: Fortran/gfortran/regression/c-interop/c535c-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535c-1.f90 @@ -0,0 +1,164 @@ +! PR 54753 +! { dg-do compile} +! +! TS 29113 +! C535c If an assumed-size or nonallocatable nonpointer assumed-rank +! array is an actual argument corresponding to a dummy argument that +! is an INTENT(OUT) assumed-rank array, it shall not be polymorphic, [...]. +! +! This constraint is numbered C839 in the Fortran 2018 standard. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +module t + type :: t1 + integer :: id + real :: xyz(3) + end type +end module + +module m + use t + + ! Assumed-type dummies are (unlimited) polymorphic too, but F2018:C709 + ! already prohibits them from being declared intent(out). So we only + ! test dummies of class type that are polymorphic or unlimited + ! polymorphic. + interface + subroutine poly (x, y) + use t + class(t1) :: x(..) + class(t1), intent (out) :: y(..) + end subroutine + subroutine upoly (x, y) + class(*) :: x(..) + class(*), intent (out) :: y(..) + end subroutine + end interface + +contains + + ! The known-size calls should all be OK as they do not involve + ! assumed-size or assumed-rank actual arguments. + subroutine test_known_size_nonpolymorphic (a1, a2, n) + integer :: n + type(t1) :: a1(n,n), a2(n) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_known_size_polymorphic (a1, a2, n) + integer :: n + class(t1) :: a1(n,n), a2(n) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_known_size_unlimited_polymorphic (a1, a2, n) + integer :: n + class(*) :: a1(n,n), a2(n) + call upoly (a1, a2) + end subroutine + + ! Likewise passing a scalar as the assumed-rank argument. + subroutine test_scalar_nonpolymorphic (a1, a2) + type(t1) :: a1, a2 + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_scalar_polymorphic (a1, a2) + class(t1) :: a1, a2 + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_scalar_unlimited_polymorphic (a1, a2) + class(*) :: a1, a2 + call upoly (a1, a2) + end subroutine + + ! The polymorphic cases for assumed-size are bad. + subroutine test_assumed_size_nonpolymorphic (a1, a2) + type(t1) :: a1(*), a2(*) + call poly (a1, a2) ! OK + call upoly (a1, a2) ! OK + end subroutine + subroutine test_assumed_size_polymorphic (a1, a2) + class(t1) :: a1(*), a2(*) + call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + call poly (a1(5), a2(4:7)) + end subroutine + subroutine test_assumed_size_unlimited_polymorphic (a1, a2) + class(*) :: a1(*), a2(*) + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + + ! The arguments being passed to poly/upoly in this set are *not* + ! assumed size and should not error. + subroutine test_not_assumed_size_nonpolymorphic (a1, a2) + type(t1) :: a1(*), a2(*) + call poly (a1(5), a2(4:7)) + call upoly (a1(5), a2(4:7)) + call poly (a1(:10), a2(:-5)) + call upoly (a1(:10), a2(:-5)) + end subroutine + subroutine test_not_assumed_size_polymorphic (a1, a2) + class(t1) :: a1(*), a2(*) + call poly (a1(5), a2(4:7)) + call upoly (a1(5), a2(4:7)) + call poly (a1(:10), a2(:-5)) + call upoly (a1(:10), a2(:-5)) + end subroutine + subroutine test_not_assumed_size_unlimited_polymorphic (a1, a2) + class(*) :: a1(*), a2(*) + call upoly (a1(5), a2(4:7)) + call upoly (a1(:10), a2(:-5)) + end subroutine + + ! Polymorphic assumed-rank without pointer/allocatable is also bad. + subroutine test_assumed_rank_nonpolymorphic (a1, a2) + type(t1) :: a1(..), a2(..) + call poly (a1, a2) ! OK + call upoly (a1, a2) ! OK + end subroutine + subroutine test_assumed_rank_polymorphic (a1, a2) + class(t1) :: a1(..), a2(..) + call poly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + subroutine test_assumed_rank_unlimited_polymorphic (a1, a2) + class(*) :: a1(..), a2(..) + call upoly (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + + ! Pointer/allocatable assumed-rank should be OK. + subroutine test_pointer_nonpolymorphic (a1, a2) + type(t1), pointer :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_pointer_polymorphic (a1, a2) + class(t1), pointer :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_pointer_unlimited_polymorphic (a1, a2) + class(*), pointer :: a1(..), a2(..) + call upoly (a1, a2) + end subroutine + + subroutine test_allocatable_nonpolymorphic (a1, a2) + type(t1), allocatable :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_allocatable_polymorphic (a1, a2) + class(t1), allocatable :: a1(..), a2(..) + call poly (a1, a2) + call upoly (a1, a2) + end subroutine + subroutine test_allocatable_unlimited_polymorphic (a1, a2) + class(*), allocatable :: a1(..), a2(..) + call upoly (a1, a2) + end subroutine + +end module Index: Fortran/gfortran/regression/c-interop/c535c-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535c-2.f90 @@ -0,0 +1,74 @@ +! PR 54753 +! { dg-do compile} +! +! TS 29113 +! C535c If an assumed-size or nonallocatable nonpointer assumed-rank +! array is an actual argument corresponding to a dummy argument that +! is an INTENT(OUT) assumed-rank array, it shall not be [...] +! finalizable [...]. +! +! This constraint is numbered C839 in the Fortran 2018 standard. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +module m + + type :: t1 + integer :: id + real :: xyz(3) + contains + final :: finalize_t1 + end type + +contains + + subroutine finalize_t1 (obj) + type(t1) :: obj + end subroutine + + subroutine s1 (x, y) + type(t1) :: x(..) + type(t1), intent(out) :: y(..) + end subroutine + + ! This call should be OK as it does not involve assumed-size or + ! assumed-rank actual arguments. + subroutine test_known_size (a1, a2, n) + integer :: n + type(t1) :: a1(n,n), a2(n) + + call s1 (a1, a2) + end subroutine + + ! Calls with an assumed-size array argument should be rejected. + subroutine test_assumed_size (a1, a2) + type(t1) :: a1(*), a2(*) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_pointer (a1, a2) + type(t1), pointer :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_allocatable (a1, a2) + type(t1), allocatable :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! The call should be rejected with a nonallocatable nonpointer + ! assumed-rank actual argument. + subroutine test_assumed_rank_plain (a1, a2) + type(t1) :: a1(..), a2(..) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + +end module + Index: Fortran/gfortran/regression/c-interop/c535c-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535c-3.f90 @@ -0,0 +1,72 @@ +! PR 54753 +! { dg-do compile } +! +! TS 29113 +! C535c If an assumed-size or nonallocatable nonpointer assumed-rank +! array is an actual argument corresponding to a dummy argument that +! is an INTENT(OUT) assumed-rank array, it shall not be [...] +! of a type with an allocatable ultimate component [...]. +! +! This constraint is numbered C839 in the Fortran 2018 standard. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +module m + + type :: t1 + integer :: id + real :: xyz(3) + character, allocatable :: notes + end type + +contains + + subroutine finalize_t1 (obj) + type(t1) :: obj + end subroutine + + subroutine s1 (x, y) + type(t1) :: x(..) + type(t1), intent(out) :: y(..) + end subroutine + + ! This call should be OK as it does not involve assumed-size or + ! assumed-rank actual arguments. + subroutine test_known_size (a1, a2, n) + integer :: n + type(t1) :: a1(n,n), a2(n) + + call s1 (a1, a2) + end subroutine + + ! Calls with an assumed-size array argument should be rejected. + subroutine test_assumed_size (a1, a2) + type(t1) :: a1(*), a2(*) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_pointer (a1, a2) + type(t1), pointer :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_allocatable (a1, a2) + type(t1), allocatable :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! The call should be rejected with a nonallocatable nonpointer + ! assumed-rank actual argument. + subroutine test_assumed_rank_plain (a1, a2) + type(t1) :: a1(..), a2(..) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + +end module Index: Fortran/gfortran/regression/c-interop/c535c-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/c535c-4.f90 @@ -0,0 +1,72 @@ +! PR 54753 +! { dg-do compile } +! +! TS 29113 +! C535c If an assumed-size or nonallocatable nonpointer assumed-rank +! array is an actual argument corresponding to a dummy argument that +! is an INTENT(OUT) assumed-rank array, it shall not be [...] +! of a type for which default initialization is specified. +! +! This constraint is numbered C839 in the Fortran 2018 standard. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +module m + + type :: t1 + integer :: id + real :: xyz(3) + integer :: tag = -1 + end type + +contains + + subroutine finalize_t1 (obj) + type(t1) :: obj + end subroutine + + subroutine s1 (x, y) + type(t1) :: x(..) + type(t1), intent(out) :: y(..) + end subroutine + + ! This call should be OK as it does not involve assumed-size or + ! assumed-rank actual arguments. + subroutine test_known_size (a1, a2, n) + integer :: n + type(t1) :: a1(n,n), a2(n) + + call s1 (a1, a2) + end subroutine + + ! Calls with an assumed-size array argument should be rejected. + subroutine test_assumed_size (a1, a2) + type(t1) :: a1(*), a2(*) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_pointer (a1, a2) + type(t1), pointer :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! This call should be OK. + subroutine test_assumed_rank_allocatable (a1, a2) + type(t1), allocatable :: a1(..), a2(..) + + call s1 (a1, a2) + end subroutine + + ! The call should be rejected with a nonallocatable nonpointer + ! assumed-rank actual argument. + subroutine test_assumed_rank_plain (a1, a2) + type(t1) :: a1(..), a2(..) + + call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" } + end subroutine + +end module Index: Fortran/gfortran/regression/c-interop/cf-descriptor-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-1-c.c @@ -0,0 +1,91 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); +extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b); + +struct m { + int i; + int j; +}; + +#define imax 10 +#define jmax 5 + +void +ctest (CFI_cdesc_t *a) +{ + + struct m bdata[imax][jmax]; + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + int i, j; + CFI_index_t subscripts[2]; + struct m* mp; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + /* Transpose a's contents into bdata. */ + for (j = 0; j < jmax; j++) + { + subscripts[1] = j; + for (i = 0; i < imax; i++) + { + subscripts[0] = i; + mp = (struct m *) CFI_address (a, subscripts); + if (mp->i != i + 1) + abort (); + if (mp->j != j + 1) + abort (); + bdata[i][j].i = mp->i; + bdata[i][j].j = mp->j; + } + } + + /* Fill in bdesc. */ + subscripts[0] = jmax; + subscripts[1] = imax; + check_CFI_status ("CFI_establish", + CFI_establish (b, bdata, CFI_attribute_other, + CFI_type_struct, + sizeof (struct m), 2, subscripts)); + + /* Sanity checking to make sure the descriptor has been initialized + properly. */ + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + /* Call back into Fortran, passing both the a and b arrays. */ + ftest (a, b); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-1.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-1-c.c dump-descriptors.c" } +! +! This program checks that building a descriptor for a fixed-size array +! in C works and that you can use it to call back into a Fortran function +! declared to have c binding, as an assumed-shape argument. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +subroutine ftest (a, b) bind (c, name="ftest") + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + integer :: i, j + + if (size (a,1) .ne. imax) stop 101 + if (size (a,2) .ne. jmax) stop 102 + if (size (b,1) .ne. jmax) stop 103 + if (size (b,2) .ne. imax) stop 104 + + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 201 + if (a(i,j)%j .ne. j) stop 202 + if (b(j,i)%i .ne. i) stop 203 + if (b(j,i)%j .ne. j) stop 204 + end do + end do +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + end subroutine + end interface + + type(m) :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + ! Pass the initialized array to a C function ctest, which will generate its + ! transpose and call ftest with it. + + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-2-c.c @@ -0,0 +1,91 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); +extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b); + +struct m { + int i; + int j; +}; + +#define imax 10 +#define jmax 5 + +void +ctest (CFI_cdesc_t *a) +{ + + struct m bdata[imax][jmax]; + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + int i, j; + CFI_index_t subscripts[2]; + struct m* mp; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + /* Transpose a's contents into bdata. */ + for (j = 0; j < jmax; j++) + { + subscripts[1] = j; + for (i = 0; i < imax; i++) + { + subscripts[0] = i; + mp = (struct m *) CFI_address (a, subscripts); + if (mp->i != i + 1) + abort (); + if (mp->j != j + 1) + abort (); + bdata[i][j].i = mp->i; + bdata[i][j].j = mp->j; + } + } + + /* Fill in bdesc. */ + subscripts[0] = jmax; + subscripts[1] = imax; + check_CFI_status ("CFI_establish", + CFI_establish (b, bdata, CFI_attribute_other, + CFI_type_struct, + sizeof (struct m), 2, subscripts)); + + /* Sanity checking to make sure the descriptor has been initialized + properly. */ + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + /* Call back into Fortran, passing both the a and b arrays. */ + ftest (a, b); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-2.f90 @@ -0,0 +1,82 @@ +! PR 93308 +! { dg-do run } +! { dg-additional-sources "cf-descriptor-2-c.c dump-descriptors.c" } +! +! This program checks that building a descriptor for a fixed-size array +! in C works and that you can use it to call back into a Fortran function +! declared to have c binding, as an assumed-rank argument. +! +! Fixed by +! https://gcc.gnu.org/pipermail/gcc-patches/2021-June/572725.html + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +subroutine ftest (a, b) bind (c, name="ftest") + use iso_c_binding + use mm + type(m) :: a(..), b(..) + integer :: i, j + + select rank (a) + rank (2) + select rank (b) + rank (2) + ! print *, lbound(a,1), ubound(a,1), lbound(a,2), ubound(a,2) + ! print *, lbound(b,1), ubound(b,1), lbound(b,2), ubound(b,2) + if (lbound (a,1) .ne. 1 .or. ubound (a,1) .ne. imax) stop 101 + if (lbound (a,2) .ne. 1 .or. ubound (a,2) .ne. jmax) stop 102 + if (lbound (b,1) .ne. 1 .or. ubound (b,1) .ne. jmax) stop 103 + if (lbound (b,2) .ne. 1 .or. ubound (b,2) .ne. imax) stop 104 + do j = 1, jmax + do i = 1, imax + print *, a(i,j)%i, a(i,j)%j, b(j,i)%i, b(j,i)%j + if (a(i,j)%i .ne. i) stop 105 + if (a(i,j)%j .ne. j) stop 106 + if (b(j,i)%i .ne. i) stop 107 + if (b(j,i)%j .ne. j) stop 108 + end do + end do + rank default + stop 106 + end select + rank default + stop 107 + end select +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(..) + end subroutine + end interface + + type(m) :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + ! Pass the initialized array to a C function ctest, which will generate its + ! transpose and call ftest with it. + + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-3-c.c @@ -0,0 +1,92 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imagic, int jmagic); +extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp); + +struct m { + int i; + int j; +}; + +void +ctest (int imagic, int jmagic) +{ + CFI_CDESC_T(0) adesc; + CFI_CDESC_T(0) bdesc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + struct m* mp; + + /* Create the descriptor for a, then sanity-check it. */ + check_CFI_status ("CFI_establish", + CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 0, NULL)); + dump_CFI_cdesc_t (a); + if (a->version != CFI_VERSION) + abort (); + if (a->rank != 0) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + + /* Likewise for b. */ + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 0, NULL)); + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 0) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + + /* Call back into Fortran, passing the unallocated descriptors. */ + ftest (a, b, 0); + + /* Allocate and initialize both variables, and try again. */ + check_CFI_status ("CFI_allocate", + CFI_allocate (a, NULL, NULL, 0)); + dump_CFI_cdesc_t (a); + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + ((struct m *)a->base_addr)->i = imagic; + ((struct m *)a->base_addr)->j = jmagic; + + check_CFI_status ("CFI_allocate", + CFI_allocate (b, NULL, NULL, 0)); + dump_CFI_cdesc_t (b); + if (!b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + ((struct m *)b->base_addr)->i = imagic + 1; + ((struct m *)b->base_addr)->j = jmagic + 1; + + ftest (a, b, 1); + + /* Deallocate both objects and try again. */ + check_CFI_status ("CFI_deallocate", CFI_deallocate (a)); + if (a->base_addr) + abort (); + check_CFI_status ("CFI_deallocate", CFI_deallocate (b)); + if (b->base_addr) + abort (); + ftest (a, b, 0); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-3.f90 @@ -0,0 +1,58 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that building a descriptor for an allocatable +! or pointer scalar argument in C works and that you can use it to call +! back into a Fortran function declared to have c binding. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer(C_INT), parameter :: imagic = 42, jmagic = 69 +end module + +subroutine ftest (a, b, initp) bind (c, name="ftest") + use iso_c_binding + use mm + type(m), allocatable :: a + type(m), pointer :: b + integer(C_INT), value :: initp + + if (rank(a) .ne. 0) stop 101 + if (rank(b) .ne. 0) stop 101 + + if (initp .ne. 0 .and. .not. allocated(a)) stop 102 + if (initp .eq. 0 .and. allocated(a)) stop 103 + if (initp .ne. 0 .and. .not. associated(b)) stop 104 + if (initp .eq. 0 .and. associated(b)) stop 105 + + if (initp .ne. 0) then + if (a%i .ne. imagic) stop 201 + if (a%j .ne. jmagic) stop 202 + if (b%i .ne. imagic + 1) stop 203 + if (b%j .ne. jmagic + 1) stop 204 + end if +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (i, j) bind (c) + use iso_c_binding + integer(C_INT), value :: i, j + end subroutine + end interface + + ! ctest will call ftest with both an unallocated and allocated argument. + + call ctest (imagic, jmagic) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-4-c.c @@ -0,0 +1,112 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imagic, int jmagic); +extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp); + +struct m { + int i; + int j; +}; + +void +ctest (int imax, int jmax) +{ + CFI_CDESC_T(2) adesc; + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + struct m* mp; + CFI_index_t lower[2], upper[2], subscripts[2]; + CFI_index_t i, j; + + /* Create the descriptor for a, then sanity-check it. */ + check_CFI_status ("CFI_establish", + CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + dump_CFI_cdesc_t (a); + if (a->version != CFI_VERSION) + abort (); + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + + /* Likewise for b. */ + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + + /* Call back into Fortran, passing the unallocated descriptors. */ + ftest (a, b, 0); + + /* Allocate and initialize both variables, and try again. */ + lower[0] = 1; + lower[1] = 1; + upper[0] = imax; + upper[1] = jmax; + + check_CFI_status ("CFI_allocate", + CFI_allocate (a, lower, upper, 0)); + dump_CFI_cdesc_t (a); + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + + upper[0] = jmax; + upper[1] = imax; + check_CFI_status ("CFI_allocate", + CFI_allocate (b, lower, upper, 0)); + dump_CFI_cdesc_t (b); + if (!b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + + for (i = 1; i <= imax; i++) + for (j = 1; j <= jmax; j++) + { + subscripts[0] = i; + subscripts[1] = j; + mp = (struct m *) CFI_address (a, subscripts); + mp->i = i; + mp->j = j; + subscripts[0] = j; + subscripts[1] = i; + mp = (struct m *) CFI_address (b, subscripts); + mp->i = i; + mp->j = j; + } + + ftest (a, b, 1); + + /* Deallocate both objects and try again. */ + check_CFI_status ("CFI_deallocate", CFI_deallocate (a)); + if (a->base_addr) + abort (); + check_CFI_status ("CFI_deallocate", CFI_deallocate (b)); + if (b->base_addr) + abort (); + ftest (a, b, 0); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-4.f90 @@ -0,0 +1,73 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-4-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that building a descriptor for an allocatable +! or pointer array argument in C works and that you can use it to call +! back into a Fortran function declared to have c binding. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer(C_INT), parameter :: imax=3, jmax=6 +end module + +subroutine ftest (a, b, initp) bind (c, name="ftest") + use iso_c_binding + use mm + type(m), allocatable :: a(:,:) + type(m), pointer :: b(:,:) + integer(C_INT), value :: initp + integer :: i, j + + if (rank(a) .ne. 2) stop 101 + if (rank(b) .ne. 2) stop 101 + + if (initp .ne. 0 .and. .not. allocated(a)) stop 102 + if (initp .eq. 0 .and. allocated(a)) stop 103 + if (initp .ne. 0 .and. .not. associated(b)) stop 104 + if (initp .eq. 0 .and. associated(b)) stop 105 + + if (initp .ne. 0) then + if (lbound (a, 1) .ne. 1) stop 201 + if (lbound (a, 2) .ne. 1) stop 202 + if (lbound (b, 2) .ne. 1) stop 203 + if (lbound (b, 1) .ne. 1) stop 204 + if (ubound (a, 1) .ne. imax) stop 205 + if (ubound (a, 2) .ne. jmax) stop 206 + if (ubound (b, 2) .ne. imax) stop 207 + if (ubound (b, 1) .ne. jmax) stop 208 + + do i = 1, imax + do j = 1, jmax + if (a(i,j)%i .ne. i) stop 301 + if (a(i,j)%j .ne. j) stop 302 + if (b(j,i)%i .ne. i) stop 303 + if (b(j,i)%j .ne. j) stop 303 + end do + end do + + end if +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (i, j) bind (c) + use iso_c_binding + integer(C_INT), value :: i, j + end subroutine + end interface + + ! ctest will call ftest with both an unallocated and allocated argument. + + call ctest (imax, jmax) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-5-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-5-c.c @@ -0,0 +1,42 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int n); +extern void ftest (CFI_cdesc_t *a, int n); + +#define BUFSIZE 512 +static char adata[BUFSIZE]; + +void +ctest (int n) +{ + CFI_CDESC_T(0) adesc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc; + + /* Use a fixed-size static buffer instead of allocating one dynamically. */ + if (n > BUFSIZE) + abort (); + + /* Fill in adesc. */ + check_CFI_status ("CFI_establish", + CFI_establish (a, adata, CFI_attribute_other, + CFI_type_char, n, 0, NULL)); + + /* Sanity checking to make sure the descriptor has been initialized + properly. */ + dump_CFI_cdesc_t (a); + if (a->version != CFI_VERSION) + abort (); + if (a->rank != 0) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->elem_len != n) + abort (); + + /* Call back into Fortran. */ + ftest (a, n); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-5.f90 @@ -0,0 +1,31 @@ +! PR92482 +! { dg-do run } +! { dg-additional-sources "cf-descriptor-5-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that building a descriptor for a character object +! in C works and that you can use it to call back into a Fortran function +! with an assumed-length dummy that is declared with C binding. + +subroutine ftest (a, n) bind (c, name="ftest") + use iso_c_binding + character(kind=C_CHAR, len=*) :: a + integer(C_INT), value :: n + + if (len (a) .ne. n) stop 101 +end subroutine + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (n) bind (c) + use iso_c_binding + integer(C_INT), value :: n + end subroutine + end interface + + call ctest (42) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-6-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-6-c.c @@ -0,0 +1,81 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2, int step1, int step2); +extern void ftest (CFI_cdesc_t *b); + +struct m { + int i; + int j; +}; + +void +ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2, + int step1, int step2) +{ + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + CFI_index_t lb[2], ub[2], step[2]; + int i, j; + + fprintf (stderr, "got new bound info (%d:%d:%d, %d:%d:%d)\n", + lb1, ub1, step1, lb2, ub2, step2); + lb[0] = lb1 - 1; + lb[1] = lb2 - 1; + ub[0] = ub1 - 1; + ub[1] = ub2 - 1; + step[0] = step1; + step[1] = step2; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + + /* Fill in bdesc. */ + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + check_CFI_status ("CFI_section", + CFI_section (b, a, lb, ub, step)); + + /* Sanity checking to make sure the descriptor has been initialized + properly. */ + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (!b->base_addr) + abort (); + if (CFI_is_contiguous (b)) + abort (); + + for (j = b->dim[1].lower_bound; + j < b->dim[1].lower_bound + b->dim[1].extent; + j++) + { + for (i = b->dim[0].lower_bound; + i < b->dim[0].lower_bound + b->dim[0].extent; + i++) + { + CFI_index_t subscripts[2]; + struct m *mp; + subscripts[0] = i; + subscripts[1] = j; + mp = (struct m *) CFI_address (b, subscripts); + fprintf (stderr, "b(%d,%d) = (%d,%d)\n", i, j, mp->i, mp->j); + } + } + + /* Call back into Fortran. */ + ftest (b); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-6.f90 @@ -0,0 +1,72 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-6-c.c dump-descriptors.c" } +! +! This program tests passing the result of the CFI_section C library +! routine back to Fortran. Most of the work happens on the C side. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 + integer, parameter :: ilb=2, jlb=1 + integer, parameter :: iub=8, jub=5 + integer, parameter :: istep=3, jstep=2 + integer, parameter :: isize=3, jsize=3 +end module + +subroutine ftest (b) bind (c, name="ftest") + use iso_c_binding + use mm + type(m), pointer :: b(:,:) + integer :: i, j, ii, jj + + if (size (b, 1) .ne. isize) stop 103 + if (size (b, 2) .ne. jsize) stop 104 + + ! ii and jj iterate over the elements of b + ! i and j iterate over the original array + jj = lbound (b, 2) + do j = jlb, jub, jstep + ii = lbound (b, 1) + do i = ilb, iub, istep + if (b (ii, jj)%i .ne. i) stop 203 + if (b (ii, jj)%j .ne. j) stop 204 + ii = ii + 1 + end do + jj = jj + 1 + end do +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a, lb1, lb2, ub1, ub2, step1, step2) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + integer(C_INT), value :: lb1, lb2, ub1, ub2, step1, step2 + end subroutine + end interface + + type(m), target :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + ! Pass the initialized array to a C function ctest, which will take + ! a section of it and pass it to ftest. + + call ctest (aa, ilb, jlb, iub, jub, istep, jstep) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-7-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-7-c.c @@ -0,0 +1,81 @@ +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); +extern void ftest (CFI_cdesc_t *iarray, CFI_cdesc_t *jarray); + +struct m { + int i; + int j; +}; + +void +ctest (CFI_cdesc_t *a) +{ + CFI_CDESC_T(2) idesc; + CFI_cdesc_t *iarray = (CFI_cdesc_t *) &idesc; + CFI_CDESC_T(2) jdesc; + CFI_cdesc_t *jarray = (CFI_cdesc_t *) &jdesc; + int i, j; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + + /* Fill in the new descriptors. */ + check_CFI_status ("CFI_establish", + CFI_establish (iarray, NULL, CFI_attribute_pointer, + CFI_type_int, + sizeof (int), 2, NULL)); + check_CFI_status ("CFI_select_part", + CFI_select_part (iarray, a, offsetof (struct m, i), + sizeof (int))); + + check_CFI_status ("CFI_establish", + CFI_establish (jarray, NULL, CFI_attribute_pointer, + CFI_type_int, + sizeof (int), 2, NULL)); + check_CFI_status ("CFI_select_part", + CFI_select_part (jarray, a, offsetof (struct m, j), + sizeof (int))); + + /* Sanity checking to make sure the descriptor has been initialized + properly. */ + dump_CFI_cdesc_t (iarray); + if (iarray->version != CFI_VERSION) + abort (); + if (iarray->rank != 2) + abort (); + if (iarray->attribute != CFI_attribute_pointer) + abort (); + if (!iarray->base_addr) + abort (); + if (iarray->dim[0].extent != a->dim[0].extent) + abort (); + if (iarray->dim[1].extent != a->dim[1].extent) + abort (); + + dump_CFI_cdesc_t (jarray); + if (jarray->version != CFI_VERSION) + abort (); + if (jarray->rank != 2) + abort (); + if (jarray->attribute != CFI_attribute_pointer) + abort (); + if (!jarray->base_addr) + abort (); + if (jarray->dim[0].extent != a->dim[0].extent) + abort (); + if (jarray->dim[1].extent != a->dim[1].extent) + abort (); + + /* Call back into Fortran. */ + ftest (iarray, jarray); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-7.f90 @@ -0,0 +1,74 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-7-c.c dump-descriptors.c" } +! +! This program tests passing the result of the CFI_select_part C library +! routine back to Fortran. Most of the work happens on the C side. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +subroutine ftest (iarray, jarray) bind (c, name="ftest") + use iso_c_binding + use mm + integer(C_INT), pointer :: iarray(:,:), jarray(:,:) + + integer :: i, j, i1, i2, j1, j2 + + ! iarray and jarray must have the same shape as the original array, + ! but might be zero-indexed instead of one-indexed. + if (size (iarray, 1) .ne. imax) stop 101 + if (size (iarray, 2) .ne. jmax) stop 102 + if (size (jarray, 1) .ne. imax) stop 103 + if (size (jarray, 2) .ne. jmax) stop 104 + + j1 = lbound(iarray, 2) + j2 = lbound(jarray, 2) + do j = 1, jmax + i1 = lbound(iarray, 1) + i2 = lbound(jarray, 1) + do i = 1, imax + if (iarray (i1, j1) .ne. i) stop 201 + if (jarray (i2, j2) .ne. j) stop 202 + i1 = i1 + 1 + i2 = i2 + 1 + end do + j1 = j1 + 1 + j2 = j2 + 1 + end do +end subroutine + + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + end subroutine + end interface + + type(m), target :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + ! Pass the initialized array to a C function ctest, which will split it + ! into i and j component arrays and pass them to ftest. + + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/cf-descriptor-8-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-8-c.c @@ -0,0 +1,73 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); +extern void ftest1 (CFI_cdesc_t *a, int lb1, int lb2); +extern void ftest2 (CFI_cdesc_t *a); + +struct m { + int i; + int j; +}; + +#define imax 10 +#define jmax 5 + +void +ctest (CFI_cdesc_t *a) +{ + + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + int i, j; + CFI_index_t subscripts[2]; + struct m* mp; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + + /* Fill in bdesc. */ + subscripts[0] = a->dim[0].extent; + subscripts[1] = a->dim[1].extent; + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 2, subscripts)); + + /* Pass the unassociated pointer descriptor b back to Fortran for + checking. */ + dump_CFI_cdesc_t (b); + ftest2 (b); + + /* Point the descriptor b at the input argument array, and check that + on the Fortran side. */ + subscripts[0] = a->dim[0].lower_bound; + subscripts[1] = a->dim[1].lower_bound; + check_CFI_status ("CFI_setpointer", + CFI_setpointer (b, a, subscripts)); + dump_CFI_cdesc_t (b); + ftest1 (b, (int)subscripts[0], (int)subscripts[1]); + + /* Diddle the lower bounds and try again. */ + subscripts[0] = 42; + subscripts[1] = -69; + check_CFI_status ("CFI_setpointer", + CFI_setpointer (b, b, subscripts)); + dump_CFI_cdesc_t (b); + ftest1 (b, 42, -69); + + /* Disassociate the pointer and check that. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (b, NULL, NULL)); + dump_CFI_cdesc_t (b); + ftest2 (b); +} Index: Fortran/gfortran/regression/c-interop/cf-descriptor-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-descriptor-8.f90 @@ -0,0 +1,78 @@ +! { dg-do run } +! { dg-additional-sources "cf-descriptor-8-c.c dump-descriptors.c" } +! +! This program tests passing the result of the CFI_setpointer C library +! function back to Fortran. Most of the work happens on the C side. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +subroutine ftest1 (a, lb1, lb2) bind (c, name="ftest1") + use iso_c_binding + use mm + type(m), pointer :: a(:,:) + integer(C_INT), value :: lb1, lb2 + integer :: i, j, ii, jj + + if (size (a,1) .ne. imax) stop 101 + if (size (a,2) .ne. jmax) stop 102 + if (lbound (a, 1) .ne. lb1) stop 103 + if (lbound (a, 2) .ne. lb2) stop 104 + + if (.not. associated (a)) stop 105 + + jj = lb2 + do j = 1, jmax + ii = lb1 + do i = 1, imax + if (a(ii,jj)%i .ne. i) stop 201 + if (a(ii,jj)%j .ne. j) stop 202 + ii = ii + 1 + end do + jj = jj + 1 + end do +end subroutine + +subroutine ftest2 (a) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m), pointer :: a(:,:) + + if (associated (a)) stop 301 +end subroutine + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + end subroutine + end interface + + type(m), target :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + ! Pass the initialized array to a C function ctest, which will use it + ! as the target of a pointer array with various bounds, calling + ! ftest1 and ftest2 to check that CFI_setpointer did the right thing. + + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-1-c.c @@ -0,0 +1,87 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b); +extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b); + +struct m { + int i; + int j; +}; + +#define imax 10 +#define jmax 5 + +void +ctest (CFI_cdesc_t *a, CFI_cdesc_t *b) +{ + CFI_index_t i, j; + CFI_index_t s[2]; + struct m *mpa, *mpb; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + dump_CFI_cdesc_t (b); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + /* Call back into Fortran, passing both the a and b arrays. */ + ftest2 (a, b); + + /* Check that we got a valid b array back. */ + dump_CFI_cdesc_t (b); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + for (j = 0; j < jmax; j++) + for (i = 0; i < imax; i++) + { + s[0] = i; + s[1] = j; + mpa = (struct m *) CFI_address (a, s); + s[0] = j; + s[1] = i; + mpb = (struct m *) CFI_address (b, s); + if (mpa->i != mpb->i) + abort (); + if (mpa->j != mpb->j) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-1.f90 @@ -0,0 +1,174 @@ +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-1-c.c dump-descriptors.c" } +! +! This program checks that calling a Fortran function with C binding and +! an intent(out) argument works from both C and Fortran. For this +! test case the argument is an assumed-shape array. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +! frob has regular Fortran binding. It transposes input array argument +! a into the intent(out) argument b. + +subroutine frob (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + integer :: i, j + + if (lbound (a, 1) .ne. lbound (b, 2)) stop 101 + if (lbound (a, 2) .ne. lbound (b, 1)) stop 102 + if (ubound (a, 1) .ne. ubound (b, 2)) stop 103 + if (ubound (a, 2) .ne. ubound (b, 1)) stop 104 + + do j = lbound (a, 2), ubound (a, 2) + do i = lbound (a, 1), ubound (a, 1) + b(j,i) = a(i,j) + end do + end do +end subroutine + +! check also has regular Fortran binding, and two input arguments. + +subroutine check (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + integer :: i, j + + if (lbound (a, 1) .ne. 1 .or. lbound (b, 2) .ne. 1) stop 101 + if (lbound (a, 2) .ne. 1 .or. lbound (b, 1) .ne. 1) stop 102 + if (ubound (a, 1) .ne. ubound (b, 2)) stop 103 + if (ubound (a, 2) .ne. ubound (b, 1)) stop 104 + + do j = 1, ubound (a, 2) + do i = 1, ubound (a, 1) + if (b(j,i)%i .ne. a(i,j)%i) stop 105 + if (b(j,i)%j .ne. a(i,j)%j) stop 106 + end do + end do +end subroutine + +! ftest1 has C binding and calls frob. This allows us to test intent(out) +! arguments passed back from Fortran binding to a Fortran function with C +! binding. + +subroutine ftest1 (a, b) bind (c, name="ftest1") + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + + interface + subroutine frob (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + end subroutine + subroutine check (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + end subroutine + end interface + + call frob (a, b) + call check (a, b) +end subroutine + +! ftest2 has C binding and calls ftest1. This allows us to test intent(out) +! arguments passed between two Fortran functions with C binding. + +subroutine ftest2 (a, b) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + + interface + subroutine ftest1 (a, b) bind (c, name="ftest1") + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + end subroutine + subroutine check (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + end subroutine + end interface + + call ftest1 (a, b) + call check (a, b) +end subroutine + +! main calls ftest2 directly and also indirectly from a C function ctest. +! The former allows us to test intent(out) arguments passed back from a +! Fortran routine with C binding to a regular Fortran routine, and the +! latter tests passing them back from Fortran to C and C to Fortran. + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ftest2 (a, b) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + end subroutine + subroutine ctest (a, b) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m), intent(out) :: b(:,:) + end subroutine + subroutine check (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + end subroutine + end interface + + type(m) :: aa(imax,jmax), bb(jmax,imax) + integer :: i, j + + ! initialize + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + bb(j,i)%i = -1 + bb(j,i)%j = -2 + end do + end do + + call ftest2 (aa, bb) + call check (aa, bb) + + ! initialize again + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + bb(j,i)%i = -1 + bb(j,i)%j = -2 + end do + end do + + call ctest (aa, bb) + call check (aa, bb) + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-2-c.c @@ -0,0 +1,87 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b); +extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b); + +struct m { + int i; + int j; +}; + +#define imax 10 +#define jmax 5 + +void +ctest (CFI_cdesc_t *a, CFI_cdesc_t *b) +{ + CFI_index_t i, j; + CFI_index_t s[2]; + struct m *mpa, *mpb; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + dump_CFI_cdesc_t (b); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + /* Call back into Fortran, passing both the a and b arrays. */ + ftest2 (a, b); + + /* Check that we got a valid b array back. */ + dump_CFI_cdesc_t (b); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_other) + abort (); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + if (b->dim[1].extent != imax) + abort (); + + for (j = 0; j < jmax; j++) + for (i = 0; i < imax; i++) + { + s[0] = i; + s[1] = j; + mpa = (struct m *) CFI_address (a, s); + s[0] = j; + s[1] = i; + mpb = (struct m *) CFI_address (b, s); + if (mpa->i != mpb->i) + abort (); + if (mpa->j != mpb->j) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-2.f90 @@ -0,0 +1,157 @@ +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-2-c.c dump-descriptors.c" } +! +! This program checks that calling a Fortran function with C binding and +! an intent(out) argument works from both C and Fortran. For this +! test case the argument is an assumed-rank array. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +! The call chains we'll be testing will be +! main -> ctest -> ftest1 +! main -> ftest2 -> ftest1 +! main -> ftest1 +! where everything has "c" binding except main. + +! ftest1 has C binding and transposes a into b. + +subroutine ftest1 (a, b) bind (c, name="ftest1") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + + select rank (a) + rank (2) + select rank (b) + rank (2) + b = transpose (a) + rank default + stop 101 + end select + rank default + stop 102 + end select +end subroutine + +! ftest2 has C binding and calls ftest1. + +subroutine ftest2 (a, b) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + + interface + subroutine ftest1 (a, b) bind (c, name="ftest1") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + end subroutine + end interface + + call ftest1 (a, b) + if (rank (a) .ne. 2) stop 201 + if (rank (b) .ne. 2) stop 202 +end subroutine + +! main calls ftest2 directly and also indirectly from a C function ctest. +! The former allows us to test intent(out) arguments passed back from a +! Fortran routine with C binding to a regular Fortran routine, and the +! latter tests passing them back from Fortran to C and C to Fortran. + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ftest1 (a, b) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + end subroutine + subroutine ftest2 (a, b) bind (c, name="ftest2") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + end subroutine + subroutine ctest (a, b) bind (c, name="ctest") + use iso_c_binding + use mm + type(m) :: a(..) + type(m), intent(out) :: b(..) + end subroutine + end interface + + type(m) :: aa(imax,jmax), bb(jmax,imax) + integer :: i, j + + ! initialize + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + bb(j,i)%i = -1 + bb(j,i)%j = -2 + end do + end do + + ! frob and check + call ftest1 (aa, bb) + do j = 1, jmax + do i = 1, imax + if (aa(i,j)%i .ne. bb(j,i)%i) stop 301 + if (aa(i,j)%j .ne. bb(j,i)%j) stop 302 + end do + end do + + ! initialize again + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + bb(j,i)%i = -1 + bb(j,i)%j = -2 + end do + end do + + ! frob and check + call ftest2 (aa, bb) + do j = 1, jmax + do i = 1, imax + if (aa(i,j)%i .ne. bb(j,i)%i) stop 401 + if (aa(i,j)%j .ne. bb(j,i)%j) stop 402 + end do + end do + + ! initialize again + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + bb(j,i)%i = -1 + bb(j,i)%j = -2 + end do + end do + + ! frob and check + call ctest (aa, bb) + do j = 1, jmax + do i = 1, imax + if (aa(i,j)%i .ne. bb(j,i)%i) stop 501 + if (aa(i,j)%j .ne. bb(j,i)%j) stop 502 + end do + end do + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-3-c.c @@ -0,0 +1,108 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imagic, int jmagic); +extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p); + +struct m { + int i; + int j; +}; + +void +ctest (int imagic, int jmagic) +{ + CFI_CDESC_T(0) adesc; + CFI_CDESC_T(0) aadesc; + CFI_CDESC_T(0) bdesc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc; + CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + + /* Create and sanity-check descriptors. */ + check_CFI_status ("CFI_establish", + CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 0, NULL)); + dump_CFI_cdesc_t (a); + if (a->version != CFI_VERSION) + abort (); + if (a->rank != 0) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + + check_CFI_status ("CFI_establish", + CFI_establish (aa, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 0, NULL)); + dump_CFI_cdesc_t (aa); + if (aa->version != CFI_VERSION) + abort (); + if (aa->rank != 0) + abort (); + if (aa->attribute != CFI_attribute_allocatable) + abort (); + if (aa->base_addr) + abort (); + if (aa->elem_len != sizeof (struct m)) + abort (); + check_CFI_status ("CFI_allocate", + CFI_allocate (aa, NULL, NULL, 0)); + ((struct m *)aa->base_addr)->i = 0; + ((struct m *)aa->base_addr)->j = 0; + + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 0, NULL)); + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 0) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + + /* Call back into Fortran, which will allocate and initialize the + objects. */ + frob (a, aa, b); + + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + if (((struct m *)a->base_addr)->i != imagic) + abort (); + if (((struct m *)a->base_addr)->j != jmagic) + abort (); + + if (!aa->base_addr) + abort (); + if (aa->elem_len != sizeof (struct m)) + abort (); + if (((struct m *)aa->base_addr)->i != imagic) + abort (); + if (((struct m *)aa->base_addr)->j != jmagic) + abort (); + + if (!b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + if (((struct m *)b->base_addr)->i != imagic) + abort (); + if (((struct m *)b->base_addr)->j != jmagic) + abort (); +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-3.f90 @@ -0,0 +1,134 @@ +! PR 92621 (?) +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that calling a Fortran function with C binding and +! an intent(out) argument works from both C and Fortran. For this +! test case the argument is an allocatable or pointer scalar. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imagic=-1, jmagic=42 + +end module + +! The call chains being tested here are +! main -> frob +! main -> ftest -> frob +! main -> ctest -> frob +! where everything other than main has C binding. + +! frob allocates and initializes its arguments. +! There are two allocatable dummies so that we can pass both +! unallocated (a) and allocated (aa). + +subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a, aa + type(m), intent(out), pointer :: p + + if (allocated (a)) stop 101 + allocate (a) + a%i = imagic + a%j = jmagic + + if (allocated (aa)) stop 102 + allocate (aa) + aa%i = imagic + aa%j = jmagic + + ! association status of p is undefined on entry + allocate (p) + p%i = imagic + p%j = jmagic +end subroutine + +subroutine ftest () bind (c, name="ftest") + use iso_c_binding + use mm + type(m), allocatable :: a, aa + type(m), pointer :: p + + interface + subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a, aa + type(m), intent(out), pointer :: p + end subroutine + end interface + + p => NULL () + allocate (aa) + aa%i = 0 + aa%j = 0 + call frob (a, aa, p) + + if (.not. allocated (a)) stop 201 + if (a%i .ne. imagic) stop 202 + if (a%j .ne. jmagic) stop 203 + + if (.not. allocated (aa)) stop 204 + if (a%i .ne. imagic) stop 205 + if (a%j .ne. jmagic) stop 206 + + if (.not. associated (p)) stop 207 + if (p%i .ne. imagic) stop 208 + if (p%j .ne. jmagic) stop 209 + +end subroutine + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a, aa + type(m), intent(out), pointer :: p + end subroutine + subroutine ftest () bind (c, name="ftest") + use iso_c_binding + use mm + end subroutine + subroutine ctest (ii, jj) bind (c, name="ctest") + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + end subroutine + end interface + + type(m), allocatable :: a, aa + type(m), pointer :: p + + p => NULL () + allocate (aa) + aa%i = 0 + aa%j = 0 + call frob (a, aa, p) + + if (.not. allocated (a)) stop 201 + if (a%i .ne. imagic) stop 202 + if (a%j .ne. jmagic) stop 203 + + if (.not. allocated (aa)) stop 204 + if (a%i .ne. imagic) stop 205 + if (a%j .ne. jmagic) stop 206 + + if (.not. associated (p)) stop 207 + if (p%i .ne. imagic) stop 208 + if (p%j .ne. jmagic) stop 209 + + call ftest + call ctest (imagic, jmagic) + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-4-c.c @@ -0,0 +1,175 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imax, int jmax); +extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p); + +struct m { + int i; + int j; +}; + +void +ctest (int imax, int jmax) +{ + CFI_CDESC_T(2) adesc; + CFI_CDESC_T(2) aadesc; + CFI_CDESC_T(2) bdesc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc; + CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + CFI_index_t i, j; + CFI_index_t s[2]; + CFI_index_t lb[2], ub[2]; + struct m* mp; + + /* Create and sanity-check a. */ + check_CFI_status ("CFI_establish", + CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + dump_CFI_cdesc_t (a); + if (a->version != CFI_VERSION) + abort (); + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + + check_CFI_status ("CFI_establish", + CFI_establish (aa, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + dump_CFI_cdesc_t (aa); + if (aa->version != CFI_VERSION) + abort (); + if (aa->rank != 2) + abort (); + if (aa->attribute != CFI_attribute_allocatable) + abort (); + if (aa->base_addr) + abort (); + if (aa->elem_len != sizeof (struct m)) + abort (); + + /* aa is allocated/initialized so that we can confirm that it's + magically deallocated when passed as intent(out). */ + lb[0] = 0; + lb[1] = 0; + ub[0] = jmax; + ub[1] = jmax; + check_CFI_status ("CFI_allocate", + CFI_allocate (aa, lb, ub, 0)); + for (j = 1; j <= jmax; j++) + for (i = 1; i <= imax; i++) + { + s[0] = j; + s[1] = i; + mp = (struct m *)CFI_address (aa, s); + mp->i = 0; + mp->j = 0; + } + + /* Likewise create and sanity-check b. */ + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct m), 2, NULL)); + dump_CFI_cdesc_t (b); + if (b->version != CFI_VERSION) + abort (); + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + + /* Call back into Fortran, which will allocate and initialize the + objects. */ + frob (a, aa, b); + + dump_CFI_cdesc_t (a); + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof (struct m)) + abort (); + if (a->dim[0].lower_bound != 1) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 1) + abort (); + if (a->dim[1].extent != jmax) + abort (); + for (j = 1; j <= jmax; j++) + for (i = 1; i <= imax; i++) + { + s[0] = i; + s[1] = j; + mp = (struct m *)CFI_address (a, s); + if (mp->i != i) + abort (); + if (mp->j != j) + abort (); + } + + dump_CFI_cdesc_t (aa); + if (!aa->base_addr) + abort (); + if (aa->elem_len != sizeof (struct m)) + abort (); + if (aa->dim[0].lower_bound != 1) + abort (); + if (aa->dim[0].extent != imax) + abort (); + if (aa->dim[1].lower_bound != 1) + abort (); + if (aa->dim[1].extent != jmax) + abort (); + for (j = 1; j <= jmax; j++) + for (i = 1; i <= imax; i++) + { + s[0] = i; + s[1] = j; + mp = (struct m *)CFI_address (aa, s); + if (mp->i != i) + abort (); + if (mp->j != j) + abort (); + } + + dump_CFI_cdesc_t (b); + if (!b->base_addr) + abort (); + if (b->elem_len != sizeof (struct m)) + abort (); + if (b->dim[0].lower_bound != 1) + abort (); + if (b->dim[0].extent != jmax) + abort (); + if (b->dim[1].lower_bound != 1) + abort (); + if (b->dim[1].extent != imax) + abort (); + for (j = 1; j <= jmax; j++) + for (i = 1; i <= imax; i++) + { + s[0] = j; + s[1] = i; + mp = (struct m *)CFI_address (b, s); + if (mp->i != i) + abort (); + if (mp->j != j) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-4.f90 @@ -0,0 +1,207 @@ +! PR 92621 (?) +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-4-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that calling a Fortran function with C binding and +! an intent(out) argument works from both C and Fortran. For this +! test case the argument is an allocatable or pointer array. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=5, jmax=10 + +end module + +! The call chains being tested here are +! main -> frob +! main -> ftest -> frob +! main -> ctest -> frob +! where everything other than main has C binding. + +! frob allocates and initializes its arguments. +! There are two allocatable dummies so that we can pass both +! unallocated (a) and allocated (aa). + +subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a(:,:), aa(:,:) + type(m), intent(out), pointer :: p(:,:) + integer :: i, j + + if (allocated (a)) stop 101 + allocate (a (imax, jmax)) + do j = 1, jmax + do i = 1, imax + a(i,j)%i = i + a(i,j)%j = j + end do + end do + + if (allocated (aa)) stop 102 + allocate (aa (imax, jmax)) + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + allocate (p (jmax, imax)) + do j = 1, jmax + do i = 1, imax + p(j,i)%i = i + p(j,i)%j = j + end do + end do +end subroutine + +subroutine ftest () bind (c, name="ftest") + use iso_c_binding + use mm + type(m), allocatable :: a(:,:), aa(:,:) + type(m), pointer :: p(:,:) + + integer :: i, j + + interface + subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a(:,:), aa(:,:) + type(m), intent(out), pointer :: p(:,:) + end subroutine + end interface + + p => NULL () + if (allocated (a) .or. allocated (aa)) stop 200 + allocate (aa (jmax, imax)) + do j = 1, jmax + do i = 1, imax + aa(j,i)%i = 0 + aa(j,i)%j = 0 + end do + end do + call frob (a, aa, p) + + if (.not. allocated (a)) stop 201 + if (lbound (a, 1) .ne. 1) stop 202 + if (lbound (a, 2) .ne. 1) stop 203 + if (ubound (a, 1) .ne. imax) stop 204 + if (ubound (a, 2) .ne. jmax) stop 205 + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 206 + if (a(i,j)%j .ne. j) stop 207 + end do + end do + + if (.not. allocated (aa)) stop 211 + if (lbound (aa, 1) .ne. 1) stop 212 + if (lbound (aa, 2) .ne. 1) stop 213 + if (ubound (aa, 1) .ne. imax) stop 214 + if (ubound (aa, 2) .ne. jmax) stop 215 + do j = 1, jmax + do i = 1, imax + if (aa(i,j)%i .ne. i) stop 216 + if (aa(i,j)%j .ne. j) stop 217 + end do + end do + + if (.not. associated (p)) stop 221 + if (lbound (p, 1) .ne. 1) stop 222 + if (lbound (p, 2) .ne. 1) stop 223 + if (ubound (p, 1) .ne. jmax) stop 224 + if (ubound (p, 2) .ne. imax) stop 225 + do j = 1, jmax + do i = 1, imax + if (p(j,i)%i .ne. i) stop 226 + if (p(j,i)%j .ne. j) stop 227 + end do + end do + +end subroutine + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine frob (a, aa, p) bind (c, name="frob") + use iso_c_binding + use mm + type(m), intent(out), allocatable :: a(:,:), aa(:,:) + type(m), intent(out), pointer :: p(:,:) + end subroutine + subroutine ftest () bind (c, name="ftest") + use iso_c_binding + use mm + end subroutine + subroutine ctest (ii, jj) bind (c, name="ctest") + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + end subroutine + end interface + + type(m), allocatable :: a(:,:), aa(:,:) + type(m), pointer :: p(:,:) + integer :: i, j + + p => NULL () + if (allocated (a) .or. allocated (aa)) stop 300 + allocate (aa (jmax, imax)) + do j = 1, jmax + do i = 1, imax + aa(j,i)%i = 0 + aa(j,i)%j = 0 + end do + end do + call frob (a, aa, p) + + if (.not. allocated (a)) stop 301 + if (lbound (a, 1) .ne. 1) stop 302 + if (lbound (a, 2) .ne. 1) stop 303 + if (ubound (a, 1) .ne. imax) stop 304 + if (ubound (a, 2) .ne. jmax) stop 305 + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 306 + if (a(i,j)%j .ne. j) stop 307 + end do + end do + + if (.not. allocated (aa)) stop 311 + if (lbound (aa, 1) .ne. 1) stop 312 + if (lbound (aa, 2) .ne. 1) stop 313 + if (ubound (aa, 1) .ne. imax) stop 314 + if (ubound (aa, 2) .ne. jmax) stop 315 + do j = 1, jmax + do i = 1, imax + if (aa(i,j)%i .ne. i) stop 316 + if (aa(i,j)%j .ne. j) stop 317 + end do + end do + + if (.not. associated (p)) stop 321 + if (lbound (p, 1) .ne. 1) stop 322 + if (lbound (p, 2) .ne. 1) stop 323 + if (ubound (p, 1) .ne. jmax) stop 324 + if (ubound (p, 2) .ne. imax) stop 325 + do j = 1, jmax + do i = 1, imax + if (p(j,i)%i .ne. i) stop 326 + if (p(j,i)%j .ne. j) stop 327 + end do + end do + + call ftest + call ctest (imax, jmax) + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-5-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-5-c.c @@ -0,0 +1,31 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, int n); +extern void ftest (CFI_cdesc_t *a, int n); + +void +ctest (CFI_cdesc_t *a, int n) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The actual argument object on the Fortran side has length n and + was passed as character(len=*). + Make sure that matches what's in the descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != n) + abort (); + if (a->rank != 0) + abort (); + if (a->type != CFI_type_char) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + ftest (a, n); +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-5.f90 @@ -0,0 +1,48 @@ +! PR92482 +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-5-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks use of an assumed-length character dummy argument +! as an intent(out) parameter in subroutines with C binding. + +subroutine ftest (a, n) bind (c, name="ftest") + use iso_c_binding + character(kind=C_CHAR, len=*), intent(out) :: a + integer(C_INT), value :: n + + if (len (a) .ne. n) stop 101 + a = 'abcdefghijklmnopqrstuvwxyz' +end subroutine + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a, n) bind (c) + use iso_c_binding + character(kind=C_CHAR, len=*), intent(out) :: a + integer(C_INT), value :: n + end subroutine + + subroutine ftest (a, n) bind (c) + use iso_c_binding + character(kind=C_CHAR, len=*), intent(out) :: a + integer(C_INT), value :: n + end subroutine + end interface + + character(kind=C_CHAR, len=42) :: aa + + ! call ftest directly + aa = '12345678910' + call ftest (aa, 42) + print *, aa + + ! ctest calls ftest indirectly + aa = '12345678910' + call ctest (aa, 42) + print *, aa + +end program Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-6-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-6-c.c @@ -0,0 +1,42 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, int n); +extern void ftest (CFI_cdesc_t *a, int n); + +void +ctest (CFI_cdesc_t *a, int n) +{ + int i; + CFI_index_t s[1]; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 1) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != -1) + abort (); + + ftest (a, n); + + for (i = 0; i < n; i++) + { + s[0] = i; + if (*((int *)CFI_address (a, s)) != i + 1) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/cf-out-descriptor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/cf-out-descriptor-6.f90 @@ -0,0 +1,115 @@ +! Reported as pr94070. +! { dg-do run } +! { dg-additional-sources "cf-out-descriptor-6-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks passing an assumed-size array as an intent(out) +! argument to a bind (c) Fortran function from both C and Fortran. + +! Assumed-size arrays are not passed by descriptor. What we'll do +! for this test function is pass the assumed-size array as the actual +! argument corresponding to an assumed-rank dummy. This is supposed to +! fill in the descriptor with information about the array present at +! the call site. + +subroutine ftest (a, n) bind (c, name="ftest") + use iso_c_binding + integer(C_INT), intent(out) :: a(..) + integer(C_INT), value :: n + integer :: i + + ! TS 29113 + ! 6.4.2 SIZE + ! (1) for an assumed-rank object that is associated with an + ! assumed-size array, the result has the value −1 if DIM is + ! present and equal to the rank of ARRAY + if (rank (a) .ne. 1) stop 102 + if (size (a, rank (a)) .ne. -1) stop 100 + if (lbound (a, rank (a)) .ne. 1) stop 101 + + select rank (a) + rank (*) + do i = 1, n + a(i) = i + end do + rank default + stop 102 + end select +end subroutine + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a, n) bind (c, name="ctest") + use iso_c_binding + integer(C_INT), intent(out) :: a(..) + integer(C_INT), value :: n + end subroutine + subroutine ftest (a, n) bind (c, name="ftest") + use iso_c_binding + integer(C_INT), intent(out) :: a(..) + integer(C_INT), value :: n + end subroutine + end interface + + integer(C_INT), target :: aa(10) + + ! To get an assumed-size array descriptor, we have to first pass the + ! fixed-size array to a Fortran function with an assumed-size dummy, + call ftest1 (aa, 10) ! calls ftest + call ftest2 (aa, 10) ! has c binding, calls ftest + call ftest3 (aa, 10) ! calls ctest -> ftest + call ftest4 (aa, 10) ! has c binding, calls ctest -> ftest + +contains + + subroutine ftest1 (a, n) + use iso_c_binding + integer(C_INT), intent(out) :: a(*) + integer(C_INT), value :: n + integer :: i + a(1:n) = 0 + call ftest (a, n) + do i = 1, n + if (a (i) .ne. i) stop 200 + end do + end subroutine + + subroutine ftest2 (a, n) bind (c) + use iso_c_binding + integer(C_INT), intent(out) :: a(*) + integer(C_INT), value :: n + integer :: i + a(1:n) = 0 + call ftest (a, n) + do i = 1, n + if (a (i) .ne. i) stop 201 + end do + end subroutine + + subroutine ftest3 (a, n) + use iso_c_binding + integer(C_INT), intent(out) :: a(*) + integer(C_INT), value :: n + integer :: i + a(1:n) = 0 + call ctest (a, n) + do i = 1, n + if (a (i) .ne. i) stop 202 + end do + end subroutine + + subroutine ftest4 (a, n) bind (c) + use iso_c_binding + integer(C_INT), intent(out) :: a(*) + integer(C_INT), value :: n + integer :: i + a(1:n) = 0 + call ctest (a, n) + do i = 1, n + if (a (i) .ne. i) stop 203 + end do + end subroutine +end program Index: Fortran/gfortran/regression/c-interop/contiguous-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-1-c.c @@ -0,0 +1,56 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest1 (CFI_cdesc_t *a); +extern void ctest2 (CFI_cdesc_t *a); + +static void +ctest (CFI_cdesc_t *a) +{ + int i; + int *p; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* Make sure we got a valid descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 1) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].sm != sizeof(int)) + abort (); + if (!CFI_is_contiguous (a)) + abort (); + + /* Negate the elements of the array. */ + p = (int *)a->base_addr; + for (i = 0; i < a->dim[0].extent; i++) + p[i] = -p[i]; +} + + +/* The two entry points are declared differently on the C side, but both + should do the same thing. */ + +void +ctest1 (CFI_cdesc_t *a) +{ + ctest (a); +} + +void +ctest2 (CFI_cdesc_t *a) +{ + ctest (a); +} + Index: Fortran/gfortran/regression/c-interop/contiguous-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-1.f90 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-additional-sources "contiguous-1-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! TS 29113 +! 8.7 In an invocation of an interoperable procedure whose Fortran +! interface has an assumed-shape or assumed-rank dummy argument with the +! CONTIGUOUS attribute, the associated effective argument may be an +! array that is not contiguous or the address of a C descriptor for such +! an array. If the procedure is invoked from Fortran or the procedure is +! a Fortran procedure, the Fortran processor will handle the difference +! in contiguity. If the procedure is invoked from C and the procedure is +! a C procedure, the C code within the procedure shall be prepared to +! handle the situation of receiving a discontiguous argument. +! +! This program tests the cases where Fortran code passes a non-contiguous +! array section to a C function whose interface has the contiguous +! attribute. + +program testit + use iso_c_binding + implicit none + + interface + ! ctest1 and ctest2 both negate the elements of their input array. + subroutine ctest1 (a) bind (c) + use iso_c_binding + integer(C_INT), contiguous :: a(:) + end subroutine + subroutine ctest2 (a) bind (c) + use iso_c_binding + integer(C_INT), contiguous :: a(..) + end subroutine + end interface + + integer(C_INT) :: aa(32) + integer :: i + + ! assumed-shape + do i = 1, 32 + aa(i) = i + end do + call ctest1 (aa(4:12:2)) + do i = 1, 32 + if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then + if (aa (i) .ne. -i) stop 101 + else + if (aa (i) .ne. i) stop 102 + end if + end do + + ! assumed-rank + do i = 1, 32 + aa(i) = i + end do + call ctest2 (aa(7:19:3)) + do i = 1, 32 + if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then + if (aa (i) .ne. -i) stop 201 + else + if (aa (i) .ne. i) stop 202 + end if + end do + +end program + + Index: Fortran/gfortran/regression/c-interop/contiguous-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-2-c.c @@ -0,0 +1,113 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest1 (CFI_cdesc_t *a); +extern void ctest2 (CFI_cdesc_t *a); +extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step); +extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step); + +#if 0 +static void +dump_array (CFI_cdesc_t *a, const char *name, const char *note) +{ + int i; + + fprintf (stderr, "%s\n", note); + for (i = 0; i < a->dim[0].extent; i++) + { + int j = i + a->dim[0].lower_bound; + int elt; + CFI_index_t sub[1]; + sub[0] = j; + elt = *((int *) CFI_address (a, sub)); + fprintf (stderr, "%s[%d] = %d\n", name, j, elt); + } + fprintf (stderr, "\n"); +} +#else +#define dump_array(a, name, note) +#endif + +static void +ctest (CFI_cdesc_t *a, int lb, int ub, int s, + void (*fn) (CFI_cdesc_t *, int, int, int)) +{ + CFI_CDESC_T(1) bdesc; + CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc; + CFI_index_t lb_array[1], ub_array[1], s_array[1]; + int i; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* Make sure we got a valid descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 1) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + + /* Create an array section and pass it to fn. */ + check_CFI_status ("CFI_establish", + CFI_establish (b, NULL, CFI_attribute_other, + CFI_type_int, + sizeof (int), 1, NULL)); + lb_array[0] = lb - 1 + a->dim[0].lower_bound; + ub_array[0] = ub - 1 + a->dim[0].lower_bound; + s_array[0] = s; + check_CFI_status ("CFI_section", + CFI_section (b, a, lb_array, ub_array, s_array)); + dump_CFI_cdesc_t (b); + dump_array (b, "b", "b after CFI_section"); + + /* Pass it to the Fortran function fn. */ + if (CFI_is_contiguous (b)) + abort (); + (*fn) (b, lb, ub, s); + dump_CFI_cdesc_t (b); + dump_array (b, "b", "b after calling Fortran fn"); + + /* fn is supposed to negate the elements of the array section it + receives. Check that the original array has been updated. */ + dump_array (a, "a", "a after calling Fortran fn"); + for (i = 0; i < a->dim[0].extent; i++) + { + int elt; + int j = i + a->dim[0].lower_bound; + CFI_index_t sub[1]; + sub[0] = j; + elt = *((int *) CFI_address (a, sub)); + if (i + 1 >= lb && i + 1 <= ub && (i + 1 - lb) % s == 0) + { + if (elt != - (i + 1)) + abort (); + } + else if (elt != (i + 1)) + abort (); + } +} + + +/* Entry points for the Fortran side. */ + +void +ctest1 (CFI_cdesc_t *a) +{ + ctest (a, 5, 13, 2, ftest1); +} + +void +ctest2 (CFI_cdesc_t *a) +{ + ctest (a, 8, 20, 3, ftest2); +} + Index: Fortran/gfortran/regression/c-interop/contiguous-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-2.f90 @@ -0,0 +1,152 @@ +! PR 101304 +! { dg-do run } +! { dg-additional-sources "contiguous-2-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! TS 29113 +! 8.7 In an invocation of an interoperable procedure whose Fortran +! interface has an assumed-shape or assumed-rank dummy argument with the +! CONTIGUOUS attribute, the associated effective argument may be an +! array that is not contiguous or the address of a C descriptor for such +! an array. If the procedure is invoked from Fortran or the procedure is +! a Fortran procedure, the Fortran processor will handle the difference +! in contiguity. If the procedure is invoked from C and the procedure is +! a C procedure, the C code within the procedure shall be prepared to +! handle the situation of receiving a discontiguous argument. +! +! The wording is different in the 2018 standard, but the intent is more +! or less the same: +! +! When an interoperable Fortran procedure that is invoked from C has a +! dummy argument with the CONTIGUOUS attribute or that is an assumed-length +! CHARACTER explicit-shape or assumed-size array, and the actual argument +! is the address of a C descriptor for a discontiguous object, the Fortran +! processor shall handle the difference in contiguity. +! +! This program tests the cases where a Fortran procedure with C binding and +! a dummy array argument with the contiguous attribute is invoked from +! both C or Fortran. + +! ftest1 and ftest2 both negate the elements of their input array; +! this allows testing that modifications to the array contents get +! propagated back to the base array. + +module m + + contains + + subroutine ftest1 (a, first, last, step) bind (c) + use iso_c_binding + integer(C_INT), contiguous :: a(:) + integer(C_INT), value :: first, last, step + integer :: i, ival + + ! Sanity checking that we got a contiguous array. The direct call + ! to is_contiguous might be optimized away, but the indirect one + ! in check_contiguous shouldn't be. + ! FIXME: is this correct? "the Fortran processor will handle the + ! difference in contiguity" may not mean that it's required to make + ! the array contiguous, just that it can access it correctly? + if (.not. is_contiguous (a)) stop 301 + call check_contiguous (a) + + ! Sanity checking that we got the right input array contents. + ! print *, 'a on entry to ftest1' + ! do i = lbound(a, 1), ubound(a, 1) + ! print *, 'a(', i, ') = ', a(i) + ! end do + ival = first + do i = lbound(a, 1), ubound(a, 1) + if (a (i) .ne. ival) then + print *, 'a(', i, ') = ', a(i), ' expected ', ival + stop 302 + end if + a(i) = - a(i) + ival = ival + step + end do + end subroutine + + subroutine ftest2 (a, first, last, step) bind (c) + use iso_c_binding + + integer(C_INT), contiguous :: a(..) + integer(C_INT), value :: first, last, step + + select rank (a) + rank (1) + call ftest1 (a(:), first, last, step) + rank default + stop 303 + end select + end subroutine + + subroutine check_contiguous (a) + use iso_c_binding + integer(C_INT) :: a(..) + if (.not. is_contiguous (a)) stop 304 + end subroutine + +end module + + +program testit + use iso_c_binding + use m + implicit none + + interface + subroutine ctest1 (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(:) + end subroutine + subroutine ctest2 (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(..) + end subroutine + end interface + + integer(C_INT) :: aa(32) + integer :: i + + ! assumed-shape, called from Fortran + do i = 1, 32 + aa(i) = i + end do + call ftest1 (aa(4:12:2), 4, 12, 2) + do i = 1, 32 + if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then + if (aa (i) .ne. -i) stop 101 + else + if (aa (i) .ne. i) stop 102 + end if + end do + + ! assumed-shape, called from C code which will use the C interface + ! to create a non-contiguous array section and pass it to ftest1. + do i = 1, 32 + aa(i) = i + end do + call ctest1 (aa) + + ! assumed-rank, called from Fortran + do i = 1, 32 + aa(i) = i + end do + call ftest2 (aa(7:19:3), 7, 19, 3) + do i = 1, 32 + if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then + if (aa (i) .ne. -i) stop 201 + else + if (aa (i) .ne. i) stop 202 + end if + end do + + ! assumed-rank, called from C code which will use the C interface + ! to create a non-contiguous array section and pass it to ftest2. + do i = 1, 32 + aa(i) = i + end do + call ctest2 (aa) + +end program + Index: Fortran/gfortran/regression/c-interop/contiguous-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-3-c.c @@ -0,0 +1,80 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest1 (CFI_cdesc_t *a, int first, int last, int step); +extern void ctest2 (CFI_cdesc_t *a, int first, int last, int step); +extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step); +extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step); + +#if 0 +static void +dump_array (CFI_cdesc_t *a, const char *name, const char *note) +{ + int i; + + fprintf (stderr, "%s\n", note); + for (i = 0; i < a->dim[0].extent; i++) + { + int j = i + a->dim[0].lower_bound; + int elt; + CFI_index_t sub[1]; + sub[0] = j; + elt = *((int *) CFI_address (a, sub)); + fprintf (stderr, "%s[%d] = %d\n", name, j, elt); + } + fprintf (stderr, "\n"); +} +#else +#define dump_array(a, name, note) +#endif + +static void +ctest (CFI_cdesc_t *a, int first, int last, int step, + void (*fn) (CFI_cdesc_t *, int, int, int)) +{ + int i; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + dump_array (a, "a", "a on input to ctest"); + + /* Make sure we got a valid descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 1) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + + /* Pass it to the Fortran function fn. */ + (*fn) (a, first, last, step); + dump_CFI_cdesc_t (a); + dump_array (a, "a", "a after calling Fortran fn"); +} + +/* Entry points for the Fortran side. + Note that the Fortran code has already created the array section + and these functions were declared without the CONTIGUOUS attribute + so they receive a non-contiguous array. The magic is supposed to + happen when we pass them back into a Fortran function declared with + the CONTIGUOUS attribute. */ + +void +ctest1 (CFI_cdesc_t *a, int first, int last, int step) +{ + ctest (a, first, last, step, ftest1); +} + +void +ctest2 (CFI_cdesc_t *a, int first, int last, int step) +{ + ctest (a, first, last, step, ftest2); +} Index: Fortran/gfortran/regression/c-interop/contiguous-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/contiguous-3.f90 @@ -0,0 +1,171 @@ +! PR 101304 +! { dg-do run } +! { dg-additional-sources "contiguous-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! TS 29113 +! 8.7 In an invocation of an interoperable procedure whose Fortran +! interface has an assumed-shape or assumed-rank dummy argument with the +! CONTIGUOUS attribute, the associated effective argument may be an +! array that is not contiguous or the address of a C descriptor for such +! an array. If the procedure is invoked from Fortran or the procedure is +! a Fortran procedure, the Fortran processor will handle the difference +! in contiguity. If the procedure is invoked from C and the procedure is +! a C procedure, the C code within the procedure shall be prepared to +! handle the situation of receiving a discontiguous argument. +! +! The wording is different in the 2018 standard, but the intent is more +! or less the same: +! +! When an interoperable Fortran procedure that is invoked from C has a +! dummy argument with the CONTIGUOUS attribute or that is an assumed-length +! CHARACTER explicit-shape or assumed-size array, and the actual argument +! is the address of a C descriptor for a discontiguous object, the Fortran +! processor shall handle the difference in contiguity. +! +! This program tests the cases where a Fortran procedure with C binding and +! a dummy array argument with the contiguous attribute is invoked from +! both C or Fortran. It is similar to contiguous-2.f90 but here the array +! sections are created in Fortran even in the called-from-C case, rather +! than by calling CFI_section. + +! ftest1 and ftest2 both negate the elements of their input array; +! this allows testing that modifications to the array contents get +! propagated back to the base array. + +module m + + contains + + subroutine ftest1 (a, first, last, step) bind (c) + use iso_c_binding + integer(C_INT), contiguous :: a(:) + integer(C_INT), value :: first, last, step + integer :: i, ival + + ! Sanity checking that we got a contiguous array. The direct call + ! to is_contiguous might be optimized away, but the indirect one + ! in check_contiguous shouldn't be. + ! FIXME: is this correct? "the Fortran processor will handle the + ! difference in contiguity" may not mean that it's required to make + ! the array contiguous, just that it can access it correctly? + if (.not. is_contiguous (a)) stop 301 + call check_contiguous (a) + + ! Sanity checking that we got the right input array contents. + ! print *, 'a on entry to ftest1' + ! do i = lbound(a, 1), ubound(a, 1) + ! print *, 'a(', i, ') = ', a(i) + ! end do + ival = first + do i = lbound(a, 1), ubound(a, 1) + if (a (i) .ne. ival) then + print *, 'a(', i, ') = ', a(i), ' expected ', ival + stop 302 + end if + a(i) = - a(i) + ival = ival + step + end do + end subroutine + + subroutine ftest2 (a, first, last, step) bind (c) + use iso_c_binding + + integer(C_INT), contiguous :: a(..) + integer(C_INT), value :: first, last, step + + select rank (a) + rank (1) + call ftest1 (a(:), first, last, step) + rank default + stop 303 + end select + end subroutine + + subroutine check_contiguous (a) + use iso_c_binding + integer(C_INT) :: a(..) + if (.not. is_contiguous (a)) stop 304 + end subroutine + +end module + + +program testit + use iso_c_binding + use m + implicit none + + ! Note ctest1 and ctest2 do not have the contiguous attribute on a. + interface + subroutine ctest1 (a, first, last, step) bind (c) + use iso_c_binding + integer(C_INT) :: a(:) + integer(C_INT), value :: first, last, step + end subroutine + subroutine ctest2 (a, first, last, step) bind (c) + use iso_c_binding + integer(C_INT) :: a(..) + integer(C_INT), value :: first, last, step + end subroutine + end interface + + integer(C_INT) :: aa(32) + integer :: i + + ! assumed-shape, called from Fortran + do i = 1, 32 + aa(i) = i + end do + call ftest1 (aa(4:12:2), 4, 12, 2) + do i = 1, 32 + if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then + if (aa (i) .ne. -i) stop 101 + else + if (aa (i) .ne. i) stop 102 + end if + end do + + ! assumed-shape, called indirectly from C code, using an array + ! section created in Fortran instead of by CFI_section + do i = 1, 32 + aa(i) = i + end do + call ctest1 (aa(5:13:2), 5, 13, 2) + do i = 1, 32 + if (i .ge. 5 .and. i .le. 13 .and. mod (i-5,2) .eq. 0) then + if (aa (i) .ne. -i) stop 103 + else + if (aa (i) .ne. i) stop 104 + end if + end do + + ! assumed-rank, called from Fortran + do i = 1, 32 + aa(i) = i + end do + call ftest2 (aa(7:19:3), 7, 19, 3) + do i = 1, 32 + if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then + if (aa (i) .ne. -i) stop 201 + else + if (aa (i) .ne. i) stop 202 + end if + end do + + ! assumed-rank, called indirectly from C code, using an array + ! section created in Fortran instead of by CFI_section + do i = 1, 32 + aa(i) = i + end do + call ctest2 (aa(8:20:3), 8, 20, 3) + do i = 1, 32 + if (i .ge. 8 .and. i .le. 20 .and. mod (i-8,3) .eq. 0) then + if (aa (i) .ne. -i) stop 203 + else + if (aa (i) .ne. i) stop 204 + end if + end do + +end program + Index: Fortran/gfortran/regression/c-interop/deferred-character-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/deferred-character-1.f90 @@ -0,0 +1,76 @@ +! PR92482 +! { dg-do compile} +! +! TS 29113 +! 8.7 Interoperability of procedures and procedure interfaces +! +! If a dummy argument in an interoperable interface is of type +! CHARACTER and is allocatable or a pointer, its character length shall +! be deferred. +! +! This test checks that this error is diagnosed and is supposed to fail. + +module m + use iso_c_binding + + interface + + ! These are supposed to be OK + subroutine good1 (x, n) bind (c) + use iso_c_binding + character (kind=C_CHAR, len=:), allocatable :: x + integer(C_INT), value :: n + end subroutine + subroutine good2 (x, n) bind (c) + use iso_c_binding + character (kind=C_CHAR, len=:), pointer :: x + integer(C_INT), value :: n + end subroutine + + ! These are supposed to fail. + subroutine bad1 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=*), allocatable :: x + integer(C_INT), value :: n + end subroutine + subroutine bad2 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=*), pointer :: x + integer(C_INT), value :: n + end subroutine + + subroutine bad3 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=80), allocatable :: x + integer(C_INT), value :: n + end subroutine + subroutine bad4 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=80), pointer :: x + integer(C_INT), value :: n + end subroutine + + subroutine bad5 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=1), allocatable :: x + integer(C_INT), value :: n + end subroutine + subroutine bad6 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR, len=1), pointer :: x + integer(C_INT), value :: n + end subroutine + + subroutine bad7 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR), allocatable :: x + integer(C_INT), value :: n + end subroutine + subroutine bad8 (x, n) bind (c) ! { dg-error "must have deferred length" } + use iso_c_binding + character (kind=C_CHAR), pointer :: x + integer(C_INT), value :: n + end subroutine + end interface + +end module Index: Fortran/gfortran/regression/c-interop/deferred-character-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/deferred-character-2.f90 @@ -0,0 +1,55 @@ +! PR 92482 +! { dg-do run } +! +! TS 29113 +! 8.7 Interoperability of procedures and procedure interfaces +! +! If a dummy argument in an interoperable interface is of type +! CHARACTER and is allocatable or a pointer, its character length shall +! be deferred. + +program testit + use iso_c_binding + + character (kind=C_CHAR, len=:), allocatable :: aa + character (kind=C_CHAR, len=:), pointer :: pp + + + pp => NULL () + + call frobf (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 'foo') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 'bar') stop 104 + + pp => NULL () + + call frobc (aa, pp) + if (.not. allocated (aa)) stop 101 + if (aa .ne. 'frog') stop 102 + if (.not. associated (pp)) stop 103 + if (pp .ne. 'toad') stop 104 + + + contains + + subroutine frobf (a, p) + use iso_c_binding + character (kind=C_CHAR, len=:), allocatable :: a + character (kind=C_CHAR, len=:), pointer :: p + allocate (character(len=3) :: p) + a = 'foo' + p = 'bar' + end subroutine + + subroutine frobc (a, p) bind (c) + use iso_c_binding + character (kind=C_CHAR, len=:), allocatable :: a + character (kind=C_CHAR, len=:), pointer :: p + allocate (character(len=4) :: p) + a = 'frog' + p = 'toad' + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/dump-descriptors.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/dump-descriptors.h @@ -0,0 +1,12 @@ +/* Definitions of functions in dump-descriptors.c. */ + +#include "ISO_Fortran_binding.h" + +extern void dump_CFI_cdesc_t (CFI_cdesc_t *d); +extern void dump_CFI_dim_t (CFI_dim_t *d); +extern void dump_CFI_attribute_t (CFI_attribute_t a); +extern void dump_CFI_index_t (CFI_index_t i); +extern void dump_CFI_rank_t (CFI_rank_t r); +extern void dump_CFI_type_t (CFI_type_t t); + +void check_CFI_status (const char *fn, int code); Index: Fortran/gfortran/regression/c-interop/dump-descriptors.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/dump-descriptors.c @@ -0,0 +1,195 @@ +/* This file contains some useful routines for debugging problems with C + descriptors. Compiling it also acts as a test that the implementation of + ISO_Fortran_binding.h provides all the types and constants specified in + TS29113. */ + +#include +#include +#include +#include "dump-descriptors.h" + +void +dump_CFI_cdesc_t (CFI_cdesc_t *d) +{ + fprintf (stderr, "base_addr, (long)(d->elem_len), d->version); + fprintf (stderr, "\n rank="); + dump_CFI_rank_t (d->rank); + fprintf (stderr, " type="); + dump_CFI_type_t (d->type); + fprintf (stderr, " attribute="); + dump_CFI_attribute_t (d->attribute); + + /* Dimension info may not be initialized if it's an allocatable + or pointer descriptor with a null base_addr. */ + if (d->rank > 0 && d->base_addr) + { + CFI_rank_t i; + for (i = 0; i < d->rank; i++) + { + if (i == 0) + fprintf (stderr, "\n dim=["); + else + fprintf (stderr, ",\n "); + dump_CFI_dim_t (d->dim + i); + } + fprintf (stderr, "]"); + } + fprintf (stderr, ">\n"); +} + +void +dump_CFI_dim_t (CFI_dim_t *d) +{ + fprintf (stderr, ""); +} + +void +dump_CFI_attribute_t (CFI_attribute_t a) +{ + switch (a) + { + case CFI_attribute_pointer: + fprintf (stderr, "CFI_attribute_pointer"); + break; + case CFI_attribute_allocatable: + fprintf (stderr, "CFI_attribute_allocatable"); + break; + case CFI_attribute_other: + fprintf (stderr, "CFI_attribute_other"); + break; + default: + fprintf (stderr, "unknown(%d)", (int)a); + break; + } +} + +void +dump_CFI_index_t (CFI_index_t i) +{ + fprintf (stderr, "%ld", (long)i); +} + +void +dump_CFI_rank_t (CFI_rank_t r) +{ + fprintf (stderr, "%d", (int)r); +} + +/* We can't use a switch statement to dispatch CFI_type_t because + the type name macros may not be unique. Iterate over a table + instead. */ + +struct type_name_map { + CFI_type_t t; + const char *n; +}; + +struct type_name_map type_names[] = +{ + { CFI_type_signed_char, "CFI_type_signed_char" }, + { CFI_type_short, "CFI_type_short" }, + { CFI_type_int, "CFI_type_int" }, + { CFI_type_long, "CFI_type_long" }, + { CFI_type_long_long, "CFI_type_long_long" }, + { CFI_type_size_t, "CFI_type_size_t" }, + { CFI_type_int8_t, "CFI_type_int8_t" }, + { CFI_type_int16_t, "CFI_type_int16_t" }, + { CFI_type_int32_t, "CFI_type_int32_t" }, + { CFI_type_int64_t, "CFI_type_int64_t" }, + { CFI_type_int_least8_t, "CFI_type_int_least8_t" }, + { CFI_type_int_least16_t, "CFI_type_int_least16_t" }, + { CFI_type_int_least32_t, "CFI_type_int_least32_t" }, + { CFI_type_int_least64_t, "CFI_type_int_least64_t" }, + { CFI_type_int_fast8_t, "CFI_type_int_fast8_t" }, + { CFI_type_int_fast16_t, "CFI_type_int_fast16_t" }, + { CFI_type_int_fast32_t, "CFI_type_int_fast32_t" }, + { CFI_type_int_fast64_t, "CFI_type_int_fast64_t" }, + { CFI_type_intmax_t, "CFI_type_intmax_t" }, + { CFI_type_intptr_t, "CFI_type_intptr_t" }, + { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t" }, + { CFI_type_float, "CFI_type_float" }, + { CFI_type_double, "CFI_type_double" }, + { CFI_type_long_double, "CFI_type_long_double" }, + { CFI_type_float_Complex, "CFI_type_float_Complex" }, + { CFI_type_double_Complex, "CFI_type_double_Complex" }, + { CFI_type_long_double_Complex, "CFI_type_long_double_Complex" }, + { CFI_type_Bool, "CFI_type_Bool" }, + { CFI_type_char, "CFI_type_char" }, + { CFI_type_cptr, "CFI_type_cptr" }, + { CFI_type_struct, "CFI_type_struct" }, + { CFI_type_other, "CFI_type_other" }, + /* Extension types */ + { CFI_type_int128_t, "CFI_type_int128_t" }, + { CFI_type_int_least128_t, "CFI_type_int_least128_t" }, + { CFI_type_int_fast128_t, "CFI_type_int_fast128_t" }, + { CFI_type_ucs4_char, "CFI_type_ucs4_char" }, + { CFI_type_float128, "CFI_type_float128" }, + { CFI_type_float128_Complex, "CFI_type_float128_Complex" }, + { CFI_type_cfunptr, "CFI_type_cfunptr" } +}; + +void +dump_CFI_type_t (CFI_type_t t) +{ + int i; + for (i = 0; i < sizeof (type_names) / sizeof (struct type_name_map); i++) + if (type_names[i].t == t) + { + fprintf (stderr, "%s", type_names[i].n); + return; + } + fprintf (stderr, "unknown(%d)", (int)t); +} + +void +check_CFI_status (const char *fn, int code) +{ + const char *msg; + switch (code) + { + case CFI_SUCCESS: + return; + case CFI_ERROR_BASE_ADDR_NULL: + msg = "CFI_ERROR_BASE_ADDR_NULL"; + break; + case CFI_ERROR_BASE_ADDR_NOT_NULL: + msg = "CFI_ERROR_BASE_ADDR_NOT_NULL"; + break; + case CFI_INVALID_ELEM_LEN: + msg = "CFI_INVALID_ELEM_LEN"; + break; + case CFI_INVALID_RANK: + msg = "CFI_INVALID_RANK"; + break; + case CFI_INVALID_TYPE: + msg = "CFI_INVALID_TYPE"; + break; + case CFI_INVALID_ATTRIBUTE: + msg = "CFI_INVALID_ATTRIBUTE"; + break; + case CFI_INVALID_EXTENT: + msg = "CFI_INVALID_EXTENT"; + break; + case CFI_INVALID_DESCRIPTOR: + msg = "CFI_INVALID_DESCRIPTOR"; + break; + case CFI_ERROR_MEM_ALLOCATION: + msg = "CFI_ERROR_MEM_ALLOCATION"; + break; + case CFI_ERROR_OUT_OF_BOUNDS: + msg = "CFI_ERROR_OUT_OF_BOUNDS"; + break; + default: + msg = "unknown error"; + break; + } + fprintf (stderr, "%s returned %s\n", fn, msg); + abort (); +} Index: Fortran/gfortran/regression/c-interop/establish-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/establish-c.c @@ -0,0 +1,134 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +/* For simplicity, point descriptors at a static buffer. BUFSIZE should + be large enough for any of the standard types and we'll use DIM0 and DIM1 + for array dimensions. */ +#define BUFSIZE 64 +#define DIM0 3 +#define DIM1 10 +#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1 +static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8))); +static CFI_index_t extents[] = {DIM0, DIM1}; + +/* Magic number to use for elem_len field. */ +#define MAGIC_ELEM_LEN 20 + +struct tc_info +{ + CFI_type_t typecode; + char *name; + size_t size; +}; + +static struct tc_info tc_table[] = +{ + { CFI_type_signed_char, "CFI_type_signed_char", sizeof (signed char) }, + { CFI_type_short, "CFI_type_short", sizeof (short) }, + { CFI_type_int, "CFI_type_int", sizeof (int) }, + { CFI_type_long, "CFI_type_long", sizeof (long) }, + { CFI_type_long_long, "CFI_type_long_long", sizeof (long long) }, + { CFI_type_size_t, "CFI_type_size_t", sizeof (size_t) }, + { CFI_type_int8_t, "CFI_type_int8_t", sizeof (int8_t) }, + { CFI_type_int16_t, "CFI_type_int16_t", sizeof (int16_t) }, + { CFI_type_int32_t, "CFI_type_int32_t", sizeof (int32_t) }, + { CFI_type_int64_t, "CFI_type_int64_t", sizeof (int64_t) }, + { CFI_type_int_least8_t, "CFI_type_int_least8_t", sizeof (int_least8_t) }, + { CFI_type_int_least16_t, "CFI_type_int_least16_t", sizeof (int_least16_t) }, + { CFI_type_int_least32_t, "CFI_type_int_least32_t", sizeof (int_least32_t) }, + { CFI_type_int_least64_t, "CFI_type_int_least64_t", sizeof (int_least64_t) }, + { CFI_type_int_fast8_t, "CFI_type_int_fast8_t", sizeof (int_fast8_t) }, + { CFI_type_int_fast16_t, "CFI_type_int_fast16_t", sizeof (int_fast16_t) }, + { CFI_type_int_fast32_t, "CFI_type_int_fast32_t", sizeof (int_fast32_t) }, + { CFI_type_int_fast64_t, "CFI_type_int_fast64_t", sizeof (int_fast64_t) }, + { CFI_type_intmax_t, "CFI_type_intmax_t", sizeof (intmax_t) }, + { CFI_type_intptr_t, "CFI_type_intptr_t", sizeof (intptr_t) }, + { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t", sizeof (ptrdiff_t) }, + { CFI_type_float, "CFI_type_float", sizeof (float) }, + { CFI_type_double, "CFI_type_double", sizeof (double) }, + { CFI_type_long_double, "CFI_type_long_double", sizeof (long double) }, + { CFI_type_float_Complex, "CFI_type_float_Complex", + sizeof (float _Complex) }, + { CFI_type_double_Complex, "CFI_type_double_Complex", + sizeof (double _Complex) }, + { CFI_type_long_double_Complex, "CFI_type_long_double_Complex", + sizeof (long double _Complex) }, + { CFI_type_Bool, "CFI_type_Bool", sizeof (_Bool) }, + { CFI_type_char, "CFI_type_char", sizeof (char) }, + { CFI_type_cptr, "CFI_type_cptr", sizeof (void *) }, + { CFI_type_struct, "CFI_type_struct", 0 }, + { CFI_type_other, "CFI_type_other", -1 } +}; + +int +test_array (struct tc_info *tc, void *ptr, CFI_attribute_t attr) +{ + CFI_CDESC_T(2) desc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &desc; + int bad = 0; + size_t elem_len; + + /* Initialize the descriptor to garbage values so we can confirm it's + properly initialized with good ones later. */ + memset (a, -1, sizeof(desc)); + + check_CFI_status ("CFI_establish", + CFI_establish (a, ptr, attr, tc->typecode, + MAGIC_ELEM_LEN, 2, extents)); + + /* elem_len is ignored unless type is CFI type struct, CFI type other, + or a character type. */ + if (tc->typecode == CFI_type_char + || tc->typecode == CFI_type_struct + || tc->typecode == CFI_type_other) + elem_len = MAGIC_ELEM_LEN; + else + elem_len = tc->size; + + if (a->elem_len != elem_len + || a->base_addr != ptr + || a->type != tc->typecode + || a->version != CFI_VERSION + || a->attribute != attr + || a->rank != 2 + || (ptr && + /* extents parameter is ignored if ptr is null */ + (a->dim[0].lower_bound != 0 + || a->dim[0].extent != DIM0 + || a->dim[0].sm != elem_len + || a->dim[1].lower_bound != 0 + || a->dim[1].extent != DIM1 + || a->dim[1].sm != elem_len*DIM0))) + { + fprintf (stderr, "Bad array descriptor for %s:\n", tc->name); + dump_CFI_cdesc_t (a); + return 1; + } + return 0; +} + +/* External entry point. */ +extern void ctest_establish (void); + +void +ctest_establish (void) +{ + int ncodes = sizeof (tc_table) / sizeof (struct tc_info); + int i; + int bad = 0; + + for (i = 0; i < ncodes; i++) + { + bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_other); + bad += test_array (&tc_table[i], NULL, CFI_attribute_allocatable); + bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_pointer); + } + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/establish-errors-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/establish-errors-c.c @@ -0,0 +1,120 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +/* For simplicity, point descriptors at a static buffer. BUFSIZE should + be large enough for any of the standard types and we'll use DIM0 and DIM1 + for array dimensions. */ +#define BUFSIZE 64 +#define DIM0 3 +#define DIM1 10 +#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1 +static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8))); +static CFI_index_t extents[] = {DIM0, DIM1}; + +/* Magic number to use for elem_len field. */ +#define MAGIC_ELEM_LEN 20 + + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + int bad = 0; + int status; + CFI_CDESC_T(2) desc; + CFI_cdesc_t *a = (CFI_cdesc_t *) &desc; + + /* If the attribute argument is CFI_attribute_allocatable, + base_addr shall be a null pointer. */ + status = CFI_establish (a, (void *)buf, CFI_attribute_allocatable, + CFI_type_int, 0, 2, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for non-null pointer with CFI_attribute_allocatable\n"); + bad ++; + } + + /* type shall have the value of one of the type codes in Table 18.4, + or have a positive value corresponding to an interoperable C type. */ + status = CFI_establish (a, (void *)buf, CFI_attribute_other, + CFI_type_other - 1, 0, 2, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for invalid negative type code\n"); + bad ++; + } + + /* If the type is CFI_type_struct, CFI_type_other, or a Fortran + character type, elem_len shall be greater than zero and equal to + the storage size in bytes of an element of the object. */ + status = CFI_establish (a, (void *)buf, CFI_attribute_other, + CFI_type_struct, 0, 2, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for invalid size with CFI_type_struct\n"); + bad ++; + } + + status = CFI_establish (a, (void *)buf, CFI_attribute_other, + CFI_type_char, 0, 2, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for invalid size with CFI_type_char\n"); + bad ++; + } + + /* Rank shall be between 0 and CFI_MAX_RANK inclusive. */ + status = CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, -1, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for negative rank\n"); + bad ++; + } + status = CFI_establish (a, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, CFI_MAX_RANK + 1, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank > CFI_MAX_RANK\n"); + bad ++; + } + + /* extents is ignored if the rank r is zero or if base_addr is a + null pointer. Otherwise, it shall be the address of an array... */ + status = CFI_establish (a, (void *)buf, CFI_attribute_other, + CFI_type_int, 0, 2, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for null extents\n"); + bad ++; + } + + /* Extents shall all be nonnegative. */ + extents[1] = -extents[1]; + status = CFI_establish (a, (void *)buf, CFI_attribute_other, + CFI_type_int, 0, 2, extents); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for negative extents\n"); + bad ++; + } + + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/establish-errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/establish-errors.f90 @@ -0,0 +1,30 @@ +! PR101317 +! { dg-do run } +! { dg-additional-sources "establish-errors-c.c dump-descriptors.c" } +! { dg-additional-options "-Wno-error -fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! This program tests that the CFI_establish function properly detects +! invalid arguments. All the interesting things happen in the +! corresponding C code. +! +! The situation here seems to be that while TS29113 defines error codes +! for CFI_establish, it doesn't actually require the implementation to detect +! those errors by saying the arguments "shall be" such-and-such, e.g. it is +! undefined behavior if they are not. In gfortran you can enable some +! run-time checking by building with -fcheck=all. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest () bind (c) + end subroutine + + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/establish.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/establish.f90 @@ -0,0 +1,35 @@ +! PR 101305 +! { dg-do run } +! { dg-additional-sources "establish-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests the CFI_establish function. All the interesting +! things happen in the corresponding C code. + +! Eventually we might want to make the C code pass the descriptors back to +! C-callable Fortran functions, but for now it just checks them internally. + +module mm + use iso_c_binding + + type, bind (c) :: s + integer(C_INT) :: i, j + end type +end module + + +program testit + use iso_c_binding + use mm + implicit none + + interface + + subroutine ctest_establish () bind (c) + end subroutine + + end interface + + call ctest_establish () + +end program Index: Fortran/gfortran/regression/c-interop/explicit-interface.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/explicit-interface.f90 @@ -0,0 +1,60 @@ +! { dg-do compile } +! +! TS 29113 +! 6.2 Explicit interface +! +! Additionally to the rules of subclause 12.4.2.2 of ISO/IEC 1539-1:2010, +! a procedure shall have an explicit interface if it has a dummy argument +! that is assumed-rank. +! +! NOTE 6.1 +! An explicit interface is also required for a procedure if it has a +! dummy argument that is assumed-type because an assumed-type dummy +! argument is polymorphic. +! +! This file contains code that is expected to produce errors. + +module m1 + + interface + + subroutine s1 (a) + integer :: a(..) + end subroutine + + subroutine s2 (b) + type(*) :: b + end subroutine + + end interface + +end module + +module m2 + + contains + + ! This subroutine has an explicit interface, and so do the things + ! it calls. + subroutine good (a, b) + use m1 + integer :: a(..) + type (*) :: b + + call s1 (a) + call s2 (b) + end subroutine + + ! This subroutine has an explicit interface, but the things it calls don't. + subroutine bad (a, b) + use m1 + integer :: a(..) + type (*) :: b + external :: s3, s4 + + call s3 (a) ! { dg-error "Assumed-rank argument" } + call s4 (b) ! { dg-error "Assumed-type argument" } + end subroutine + +end module + Index: Fortran/gfortran/regression/c-interop/fc-descriptor-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-1-c.c @@ -0,0 +1,46 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The actual argument on the Fortran side was declared as + integer(C_INT) :: aa(10,-1:3) + Make sure that matches what's in the descriptor. Note that per + section 18.5.3 in the 2018 standard, for a nonallocatable nonpointer + array, the array dimensions in the descriptor reflect the shape of + the array rather than the actual bounds; the lower_bound is required + to be zero. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 10) + abort (); + if (a->dim[0].sm != sizeof(int)) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != 5) + abort (); + if (a->dim[1].sm != a->dim[0].extent * sizeof(int)) + abort (); + if (!CFI_is_contiguous (a)) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-1.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-additional-sources "fc-descriptor-1-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This checks that a C function declared to have an assumed-shape array +! argument can be called from Fortran and receives a correct descriptor. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(:,:) + end subroutine + end interface + + integer(C_INT) :: aa(10,-1:3) + + ! Test both passing the fixed-size array directly to the function + ! with a C interface, and indirectly via a Fortran function with an + ! assumed-shape dummy argument. + call ctest (aa) + call ftest (aa) + +contains + subroutine ftest (a) + use iso_c_binding + integer(C_INT) :: a(:,:) + call ctest (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-2-c.c @@ -0,0 +1,68 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, int n); + +void +ctest (CFI_cdesc_t *a, int n) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(float)) + abort (); + if (a->type != CFI_type_float) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + + if (n == 1) + { + /* The actual argument on the Fortran side was declared as + real(C_FLOAT):: aa(100) */ + if (a->rank != 1) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 100) + abort (); + if (a->dim[0].sm != sizeof(float)) + abort (); + if (!CFI_is_contiguous (a)) + abort (); + } + else if (n == 3) + { + /* The actual argument on the Fortran side was declared as + real(C_FLOAT) :: bb(3,4,5) */ + if (a->rank != 3) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 3) + abort (); + if (a->dim[0].sm != sizeof(float)) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != 4) + abort (); + if (a->dim[1].sm != a->dim[0].sm * a->dim[0].extent) + abort (); + if (a->dim[2].lower_bound != 0) + abort (); + if (a->dim[2].extent != 5) + abort (); + if (a->dim[2].sm != a->dim[1].sm * a->dim[1].extent) + abort (); + if (!CFI_is_contiguous (a)) + abort (); + } + else + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! { dg-additional-sources "fc-descriptor-2-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that a C function declared to take an assumed-rank +! array argument can be called from Fortran, and receives a correct +! descriptor. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a, n) bind (c) + use iso_c_binding + real(C_FLOAT) :: a(..) + integer(C_INT), value :: n + end subroutine + end interface + + real(C_FLOAT) :: aa(100) + real(C_FLOAT) :: bb(3,4,5) + + ! Test both passing the fixed-size array directly to the function + ! with a C interface, and indirectly via a Fortran function with an + ! assumed-rank dummy argument. + call ctest (aa, 1) + call ctest (bb, 3) + call ftest (aa, 1) + call ftest (bb, 3) + +contains + subroutine ftest (a, n) + use iso_c_binding + real(C_FLOAT) :: a(..) + integer, value :: n + call ctest (a, n) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-3-c.c @@ -0,0 +1,42 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp); + +void +ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (b); + + /* Make sure the descriptors match what we are expecting. a is an + allocatable derived type object, b is a pointer which points at a + if initp is true. */ + if (initp && !a->base_addr) + abort (); + else if (!initp && a->base_addr) + abort (); + if (a->base_addr != b->base_addr) + abort (); + + if (a->rank != 0) + abort (); + if (b->rank != 0) + abort (); + if (a->type != CFI_type_struct) + abort (); + if (b->type != CFI_type_struct) + abort (); + if (a->elem_len != 3 * 3 * sizeof(double)) + abort (); + if (b->elem_len != 3 * 3 * sizeof(double)) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-3.f90 @@ -0,0 +1,37 @@ +! PR 101308 +! { dg-do run } +! { dg-additional-sources "fc-descriptor-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that pointer and allocatable scalar arguments are +! correctly passed by descriptor from Fortran code into C. + +program testit + use iso_c_binding + implicit none + + type, bind (c) :: m + real(C_DOUBLE) :: a(3, 3) + end type + + interface + subroutine ctest (a, b, initp) bind (c) + use iso_c_binding + import m + type(m), allocatable :: a + type(m), pointer :: b + integer(C_INT), value :: initp + end subroutine + end interface + + type (m), allocatable, target :: aa + type (m), pointer :: bb + + ! Test both before and after allocation/pointer initialization. + bb => null() + call ctest (aa, bb, 0) + allocate (aa) + bb => aa + call ctest (aa, bb, 1) + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-4-c.c @@ -0,0 +1,57 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp); + +void +ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (b); + + /* Make sure the descriptors match what we are expecting. a is an + allocatable derived type object, b is a pointer which points at a + if initp is true. */ + if (initp && !a->base_addr) + abort (); + else if (!initp && a->base_addr) + abort (); + if (a->base_addr != b->base_addr) + abort (); + + if (a->type != CFI_type_struct) + abort (); + if (b->type != CFI_type_struct) + abort (); + if (a->elem_len != 3 * 3 * sizeof(double)) + abort (); + if (b->elem_len != 3 * 3 * sizeof(double)) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + + if (initp) + /* The actual array is allocated with + allocate (aa(3:7)) + Per 8.3.3 of TS29113, the lower_bound must reflect that. */ + { + if (a->rank != 1) + abort (); + if (b->rank != 1) + abort (); + if (a->dim[0].lower_bound != 3) + abort (); + if (b->dim[0].lower_bound != 3) + abort (); + if (a->dim[0].extent != 5) + abort (); + if (b->dim[0].extent != 5) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-4.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-additional-sources "fc-descriptor-4-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that pointer and allocatable array arguments are +! correctly passed by descriptor from Fortran code into C. + +program testit + use iso_c_binding + implicit none + + type, bind (c) :: m + real(C_DOUBLE) :: a(3, 3) + end type + + interface + subroutine ctest (a, b, initp) bind (c) + use iso_c_binding + import m + type(m), allocatable :: a(:) + type(m), pointer :: b(:) + integer(C_INT), value :: initp + end subroutine + end interface + + type (m), allocatable, target :: aa(:) + type (m), pointer :: bb(:) + + ! Test both before and after allocation/pointer initialization. + bb => NULL () + call ctest (aa, bb, 0) + allocate (aa(3:7)) + bb => aa + call ctest (aa, bb, 1) + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-5-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-5-c.c @@ -0,0 +1,28 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The actual argument on the Fortran side was declared as + character(len=20) :: aa + Make sure that matches what's in the descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != 20) + abort (); + if (a->rank != 0) + abort (); + if (a->type != CFI_type_char) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-5.f90 @@ -0,0 +1,35 @@ +! PR92482 +! { dg-do run } +! { dg-additional-sources "fc-descriptor-5-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests it works to call a C function from Fortran with +! an assumed length character dummy. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + end subroutine + end interface + + character(len=20,kind=C_CHAR) :: aa + + ! Test both passing the fixed-length string directly to the function + ! with a C interface, and indirectly via a Fortran function with an + ! assumed-length dummy argument. + call ctest (aa) + call ftest (aa) + +contains + subroutine ftest (a) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + call ctest (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-6-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-6-c.c @@ -0,0 +1,51 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The actual argument on the Fortran side was declared as + integer(C_INT) :: aa(10,5:8) + but was passed via other functions that variously describe it as + having size (10,*), (10,1:*), or (10,5:*). But, the spec says: + + For a C descriptor of a nonallocatable nonpointer object, the + value of the lower_bound member of each element of the dim member + of the descriptor is zero. + + In a C descriptor of an assumed-size array, the extent member of + the last element of the dim member has the value −1. */ + + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 10) + abort (); + if (a->dim[0].sm != sizeof(int)) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != -1) + abort (); + if (a->dim[1].sm != a->dim[0].extent * sizeof(int)) + abort (); +} + + Index: Fortran/gfortran/regression/c-interop/fc-descriptor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-6.f90 @@ -0,0 +1,50 @@ +! Reported as pr94070. +! { dg-do run } +! { dg-additional-sources "fc-descriptor-6-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that an assumed-size array argument can be passed +! to a C function via a descriptor, and that the argument descriptor +! received by C correctly identifies it as assumed-size. + +program testit + use iso_c_binding + implicit none + + ! Assumed-size arrays are not passed by descriptor. What we'll do + ! for this test function is bind an assumed-rank dummy + ! to the assumed-size array. This is supposed to fill in the descriptor + ! with information about the array present at the call site. + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(..) + end subroutine + end interface + + integer(C_INT), target :: aa(10,5:8) + + ! To get an assumed-size array descriptor, we have to first pass the + ! fixed-size array to a Fortran function with an assumed-size dummy, + call ftest1 (aa) + call ftest2 (aa) + call ftest3 (aa) + +contains + subroutine ftest1 (a) + use iso_c_binding + integer(C_INT) :: a(10,*) + call ctest (a) + end subroutine + subroutine ftest2 (a) + use iso_c_binding + integer(C_INT) :: a(10,5:*) + call ctest (a) + end subroutine + subroutine ftest3 (a) + use iso_c_binding + integer(C_INT) :: a(10,1:*) + call ctest (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-7-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-7-c.c @@ -0,0 +1,53 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *, _Bool); + +void +ctest (CFI_cdesc_t *a, _Bool is_cont) +{ + CFI_index_t subscripts[2]; + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + +#if DEBUG + dump_CFI_cdesc_t (a); +#endif + + /* We expect to get an array of shape (5,10) that may not be + contiguous. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 5) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != 10) + abort (); + + if (is_cont != CFI_is_contiguous (a)) + abort (); + + if (abs (a->dim[0].sm) < a->elem_len) + abort (); + + for (int j = 0; j < 5; ++j) + for (int i = 0; i < 10; ++i) + { + subscripts[0] = j; subscripts[1] = i; + if (*(int *) CFI_address (a, subscripts) != (i+1) + 100*(j+1)) + abort (); + } +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-7.f90 @@ -0,0 +1,147 @@ +! PR 101309 +! { dg-do run } +! { dg-additional-sources "fc-descriptor-7-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests passing arrays that may not be contiguous through +! descriptors to C functions as assumed-shape arguments. + +program testit + use iso_c_binding + implicit none (type, external) + + interface + subroutine ctest (a, is_cont) bind (c) + use iso_c_binding + integer(C_INT) :: a(:,:) + logical(C_Bool), value :: is_cont + end subroutine + subroutine ctest_cont (a, is_cont) bind (c, name="ctest") + use iso_c_binding + integer(C_INT), contiguous :: a(:,:) + logical(C_Bool), value :: is_cont + end subroutine + + subroutine ctest_ar (a, is_cont) bind (c, name="ctest") + use iso_c_binding + integer(C_INT) :: a(..) + logical(C_Bool), value :: is_cont + end subroutine + subroutine ctest_ar_cont (a, is_cont) bind (c, name="ctest") + use iso_c_binding + integer(C_INT), contiguous :: a(..) + logical(C_Bool), value :: is_cont + end subroutine + end interface + + integer :: i , j + integer(C_INT), target :: aa(10,5) + integer(C_INT), target :: bb(10,10) + + ! Original array + do j = 1, 5 + do i = 1, 10 + aa(i,j) = i + 100*j + end do + end do + + ! Transposed array + do j = 2, 10, 2 + do i = 1, 10 + bb(j, i) = i + 100*((j-2)/2 + 1) + end do + end do + + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + + ! Test both calling the C function directly, and via another function + ! that takes an assumed-shape/assumed-rank argument. + + call ftest (transpose (aa), is_cont=.true._c_bool) ! Implementation choice: copy in; hence, contiguous + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + + call ctest (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_cont (transpose (aa), is_cont=.true._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_ar (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_ar_cont (transpose (aa), is_cont=.true._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + + + call ftest (bb(2:10:2, :), is_cont=.false._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + + call ctest (bb(2:10:2, :), is_cont=.false._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_cont (bb(2:10:2, :), is_cont=.true._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_ar (bb(2:10:2, :), is_cont=.false._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + call ctest_ar_cont (bb(2:10:2, :), is_cont=.true._c_bool) + if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1 + +contains + subroutine ftest (a, is_cont) + use iso_c_binding + integer(C_INT) :: a(:,:) + logical(c_bool), value, intent(in) :: is_cont + if (is_cont .NEQV. is_contiguous (a)) error stop 2 + if (any (shape (a) /= [5, 10])) error stop 3 + do j = 1, 5 + do i = 1, 10 + if (a(j, i) /= i + 100*j) error stop 4 + if (a(j, i) /= aa(i,j)) error stop + end do + end do + call ctest (a, is_cont) + call ctest_cont (a, is_cont=.true._c_bool) + call ctest_ar (a, is_cont) + call ctest_ar_cont (a, is_cont=.true._c_bool) + end subroutine + + subroutine ftest_ar (a, is_cont) + use iso_c_binding + integer(C_INT) :: a(..) + logical(c_bool), value, intent(in) :: is_cont + if (is_cont .NEQV. is_contiguous (a)) error stop 2 + if (any (shape (a) /= [5, 10])) error stop 3 + select rank (a) + rank(2) + do j = 1, 5 + do i = 1, 10 + if (a(j, i) /= i + 100*j) error stop 4 + if (a(j, i) /= aa(i,j)) error stop + end do + end do + call ctest (a, is_cont) + call ctest_cont (a, is_cont=.true._c_bool) + call ftest_ar_con (a, is_cont=.true._c_bool) + end select + call ctest_ar (a, is_cont) + ! call ctest_ar_cont (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729 + ! call ftest_ar_con (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729 + end subroutine + + subroutine ftest_ar_con (a, is_cont) + use iso_c_binding + integer(C_INT), contiguous :: a(..) + logical(c_bool), value, intent(in) :: is_cont + if (is_cont .NEQV. is_contiguous (a)) error stop 2 + if (any (shape (a) /= [5, 10])) error stop 3 + select rank (a) + rank(2) + do j = 1, 5 + do i = 1, 10 + if (a(j, i) /= i + 100*j) error stop 4 + if (a(j, i) /= aa(i,j)) error stop + end do + end do + call ctest (a, is_cont) + call ctest_cont (a, is_cont=.true._c_bool) + end select + call ctest_ar (a, is_cont) + call ctest_ar_cont (a, is_cont=.true._c_bool) + end subroutine +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-8-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-8-c.c @@ -0,0 +1,20 @@ +/* TS29113 8.3.1: ISO_Fortran_binding.h may be included more than once. */ + +#include + +#include +#include "dump-descriptors.h" +#include + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->version != CFI_VERSION) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-8.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-additional-sources "fc-descriptor-8-c.c dump-descriptors.c" } +! +! Check that C descriptors have the version field set correctly. +! This program is just a stub to create a descriptor and pass it to the +! C function, which does the actual test. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(:,:) + end subroutine + end interface + + integer(C_INT) :: aa(10,-1:3) + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-9-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-9-c.c @@ -0,0 +1,42 @@ +/* 8.3.1: ISO_Fortran_binding.h may be included more than once. */ + +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +struct descriptor_fixed_part { + void *base_addr; + size_t elem_len; + int version; +}; + +void +ctest (CFI_cdesc_t *a) +{ + struct descriptor_fixed_part *f = (struct descriptor_fixed_part *) a; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The first three members of the structure shall be base_addr, + elem_len, and version in that order. */ + if (&(a->base_addr) != &(f->base_addr)) + abort (); + if (&(a->elem_len) != &(f->elem_len)) + abort (); + if (&(a->version) != &(f->version)) + abort (); + + /* The final member shall be dim, with the other members after version + and before dim in any order. */ + if ((void *)&(a->rank) >= (void *)a->dim) + abort (); + if ((void *)&(a->type) >= (void *)a->dim) + abort (); + if ((void *)&(a->attribute) >= (void *)a->dim) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-descriptor-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-9.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-additional-sources "fc-descriptor-9-c.c dump-descriptors.c" } +! +! Check that C descriptors follow the layout restrictions described in +! section 8.3.3 of TS29113. +! This program is just a stub to create a descriptor and pass it to the +! C function, which does the actual test. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(:,:) + end subroutine + end interface + + integer(C_INT) :: aa(10,-1:3) + call ctest (aa) + +end program Index: Fortran/gfortran/regression/c-interop/fc-descriptor-pr108621.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-descriptor-pr108621.f90 @@ -0,0 +1,65 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/108621 +! +! If the bind(C) procedure's dummy argument is a POINTER with INTENT(OUT), +! avoid converting the array bounds for the CFI descriptor before the call. +! +! Rational: Fewer code and, esp. for undefined pointers, there might be a +! compile-time warning or a runtime error due to the 'extent' arithmentic +! and integer overflows (i.e. random values and -fsanitize=undefined). +! +! (For disassociated pointers, it would/should be only pointless code as +! the bound setting is guarded by a != NULL condtion. However, as the PR shows, +! a bogus may-use-uninitialized-memory warning might still be shown in that case.) +! +! Without 'intent' (but still intent(out) internally), the same applies but +! there is nothing the compiler can do on the caller side. +! Still, as only uninit memory and not invalid memory it accessed, it should still +! work (at least when run-time checking is turned off). +! +subroutine demo(f) +use, intrinsic :: iso_c_binding, only : c_int +implicit none + +interface + subroutine fun(f_p) bind(c) + import c_int + integer(c_int), pointer, intent(out) :: f_p(:) + end subroutine +end interface + +integer(c_int), pointer :: f(:) + +call fun(f) +end + +! The following ones must be present even with intent(out): +! +! { dg-final { scan-tree-dump "cfi...version = 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...rank = 1;" "original" } } +! { dg-final { scan-tree-dump "cfi...type = 1025;" "original" } } +! { dg-final { scan-tree-dump "cfi...attribute = 0;" "original" } } +! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } } + + +! The following is not needed - but user code might expect that an incoming pointer is NULL +! in this case. - At least the GCC testsuite expects this in the C code at +! gfortran.dg/c-interop/section-{1,2}.f90 +! Thus, it is kept as it does not cause any harm: +! +! { dg-final { scan-tree-dump "cfi...base_addr = f->data;" "original" } } + + +! The following ones are not need with intent(out) and, therefore, shouldn't be there: +! +! cfi.0.dim[idx.1].lower_bound = f->dim[idx.1].lbound; +! cfi.0.dim[idx.1].extent = (f->dim[idx.1].ubound - f->dim[idx.1].lbound) + 1; +! cfi.0.dim[idx.1].sm = f->dim[idx.1].stride * f->span; +! +! Now match those - but using a rather generic pattern as it is a ...-not scan: +! +! { dg-final { scan-tree-dump-not "lower_bound = " "original" } } +! { dg-final { scan-tree-dump-not "extent = " "original" } } +! { dg-final { scan-tree-dump-not "sm = " "original" } } Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-1-c.c @@ -0,0 +1,52 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imax, int jmax, CFI_cdesc_t *a); + +struct m { + int i; + int j; +}; + +void +ctest (int imax, int jmax, CFI_cdesc_t *a) +{ + + int i, j; + CFI_index_t subscripts[2]; + struct m* mp; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + /* Fill in the contents of a. a is zero-based but we want the ->i and ->j + members of each element to be numbered starting from 1. */ + for (j = 0; j < jmax; j++) + { + subscripts[1] = j; + for (i = 0; i < imax; i++) + { + subscripts[0] = i; + mp = (struct m *) CFI_address (a, subscripts); + mp->i = i + 1; + mp->j = j + 1; + } + } +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-1.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-1-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that passing a fixed-size array as an intent(out) +! assumed-shape argument to a C function called from Fortran works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (ii, jj, a) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + type(m), intent(out) :: a(:,:) + end subroutine + end interface + + type(m) :: aa(imax,jmax) + integer :: i, j + + ! initialize the array to all zeros; ctest will overwrite it. + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = 0 + aa(i,j)%j = 0 + end do + end do + + call ctest (imax, jmax, aa) + call verify (aa) + +contains +subroutine verify (a) + use iso_c_binding + use mm + type(m) :: a(:,:) + integer :: i, j + + if (rank (a) .ne. 2) stop 100 + if (lbound (a, 1) .ne. 1) stop 101 + if (lbound (a, 2) .ne. 1) stop 102 + if (ubound (a, 1) .ne. imax) stop 103 + if (ubound (a, 2) .ne. jmax) stop 104 + + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 201 + if (a(i,j)%j .ne. j) stop 202 + end do + end do +end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-2-c.c @@ -0,0 +1,52 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (int imax, int jmax, CFI_cdesc_t *a); + +struct m { + int i; + int j; +}; + +void +ctest (int imax, int jmax, CFI_cdesc_t *a) +{ + + int i, j; + CFI_index_t subscripts[2]; + struct m* mp; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != imax) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != jmax) + abort (); + + /* Fill in the contents of a. a is zero-based but we want the ->i and ->j + members of each element to be numbered starting from 1. */ + for (j = 0; j < jmax; j++) + { + subscripts[1] = j; + for (i = 0; i < imax; i++) + { + subscripts[0] = i; + mp = (struct m *) CFI_address (a, subscripts); + mp->i = i + 1; + mp->j = j + 1; + } + } +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-2.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-2-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that passing a fixed-size array as an intent(out) +! assumed-rank argument to a C function called from Fortran works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (ii, jj, a) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + type(m), intent(out) :: a(..) + end subroutine + end interface + + type(m) :: aa(imax,jmax) + integer :: i, j + + ! initialize the array to all zeros; ctest will overwrite it. + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = 0 + aa(i,j)%j = 0 + end do + end do + + call ctest (imax, jmax, aa) + call verify (aa) + +contains +subroutine verify (a) + use iso_c_binding + use mm + type(m) :: a(:,:) + integer :: i, j + + if (rank (a) .ne. 2) stop 100 + if (lbound (a, 1) .ne. 1) stop 101 + if (lbound (a, 2) .ne. 1) stop 102 + if (ubound (a, 1) .ne. imax) stop 103 + if (ubound (a, 2) .ne. jmax) stop 104 + + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 201 + if (a(i,j)%j .ne. j) stop 202 + end do + end do +end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-3-c.c @@ -0,0 +1,71 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest1 (int iinit, int jinit, CFI_cdesc_t *p); +extern void ctest2 (int iinit, int jinit, CFI_cdesc_t *a); + +struct m { + int i; + int j; +}; + +void +ctest1 (int iinit, int jinit, CFI_cdesc_t *p) +{ + struct m *mp; + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (p); + + if (p->rank != 0) + abort (); + if (p->attribute != CFI_attribute_pointer) + abort (); + if (p->type != CFI_type_struct) + abort (); + + check_CFI_status ("CFI_allocate", + CFI_allocate (p, NULL, NULL, sizeof (struct m))); + + if (p->base_addr == NULL) + abort (); + + mp = (struct m *) CFI_address (p, NULL); + mp->i = iinit; + mp->j = jinit; +} + + +void +ctest2 (int iinit, int jinit, CFI_cdesc_t *a) +{ + struct m *mp; + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 0) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->type != CFI_type_struct) + abort (); + + /* The intent(out) allocatable array is supposed to be deallocated + automatically on entry, if it was previously allocated. */ + if (a->base_addr) + abort (); + + check_CFI_status ("CFI_allocate", + CFI_allocate (a, NULL, NULL, sizeof (struct m))); + + if (a->base_addr == NULL) + abort (); + + mp = (struct m *) CFI_address (a, NULL); + mp->i = iinit; + mp->j = jinit; +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-3.f90 @@ -0,0 +1,59 @@ +! PR 101308 +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that passing an allocatable or pointer scalar +! as an intent(out) argument to a C function called from Fortran works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer(C_INT), parameter :: iinit = 42, jinit = 12345 + +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest1 (ii, jj, p) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + type(m), intent(out), pointer :: p + end subroutine + subroutine ctest2 (ii, jj, a) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: ii, jj + type(m), intent(out), allocatable :: a + end subroutine + end interface + + type(m), pointer :: p + type(m), allocatable :: a + + ! The association status of the intent(out) pointer argument is supposed + ! to become undefined on entry to the called procedure. + p => NULL () + call ctest1 (iinit, jinit, p) + if (.not. associated (p)) stop 101 + if (p%i .ne. iinit) stop 102 + if (p%j .ne. jinit) stop 103 + + ! The intent(out) argument is supposed to be deallocated automatically + ! on entry to the called function. + allocate (a) + a%i = 0 + a%j = 0 + call ctest2 (iinit, jinit, a) + if (.not. allocated (a)) stop 201 + if (a%i .ne. iinit) stop 202 + if (a%j .ne. jinit) stop 203 +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-4-c.c @@ -0,0 +1,96 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest1 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *p); +extern void ctest2 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *a); + +struct m { + int i; + int j; +}; + +void +ctest1 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *p) +{ + struct m *mp; + int i, j; + CFI_index_t lb[2], ub[2], s[2]; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (p); + + if (p->rank != 2) + abort (); + if (p->attribute != CFI_attribute_pointer) + abort (); + if (p->type != CFI_type_struct) + abort (); + + lb[0] = imin; + lb[1] = jmin; + ub[0] = imax; + ub[1] = jmax; + check_CFI_status ("CFI_allocate", + CFI_allocate (p, lb, ub, sizeof (struct m))); + + if (p->base_addr == NULL) + abort (); + + for (j = jmin; j <= jmax; j++) + for (i = imin; i <= imax; i++) + { + s[0] = i; + s[1] = j; + mp = (struct m *) CFI_address (p, s); + mp->i = i; + mp->j = j; + } +} + +void +ctest2 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *a) +{ + struct m *mp; + int i, j; + CFI_index_t lb[2], ub[2], s[2]; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_allocatable) + abort (); + if (a->type != CFI_type_struct) + abort (); + + /* Intent(out) argument is supposed to be deallocated automatically + on entry. */ + if (a->base_addr) + abort (); + + lb[0] = imin; + lb[1] = jmin; + ub[0] = imax; + ub[1] = jmax; + check_CFI_status ("CFI_allocate", + CFI_allocate (a, lb, ub, sizeof (struct m))); + + if (a->base_addr == NULL) + abort (); + + for (j = jmin; j <= jmax; j++) + for (i = imin; i <= imax; i++) + { + s[0] = i; + s[1] = j; + mp = (struct m *) CFI_address (a, s); + mp->i = i; + mp->j = j; + } +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-4.f90 @@ -0,0 +1,75 @@ +! PR 92621 (?) +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-4-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that passing an allocatable or pointer array +! as an intent(out) argument to a C function called from Fortran works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer(C_INT), parameter :: imin = 5, imax = 10, jmin = -10, jmax = -1 + +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest1 (i0, ii, j0, jj, p) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: i0, ii, j0, jj + type(m), intent(out), pointer :: p(:,:) + end subroutine + subroutine ctest2 (i0, ii, j0, jj, a) bind (c) + use iso_c_binding + use mm + integer(C_INT), value :: i0, ii, j0, jj + type(m), intent(out), allocatable :: a(:,:) + end subroutine + end interface + + type(m), pointer :: p(:,:) + type(m), allocatable :: a(:,:) + integer :: i, j + + p => NULL () + call ctest1 (imin, imax, jmin, jmax, p) + if (.not. associated (p)) stop 101 + if (rank(p) .ne. 2) stop 102 + if (lbound (p, 1) .ne. imin) stop 103 + if (ubound (p, 1) .ne. imax) stop 104 + if (lbound (p, 2) .ne. jmin) stop 105 + if (ubound (p, 2) .ne. jmax) stop 106 + do j = jmin, jmax + do i = imin, imax + if (p(i,j)%i .ne. i) stop 107 + if (p(i,j)%j .ne. j) stop 108 + end do + end do + + ! The intent(out) argument is supposed to be deallocated automatically + ! on entry to the called function. + allocate (a (jmin:jmax,imin:imax)) + if (.not. allocated (a)) stop 201 + call ctest2 (imin, imax, jmin, jmax, a) + if (.not. allocated (a)) stop 201 + if (rank(a) .ne. 2) stop 202 + if (lbound (a, 1) .ne. imin) stop 203 + if (ubound (a, 1) .ne. imax) stop 204 + if (lbound (a, 2) .ne. jmin) stop 205 + if (ubound (a, 2) .ne. jmax) stop 206 + do j = jmin, jmax + do i = imin, imax + if (a(i,j)%i .ne. i) stop 207 + if (a(i,j)%j .ne. j) stop 208 + end do + end do +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-5-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-5-c.c @@ -0,0 +1,30 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The character object passed as the argument was declared on the + Fortran side as character(len=26) :: aa + Make sure that matches what's in the descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != 26) + abort (); + if (a->rank != 0) + abort (); + if (a->type != CFI_type_char) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + strncpy ((char *)a->base_addr, "0123456789", 10); +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-5.f90 @@ -0,0 +1,35 @@ +! PR92482 +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-5-c.c dump-descriptors.c" } +! +! This program checks that you can call a C function declared with an +! assumed-length character dummy from Fortran. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a) bind (c) + use iso_c_binding + character(len=*,kind=C_CHAR), intent(out) :: a + end subroutine + end interface + + character(len=26,kind=C_CHAR) :: aa + aa = 'abcdefghijklmnopqrstuvwxyz' + + ! Test both passing the fixed-length-string directly to the function + ! with a C interface, and indirectly via a Fortran function with an + ! assumed-length dummy argument. + call ctest (aa) + call ftest (aa) + +contains + subroutine ftest (a) bind (c) + use iso_c_binding + character(len=*,kind=C_CHAR), intent(out) :: a + call ctest (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-6-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-6-c.c @@ -0,0 +1,50 @@ +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a); + +void +ctest (CFI_cdesc_t *a) +{ + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + dump_CFI_cdesc_t (a); + + /* The actual argument on the Fortran side was declared as + integer(C_INT) :: aa(10,5:8) + but was passed via other functions that variously describe it as + having size (10,*), (10,1:*), or (10,5:*) before calling this function + with an assumed-rank array dummy. But, the spec says: + + For a C descriptor of a nonallocatable nonpointer object, the + value of the lower_bound member of each element of the dim member + of the descriptor is zero. + + In a C descriptor of an assumed-size array, the extent member of + the last element of the dim member has the value −1. */ + + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 10) + abort (); + if (a->dim[0].sm != sizeof(int)) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != -1) + abort (); + if (a->dim[1].sm != a->dim[0].extent * sizeof(int)) + abort (); +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-6.f90 @@ -0,0 +1,49 @@ +! Reported as pr94070. +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-6-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks passing an assumed-size array argument via descriptor +! from Fortran to C. + +program testit + use iso_c_binding + implicit none + + ! Assumed-size arrays are not passed by descriptor. What we'll do + ! for this test function is bind an assumed-rank dummy to an + ! assumed-size array. This is supposed to fill in the descriptor + ! with information about the array present at the call site. + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT), intent(out) :: a(..) + end subroutine + end interface + + integer(C_INT), target :: aa(10,5:8) + + ! To get an assumed-size array descriptor, we have to first pass the + ! fixed-size array to a Fortran function with an assumed-size dummy. + call ftest1 (aa) + call ftest2 (aa) + call ftest3 (aa) + +contains + subroutine ftest1 (a) + use iso_c_binding + integer(C_INT) :: a(10,*) + call ctest (a) + end subroutine + subroutine ftest2 (a) + use iso_c_binding + integer(C_INT) :: a(10,5:*) + call ctest (a) + end subroutine + subroutine ftest3 (a) + use iso_c_binding + integer(C_INT) :: a(10,1:*) + call ctest (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-7-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-7-c.c @@ -0,0 +1,136 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +struct m { + int i; + int j; +}; + +extern void ctest (CFI_cdesc_t *a, int lb1, int ub1, int s1, + int lb2, int ub2, int s2, CFI_cdesc_t *b); + +/* Check array b against the section of array a defined by the given + bounds. */ +static void +check_array (CFI_cdesc_t *a, CFI_cdesc_t *b, + int lb1, int ub1, int s1, int lb2, int ub2, int s2) +{ + int bad = 0; + int i, ii, j, jj; + CFI_index_t sub[2]; + struct m *ap, *bp; + + for (j = lb2, jj = b->dim[1].lower_bound; j <= ub2; jj++, j += s2) + for (i = lb1, ii = b->dim[0].lower_bound; i <= ub1; ii++, i += s1) + { + sub[0] = i; + sub[1] = j; + ap = (struct m *) CFI_address (a, sub); + sub[0] = ii; + sub[1] = jj; + bp = (struct m *) CFI_address (b, sub); +#if 0 + fprintf (stderr, "b(%d,%d) = (%d,%d) expecting (%d,%d)\n", + ii, jj, bp->i, bp->j, ap->i, ap->j); +#endif + if (ap->i != bp->i || ap->j != bp->j) + bad = 1; + } + if (bad) + abort (); +} + +void +ctest (CFI_cdesc_t *a, int lb1, int ub1, int s1, + int lb2, int ub2, int s2, CFI_cdesc_t *b) +{ + CFI_index_t lb[2], ub[2], s[2]; + CFI_index_t i, j; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + fprintf (stderr, "input arrays\n"); + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (b); + + /* We expect to get a zero-based input array of shape (10,5). */ + if (a->rank != 2) + abort (); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->type != CFI_type_struct) + abort (); + if (a->dim[0].lower_bound != 0) + abort (); + if (a->dim[0].extent != 10) + abort (); + if (a->dim[1].lower_bound != 0) + abort (); + if (a->dim[1].extent != 5) + abort (); + + /* The output descriptor has to agree with the input descriptor. */ + if (b->rank != 2) + abort (); + if (b->attribute != CFI_attribute_pointer) + abort (); + if (b->type != CFI_type_struct) + abort (); + if (b->elem_len != a->elem_len) + abort (); + + /* Point b at a, keeping the 0-based bounds. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (b, a, NULL)); + fprintf (stderr, "After initializing b\n"); + dump_CFI_cdesc_t (b); + if (b->dim[0].lower_bound != 0) + abort (); + if (b->dim[1].lower_bound != 0) + abort (); + check_array (a, b, + a->dim[0].lower_bound, + a->dim[0].lower_bound + a->dim[0].extent - 1, + 1, + a->dim[1].lower_bound, + a->dim[1].lower_bound + a->dim[1].extent - 1, + 1); + + /* Take a section of the array. The bounds passed in to this function + assume the array is 1-based in both dimensions, so subtract 1. */ + lb[0] = b->dim[0].lower_bound + lb1 - 1; + lb[1] = b->dim[1].lower_bound + lb2 - 1; + ub[0] = b->dim[0].lower_bound + ub1 - 1; + ub[1] = b->dim[1].lower_bound + ub2 - 1; + s[0] = s1; + s[1] = s2; + check_CFI_status ("CFI_section", + CFI_section (b, b, lb, ub, s)); + fprintf (stderr, "After CFI_section\n"); + dump_CFI_cdesc_t (b); + check_array (a, b, + a->dim[0].lower_bound + lb1 - 1, + a->dim[0].lower_bound + ub1 - 1, + s1, + a->dim[1].lower_bound + lb2 - 1, + a->dim[1].lower_bound + ub2 - 1, + s2); + + /* Adjust b to be 1-based. */ + lb[0] = 1; + lb[1] = 1; + fprintf (stderr, "After rebasing b again\n"); + check_CFI_status ("CFI_setpointer", + CFI_setpointer (b, b, lb)); + dump_CFI_cdesc_t (b); + check_array (a, b, + a->dim[0].lower_bound + lb1 - 1, + a->dim[0].lower_bound + ub1 - 1, + s1, + a->dim[1].lower_bound + lb2 - 1, + a->dim[1].lower_bound + ub2 - 1, + s2); +} Index: Fortran/gfortran/regression/c-interop/fc-out-descriptor-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/fc-out-descriptor-7.f90 @@ -0,0 +1,71 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "fc-out-descriptor-7-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program checks that returning a noncontiguous array as an intent(out) +! argument to a C function called from Fortran works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer(C_INT), parameter :: imax = 10, jmax=5 + +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + ! ctest points b at a section of array a defined by the + ! indicated bounds and steps. The returned array is 1-based. + subroutine ctest (a, lb1, ub1, s1, lb2, ub2, s2, b) bind (c) + use iso_c_binding + use mm + type(m), target :: a(:,:) + integer(C_INT), value :: lb1, ub1, s1, lb2, ub2, s2 + type(m), intent(out), pointer :: b(:,:) + end subroutine + end interface + + type(m), target :: a(imax, jmax) + type(m), pointer :: b(:,:) + integer :: i, j, ii, jj + + do j = 1, jmax + do i = 1, imax + a(i,j)%i = i + a(i,j)%j = j + end do + end do + + b => NULL () + ! resulting array is 1-based and has shape (3,3) + call ctest (a, 2, 8, 3, 1, 5, 2, b) + if (.not. associated (b)) stop 101 + if (rank(b) .ne. 2) stop 102 + if (lbound (b, 1) .ne. 1) stop 103 + if (ubound (b, 1) .ne. 3) stop 104 + if (lbound (b, 2) .ne. 1) stop 105 + if (ubound (b, 2) .ne. 3) stop 106 + + ! check that the returned array b contains the expected elements + ! from array a. + jj = lbound (b, 2) + do j = 1, 5, 2 + ii = lbound (b, 1) + do i = 2, 8, 3 + if (b(ii,jj)%i .ne. i) stop 107 + if (b(ii,jj)%j .ne. j) stop 108 + ii = ii + 1 + end do + jj = jj + 1 + end do + +end program + Index: Fortran/gfortran/regression/c-interop/ff-descriptor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-1.f90 @@ -0,0 +1,123 @@ +! { dg-do run } +! +! This program checks that passing arrays as assumed-shape dummies to +! and from Fortran functions with C binding works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +program testit + use iso_c_binding + use mm + implicit none + + type(m) :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + call testc (aa) + call testf (aa) + +contains + + ! C binding version + + subroutine checkc (a, b) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + integer :: i, j + + if (size (a,1) .ne. imax) stop 101 + if (size (a,2) .ne. jmax) stop 102 + if (size (b,1) .ne. jmax) stop 103 + if (size (b,2) .ne. imax) stop 104 + + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 105 + if (a(i,j)%j .ne. j) stop 106 + if (b(j,i)%i .ne. i) stop 107 + if (b(j,i)%j .ne. j) stop 108 + end do + end do + end subroutine + + ! Fortran binding version + subroutine checkf (a, b) + use iso_c_binding + use mm + type(m) :: a(:,:), b(:,:) + integer :: i, j + + if (size (a,1) .ne. imax) stop 201 + if (size (a,2) .ne. jmax) stop 202 + if (size (b,1) .ne. jmax) stop 203 + if (size (b,2) .ne. imax) stop 204 + + do j = 1, jmax + do i = 1, imax + if (a(i,j)%i .ne. i) stop 205 + if (a(i,j)%j .ne. j) stop 206 + if (b(j,i)%i .ne. i) stop 207 + if (b(j,i)%j .ne. j) stop 208 + end do + end do + end subroutine + + ! C binding version + subroutine testc (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m) :: b(jmax, imax) + integer :: i, j + + if (size (a,1) .ne. imax) stop 301 + if (size (a,2) .ne. jmax) stop 302 + do j = 1, jmax + do i = 1, imax + b(j,i)%i = a(i,j)%i + b(j,i)%j = a(i,j)%j + end do + end do + + ! Call both the C and Fortran binding check functions + call checkc (a, b) + call checkf (a, b) + end subroutine + + ! Fortran binding version + subroutine testf (a) + use iso_c_binding + use mm + type(m) :: a(:,:) + type(m) :: b(jmax, imax) + integer :: i, j + + if (size (a,1) .ne. imax) stop 401 + if (size (a,2) .ne. jmax) stop 402 + do j = 1, jmax + do i = 1, imax + b(j,i)%i = a(i,j)%i + b(j,i)%j = a(i,j)%j + end do + end do + + ! Call both the C and Fortran binding check functions + call checkc (a, b) + call checkf (a, b) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-2.f90 @@ -0,0 +1,97 @@ +! { dg-do run } +! +! This program checks that passing arrays as assumed-rank dummies to +! and from Fortran functions with C binding works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imax=10, jmax=5 +end module + +program testit + use iso_c_binding + use mm + implicit none + + type(m) :: aa(imax,jmax) + integer :: i, j + do j = 1, jmax + do i = 1, imax + aa(i,j)%i = i + aa(i,j)%j = j + end do + end do + + call testc (aa) + call testf (aa) + +contains + + ! C binding version + + subroutine checkc (a, b) bind (c) + use iso_c_binding + use mm + type(m) :: a(..), b(..) + + if (rank (a) .ne. 2) stop 101 + if (rank (b) .ne. 2) stop 102 + if (size (a,1) .ne. imax) stop 103 + if (size (a,2) .ne. jmax) stop 104 + if (size (b,1) .ne. jmax) stop 105 + if (size (b,2) .ne. imax) stop 106 + + end subroutine + + ! Fortran binding version + subroutine checkf (a, b) + use iso_c_binding + use mm + type(m) :: a(..), b(..) + + if (rank (a) .ne. 2) stop 201 + if (rank (b) .ne. 2) stop 202 + if (size (a,1) .ne. imax) stop 203 + if (size (a,2) .ne. jmax) stop 204 + if (size (b,1) .ne. jmax) stop 205 + if (size (b,2) .ne. imax) stop 206 + + end subroutine + + ! C binding version + subroutine testc (a) bind (c) + use iso_c_binding + use mm + type(m) :: a(..) + type(m) :: b(jmax, imax) + + if (rank (a) .ne. 2) stop 301 + if (size (a,1) .ne. imax) stop 302 + if (size (a,2) .ne. jmax) stop 303 + + ! Call both the C and Fortran binding check functions + call checkc (a, b) + call checkf (a, b) + end subroutine + + ! Fortran binding version + subroutine testf (a) + use iso_c_binding + use mm + type(m) :: a(..) + type(m) :: b(jmax, imax) + + if (rank (a) .ne. 2) stop 401 + if (size (a,1) .ne. imax) stop 402 + if (size (a,2) .ne. jmax) stop 403 + + ! Call both the C and Fortran binding check functions + call checkc (a, b) + call checkf (a, b) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-3.f90 @@ -0,0 +1,148 @@ +! { dg-do run } +! +! This program checks that passing allocatable and pointer scalars to +! and from Fortran functions with C binding works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type + + integer, parameter :: imagic=-1, jmagic=42 +end module + +program testit + use iso_c_binding + use mm + implicit none + + type(m), allocatable :: a + type(m), target :: t + type(m), pointer :: p + + p => NULL() + + call testc (a, t, p) + call testf (a, t, p) + +contains + + ! C binding version + + subroutine checkc (a, t, p, initp) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a + type(m), target :: t + type(m), pointer :: p + logical, value :: initp + + if (initp) then + if (.not. allocated (a)) stop 101 + if (a%i .ne. imagic) stop 102 + if (a%j .ne. jmagic) stop 103 + if (.not. associated (p)) stop 104 + if (.not. associated (p, t)) stop 105 + if (p%i .ne. imagic) stop 106 + if (p%j .ne. jmagic) stop 107 + else + if (allocated (a)) stop 108 + if (associated (p)) stop 109 + end if + + if (rank (a) .ne. 0) stop 110 + if (rank (t) .ne. 0) stop 111 + if (rank (p) .ne. 0) stop 112 + + end subroutine + + ! Fortran binding version + subroutine checkf (a, t, p, initp) + use iso_c_binding + use mm + type(m), allocatable :: a + type(m), target :: t + type(m), pointer :: p + logical, value :: initp + + if (initp) then + if (.not. allocated (a)) stop 201 + if (a%i .ne. imagic) stop 202 + if (a%j .ne. jmagic) stop 203 + if (.not. associated (p)) stop 204 + if (.not. associated (p, t)) stop 205 + if (p%i .ne. imagic) stop 206 + if (p%j .ne. jmagic) stop 207 + else + if (allocated (a)) stop 208 + if (associated (p)) stop 209 + end if + + if (rank (a) .ne. 0) stop 210 + if (rank (t) .ne. 0) stop 211 + if (rank (p) .ne. 0) stop 212 + + end subroutine + + ! C binding version + subroutine testc (a, t, p) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a + type(m), target :: t + type(m), pointer :: p + + ! Call both the C and Fortran binding check functions + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate and check again. + allocate (a) + a%i = imagic + a%j = jmagic + p => t + t%i = imagic + t%j = jmagic + call checkc (a, t, p, .true.) + call checkf (a, t, p, .true.) + + ! Reset and check a third time. + deallocate (a) + p => NULL () + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + end subroutine + + ! Fortran binding version + subroutine testf (a, t, p) + use iso_c_binding + use mm + type(m), allocatable :: a + type(m), target :: t + type(m), pointer :: p + + ! Call both the C and Fortran binding check functions + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate and check again. + allocate (a) + a%i = imagic + a%j = jmagic + p => t + t%i = imagic + t%j = jmagic + call checkc (a, t, p, .true.) + call checkf (a, t, p, .true.) + + ! Reset and check a third time. + deallocate (a) + p => NULL () + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-4.f90 @@ -0,0 +1,198 @@ +! { dg-do run } +! +! This program checks that passing allocatable and pointer arrays to +! and from Fortran functions with C binding works. + +module mm + use iso_c_binding + type, bind (c) :: m + integer(C_INT) :: i, j + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + + p => NULL() + + call testc (a, t, p) + call testf (a, t, p) + +contains + + ! C binding version + + subroutine checkc (a, t, p, initp) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + logical, value :: initp + integer :: i, j + + if (rank (a) .ne. 1) stop 101 + if (rank (t) .ne. 2) stop 102 + if (rank (p) .ne. 2) stop 103 + + if (initp) then + if (.not. allocated (a)) stop 104 + if (.not. associated (p)) stop 105 + if (.not. associated (p, t)) stop 106 + if (size (a, 1) .ne. 5) stop 107 + if (size (p, 1) .ne. 3) stop 108 + if (size (p, 2) .ne. 10) stop 109 + else + if (allocated (a)) stop 121 + if (associated (p)) stop 122 + end if + + end subroutine + + ! Fortran binding version + subroutine checkf (a, t, p, initp) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + logical, value :: initp + integer :: i, j + + if (rank (a) .ne. 1) stop 201 + if (rank (t) .ne. 2) stop 202 + if (rank (p) .ne. 2) stop 203 + + if (initp) then + if (.not. allocated (a)) stop 204 + if (.not. associated (p)) stop 205 + if (.not. associated (p, t)) stop 206 + if (size (a, 1) .ne. 5) stop 207 + if (size (p, 1) .ne. 3) stop 208 + if (size (p, 2) .ne. 10) stop 209 + else + if (allocated (a)) stop 221 + if (associated (p)) stop 222 + end if + + end subroutine + + ! C binding version + subroutine allocatec (a, t, p) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + + allocate (a(10:20)) + p => t + end subroutine + + ! Fortran binding version + subroutine allocatef (a, t, p) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + + allocate (a(5:15)) + p => t + end subroutine + + ! C binding version + subroutine testc (a, t, p) bind (c) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + + ! Call both the C and Fortran binding check functions + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate and check again. + allocate (a(5)) + p => t + call checkc (a, t, p, .true.) + call checkf (a, t, p, .true.) + + ! Reset and check a third time. + deallocate (a) + p => NULL () + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate inside a function with Fortran binding. + call allocatef (a, t, p) + if (.not. allocated (a)) stop 301 + if (.not. associated (p)) stop 302 + if (lbound (a, 1) .ne. 5) stop 303 + if (ubound (a, 1) .ne. 15) stop 304 + deallocate (a) + p => NULL () + + ! Allocate/associate inside a function with C binding. + call allocatec (a, t, p) + if (.not. allocated (a)) stop 311 + if (.not. associated (p)) stop 312 + if (lbound (a, 1) .ne. 10) stop 313 + if (ubound (a, 1) .ne. 20) stop 314 + deallocate (a) + p => NULL () + + end subroutine + + ! Fortran binding version + subroutine testf (a, t, p) + use iso_c_binding + use mm + type(m), allocatable :: a(:) + type(m), target :: t(3,10) + type(m), pointer :: p(:,:) + + ! Call both the C and Fortran binding check functions + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate and check again. + allocate (a(5)) + p => t + call checkc (a, t, p, .true.) + call checkf (a, t, p, .true.) + + ! Reset and check a third time. + deallocate (a) + p => NULL () + call checkc (a, t, p, .false.) + call checkf (a, t, p, .false.) + + ! Allocate/associate inside a function with Fortran binding. + call allocatef (a, t, p) + if (.not. allocated (a)) stop 401 + if (.not. associated (p)) stop 402 + if (lbound (a, 1) .ne. 5) stop 403 + if (ubound (a, 1) .ne. 15) stop 404 + deallocate (a) + p => NULL () + + ! Allocate/associate inside a function with C binding. + call allocatec (a, t, p) + if (.not. allocated (a)) stop 411 + if (.not. associated (p)) stop 412 + if (lbound (a, 1) .ne. 10) stop 413 + if (ubound (a, 1) .ne. 20) stop 414 + deallocate (a) + p => NULL () + + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-5.f90 @@ -0,0 +1,61 @@ +! PR92482 +! { dg-do run } +! +! This program checks that passing arrays as assumed-length character +! dummies to and from Fortran functions with C binding works. + +program testit + use iso_c_binding + implicit none + + character(len=26,kind=C_CHAR) :: aa + + call testc (aa) + call testf (aa) + +contains + + ! C binding version + + subroutine checkc (a) bind (c) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + + if (rank (a) .ne. 0) stop 101 + if (len (a) .ne. 26) stop 102 + if (a .ne. 'abcdefghijklmnopqrstuvwxyz') stop 103 + end subroutine + + ! Fortran binding version + subroutine checkf (a) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + + if (rank (a) .ne. 0) stop 201 + if (len (a) .ne. 26) stop 202 + if (a .ne. 'abcdefghijklmnopqrstuvwxyz') stop 203 + end subroutine + + ! C binding version + subroutine testc (a) bind (c) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + + ! Call both the C and Fortran binding check functions + a = 'abcdefghijklmnopqrstuvwxyz' + call checkc (a) + call checkf (a) + end subroutine + + ! Fortran binding version + subroutine testf (a) + use iso_c_binding + character(len=*,kind=C_CHAR) :: a + + ! Call both the C and Fortran binding check functions + a = 'abcdefghijklmnopqrstuvwxyz' + call checkc (a) + call checkf (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-6.f90 @@ -0,0 +1,71 @@ +! Reported as pr94070. +! { dg-do run } +! +! This program checks that passing assumed-size arrays to +! and from Fortran functions with C binding works. +! + +program testit + use iso_c_binding + implicit none + + ! Assumed-size arrays are not passed by descriptor. What we'll do + ! for this test function is bind an assumed-rank dummy + ! to the assumed-size array. This is supposed to fill in the descriptor + ! with information about the array present at the call site. + interface + subroutine ctest (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(..) + end subroutine + end interface + + integer(C_INT), target :: aa(10,5:8) + + ! To get an assumed-size array descriptor, we have to first pass the + ! fixed-size array to a Fortran function with an assumed-size dummy, + call ftest1 (aa) + call ftest2 (aa) + call ftest3 (aa) + +contains + subroutine ftest1 (a) + use iso_c_binding + integer(C_INT) :: a(10,*) + call testf (a) + call testc (a) + end subroutine + subroutine ftest2 (a) + use iso_c_binding + integer(C_INT) :: a(10,5:*) + call testf (a) + call testc (a) + end subroutine + subroutine ftest3 (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(10,1:*) + call testf (a) + call testc (a) + end subroutine + + subroutine testf (a) + use iso_c_binding + integer(C_INT) :: a(..) + if (rank (a) .ne. 2) stop 101 + print *, size (a, 1), size (a, 2) + if (size (a, 1) .ne. 10) stop 102 + if (size (a, 2) .ne. -1) stop 103 + if (any (lbound (a) .eq. 0)) stop 104 + end subroutine + + subroutine testc (a) bind (c) + use iso_c_binding + integer(C_INT) :: a(..) + if (rank (a) .ne. 2) stop 201 + print *, size (a, 1), size (a, 2) + if (size (a, 1) .ne. 10) stop 202 + if (size (a, 2) .ne. -1) stop 203 + if (any (lbound (a) .eq. 0)) stop 204 + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ff-descriptor-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ff-descriptor-7.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! Test that arrays that may not be contiguous can be passed both ways +! between Fortran subroutines with C and Fortran binding conventions. + +program testit + use iso_c_binding + implicit none + + integer(C_INT), target :: aa(10,5) + integer(C_INT), target :: bb(10,10) + + integer :: i, j, n + + ! Test both C and Fortran binding. + n = 0 + do j = 1, 10 + do i = 1, 5 + aa(j,i) = n + n = n + 1 + end do + end do + call testc (transpose (aa)) + call testf (transpose (aa)) + + bb = -1 + n = 0 + do j = 1, 10 + do i = 2, 10, 2 + bb(i,j) = n + n = n + 1 + end do + end do + call testc (bb(2:10:2, :)) + call testf (bb(2:10:2, :)) + +contains + + subroutine testc (a) bind (c) + use iso_c_binding + integer(C_INT), intent(in) :: a(:,:) + call checkc (a) + call checkf (a) + end subroutine + + subroutine testf (a) + use iso_c_binding + integer(C_INT), intent(in) :: a(:,:) + call checkc (a) + call checkf (a) + end subroutine + + subroutine checkc (a) bind (c) + use iso_c_binding + integer(C_INT), intent(in) :: a(:,:) + integer :: i, j, n + + if (rank (a) .ne. 2) stop 101 + if (size (a, 1) .ne. 5) stop 102 + if (size (a, 2) .ne. 10) stop 103 + + n = 0 + do j = 1, 10 + do i = 1, 5 + if (a(i,j) .ne. n) stop 104 + n = n + 1 + end do + end do + end subroutine + + subroutine checkf (a) + use iso_c_binding + integer(C_INT), intent(in) :: a(:,:) + integer :: i, j, n + + if (rank (a) .ne. 2) stop 101 + if (size (a, 1) .ne. 5) stop 102 + if (size (a, 2) .ne. 10) stop 103 + + n = 0 + do j = 1, 10 + do i = 1, 5 + if (a(i,j) .ne. n) stop 104 + n = n + 1 + end do + end do + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/note-5-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/note-5-3.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! +! TS 29113 +! NOTE 5.3 +! The intrinsic inquiry function RANK can be used to inquire about the +! rank of a data object. The rank of an assumed-rank object is zero if +! the rank of the corresponding actual argument is zero. + +program test + + integer :: scalar, array_1d(10), array_2d(3, 3) + + call testit (scalar, array_1d, array_2d) + +contains + + function test_rank (a) + integer :: test_rank + integer :: a(..) + + test_rank = rank (a) + end function + + subroutine testit (a0, a1, a2) + integer :: a0(..), a1(..), a2(..) + + integer, target :: b0, b1(10), b2(3, 3) + integer, allocatable :: c0, c1(:), c2(:,:) + integer, pointer :: d0, d1(:), d2(:,:) + + ! array descriptor passed from caller through testit to test_rank + if (test_rank (a0) .ne. 0) stop 100 + if (test_rank (a1) .ne. 1) stop 101 + if (test_rank (a2) .ne. 2) stop 102 + + ! array descriptor created locally here, fixed size + if (test_rank (b0) .ne. 0) stop 200 + if (test_rank (b1) .ne. 1) stop 201 + if (test_rank (b2) .ne. 2) stop 202 + + ! allocatable arrays don't actually have to be allocated. + if (test_rank (c0) .ne. 0) stop 300 + if (test_rank (c1) .ne. 1) stop 301 + if (test_rank (c2) .ne. 2) stop 302 + + ! pointer arrays do need to point at something. + d0 => b0 + d1 => b1 + d2 => b2 + if (test_rank (d0) .ne. 0) stop 400 + if (test_rank (d1) .ne. 1) stop 401 + if (test_rank (d2) .ne. 2) stop 402 + + end subroutine +end program Index: Fortran/gfortran/regression/c-interop/note-5-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/note-5-4-c.c @@ -0,0 +1,10 @@ +#include + +extern int test_rank (CFI_cdesc_t *a); + +int test_rank (CFI_cdesc_t *a) +{ + if (!a) + return -1; /* Should not happen. */ + return a->rank; +} Index: Fortran/gfortran/regression/c-interop/note-5-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/note-5-4.f90 @@ -0,0 +1,63 @@ +! { dg-do run } +! { dg-additional-sources note-5-4-c.c } +! +! TS 29113 +! NOTE 5.4 +! Assumed rank is an attribute of a Fortran dummy argument. When a C +! function is invoked with an actual argument that corresponds to an +! assumed-rank dummy argument in a Fortran interface for that C function, +! the corresponding formal parameter is the address of a descriptor of +! type CFI_cdesc_t (8.7). The rank member of the descriptor provides the +! rank of the actual argument. The C function should therefore be able +! to handle any rank. On each invocation, the rank is available to it. + +program test + + interface + function test_rank (a) bind (c, name="test_rank") + integer :: test_rank + integer :: a(..) + end function + end interface + + integer :: scalar, array_1d(10), array_2d(3, 3) + + call testit (scalar, array_1d, array_2d) + +contains + + subroutine testit (a0, a1, a2) + integer :: a0(..), a1(..), a2(..) + + integer, target :: b0, b1(10), b2(3, 3) + integer, allocatable :: c0, c1(:), c2(:,:) + integer, pointer :: d0, d1(:), d2(:,:) + + ! array descriptor passed from caller through testit to test_rank + if (test_rank (a0) .ne. 0) stop 100 + if (test_rank (a1) .ne. 1) stop 101 + if (test_rank (a2) .ne. 2) stop 102 + + ! array descriptor created locally here, fixed size + if (test_rank (b0) .ne. 0) stop 200 + if (test_rank (b1) .ne. 1) stop 201 + if (test_rank (b2) .ne. 2) stop 202 + + ! allocatables + allocate (c0) + allocate (c1 (10)) + allocate (c2 (3, 3)) + if (test_rank (c0) .ne. 0) stop 300 + if (test_rank (c1) .ne. 1) stop 301 + if (test_rank (c2) .ne. 2) stop 302 + + ! pointers + d0 => b0 + d1 => b1 + d2 => b2 + if (test_rank (d0) .ne. 0) stop 400 + if (test_rank (d1) .ne. 1) stop 401 + if (test_rank (d2) .ne. 2) stop 402 + + end subroutine +end program Index: Fortran/gfortran/regression/c-interop/optional-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/optional-c.c @@ -0,0 +1,82 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ftest (int n, CFI_cdesc_t *a, int *b, char *c, double *d); +extern void ctest1 (CFI_cdesc_t *a, int *b, char *c, double *d); +extern void ctest2 (int n, CFI_cdesc_t *a, int *b, char *c, double *d); + +static void *aa; +static int *bb; +static char *cc; +static double *dd; + +extern void +ctest1 (CFI_cdesc_t *a, int *b, char *c, double *d) +{ + /* Cache all the pointer arguments for later use by ctest2. */ + aa = a->base_addr; + bb = b; + cc = c; + dd = d; + + /* Test calling back into Fortran. */ + ftest (0, NULL, NULL, NULL, NULL); + ftest (1, a, NULL, NULL, NULL); + ftest (2, a, b, NULL, NULL); + ftest (3, a, b, c, NULL); + ftest (4, a, b, c, d); +} + +extern void +ctest2 (int n, CFI_cdesc_t *a, int *b, char *c, double *d) +{ + if (n >= 1) + { + if (!a) + abort (); + if (a->base_addr != aa) + abort (); + } + else + if (a) + abort (); + + if (n >= 2) + { + if (!b) + abort (); + if (*b != *bb) + abort (); + } + else + if (b) + abort (); + + if (n >= 3) + { + if (!c) + abort (); + if (*c != *cc) + abort (); + } + else + if (c) + abort (); + + if (n >= 4) + { + if (!d) + abort (); + if (*d != *dd) + abort (); + } + else + if (d) + abort (); + +} + + Index: Fortran/gfortran/regression/c-interop/optional.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/optional.f90 @@ -0,0 +1,114 @@ +! { dg-do run } +! { dg-additional-sources "optional-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! TS 29113 +! 8.7 An absent actual argument in a reference to an interoperable +! procedure is indicated by a corresponding formal parameter with the +! value of a null pointer. An absent optional dummy argument in a +! reference to an interoperable procedure from a C function is indicated +! by a corresponding argument with the value of a null pointer. + +module m + use iso_c_binding + integer(C_INT) :: aa(32) + integer(C_INT) :: bb + character(C_CHAR) :: cc + real(C_DOUBLE) :: dd +end module + +subroutine ftest (n, a, b, c, d) bind (c) + use iso_c_binding + use m + implicit none + integer(C_INT), value :: n + integer(C_INT), optional :: a(:) + integer(C_INT), optional :: b + character(C_CHAR), optional :: c + real(C_DOUBLE), optional :: d + + if (n .ge. 1) then + if (.not. present (a)) stop 101 + if (any (a .ne. aa)) stop 201 + else + if (present (a)) stop 301 + end if + + if (n .ge. 2) then + if (.not. present (b)) stop 102 + if (b .ne. bb) stop 201 + else + if (present (b)) stop 302 + end if + + if (n .ge. 3) then + if (.not. present (c)) stop 103 + if (c .ne. cc) stop 201 + else + if (present (c)) stop 303 + end if + + if (n .ge. 4) then + if (.not. present (d)) stop 104 + if (d .ne. dd) stop 201 + else + if (present (d)) stop 304 + end if +end subroutine + +program testit + use iso_c_binding + use m + implicit none + + interface + subroutine ctest1 (a, b, c, d) bind (c) + use iso_c_binding + integer(C_INT) :: a(:) + integer(C_INT) :: b + character(C_CHAR) :: c + real(C_DOUBLE) :: d + end subroutine + subroutine ctest2 (n, a, b, c, d) bind (c) + use iso_c_binding + integer(C_INT), value :: n + integer(C_INT), optional :: a(:) + integer(C_INT), optional :: b + character(C_CHAR), optional :: c + real(C_DOUBLE), optional :: d + end subroutine + subroutine ftest (n, a, b, c, d) bind (c) + use iso_c_binding + integer(C_INT), value :: n + integer(C_INT), optional :: a(:) + integer(C_INT), optional :: b + character(C_CHAR), optional :: c + real(C_DOUBLE), optional :: d + end subroutine + end interface + + + ! Initialize the variables above. + integer :: i + do i = 1, 32 + aa(i) = i + end do + bb = 42 + cc = '$' + dd = acos(-1.D0) + + call ftest (0) + call ftest (1, aa) + call ftest (2, aa, bb) + call ftest (3, aa, bb, cc) + call ftest (4, aa, bb, cc, dd) + + call ctest1 (aa, bb, cc, dd) + call ctest2 (0) + call ctest2 (1, aa) + call ctest2 (2, aa, bb) + call ctest2 (3, aa, bb, cc) + call ctest2 (4, aa, bb, cc, dd) + +end program + Index: Fortran/gfortran/regression/c-interop/pr103287-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103287-1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine g + call s([1]) +end +subroutine h(x) + integer, pointer :: x(..) + call s(x) ! { dg-error "Assumed-rank argument requires an explicit interface" } +end Index: Fortran/gfortran/regression/c-interop/pr103287-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103287-2.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine g + call s(1) +end +subroutine h(x) + integer, pointer :: x(..) + call s(x) ! { dg-error "Assumed-rank argument requires an explicit interface" } +end Index: Fortran/gfortran/regression/c-interop/pr103390-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-1.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! This program used to ICE in gimplification on the call to S, because it +! was trying to copy out the array after the call to something that wasn't +! an lvalue. + +program p + integer, pointer :: z(:) + integer, target :: x(3) = [1, 2, 3] + z => x + call s(shape(z)) +contains + subroutine s(x) bind(c) + integer, contiguous :: x(:) + end +end + +! It should not emit any copy loops, just the loop for inlining SHAPE. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } } + +! It should not emit code to check the contiguous property. +! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } } Index: Fortran/gfortran/regression/c-interop/pr103390-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of transpose result are +! still generated after fixing pr103390, and that it does not ICE. + +program p + integer, pointer :: z(:,:) + integer, target :: x(3,3) = reshape ([1, 2, 3, 4, 5, 6, 7, 8, 9], shape(x)) + z => x + call s(transpose(z)) +contains + subroutine s(x) bind(c) + integer, contiguous :: x(:,:) + end +end + +! Expect 2 nested copy loops both before and after the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } } + Index: Fortran/gfortran/regression/c-interop/pr103390-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-3.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of a function +! that returns a non-pointer array are generated properly after fixing +! pr103390, and that it does not ICE. In this case no copying is required. + +program p + integer, pointer :: z(:) + integer, target :: x(3) = [1, 2, 3] + z => x + call s(i(z)) +contains + function i(x) + integer :: i(3) + integer, pointer :: x(:) + i = x + end + subroutine s(x) bind(c) + integer, contiguous :: x(:) + end +end + +! Expect one loop to copy the array contents to a temporary in function i. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } } + +! It should not emit code to check the contiguous property. +! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } } + Index: Fortran/gfortran/regression/c-interop/pr103390-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-4.f90 @@ -0,0 +1,25 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of a function +! that returns a pointer to an array are generated properly after fixing +! pr103390, and that it does not ICE. + +program p + integer, pointer :: z(:) + integer, target :: x(3) = [1, 2, 3] + z => x + call s(i(z)) +contains + function i(x) + integer, pointer :: i(:) + integer, pointer :: x(:) + i => x + end + subroutine s(x) bind(c) + integer, contiguous :: x(:) + end +end + +! Expect a copy loop both before and after the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } } Index: Fortran/gfortran/regression/c-interop/pr103390-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-5.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of a function +! that returns a pointer to an array are generated properly after fixing +! pr103390, and that it does not ICE. This variant is for an intent(in) +! dummy argument so no copy-out is needed, only copy-in. + +program p + integer, pointer :: z(:) + integer, target :: x(3) = [1, 2, 3] + z => x + call s(i(z)) +contains + function i(x) + integer, pointer :: i(:) + integer, pointer :: x(:) + i => x + end + subroutine s(x) bind(c) + integer, contiguous, intent(in) :: x(:) + end +end + +! Expect a copy loop before the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } } Index: Fortran/gfortran/regression/c-interop/pr103390-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-6.f90 @@ -0,0 +1,22 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of transpose result are +! generated properly after fixing pr103390, and that it does not ICE. +! This variant is for an intent(in) dummy argument so no copy-out +! is needed, only copy-in. + +program p + integer, pointer :: z(:,:) + integer, target :: x(3,3) = reshape ([1, 2, 3, 4, 5, 6, 7, 8, 9], shape(x)) + z => x + call s(transpose(z)) +contains + subroutine s(x) bind(c) + integer, contiguous, intent(in) :: x(:,:) + end +end + +! Expect 2 nested copy loops before the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } } + Index: Fortran/gfortran/regression/c-interop/pr103390-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-7.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of an array +! section expression are generated properly after fixing pr103390, and +! that it does not ICE. + +program p + integer, pointer :: z(:) + integer :: A(5) = [1, 2, 3, 4, 5] + call s(A(::2)) +contains + subroutine s(x) bind(c) + integer, contiguous :: x(:) + end +end + +! Expect copy loops before and after the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } } Index: Fortran/gfortran/regression/c-interop/pr103390-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-8.f90 @@ -0,0 +1,20 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of an array +! section expression are generated properly after fixing pr103390, +! and that it does not ICE. This case is for an intent(in) +! dummy so no copy-out should occur, only copy-in. + +program p + integer, pointer :: z(:) + integer, parameter :: A(5) = [1, 2, 3, 4, 5] + call s(A(::2)) +contains + subroutine s(x) bind(c) + integer, contiguous, intent(in) :: x(:) + end +end + +! Expect a copy loop before the call to S. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } } Index: Fortran/gfortran/regression/c-interop/pr103390-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/pr103390-9.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-options "-fdump-tree-original" } +! +! Check that copy loops to ensure contiguity of the result of an elemental +! array-valued expression are generated properly after fixing pr103390, +! and that it does not ICE. + +program p + integer, pointer :: z(:) + integer :: a(3) = [1, 2, 3]; + integer :: b(3) = [4, 5, 6]; + call s(a + b); +contains + subroutine s(x) bind(c) + integer, contiguous :: x(:) + end +end + +! We only expect one loop before the call, to fill in the contiguous +! temporary. No copy-out is needed since the temporary is effectively +! an rvalue. +! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } } + +! It should not emit code to check the contiguous property. +! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } } + Index: Fortran/gfortran/regression/c-interop/rank-class.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/rank-class.f90 @@ -0,0 +1,88 @@ +! { dg-do run } +! +! TS 29113 +! 7.2 RANK (A) +! Description. Rank of a data object. +! Class. Inquiry function. +! Argument. +! A shall be a scalar or array of any type. +! Result Characteristics. Default integer scalar. +! Result Value. The result is the rank of A. + +module m + + type :: base + integer :: a, b + end type + + type, extends (base) :: derived + integer :: c + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(derived), target :: x1(5) + type(derived) :: y1(0:9) + type(derived), pointer :: p1(:) + type(derived), allocatable :: a1(:) + type(derived), target :: x3(2,3,4) + type(derived) :: y3(0:1,-3:-1,4) + type(derived), pointer :: p3(:,:,:) + type(derived), allocatable :: a3(:,:,:) + type(derived) :: x + + ! Test the 1-dimensional arrays. + if (rank (x1) .ne. 1) stop 201 + call testit (x1, 1) + if (rank (y1) .ne. 1) stop 202 + call testit (y1, 1) + if (rank (p1) .ne. 1) stop 203 + p1 => x1 + call testit (p1, 1) + if (rank (p1) .ne. 1) stop 204 + if (rank (a1) .ne. 1) stop 205 + allocate (a1(5)) + if (rank (a1) .ne. 1) stop 206 + call testit (a1, 1) + + ! Test the multi-dimensional arrays. + if (rank (x3) .ne. 3) stop 207 + call testit (x3, 3) + if (rank (y3) .ne. 3) stop 208 + if (rank (p3) .ne. 3) stop 209 + p3 => x3 + call testit (p3, 3) + if (rank (p3) .ne. 3) stop 210 + if (rank (a3) .ne. 3) stop 211 + allocate (a3(2,3,4)) + call testit (a3, 3) + if (rank (a3) .ne. 3) stop 212 + + ! Test scalars. + if (rank (x) .ne. 0) stop 213 + call testit (x, 0) + call test0 (x) + if (rank (x1(1)) .ne. 0) stop 215 + call test0 (x1(1)) + +contains + + subroutine testit (a, r) + use m + class(base) :: a(..) + integer :: r + + if (r .ne. rank(a)) stop 101 + end subroutine + + subroutine test0 (a) + use m + class(base) :: a(..) + if (rank (a) .ne. 0) stop 103 + call testit (a, 0) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/rank.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/rank.f90 @@ -0,0 +1,99 @@ +! { dg-do run } +! +! TS 29113 +! 7.2 RANK (A) +! Description. Rank of a data object. +! Class. Inquiry function. +! Argument. +! A shall be a scalar or array of any type. +! Result Characteristics. Default integer scalar. +! Result Value. The result is the rank of A. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + if (rank (x1) .ne. 1) stop 201 + call testit (x1, 1) + call test1 (x1) + if (rank (y1) .ne. 1) stop 202 + call testit (y1, 1) + call test1 (y1) + if (rank (p1) .ne. 1) stop 203 + p1 => x1 + call testit (p1, 1) + if (rank (p1) .ne. 1) stop 204 + call test1 (p1) + if (rank (a1) .ne. 1) stop 205 + allocate (a1(5)) + if (rank (a1) .ne. 1) stop 206 + call testit (a1, 1) + call test1 (a1) + + ! Test the multi-dimensional arrays. + if (rank (x3) .ne. 3) stop 207 + call testit (x3, 3) + call test1 (x3) + call test3 (x3, 1, 2, 1, 3) + if (rank (y3) .ne. 3) stop 208 + call test3 (y3, 0, 1, -3, -1) + if (rank (p3) .ne. 3) stop 209 + p3 => x3 + call testit (p3, 3) + call test1 (p3) + if (rank (p3) .ne. 3) stop 210 + call test3 (p3, 1, 2, 1, 3) + if (rank (a3) .ne. 3) stop 211 + allocate (a3(2,3,4)) + call testit (a3, 3) + call test1 (a3) + if (rank (a3) .ne. 3) stop 212 + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + if (rank (x) .ne. 0) stop 213 + call testit (x, 0) + call test0 (x) + if (rank (-1) .ne. 0) stop 214 + call test0 (-1) + if (rank (x1(1)) .ne. 0) stop 215 + call test0 (x1(1)) + +contains + + subroutine testit (a, r) + integer :: a(..) + integer :: r + + if (r .ne. rank(a)) stop 101 + end subroutine + + subroutine test0 (a) + integer :: a(..) + if (rank (a) .ne. 0) stop 103 + call testit (a, 0) + end subroutine + + subroutine test1 (a) + integer :: a(*) + call testit (a, 1) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + call testit (a, 3) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/removed-restrictions-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/removed-restrictions-1.f90 @@ -0,0 +1,41 @@ +! { dg-do compile} +! +! TS 29113 +! 8.1 Removed restrictions on ISO_C_BINDING module procedures +! +! The subroutine C_F_POINTER from the intrinsic module ISO_C_BINDING has +! the restriction in ISO/IEC 1539- 1:2010 that if FPTR is an array, it +! shall be of interoperable type. +! +! [...] +! +! These restrictions are removed. + +module m + use ISO_C_BINDING + implicit none + + ! An obvious example of a type that isn't interoperable is a + ! derived type without a bind(c) clause. + + integer :: buflen + parameter (buflen=256) + + type :: packet + integer :: size + integer(1) :: buf(buflen) + end type + +contains + + subroutine test (ptr, n, packets) + type(C_PTR), intent(in) :: ptr + integer, intent(in) :: n + type(packet), pointer, intent(out) :: packets(:) + + integer :: s(1) + s(1) = n + + call c_f_pointer (ptr, packets, s) + end subroutine +end module Index: Fortran/gfortran/regression/c-interop/removed-restrictions-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/removed-restrictions-2.f90 @@ -0,0 +1,35 @@ +! { dg-do compile} +! +! TS 29113 +! 8.1 Removed restrictions on ISO_C_BINDING module procedures +! +! The function C_F_PROCPOINTER from the intrinsic module ISO_C_BINDING +! has the restriction in ISO/IEC 1539-1:2010 that CPTR and FPTR shall +! not be the C address and interface of a noninteroperable Fortran +! procedure. +! +! [...] +! +! These restrictions are removed. + +module m + use ISO_C_BINDING + implicit none + + ! Declare a non-interoperable Fortran procedure interface. + abstract interface + function foo (x, y) + integer :: foo + integer, intent (in) :: x, y + end function + end interface + +contains + + subroutine test (cptr, fptr) + type(C_FUNPTR), intent(in) :: cptr + procedure (foo), pointer, intent(out) :: fptr + + call c_f_procpointer (cptr, fptr) + end subroutine +end module Index: Fortran/gfortran/regression/c-interop/removed-restrictions-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/removed-restrictions-3.f90 @@ -0,0 +1,37 @@ +! { dg-do compile} +! +! TS 29113 +! 8.1 Removed restrictions on ISO_C_BINDING module procedures +! +! The function C_LOC from the intrinsic module ISO_C_BINDING has the +! restriction in ISO/IEC 1539-1:2010 that if X is an array, it shall +! be of interoperable type. +! +! [...] +! +! These restrictions are removed. + +module m + use ISO_C_BINDING + implicit none + + ! An obvious example of a type that isn't interoperable is a + ! derived type without a bind(c) clause. + + integer :: buflen + parameter (buflen=256) + + type :: packet + integer :: size + integer(1) :: buf(buflen) + end type + +contains + + subroutine test (packets, ptr) + type(packet), pointer, intent(in) :: packets(:) + type(C_PTR), intent(out) :: ptr + + ptr = c_loc (packets) + end subroutine +end module Index: Fortran/gfortran/regression/c-interop/removed-restrictions-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/removed-restrictions-4.f90 @@ -0,0 +1,34 @@ +! { dg-do compile} +! +! TS 29113 +! 8.1 Removed restrictions on ISO_C_BINDING module procedures +! +! [...] +! +! The function C_FUNLOC from the intrinsic module ISO_C_BINDING has +! the restriction in ISO/IEC 1539-1:2010 that its argument shall be +! interoperable. +! +! These restrictions are removed. + +module m + use ISO_C_BINDING + implicit none + + ! Declare a non-interoperable Fortran procedure interface. + abstract interface + function foo (x, y) + integer :: foo + integer, intent (in) :: x, y + end function + end interface + +contains + + subroutine test (fptr, cptr) + procedure (foo), pointer, intent(in) :: fptr + type(C_FUNPTR), intent(out) :: cptr + + cptr = c_funloc (fptr) + end subroutine +end module Index: Fortran/gfortran/regression/c-interop/section-1-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-1-c.c @@ -0,0 +1,135 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *a, int lb, int ub, int s, CFI_cdesc_t *r); + +/* Take a section of array A. OFF is the start index of A on the Fortran + side and the bounds LB and UB for the section to take are relative to + that base index. Store the result in R, which is supposed to be a pointer + array with lower bound 1. */ + +void +ctest (CFI_cdesc_t *a, int lb, int ub, int s, CFI_cdesc_t *r) +{ + CFI_index_t lb_array[1], ub_array[1], s_array[1]; + CFI_index_t i, o; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + fprintf (stderr, "\n%s: lb=%d ub=%d s=%d\n", + (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer", + lb, ub, s); + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (r); + + /* Make sure we got a valid input descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(int)) + abort (); + if (a->rank != 1) + abort (); + if (a->type != CFI_type_int) + abort (); + if (a->attribute == CFI_attribute_other) + { + if (a->dim[0].lower_bound != 0) + abort (); + /* Adjust the 1-based bounds. */ + lb = lb - 1; + ub = ub - 1; + } + /* For pointer arrays, the bounds use the same indexing as the lower + bound in the array descriptor. */ + + /* Make sure we got a valid output descriptor. */ + if (r->base_addr) + abort (); + if (r->elem_len != sizeof(int)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_int) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Create an array section. */ + lb_array[0] = lb; + ub_array[0] = ub; + s_array[0] = s; + + check_CFI_status ("CFI_section", + CFI_section (r, a, lb_array, ub_array, s_array)); + + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(int)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_int) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Check the contents of the output array. */ +#if 0 + for (o = r->dim[0].lower_bound, i = lb; + (s > 0 ? i <= ub : i >= ub); + o++, i += s) + { + int *input = (int *) CFI_address (a, &i); + int *output = (int *) CFI_address (r, &o); + fprintf (stderr, "a(%d) = %d, r(%d) = %d\n", + (int)i, *input, (int)o, *output); + } +#endif + for (o = r->dim[0].lower_bound, i = lb; + (s > 0 ? i <= ub : i >= ub); + o++, i += s) + { + int *input = (int *) CFI_address (a, &i); + int *output = (int *) CFI_address (r, &o); + if (*input != *output) + abort (); + } + + /* Force the output array to be 1-based. */ + lb_array[0] = 1; + check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array)); + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(int)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_int) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + if (r->dim[0].lower_bound != 1) + abort (); + + /* Check the contents of the output array again. */ + for (o = r->dim[0].lower_bound, i = lb; + (s > 0 ? i <= ub : i >= ub); + o++, i += s) + { + int *input = (int *) CFI_address (a, &i); + int *output = (int *) CFI_address (r, &o); + if (*input != *output) + abort (); + } + +} + + + Index: Fortran/gfortran/regression/c-interop/section-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-1.f90 @@ -0,0 +1,71 @@ +! { dg-do run } +! { dg-additional-sources "section-1-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function on +! a 1-dimensional non-pointer/non-allocatable array, passed as an +! assumed-shape dummy. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (a, lb, ub, s, r) bind (c) + use iso_c_binding + integer(C_INT), target :: a(:) + integer(C_INT), value :: lb, ub, s + integer(C_INT), pointer, intent(out) :: r(:) + end subroutine + + end interface + + integer(C_INT), target :: aa(32) + integer :: i + + ! Initialize the test array by numbering its elements. + do i = 1, 32 + aa(i) = i + end do + + ! Try some cases with non-pointer input arrays. + call test (aa, 1, 32, 5, 13, 2) ! basic test + call test (aa, 4, 35, 5, 13, 2) ! non-default lower bound + call test (aa, 1, 32, 32, 16, -2) ! negative step + +contains + + ! Test function for non-pointer array AA. + ! LO and HI are the bounds for the entire array. + ! LB, UB, and S describe the section to take, and use the + ! same indexing as LO and HI. + subroutine test (aa, lo, hi, lb, ub, s) + integer :: aa(lo:hi) + integer :: lo, hi, lb, ub, s + + integer(C_INT), pointer :: rr(:) + integer :: i, o + + ! Call the C function to put a section in rr. + ! The C function expects the section bounds to be 1-based. + nullify (rr) + call ctest (aa, lb - lo + 1, ub - lo + 1, s, rr) + + ! Make sure the original array has not been modified. + do i = lo, hi + if (aa(i) .ne. i - lo + 1) stop 103 + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 111 + if (lbound (rr, 1) .ne. 1) stop 112 + if (ubound (rr, 1) .ne. (ub - lb)/s + 1) stop 113 + o = 1 + do i = lb, ub, s + if (rr(o) .ne. i - lo + 1) stop 114 + o = o + 1 + end do + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-1p.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-1p.f90 @@ -0,0 +1,75 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-1-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function on +! a 1-dimensional pointer array. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest (p, lb, ub, s, r) bind (c) + use iso_c_binding + integer(C_INT), pointer :: p(:) + integer(C_INT), value :: lb, ub, s + integer(C_INT), pointer, intent(out) :: r(:) + end subroutine + + end interface + + integer(C_INT), target :: aa(32) + integer :: i + + ! Initialize the test array by numbering its elements. + do i = 1, 32 + aa(i) = i + end do + + call test_p (aa, 0, 31, 15, 24, 3) ! zero lower bound + call test_p (aa, 1, 32, 16, 25, 3) ! non-zero lower bound + call test_p (aa, 4, 35, 16, 25, 3) ! some other lower bound + call test_p (aa, 1, 32, 32, 16, -2) ! negative step + stop + +contains + + ! Test function for non-pointer array AA. + ! LO and HI are the bounds for the entire array. + ! LB, UB, and S describe the section to take, and use the + ! same indexing as LO and HI. + subroutine test_p (aa, lo, hi, lb, ub, s) + integer, target :: aa(1:hi-lo+1) + integer :: lo, hi, lb, ub, s + + integer(C_INT), pointer :: pp(:), rr(:) + integer :: i, o + + pp(lo:hi) => aa + if (lbound (pp, 1) .ne. lo) stop 121 + if (ubound (pp, 1) .ne. hi) stop 122 + nullify (rr) + call ctest (pp, lb, ub, s, rr) + + ! Make sure the input pointer array has not been modified. + if (lbound (pp, 1) .ne. lo) stop 144 + if (ubound (pp, 1) .ne. hi) stop 145 + do i = lo, hi + if (pp(i) .ne. i - lo + 1) stop 146 + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 151 + if (lbound (rr, 1) .ne. 1) stop 152 + if (ubound (rr, 1) .ne. (ub - lb)/s + 1) stop 153 + o = 1 + do i = lb, ub, s + if (rr(o) .ne. i - lo + 1) stop 154 + o = o + 1 + end do + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-2-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-2-c.c @@ -0,0 +1,175 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +struct m { + int x, y; +}; + +extern void ctest (CFI_cdesc_t *a, int lb0, int lb1, + int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r); + +/* Take a section of array A. OFF is the start index of A on the Fortran + side and the bounds LB and UB for the section to take are relative to + that base index. Store the result in R, which is supposed to be a pointer + array with lower bound 1. */ + +void +ctest (CFI_cdesc_t *a, int lb0, int lb1, + int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r) +{ + CFI_index_t lb_array[2], ub_array[2], s_array[2]; + int i0, i1, o0, o1; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + fprintf (stderr, "\n%s: lb0=%d lb1=%d ub0=%d ub1=%d s0=%d s1=%d\n", + (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer", + lb0, lb1, ub0, ub1, s0, s1); + if (lb0 == ub0 || lb1 == ub1) + abort (); + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (r); + + /* Make sure we got a valid input descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(struct m)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_struct) + abort (); + if (a->attribute == CFI_attribute_other) + { + if (a->dim[0].lower_bound != 0) + abort (); + /* Adjust the 1-based bounds. */ + lb0 = lb0 - 1; + lb1 = lb1 - 1; + ub0 = ub0 - 1; + ub1 = ub1 - 1; + } + /* For pointer arrays, the bounds use the same indexing as the lower + bound in the array descriptor. */ + + /* Make sure we got a valid output descriptor. */ + if (r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 2) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Create an array section. */ + lb_array[0] = lb0; + lb_array[1] = lb1; + ub_array[0] = ub0; + ub_array[1] = ub1; + s_array[0] = s0; + s_array[1] = s1; + + check_CFI_status ("CFI_section", + CFI_section (r, a, lb_array, ub_array, s_array)); + + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 2) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Check the contents of the output array. */ +#if 0 + for (o1 = r->dim[1].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + index[1] = o1; + output = (struct m *) CFI_address (r, index); + fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d,%d) = (%d,%d)\n", + i0, i1, input->x, input->y, o0, o1, output->x, output->y); + } +#endif + for (o1 = r->dim[1].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + index[1] = o1; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } + + /* Force the output array to be 1-based. */ + lb_array[0] = 1; + lb_array[1] = 1; + check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array)); + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 2) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + if (r->dim[0].lower_bound != 1) + abort (); + + /* Check the contents of the output array again. */ + for (o1 = r->dim[1].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + index[1] = o1; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } +} + + + Index: Fortran/gfortran/regression/c-interop/section-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-2.f90 @@ -0,0 +1,102 @@ +! { dg-do run } +! { dg-additional-sources "section-2-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function on +! a 2-dimensional non-pointer array. + +module mm + use ISO_C_BINDING + type, bind (c) :: m + integer(C_INT) :: x, y + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a, lb0, lb1, ub0, ub1, s0, s1, r) bind (c) + use iso_c_binding + use mm + type(m), target :: a(:,:) + integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1 + type(m), pointer, intent(out) :: r(:,:) + end subroutine + + end interface + + type(m), target :: aa(10, 20) + integer :: i0, i1 + + ! Initialize the test array by numbering its elements. + do i1 = 1, 20 + do i0 = 1, 10 + aa(i0, i1)%x = i0 + aa(i0, i1)%y = i1 + end do + end do + + call test (aa, 4, 3, 10, 15, 2, 3) ! basic test + call test (aa, 10, 15, 4, 3, -2, -3) ! negative step + stop + +contains + + ! Test function for non-pointer array AA. + ! LB, UB, and S describe the section to take. + subroutine test (aa, lb0, lb1, ub0, ub1, s0, s1) + use mm + type(m) :: aa(10,20) + integer :: lb0, lb1, ub0, ub1, s0, s1 + + type(m), pointer :: rr(:,:) + integer :: i0, i1, o0, o1 + integer, parameter :: hi0 = 10 + integer, parameter :: hi1 = 20 + + ! Make sure the original array is OK. + do i1 = 1, hi1 + do i0 = 1, hi0 + if (aa(i0,i1)%x .ne. i0) stop 101 + if (aa(i0,i1)%y .ne. i1) stop 101 + end do + end do + + ! Call the C function to put a section in rr. + ! The C function expects the section bounds to be 1-based. + nullify (rr) + call ctest (aa, lb0, lb1, ub0, ub1, s0, s1, rr) + + ! Make sure the original array has not been modified. + do i1 = 1, hi1 + do i0 = 1, hi0 + if (aa(i0,i1)%x .ne. i0) stop 103 + if (aa(i0,i1)%y .ne. i1) stop 103 + end do + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 111 + if (lbound (rr, 1) .ne. 1) stop 112 + if (lbound (rr, 2) .ne. 1) stop 112 + if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113 + if (ubound (rr, 2) .ne. (ub1 - lb1)/s1 + 1) stop 113 + o1 = 1 + do i1 = lb1, ub1, s1 + o0 = 1 + do i0 = lb0, ub0, s0 + ! print 999, o0, o1, rr(o0,o1)%x, rr(o0,01)%y + ! 999 format ('rr(', i3, ',', i3, ') = (', i3, ',', i3, ')') + if (rr(o0,o1)%x .ne. i0) stop 114 + if (rr(o0,o1)%y .ne. i1) stop 114 + o0 = o0 + 1 + end do + o1 = o1 + 1 + end do + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-2p.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-2p.f90 @@ -0,0 +1,104 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-2-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function on +! a 2-dimensional pointer array. + +module mm + use ISO_C_BINDING + type, bind (c) :: m + integer(C_INT) :: x, y + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (p, lb0, lb1, ub0, ub1, s0, s1, r) bind (c) + use iso_c_binding + use mm + type(m), pointer :: p(:,:) + integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1 + type(m), pointer, intent(out) :: r(:,:) + end subroutine + + end interface + + type(m), target :: aa(10, 20) + integer :: i0, i1 + + ! Initialize the test array by numbering its elements. + do i1 = 1, 20 + do i0 = 1, 10 + aa(i0, i1)%x = i0 + aa(i0, i1)%y = i1 + end do + end do + + call test (aa, 0, 0, 3, 2, 9, 14, 2, 3) ! zero lower bound + call test (aa, 1, 1, 4, 3, 10, 15, 2, 3) ! lower bound 1 + call test (aa, 6, 11, 9, 13, 15, 25, 2, 3) ! other lower bound + call test (aa, 1, 1, 10, 15, 4, 3, -2, -3) ! negative step + stop + +contains + + ! Test function for pointer array AA. + ! The bounds of the array are adjusted so it is based at (LO0,LO1). + ! LB, UB, and S describe the section of the adjusted array to take. + subroutine test (aa, lo0, lo1, lb0, lb1, ub0, ub1, s0, s1) + use mm + type(m), target :: aa(1:10, 1:20) + integer :: lo0, lo1, lb0, lb1, ub0, ub1, s0, s1 + + type(m), pointer :: pp(:,:), rr(:,:) + integer :: i0, i1, o0, o1 + integer :: hi0, hi1 + hi0 = lo0 + 10 - 1 + hi1 = lo1 + 20 - 1 + + pp(lo0:,lo1:) => aa + if (lbound (pp, 1) .ne. lo0) stop 121 + if (lbound (pp, 2) .ne. lo1) stop 121 + if (ubound (pp, 1) .ne. hi0) stop 122 + if (ubound (pp, 2) .ne. hi1) stop 122 + nullify (rr) + call ctest (pp, lb0, lb1, ub0, ub1, s0, s1, rr) + + ! Make sure the input pointer array has not been modified. + if (lbound (pp, 1) .ne. lo0) stop 131 + if (ubound (pp, 1) .ne. hi0) stop 132 + if (lbound (pp, 2) .ne. lo1) stop 133 + if (ubound (pp, 2) .ne. hi1) stop 134 + do i1 = lo1, hi1 + do i0 = lo0, hi0 + if (pp(i0,i1)%x .ne. i0 - lo0 + 1) stop 135 + if (pp(i0,i1)%y .ne. i1 - lo1 + 1) stop 136 + end do + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 141 + if (lbound (rr, 1) .ne. 1) stop 142 + if (lbound (rr, 2) .ne. 1) stop 142 + if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 143 + if (ubound (rr, 2) .ne. (ub1 - lb1)/s1 + 1) stop 143 + o1 = 1 + do i1 = lb1, ub1, s1 + o0 = 1 + do i0 = lb0, ub0, s0 + if (rr(o0,o1)%x .ne. i0 - lo0 + 1) stop 144 + if (rr(o0,o1)%y .ne. i1 - lo1 + 1) stop 144 + o0 = o0 + 1 + end do + o1 = o1 + 1 + end do + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-3-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-3-c.c @@ -0,0 +1,235 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +struct m { + int x, y; +}; + +extern void ctest (CFI_cdesc_t *a, int lb0, int lb1, + int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r); + +/* Take a section of array A. OFF is the start index of A on the Fortran + side and the bounds LB and UB for the section to take are relative to + that base index. Store the result in R, which is supposed to be a pointer + array with lower bound 1. */ + +void +ctest (CFI_cdesc_t *a, int lb0, int lb1, + int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r) +{ + CFI_index_t lb_array[2], ub_array[2], s_array[2]; + int i0, i1, o0, o1; + + /* Dump the descriptor contents to test that we can access the fields + correctly, etc. */ + fprintf (stderr, "\n%s: lb0=%d lb1=%d ub0=%d ub1=%d s0=%d s1=%d\n", + (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer", + lb0, lb1, ub0, ub1, s0, s1); + if (! (lb0 == ub0 || lb1 == ub1)) + abort (); + dump_CFI_cdesc_t (a); + dump_CFI_cdesc_t (r); + + /* Make sure we got a valid input descriptor. */ + if (!a->base_addr) + abort (); + if (a->elem_len != sizeof(struct m)) + abort (); + if (a->rank != 2) + abort (); + if (a->type != CFI_type_struct) + abort (); + if (a->attribute == CFI_attribute_other) + { + if (a->dim[0].lower_bound != 0) + abort (); + /* Adjust the 1-based bounds. */ + lb0 = lb0 - 1; + lb1 = lb1 - 1; + ub0 = ub0 - 1; + ub1 = ub1 - 1; + } + /* For pointer arrays, the bounds use the same indexing as the lower + bound in the array descriptor. */ + + /* Make sure we got a valid output descriptor. */ + if (r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Create an array section. */ + lb_array[0] = lb0; + lb_array[1] = lb1; + ub_array[0] = ub0; + ub_array[1] = ub1; + s_array[0] = s0; + s_array[1] = s1; + + check_CFI_status ("CFI_section", + CFI_section (r, a, lb_array, ub_array, s_array)); + + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + + /* Check the contents of the output array. */ +#if 0 + if (lb1 == ub1) + { + /* Output is 1-d array that varies in dimension 0. */ + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = lb1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + output = (struct m *) CFI_address (r, index); + fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n", + i0, lb1, input->x, input->y, o0, output->x, output->y); + } + } + else if (lb0 == ub0) + { + /* Output is 1-d array that varies in dimension 1. */ + for (o1 = r->dim[0].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = lb0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o1; + output = (struct m *) CFI_address (r, index); + fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n", + lb0, i1, input->x, input->y, o1, output->x, output->y); + } + } + else + abort (); +#endif + if (lb1 == ub1) + { + /* Output is 1-d array that varies in dimension 0. */ + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = lb1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } + } + else if (lb0 == ub0) + { + /* Output is 1-d array that varies in dimension 1. */ + for (o1 = r->dim[0].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = lb0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o1; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } + } + else + abort (); + + /* Force the output array to be 1-based. */ + lb_array[0] = 1; + lb_array[1] = 1; + check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array)); + /* Check that the output descriptor is correct. */ + dump_CFI_cdesc_t (r); + if (!r->base_addr) + abort (); + if (r->elem_len != sizeof(struct m)) + abort (); + if (r->rank != 1) + abort (); + if (r->type != CFI_type_struct) + abort (); + if (r->attribute != CFI_attribute_pointer) + abort (); + if (r->dim[0].lower_bound != 1) + abort (); + + /* Check the contents of the output array again. */ + if (lb1 == ub1) + { + /* Output is 1-d array that varies in dimension 0. */ + for (o0 = r->dim[0].lower_bound, i0 = lb0; + (s0 > 0 ? i0 <= ub0 : i0 >= ub0); + o0++, i0 += s0) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = i0; + index[1] = lb1; + input = (struct m *) CFI_address (a, index); + index[0] = o0; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } + } + else if (lb0 == ub0) + { + /* Output is 1-d array that varies in dimension 1. */ + for (o1 = r->dim[0].lower_bound, i1 = lb1; + (s1 > 0 ? i1 <= ub1 : i1 >= ub1); + o1++, i1 += s1) + { + CFI_index_t index[2]; + struct m *input, *output; + index[0] = lb0; + index[1] = i1; + input = (struct m *) CFI_address (a, index); + index[0] = o1; + output = (struct m *) CFI_address (r, index); + if (input->x != output->x || input->y != output->y) + abort (); + } + } + else + abort (); +} + + + Index: Fortran/gfortran/regression/c-interop/section-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-3.f90 @@ -0,0 +1,103 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function to +! take a slice of a 2-dimensional non-pointer array. + +module mm + use ISO_C_BINDING + type, bind (c) :: m + integer(C_INT) :: x, y + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (a, lb0, lb1, ub0, ub1, s0, s1, r) bind (c) + use iso_c_binding + use mm + type(m), target :: a(:,:) + integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1 + type(m), pointer, intent(out) :: r(:) + end subroutine + + end interface + + type(m), target :: aa(10, 20) + integer :: i0, i1 + + ! Initialize the test array by numbering its elements. + do i1 = 1, 20 + do i0 = 1, 10 + aa(i0, i1)%x = i0 + aa(i0, i1)%y = i1 + end do + end do + + call test (aa, 3, 1, 3, 20, 0, 1) ! full slice 0 + call test (aa, 1, 8, 10, 8, 1, 0) ! full slice 1 + call test (aa, 3, 5, 3, 14, 0, 3) ! partial slice 0 + call test (aa, 2, 8, 10, 8, 2, 0) ! partial slice 1 + call test (aa, 3, 14, 3, 5, 0, -3) ! backwards slice 0 + call test (aa, 10, 8, 2, 8, -2, 0) ! backwards slice 1 + +contains + + ! Test function for non-pointer array AA. + ! LB, UB, and S describe the section to take. + subroutine test (aa, lb0, lb1, ub0, ub1, s0, s1) + use mm + type(m) :: aa(10,20) + integer :: lb0, lb1, ub0, ub1, s0, s1 + + type(m), pointer :: rr(:) + integer :: i0, i1, o0, o1 + integer, parameter :: hi0 = 10 + integer, parameter :: hi1 = 20 + + ! Check the bounds actually specify a "slice" rather than a subarray. + if (lb0 .ne. ub0 .and. lb1 .ne. ub1) stop 100 + + ! Call the C function to put a section in rr. + ! The C function expects the section bounds to be 1-based. + nullify (rr) + call ctest (aa, lb0, lb1, ub0, ub1, s0, s1, rr) + + ! Make sure the original array has not been modified. + do i1 = 1, hi1 + do i0 = 1, hi0 + if (aa(i0,i1)%x .ne. i0) stop 103 + if (aa(i0,i1)%y .ne. i1) stop 103 + end do + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 111 + if (lbound (rr, 1) .ne. 1) stop 112 + if (ub0 .eq. lb0) then + if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113 + o1 = 1 + do i1 = lb1, ub1, s1 + if (rr(o1)%x .ne. lb0) stop 114 + if (rr(o1)%y .ne. i1) stop 114 + o1 = o1 + 1 + end do + else + if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113 + o0 = 1 + do i0 = lb0, ub0, s0 + if (rr(o0)%x .ne. i0) stop 114 + if (rr(o0)%y .ne. lb1) stop 114 + o0 = o0 + 1 + end do + end if + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-3p.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-3p.f90 @@ -0,0 +1,127 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-3-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests basic use of the CFI_section C library function to +! take a slice of a 2-dimensional pointer array. + +module mm + use ISO_C_BINDING + type, bind (c) :: m + integer(C_INT) :: x, y + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + subroutine ctest (p, lb0, lb1, ub0, ub1, s0, s1, r) bind (c) + use iso_c_binding + use mm + type(m), pointer :: p(:,:) + integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1 + type(m), pointer, intent(out) :: r(:) + end subroutine + + end interface + + type(m), target :: aa(10, 20) + integer :: i0, i1 + + ! Initialize the test array by numbering its elements. + do i1 = 1, 20 + do i0 = 1, 10 + aa(i0, i1)%x = i0 + aa(i0, i1)%y = i1 + end do + end do + + ! Zero lower bound + call test (aa, 0, 0, 2, 0, 2, 19, 0, 1) ! full slice 0 + call test (aa, 0, 0, 0, 7, 9, 7, 1, 0) ! full slice 1 + call test (aa, 0, 0, 2, 4, 2, 13, 0, 3) ! partial slice 0 + call test (aa, 0, 0, 1, 7, 9, 7, 2, 0) ! partial slice 1 + call test (aa, 0, 0, 2, 13, 2, 4, 0, -3) ! backwards slice 0 + call test (aa, 0, 0, 9, 7, 1, 7, -2, 0) ! backwards slice 1 + + ! Lower bound 1 + call test (aa, 1, 1, 3, 1, 3, 20, 0, 1) ! full slice 0 + call test (aa, 1, 1, 1, 8, 10, 8, 1, 0) ! full slice 1 + call test (aa, 1, 1, 3, 5, 3, 14, 0, 3) ! partial slice 0 + call test (aa, 1, 1, 2, 8, 10, 8, 2, 0) ! partial slice 1 + call test (aa, 1, 1, 3, 14, 3, 5, 0, -3) ! backwards slice 0 + call test (aa, 1, 1, 10, 8, 2, 8, -2, 0) ! backwards slice 1 + + ! Some other lower bound + call test (aa, 2, 3, 4, 3, 4, 22, 0, 1) ! full slice 0 + call test (aa, 2, 3, 2, 10, 11, 10, 1, 0) ! full slice 1 + call test (aa, 2, 3, 4, 7, 4, 16, 0, 3) ! partial slice 0 + call test (aa, 2, 3, 3, 10, 11, 10, 2, 0) ! partial slice 1 + call test (aa, 2, 3, 4, 16, 4, 7, 0, -3) ! backwards slice 0 + call test (aa, 2, 3, 11, 10, 3, 10, -2, 0) ! backwards slice 1 + +contains + + subroutine test (aa, lo0, lo1, lb0, lb1, ub0, ub1, s0, s1) + use mm + type(m), target :: aa(10,20) + integer :: lo0, lo1, lb0, lb1, ub0, ub1, s0, s1 + + type(m), pointer :: pp(:,:), rr(:) + integer :: i0, i1, o0, o1 + + integer :: hi0, hi1 + hi0 = lo0 + 10 - 1 + hi1 = lo1 + 20 - 1 + + ! Check the bounds actually specify a "slice" rather than a subarray. + if (lb0 .ne. ub0 .and. lb1 .ne. ub1) stop 100 + + pp(lo0:,lo1:) => aa + if (lbound (pp, 1) .ne. lo0) stop 121 + if (lbound (pp, 2) .ne. lo1) stop 121 + if (ubound (pp, 1) .ne. hi0) stop 122 + if (ubound (pp, 2) .ne. hi1) stop 122 + nullify (rr) + call ctest (pp, lb0, lb1, ub0, ub1, s0, s1, rr) + + ! Make sure the input pointer array has not been modified. + if (lbound (pp, 1) .ne. lo0) stop 131 + if (ubound (pp, 1) .ne. hi0) stop 132 + if (lbound (pp, 2) .ne. lo1) stop 133 + if (ubound (pp, 2) .ne. hi1) stop 134 + do i1 = lo1, hi1 + do i0 = lo0, hi0 + if (pp(i0,i1)%x .ne. i0 - lo0 + 1) stop 135 + if (pp(i0,i1)%y .ne. i1 - lo1 + 1) stop 136 + end do + end do + + ! Make sure the output array has the expected bounds and elements. + if (.not. associated (rr)) stop 111 + if (lbound (rr, 1) .ne. 1) stop 112 + if (ub0 .eq. lb0) then + if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113 + o1 = 1 + do i1 = lb1, ub1, s1 + if (rr(o1)%x .ne. lb0 - lo0 + 1) stop 114 + if (rr(o1)%y .ne. i1 - lo1 + 1) stop 114 + o1 = o1 + 1 + end do + else + if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113 + o0 = 1 + do i0 = lb0, ub0, s0 + if (rr(o0)%x .ne. i0 - lo0 + 1) stop 114 + if (rr(o0)%y .ne. lb1 - lo1 + 1) stop 114 + o0 = o0 + 1 + end do + end if + end subroutine + +end program + Index: Fortran/gfortran/regression/c-interop/section-4-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-4-c.c @@ -0,0 +1,101 @@ +#include +#include + +#include +#include "dump-descriptors.h" + +struct m { + int i, j, k, l; +}; + +extern void ctest (void); + +#define IMAX 6 +#define JMAX 8 +#define KMAX 10 +#define LMAX 12 + +static struct m buffer[LMAX][KMAX][JMAX][IMAX]; + +static void +check_element (struct m *mp, int i, int j, int k, int l) +{ +#if 0 + fprintf (stderr, "expected (%d, %d, %d, %d), got (%d, %d, %d, %d)\n", + i, j, k, l, mp->i, mp->j, mp->k, mp->l); +#endif + if (mp->i != i || mp->j != j || mp->k != k || mp->l != l) + abort (); +} + +void +ctest (void) +{ + CFI_CDESC_T(4) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(4) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + CFI_index_t extents[4] = { IMAX, JMAX, KMAX, LMAX }; + CFI_index_t lb[4], ub[4], s[4]; + int i, j, k, l; + int ii, jj, kk, ll; + + /* Initialize the buffer to uniquely label each element. */ + for (i = 0; i < IMAX; i++) + for (j = 0; j < JMAX; j++) + for (k = 0; k < KMAX; k++) + for (l = 0; l < LMAX; l++) + { + buffer[l][k][j][i].i = i; + buffer[l][k][j][i].j = j; + buffer[l][k][j][i].k = k; + buffer[l][k][j][i].l = l; + } + + /* Establish the source array. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)buffer, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 4, extents)); + + /* Try taking a degenerate section (single element). */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 0, NULL)); + lb[0] = 3; lb[1] = 4; lb[2] = 5; lb[3] = 6; + ub[0] = 3; ub[1] = 4; ub[2] = 5; ub[3] = 6; + s[0] = 0; s[1] = 0; s[2] = 0; s[3] = 0; + check_CFI_status ("CFI_section", + CFI_section (result, source, lb, ub, s)); + dump_CFI_cdesc_t (result); + check_element ((struct m *)result->base_addr, 3, 4, 5, 6); + + /* Try taking a 2d chunk out of the 4d array. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, + CFI_attribute_pointer, CFI_type_struct, + sizeof (struct m), 2, NULL)); + lb[0] = 1; lb[1] = 2; lb[2] = 3; lb[3] = 4; + ub[0] = 1; ub[1] = JMAX - 2; ub[2] = 3; ub[3] = LMAX - 2; + s[0] = 0; s[1] = 2; s[2] = 0; s[3] = 3; + check_CFI_status ("CFI_section", + CFI_section (result, source, lb, ub, s)); + dump_CFI_cdesc_t (result); + + i = lb[0]; + k = lb[2]; + for (j = lb[1], jj = result->dim[0].lower_bound; + j <= ub[1]; + j += s[1], jj++) + for (l = lb[3], ll = result->dim[1].lower_bound; + l <= ub[3]; + l += s[3], ll++) + { + CFI_index_t subscripts[2]; + subscripts[0] = jj; + subscripts[1] = ll; + check_element ((struct m *) CFI_address (result, subscripts), + i, j, k, l); + } +} Index: Fortran/gfortran/regression/c-interop/section-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-4.f90 @@ -0,0 +1,23 @@ +! PR 101310 +! { dg-do run } +! { dg-additional-sources "section-4-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests various scenarios with using CFI_section to extract +! a section with rank less than the source array. Everything interesting +! happens on the C side. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + use iso_c_binding + end subroutine + + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/section-errors-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-errors-c.c @@ -0,0 +1,149 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +/* For simplicity, point descriptors at a static buffer. */ +#define BUFSIZE 256 +static char *buf[BUFSIZE] __attribute__ ((aligned (8))); +static CFI_index_t extents[] = {10}; + +/* External entry point. The arguments are descriptors for input arrays; + we'll construct new descriptors for the outputs of CFI_section. */ +extern void ctest (void); + +void +ctest (void) +{ + int bad = 0; + int status; + CFI_CDESC_T(1) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(3) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + CFI_index_t lb = 2; + CFI_index_t ub = 8; + CFI_index_t step = 2; + CFI_index_t zstep = 0; + + /* Use a 1-d integer source array for the first few tests. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)buf, CFI_attribute_other, + CFI_type_int, 0, 1, extents)); + + /* result shall be the address of a C descriptor with rank equal + to the rank of source minus the number of zero strides. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 0, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch (too small)\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + status = CFI_section (result, source, &lb, &lb, &zstep); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch (zero stride)\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch (too large)\n"); + bad ++; + } + + /* The attribute member [of result] shall have the value + CFI_attribute_other or CFI_attribute_pointer. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, 1, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_attribute_allocatable result\n"); + bad ++; + } + + /* source shall be the address of a C descriptor that describes a + nonallocatable nonpointer array, an allocated allocatable array, + or an associated array pointer. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, 1, NULL)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for unallocated allocatable source array\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (source, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for unassociated pointer source array\n"); + bad ++; + } + + /* The corresponding values of the elem_len and type members shall + be the same in the C descriptors with the addresses source + and result. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)buf, CFI_attribute_other, + CFI_type_struct, + sizeof(int), 1, extents)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_struct, + 2*sizeof (int), 1, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for elem_len mismatch\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + status = CFI_section (result, source, &lb, &ub, &step); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for type mismatch\n"); + bad ++; + } + + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/section-errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/section-errors.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-sources "section-errors-c.c dump-descriptors.c" } +! { dg-additional-options "-Wno-error -fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! This program tests that the CFI_section function properly detects +! invalid arguments. All the interesting things happen in the +! corresponding C code. +! +! The situation here seems to be that while TS29113 defines error codes +! for CFI_section, it doesn't actually require the implementation to detect +! those errors by saying the arguments "shall be" such-and-such, e.g. it is +! undefined behavior if they are not. In gfortran you can enable some +! run-time checking by building with -fcheck=all. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/select-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/select-c.c @@ -0,0 +1,138 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +/* Declare some source arrays. */ +struct ss { + char c[4]; + signed char b[4]; + int i, j, k; +} s[10][5][3]; + +char c[10][16]; + +double _Complex dc[10]; + +CFI_index_t extents3[] = {3,5,10}; +CFI_index_t extents1[] = {10}; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + CFI_CDESC_T(3) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(3) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + size_t offset; + + /* Extract an array of structure elements. */ + offset = offsetof (struct ss, j); + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)s, CFI_attribute_other, + CFI_type_struct, + sizeof (struct ss), 3, extents3)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + check_CFI_status ("CFI_select_part", + CFI_select_part (result, source, offset, 0)); + dump_CFI_cdesc_t (source); + dump_CFI_cdesc_t (result); + + if (result->elem_len != sizeof (int)) + abort (); + if (result->base_addr != source->base_addr + offset) + abort (); + if (result->dim[0].extent != source->dim[0].extent) + abort (); + if (result->dim[0].sm != source->dim[0].sm) + abort (); + if (result->dim[1].extent != source->dim[1].extent) + abort (); + if (result->dim[1].sm != source->dim[1].sm) + abort (); + if (result->dim[2].extent != source->dim[2].extent) + abort (); + if (result->dim[2].sm != source->dim[2].sm) + abort (); + + /* Check that we use the given elem_size for char but not for + signed char, which is considered an integer type instead of a Fortran + character type. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_char, 4, 3, NULL)); + if (result->elem_len != 4) + abort (); + offset = offsetof (struct ss, c); + check_CFI_status ("CFI_select_part", + CFI_select_part (result, source, offset, 4)); + if (result->elem_len != 4) + abort (); + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_signed_char, 4, 3, NULL)); + if (result->elem_len != sizeof (signed char)) + abort (); + offset = offsetof (struct ss, c); + check_CFI_status ("CFI_select_part", + CFI_select_part (result, source, offset, 4)); + if (result->elem_len != sizeof (signed char)) + abort (); + + /* Extract an array of character substrings. */ + offset = 2; + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)c, CFI_attribute_other, + CFI_type_char, 16, 1, extents1)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_char, 8, 1, NULL)); + check_CFI_status ("CFI_select_part", + CFI_select_part (result, source, offset, 8)); + dump_CFI_cdesc_t (source); + dump_CFI_cdesc_t (result); + + if (result->elem_len != 8) + abort (); + if (result->base_addr != source->base_addr + offset) + abort (); + if (result->dim[0].extent != source->dim[0].extent) + abort (); + if (result->dim[0].sm != source->dim[0].sm) + abort (); + + /* Extract an array the imaginary parts of complex numbers. + Note that the use of __imag__ to obtain the imaginary part as + an lvalue is a GCC extension. */ + offset = (void *)&(__imag__ dc[0]) - (void *)&(dc[0]); + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)dc, CFI_attribute_other, + CFI_type_double_Complex, + 0, 1, extents1)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_double, 0, 1, NULL)); + check_CFI_status ("CFI_select_part", + CFI_select_part (result, source, offset, 0)); + dump_CFI_cdesc_t (source); + dump_CFI_cdesc_t (result); + + if (result->elem_len != sizeof (double)) + abort (); + if (result->base_addr != source->base_addr + offset) + abort (); + if (result->dim[0].extent != source->dim[0].extent) + abort (); + if (result->dim[0].sm != source->dim[0].sm) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/select-errors-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/select-errors-c.c @@ -0,0 +1,125 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +/* Source is an array of structs. */ +struct ss { + int i, j; + char c[16]; + double _Complex dc; +} s[10]; + +CFI_index_t extents[] = {10}; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + int bad = 0; + int status; + CFI_CDESC_T(1) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(3) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + + /* Create a descriptor for the source array. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)s, CFI_attribute_other, + CFI_type_struct, + sizeof (struct ss), 1, extents)); + + /* The attribute member of result shall have the value + CFI_attribute_other or CFI_attribute_pointer. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, 1, NULL)); + status = CFI_select_part (result, source, offsetof (struct ss, j), 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_attribute_allocatable result\n"); + bad ++; + } + + /* The rank member of the result C descriptor shall have the same value + as the rank member of the C descriptor at the address specified + by source. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 0, NULL)); + status = CFI_select_part (result, source, offsetof (struct ss, j), 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch (too small)\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + status = CFI_select_part (result, source, offsetof (struct ss, j), 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch (too large)\n"); + bad ++; + } + + /* The value of displacement shall be between 0 and source->elem_len - 1 + inclusive. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 1, NULL)); + status = CFI_select_part (result, source, -8, 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for negative displacement\n"); + bad ++; + } + status = CFI_select_part (result, source, source->elem_len, 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for too-large displacement\n"); + bad ++; + } + + /* source shall be the address of a C descriptor for a nonallocatable + nonpointer array, an allocated allocatable array, or an associated + array pointer. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, NULL, CFI_attribute_allocatable, + CFI_type_struct, + sizeof (struct ss), 1, NULL)); + status = CFI_select_part (result, source, offsetof (struct ss, j), 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for unallocated allocatable source array\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (source, NULL, CFI_attribute_pointer, + CFI_type_struct, + sizeof (struct ss), 1, NULL)); + status = CFI_select_part (result, source, offsetof (struct ss, j), 0); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for unassociated pointer source array\n"); + bad ++; + } + + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/select-errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/select-errors.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! { dg-additional-sources "select-errors-c.c dump-descriptors.c" } +! { dg-additional-options "-Wno-error -fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! This program tests that the CFI_select_part function properly detects +! invalid arguments. All the interesting things happen in the +! corresponding C code. +! +! The situation here seems to be that while TS29113 defines error codes for +! CFI_select_part, it doesn't actually require the implementation to detect +! those errors by saying the arguments "shall be" such-and-such, e.g. it is +! undefined behavior if they are not. In gfortran you can enable some +! run-time checking by building with -fcheck=all. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/select.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/select.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-sources "select-c.c dump-descriptors.c" } +! +! This program tests the CFI_select_part function. All the interesting +! things happen in the corresponding C code. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/setpointer-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/setpointer-c.c @@ -0,0 +1,78 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +static int a[10][5][3]; +static CFI_index_t extents[] = {3, 5, 10}; +static CFI_index_t lb1[] = {1, 2, 3}; +static CFI_index_t lb2[] = {0, 1, -10}; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + CFI_CDESC_T(3) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(3) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + + /* Create descriptors. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)a, CFI_attribute_pointer, + CFI_type_int, 0, 3, extents)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + + /* Use setpointer to adjust the bounds of source in place. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (source, source, lb1)); + dump_CFI_cdesc_t (source); + if (source->dim[0].lower_bound != lb1[0]) + abort (); + if (source->dim[1].lower_bound != lb1[1]) + abort (); + if (source->dim[2].lower_bound != lb1[2]) + abort (); + + /* Use setpointer to copy the pointer and bounds from source. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (result, source, NULL)); + dump_CFI_cdesc_t (result); + if (result->base_addr != source->base_addr) + abort (); + if (result->dim[0].lower_bound != source->dim[0].lower_bound) + abort (); + if (result->dim[1].lower_bound != source->dim[1].lower_bound) + abort (); + if (result->dim[2].lower_bound != source->dim[2].lower_bound) + abort (); + + /* Use setpointer to nullify result. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (result, NULL, NULL)); + dump_CFI_cdesc_t (result); + if (result->base_addr) + abort (); + + /* Use setpointer to copy the pointer from source, but use + different bounds. */ + check_CFI_status ("CFI_setpointer", + CFI_setpointer (result, source, lb2)); + dump_CFI_cdesc_t (source); + if (result->base_addr != source->base_addr) + abort (); + if (result->dim[0].lower_bound != lb2[0]) + abort (); + if (result->dim[1].lower_bound != lb2[1]) + abort (); + if (result->dim[2].lower_bound != lb2[2]) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/setpointer-errors-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/setpointer-errors-c.c @@ -0,0 +1,127 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +static int a[10][5][3]; +static CFI_index_t extents[] = {3, 5, 10}; + +/* External entry point. */ +extern void ctest (void); + +void +ctest (void) +{ + int bad = 0; + int status; + CFI_CDESC_T(3) sdesc; + CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc; + CFI_CDESC_T(3) rdesc; + CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc; + + /* result shall be the address of a C descriptor for a Fortran pointer. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)a, CFI_attribute_other, + CFI_type_int, 0, 3, extents)); + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, 3, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_attribute_allocatable result\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_other, + CFI_type_int, 0, 3, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for CFI_attribute_other result\n"); + bad ++; + } + + /* source shall be a null pointer or the address of a C descriptor + for an allocated allocatable object, a data pointer object, or a + nonallocatable nonpointer data object that is not an + assumed-size array. */ + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + + check_CFI_status ("CFI_establish", + CFI_establish (source, NULL, CFI_attribute_allocatable, + CFI_type_int, 0, 3, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for unallocated allocatable source\n"); + bad ++; + } + + /* CFI_establish rejects negative extents, so we can't use it to make + an assumed-size array, so hack the descriptor by hand. Yuck. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)a, CFI_attribute_other, + CFI_type_int, 0, 3, extents)); + source->dim[2].extent = -1; + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for assumed-size source array\n"); + bad ++; + } + + /* If source is not a null pointer, the corresponding values of the + elem_len, rank, and type members shall be the same in the C + descriptors with the addresses source and result. */ + check_CFI_status ("CFI_establish", + CFI_establish (source, (void *)a, CFI_attribute_other, + CFI_type_char, sizeof(int), 3, extents)); + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_char, 1, 3, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for elem_len mismatch\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_char, sizeof(int), 1, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for rank mismatch\n"); + bad ++; + } + + check_CFI_status ("CFI_establish", + CFI_establish (result, NULL, CFI_attribute_pointer, + CFI_type_int, 0, 3, NULL)); + status = CFI_setpointer (result, source, NULL); + if (status == CFI_SUCCESS) + { + fprintf (stderr, + "no error for type mismatch\n"); + bad ++; + } + + if (bad) + abort (); +} + Index: Fortran/gfortran/regression/c-interop/setpointer-errors.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/setpointer-errors.f90 @@ -0,0 +1,28 @@ +! PR 101317 +! { dg-do run } +! { dg-additional-sources "setpointer-errors-c.c dump-descriptors.c" } +! { dg-additional-options "-Wno-error -fcheck=all" } +! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 } +! +! This program tests that the CFI_setpointer function properly detects +! invalid arguments. All the interesting things happen in the +! corresponding C code. +! +! The situation here seems to be that while TS29113 defines error codes for +! CFI_setpointer, it doesn't actually require the implementation to detect +! those errors by saying the arguments "shall be" such-and-such, e.g. it is +! undefined behavior if they are not. In gfortran you can enable some +! run-time checking by building with -fcheck=all. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/setpointer.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/setpointer.f90 @@ -0,0 +1,18 @@ +! { dg-do run } +! { dg-additional-sources "setpointer-c.c dump-descriptors.c" } +! +! This program tests the CFI_setpointer function. All the interesting +! things happen in the corresponding C code. + +program testit + use iso_c_binding + implicit none + + interface + subroutine ctest () bind (c) + end subroutine + end interface + + call ctest () + +end program Index: Fortran/gfortran/regression/c-interop/shape-bindc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/shape-bindc.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.1 SHAPE +! +! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010 +! is changed for an assumed-rank array that is associated with an +! assumed-size array; an assumed-size array has no shape, but in this +! case the result has a value equal to +! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ] +! with KIND omitted from SIZE if it was omitted from SHAPE. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + +contains + + subroutine testit (a) bind(c) + integer :: a(..) + + integer :: r + r = rank(a) + + block + integer :: s(r) + s = shape(a) + do i = 1, r + if (s(i) .ne. size(a,i)) stop 101 + end do + end block + + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/shape-poly.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/shape-poly.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.1 SHAPE +! +! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010 +! is changed for an assumed-rank array that is associated with an +! assumed-size array; an assumed-size array has no shape, but in this +! case the result has a value equal to +! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ] +! with KIND omitted from SIZE if it was omitted from SHAPE. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is the polymorphic version of shape.f90. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + +contains + + subroutine testit (a) + use m + class(t) :: a(..) + + integer :: r + r = rank(a) + + block + integer :: s(r) + s = shape(a) + do i = 1, r + if (s(i) .ne. size(a,i)) stop 101 + end do + end block + + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/shape.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/shape.f90 @@ -0,0 +1,77 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.1 SHAPE +! +! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010 +! is changed for an assumed-rank array that is associated with an +! assumed-size array; an assumed-size array has no shape, but in this +! case the result has a value equal to +! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ] +! with KIND omitted from SIZE if it was omitted from SHAPE. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + implicit none + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + +contains + + subroutine testit (a) + integer :: a(..) + + integer :: r + r = rank(a) + + block + integer :: s(r), i + s = shape(a) + do i = 1, r + if (s(i) .ne. size(a,i)) stop 101 + end do + end block + + end subroutine + + subroutine test1 (a) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/size-bindc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/size-bindc.f90 @@ -0,0 +1,106 @@ +! Reported as pr94070. +! { dg-do run } +! +! TS 29113 +! 6.4.2 SIZE +! +! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010 +! is changed in the following cases: +! +! (1) for an assumed-rank object that is associated with an assumed-size +! array, the result has the value −1 if DIM is present and equal to the +! rank of ARRAY, and a negative value that is equal to +! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] ) +! if DIM is not present; +! +! (2) for an assumed-rank object that is associated with a scalar, the +! result has the value 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a, r, sizes) bind(c) + integer :: a(..) + integer :: r + integer :: sizes(r) + + integer :: totalsize, thissize + totalsize = 1 + + if (r .ne. rank(a)) stop 101 + + do i = 1, r + thissize = size (a, i) + print *, 'got size ', thissize, ' expected ', sizes(i) + if (thissize .ne. sizes(i)) stop 102 + totalsize = totalsize * thissize + end do + + if (size(a) .ne. totalsize) stop 103 + end subroutine + + subroutine test0 (a) bind(c) + integer :: a(..) + + if (size (a) .ne. 1) stop 103 + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + integer :: sizes(1) + sizes(1) = -1 + call testit (a, 1, sizes) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + integer :: sizes(3) + sizes(1) = u1 - l1 + 1 + sizes(2) = u2 - l2 + 1 + sizes(3) = -1 + + call testit (a, 3, sizes) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/size-poly.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/size-poly.f90 @@ -0,0 +1,118 @@ +! Reported as pr94070. +! { dg-do run } +! +! TS 29113 +! 6.4.2 SIZE +! +! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010 +! is changed in the following cases: +! +! (1) for an assumed-rank object that is associated with an assumed-size +! array, the result has the value −1 if DIM is present and equal to the +! rank of ARRAY, and a negative value that is equal to +! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] ) +! if DIM is not present; +! +! (2) for an assumed-rank object that is associated with a scalar, the +! result has the value 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is the polymorphic version of size.f90. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + type(t) :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + call test0 (x) + call test0 (x1(1)) + +contains + + subroutine testit (a, r, sizes) + use m + class(t) :: a(..) + integer :: r + integer :: sizes(r) + + integer :: totalsize, thissize + totalsize = 1 + + if (r .ne. rank(a)) stop 101 + + do i = 1, r + thissize = size (a, i) + print *, 'got size ', thissize, ' expected ', sizes(i) + if (thissize .ne. sizes(i)) stop 102 + totalsize = totalsize * thissize + end do + + if (size(a) .ne. totalsize) stop 103 + end subroutine + + subroutine test0 (a) + use m + class(t) :: a(..) + + if (size (a) .ne. 1) stop 103 + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + integer :: sizes(1) + sizes(1) = -1 + call testit (a, 1, sizes) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + integer :: sizes(3) + sizes(1) = u1 - l1 + 1 + sizes(2) = u2 - l2 + 1 + sizes(3) = -1 + + call testit (a, 3, sizes) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/size.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/size.f90 @@ -0,0 +1,106 @@ +! Reported as pr94070. +! { dg-do run } +! +! TS 29113 +! 6.4.2 SIZE +! +! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010 +! is changed in the following cases: +! +! (1) for an assumed-rank object that is associated with an assumed-size +! array, the result has the value −1 if DIM is present and equal to the +! rank of ARRAY, and a negative value that is equal to +! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] ) +! if DIM is not present; +! +! (2) for an assumed-rank object that is associated with a scalar, the +! result has the value 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call test1 (y1) + p1 => x1 + call test1 (p1) + allocate (a1(5)) + call test1 (a1) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a, r, sizes) + integer :: a(..) + integer :: r + integer :: sizes(r) + + integer :: totalsize, thissize + totalsize = 1 + + if (r .ne. rank(a)) stop 101 + + do i = 1, r + thissize = size (a, i) + print *, 'got size ', thissize, ' expected ', sizes(i) + if (thissize .ne. sizes(i)) stop 102 + totalsize = totalsize * thissize + end do + + if (size(a) .ne. totalsize) stop 103 + end subroutine + + subroutine test0 (a) + integer :: a(..) + + if (size (a) .ne. 1) stop 103 + end subroutine + + subroutine test1 (a) + integer :: a(*) + + integer :: sizes(1) + sizes(1) = -1 + call testit (a, 1, sizes) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + integer :: sizes(3) + sizes(1) = u1 - l1 + 1 + sizes(2) = u2 - l2 + 1 + sizes(3) = -1 + + call testit (a, 3, sizes) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/tkr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/tkr.f90 @@ -0,0 +1,46 @@ +! { dg-do compile} +! +! TS 29113 +! The definition of TKR compatible in paragraph 2 of subclause 12.4.3.4.5 +! of ISO/IEC 1539-1:2010 is changed to: +! +! A dummy argument is type, kind, and rank compatible, or TKR compatible, +! with another dummy argument if the first is type compatible with the +! second, the kind type parameters of the first have the same values as +! the corresponding kind type parameters of the second, and both have the +! same rank or either is assumed-rank. +! +! This test file contains tests that are expected to issue diagnostics +! for invalid code. + +module m + +interface foo + subroutine foo_1 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x(..) + end subroutine + subroutine foo_2 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x(:, :) + end subroutine +end interface + +interface bar + subroutine bar_1 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x(..) + end subroutine + subroutine bar_2 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x(..) + end subroutine +end interface + +interface baz + subroutine baz_1 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x + end subroutine + subroutine baz_2 (x) ! { dg-error "Ambiguous interfaces" } + integer :: x(..) + end subroutine +end interface + +end module + Index: Fortran/gfortran/regression/c-interop/typecodes-array-basic-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-basic-c.c @@ -0,0 +1,169 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest_int1 (CFI_cdesc_t *arg_int, + CFI_cdesc_t *arg_short, + CFI_cdesc_t *arg_long, + CFI_cdesc_t *arg_long_long, + CFI_cdesc_t *arg_signed_char); + +extern void ctest_int2 (CFI_cdesc_t *arg_int8, + CFI_cdesc_t *arg_int16, + CFI_cdesc_t *arg_int32, + CFI_cdesc_t *arg_int64); + +extern void ctest_int3 (CFI_cdesc_t *arg_least8, + CFI_cdesc_t *arg_least16, + CFI_cdesc_t *arg_least32, + CFI_cdesc_t *arg_least64); + +extern void ctest_int4 (CFI_cdesc_t *arg_fast8, + CFI_cdesc_t *arg_fast16, + CFI_cdesc_t *arg_fast32, + CFI_cdesc_t *arg_fast64); + +extern void ctest_int5 (CFI_cdesc_t *arg_size, + CFI_cdesc_t *arg_intmax, + CFI_cdesc_t *arg_intptr, + CFI_cdesc_t *arg_ptrdiff); + +extern void ctest_real (CFI_cdesc_t *arg_float, + CFI_cdesc_t *arg_double); + +extern void ctest_complex (CFI_cdesc_t *arg_float_complex, + CFI_cdesc_t *arg_double_complex); + +extern void ctest_misc (CFI_cdesc_t *arg_bool, + CFI_cdesc_t *arg_cptr, + CFI_cdesc_t *arg_cfunptr, + CFI_cdesc_t *arg_struct); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->base_addr == NULL) + abort (); + if (a->rank != 1) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + + +/* Test that the basic integer types correspond correctly. */ +void +ctest_int1 (CFI_cdesc_t *arg_int, + CFI_cdesc_t *arg_short, + CFI_cdesc_t *arg_long, + CFI_cdesc_t *arg_long_long, + CFI_cdesc_t *arg_signed_char) +{ + check (arg_int, sizeof (int), CFI_type_int); + check (arg_short, sizeof (short), CFI_type_short); + check (arg_long, sizeof (long), CFI_type_long); + check (arg_long_long, sizeof (long long int), CFI_type_long_long); + check (arg_signed_char, sizeof (signed char), CFI_type_signed_char); +} + +/* Test the integer types of explicit sizes. */ +void +ctest_int2 (CFI_cdesc_t *arg_int8, + CFI_cdesc_t *arg_int16, + CFI_cdesc_t *arg_int32, + CFI_cdesc_t *arg_int64) +{ + check (arg_int8, sizeof (int8_t), CFI_type_int8_t); + check (arg_int16, sizeof (int16_t), CFI_type_int16_t); + check (arg_int32, sizeof (int32_t), CFI_type_int32_t); + check (arg_int64, sizeof (int64_t), CFI_type_int64_t); +} + +/* Check the int_least*_t types. */ + +void +ctest_int3 (CFI_cdesc_t *arg_least8, + CFI_cdesc_t *arg_least16, + CFI_cdesc_t *arg_least32, + CFI_cdesc_t *arg_least64) +{ + check (arg_least8, sizeof (int_least8_t), CFI_type_int_least8_t); + check (arg_least16, sizeof (int_least16_t), CFI_type_int_least16_t); + check (arg_least32, sizeof (int_least32_t), CFI_type_int_least32_t); + check (arg_least64, sizeof (int_least64_t), CFI_type_int_least64_t); +} + +/* Check the int_fast*_t types. */ +void +ctest_int4 (CFI_cdesc_t *arg_fast8, + CFI_cdesc_t *arg_fast16, + CFI_cdesc_t *arg_fast32, + CFI_cdesc_t *arg_fast64) +{ + check (arg_fast8, sizeof (int_fast8_t), CFI_type_int_fast8_t); + check (arg_fast16, sizeof (int_fast16_t), CFI_type_int_fast16_t); + check (arg_fast32, sizeof (int_fast32_t), CFI_type_int_fast32_t); + check (arg_fast64, sizeof (int_fast64_t), CFI_type_int_fast64_t); +} + +/* Check the "purposeful" integer types. */ +void +ctest_int5 (CFI_cdesc_t *arg_size, + CFI_cdesc_t *arg_intmax, + CFI_cdesc_t *arg_intptr, + CFI_cdesc_t *arg_ptrdiff) +{ + check (arg_size, sizeof (size_t), CFI_type_size_t); + check (arg_intmax, sizeof (intmax_t), CFI_type_intmax_t); + check (arg_intptr, sizeof (intptr_t), CFI_type_intptr_t); + check (arg_ptrdiff, sizeof (ptrdiff_t), CFI_type_ptrdiff_t); +} + +/* Check the floating-point types. */ +void +ctest_real (CFI_cdesc_t *arg_float, + CFI_cdesc_t *arg_double) +{ + check (arg_float, sizeof (float), CFI_type_float); + check (arg_double, sizeof (double), CFI_type_double); +} + +/* Likewise for the complex types. */ +void +ctest_complex (CFI_cdesc_t *arg_float_complex, + CFI_cdesc_t *arg_double_complex) +{ + check (arg_float_complex, sizeof (float _Complex), + CFI_type_float_Complex); + check (arg_double_complex, sizeof (double _Complex), + CFI_type_double_Complex); +} + +/* Misc types. */ +void +ctest_misc (CFI_cdesc_t *arg_bool, + CFI_cdesc_t *arg_cptr, + CFI_cdesc_t *arg_cfunptr, + CFI_cdesc_t *arg_struct) +{ + struct m + { + int i, j; + }; + + check (arg_bool, sizeof (_Bool), CFI_type_Bool); + check (arg_cptr, sizeof (void *), CFI_type_cptr); + check (arg_cfunptr, sizeof (void (*)(void)), CFI_type_cfunptr); + check (arg_struct, sizeof (struct m), CFI_type_struct); +} Index: Fortran/gfortran/regression/c-interop/typecodes-array-basic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-basic.f90 @@ -0,0 +1,151 @@ +! PR 101305 +! PR 100917 +! { dg-do run } +! { dg-additional-sources "typecodes-array-basic-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that kind constants in the ISO_C_BINDING +! module result in the right type field in arguments passed by descriptor, +! also matching the size of the corresponding C type. We use +! assumed-rank arrays to force the use of a descriptor. +! +! Some types are tested in their own testcases to allow conditionalization +! for target-specific support or xfailing to track bugs. + +module mm + use iso_c_binding + + type, bind (c) :: s + integer(C_INT) :: i, j + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + + subroutine ctest_int1 (arg_int, arg_short, arg_long, arg_long_long, & + arg_signed_char) bind (c) + use iso_c_binding + integer(C_INT) :: arg_int(:) + integer(C_SHORT) :: arg_short(:) + integer(C_LONG) :: arg_long(:) + integer(C_LONG_LONG) :: arg_long_long(:) + integer(C_SIGNED_CHAR) :: arg_signed_char(:) + end subroutine + + subroutine ctest_int2 (arg_int8, arg_int16, arg_int32, arg_int64) bind (c) + use iso_c_binding + integer(C_INT8_T) :: arg_int8(:) + integer(C_INT16_T) :: arg_int16(:) + integer(C_INT32_T) :: arg_int32(:) + integer(C_INT64_T) :: arg_int64(:) + end subroutine + + subroutine ctest_int3 (arg_least8, arg_least16, arg_least32, & + arg_least64) bind (c) + use iso_c_binding + integer(C_INT_LEAST8_T) :: arg_least8(:) + integer(C_INT_LEAST16_T) :: arg_least16(:) + integer(C_INT_LEAST32_T) :: arg_least32(:) + integer(C_INT_LEAST64_T) :: arg_least64(:) + end subroutine + + subroutine ctest_int4 (arg_fast8, arg_fast16, arg_fast32, & + arg_fast64) bind (c) + use iso_c_binding + integer(C_INT_FAST8_T) :: arg_fast8(:) + integer(C_INT_FAST16_T) :: arg_fast16(:) + integer(C_INT_FAST32_T) :: arg_fast32(:) + integer(C_INT_FAST64_T) :: arg_fast64(:) + end subroutine + + subroutine ctest_int5 (arg_size, arg_intmax, arg_intptr, & + arg_ptrdiff) bind (c) + use iso_c_binding + integer(C_SIZE_T) :: arg_size(:) + integer(C_INTMAX_T) :: arg_intmax(:) + integer(C_INTPTR_T) :: arg_intptr(:) + integer(C_PTRDIFF_T) :: arg_ptrdiff(:) + end subroutine + + subroutine ctest_real (arg_float, arg_double) bind (c) + use iso_c_binding + real(C_FLOAT) :: arg_float(:) + real(C_DOUBLE) :: arg_double(:) + end subroutine + + subroutine ctest_complex (arg_float_complex, arg_double_complex) & + bind (c) + use iso_c_binding + complex(C_FLOAT_COMPLEX) :: arg_float_complex(:) + complex(C_DOUBLE_COMPLEX) :: arg_double_complex(:) + end subroutine + + subroutine ctest_misc (arg_bool, arg_cptr, arg_cfunptr, & + arg_struct) bind (c) + use iso_c_binding + use mm + logical(C_BOOL) :: arg_bool(:) + type(C_PTR) :: arg_cptr(:) + type(C_FUNPTR) :: arg_cfunptr(:) + type(s) :: arg_struct(:) + end subroutine + + end interface + + integer(C_INT) :: var_int(4) + integer(C_SHORT) :: var_short(4) + integer(C_LONG) :: var_long(4) + integer(C_LONG_LONG) :: var_long_long(4) + integer(C_SIGNED_CHAR) :: var_signed_char(4) + integer(C_INT8_T) :: var_int8(4) + integer(C_INT16_T) :: var_int16(4) + integer(C_INT32_T) :: var_int32(4) + integer(C_INT64_T) :: var_int64(4) + integer(C_INT_LEAST8_T) :: var_least8(4) + integer(C_INT_LEAST16_T) :: var_least16(4) + integer(C_INT_LEAST32_T) :: var_least32(4) + integer(C_INT_LEAST64_T) :: var_least64(4) + integer(C_INT_FAST8_T) :: var_fast8(4) + integer(C_INT_FAST16_T) :: var_fast16(4) + integer(C_INT_FAST32_T) :: var_fast32(4) + integer(C_INT_FAST64_T) :: var_fast64(4) + integer(C_SIZE_T) :: var_size(4) + integer(C_INTMAX_T) :: var_intmax(4) + integer(C_INTPTR_T) :: var_intptr(4) + integer(C_PTRDIFF_T) :: var_ptrdiff(4) + real(C_FLOAT) :: var_float(4) + real(C_DOUBLE) :: var_double(4) + complex(C_FLOAT_COMPLEX) :: var_float_complex(4) + complex(C_DOUBLE_COMPLEX) :: var_double_complex(4) + logical(C_BOOL) :: var_bool(4) + type(C_PTR) :: var_cptr(4) + type(C_FUNPTR) :: var_cfunptr(4) + type(s) :: var_struct(4) + + call ctest_int1 (var_int, var_short, var_long, var_long_long, & + var_signed_char) + + call ctest_int2 (var_int8, var_int16, var_int32, var_int64) + + call ctest_int3 (var_least8, var_least16, var_least32, var_least64) + + call ctest_int4 (var_fast8, var_fast16, var_fast32, var_fast64) + + call ctest_int5 (var_size, var_intmax, var_intptr, var_ptrdiff) + + call ctest_real (var_float, var_double) + + call ctest_complex (var_float_complex, var_double_complex) + + call ctest_misc (var_bool, var_cptr, var_cfunptr, var_struct) + + ! FIXME: how do you pass something that corresponds to CFI_type_other? + ! The Fortran front end complains if you try to pass something that + ! isn't interoperable, such as a derived type object without bind(c). + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-array-char-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-char-c.c @@ -0,0 +1,41 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->base_addr == NULL) + abort (); + if (a->rank != 1) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4) +{ + check (arg_char, 1, CFI_type_char); + check (arg_ucs4, 4, CFI_type_ucs4_char); +} + +void +ctest_5 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4) +{ + check (arg_char, 5*1, CFI_type_char); + check (arg_ucs4, 5*4, CFI_type_ucs4_char); +} Index: Fortran/gfortran/regression/c-interop/typecodes-array-char.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-char.f90 @@ -0,0 +1,47 @@ +! PR 101305 +! PR 92482 +! { dg-do run } +! { dg-additional-sources "typecodes-array-char-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that the character kind constants provided by +! gfortran's ISO_C_BINDING module result in the right type field in +! arguments passed by descriptor, also matching the size of the corresponding +! C type. We use assumed-shape arrays to force the use of a descriptor. +! +! FIXME: because of PR92482, we can only test len=1 characters. This +! test should be extended once that bug is fixed. + +program testit + use iso_c_binding + implicit none + + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + + interface + + subroutine ctest_1 (arg_cchar, arg_ucs4) bind (c) + use iso_c_binding + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + character(kind=C_CHAR) :: arg_cchar(:) + character(kind=ucs4) :: arg_ucs4(:) + end subroutine + + subroutine ctest_5 (arg_cchar, arg_ucs4) bind (c) + use iso_c_binding + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + character(kind=C_CHAR,len=*) :: arg_cchar(:) + character(kind=ucs4,len=*) :: arg_ucs4(:) + end subroutine + + end interface + + character(kind=C_CHAR) :: var_cchar(4) + character(kind=ucs4) :: var_ucs4(4) + character(kind=C_CHAR,len=5) :: var_cchar_5(4) + character(kind=ucs4,len=5) :: var_ucs4_5(4) + + call ctest_1 (var_cchar, var_ucs4) + call ctest_5 (var_cchar_5, var_ucs4_5) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-array-float128-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-float128-c.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_float128, + CFI_cdesc_t *arg_complex128); + + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->base_addr == NULL) + abort (); + if (a->rank != 1) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_float128, + CFI_cdesc_t *arg_complex128) +{ + check (arg_float128, sizeof (_Float128), CFI_type_float128); + check (arg_complex128, sizeof (_Float128) * 2, + CFI_type_float128_Complex); +} Index: Fortran/gfortran/regression/c-interop/typecodes-array-float128.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-float128.f90 @@ -0,0 +1,34 @@ +! PR 101305 +! PR 100914 +! PR 100917 +! Fails on x86 targets where sizeof(long double) == 16 (PR100917). +! { dg-do run } +! { dg-require-effective-target fortran_real_c_float128 } +! { dg-additional-sources "typecodes-array-float128-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that the vendor extension kind constants provided by +! gfortran's ISO_C_BINDING module result in the right type field in +! arguments passed by descriptor, also matching the size of the corresponding +! C type. We use assumed-shape arrays to force the use of a descriptor. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_float128, arg_complex128) bind (c) + use iso_c_binding + real(C_FLOAT128) :: arg_float128(:) + complex(C_FLOAT128_COMPLEX) :: arg_complex128(:) + end subroutine + + end interface + + real(C_FLOAT128) :: var_float128(4) + complex(C_FLOAT128_COMPLEX) :: var_complex128(4) + + call ctest (var_float128, var_complex128) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-array-int128-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-int128-c.c @@ -0,0 +1,40 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_int128, + CFI_cdesc_t *arg_least128, + CFI_cdesc_t *arg_fast128); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->base_addr == NULL) + abort (); + if (a->rank != 1) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_int128, + CFI_cdesc_t *arg_least128, + CFI_cdesc_t *arg_fast128) +{ + check (arg_int128, sizeof (__int128), CFI_type_int128_t); + check (arg_least128, sizeof (__int128), CFI_type_int_least128_t); + check (arg_fast128, sizeof (__int128), CFI_type_int_fast128_t); +} + Index: Fortran/gfortran/regression/c-interop/typecodes-array-int128.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-int128.f90 @@ -0,0 +1,33 @@ +! PR 101305 +! { dg-do run } +! { dg-require-effective-target fortran_integer_16 } +! { dg-additional-sources "typecodes-array-int128-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that 128-bit integer kind constants provided by +! gfortran's ISO_C_BINDING module result in the right type field in +! arguments passed by descriptor, also matching the size of the corresponding +! C type. We use assumed-shape arrays to force the use of a descriptor. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_int128, arg_least128, arg_fast128) bind (c) + use iso_c_binding + integer(C_INT128_T) :: arg_int128(:) + integer(C_INT_LEAST128_T) :: arg_least128(:) + integer(C_INT_FAST128_T) :: arg_fast128(:) + end subroutine + + end interface + + integer(C_INT128_T) :: var_int128(4) + integer(C_INT_LEAST128_T) :: var_least128(4) + integer(C_INT_FAST128_T) :: var_fast128(4) + + call ctest (var_int128, var_least128, var_fast128) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-array-longdouble-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-longdouble-c.c @@ -0,0 +1,37 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_long_double, + CFI_cdesc_t *arg_long_double_complex); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_other) + abort (); + if (a->base_addr == NULL) + abort (); + if (a->rank != 1) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_long_double, + CFI_cdesc_t *arg_long_double_complex) +{ + check (arg_long_double, sizeof (long double), CFI_type_long_double); + check (arg_long_double_complex, sizeof (long double _Complex), + CFI_type_long_double_Complex); +} Index: Fortran/gfortran/regression/c-interop/typecodes-array-longdouble.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-array-longdouble.f90 @@ -0,0 +1,32 @@ +! PR 101305 +! PR 100917 +! { dg-do run } +! { dg-additional-sources "typecodes-array-longdouble-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that long double kind constants in the ISO_C_BINDING +! module result in the right type field in arguments passed by descriptor, +! also matching the size of the corresponding C type. We use +! assumed-rank arrays to force the use of a descriptor. + + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_long_double, arg_long_double_complex) bind (c) + use iso_c_binding + real(C_LONG_DOUBLE) :: arg_long_double(:) + complex(C_LONG_DOUBLE_COMPLEX) :: arg_long_double_complex(:) + end subroutine + + end interface + + real(C_LONG_DOUBLE) :: var_long_double(4) + complex(C_LONG_DOUBLE_COMPLEX) :: var_long_double_complex(4) + + call ctest (var_long_double, var_long_double_complex) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-sanity-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-sanity-c.c @@ -0,0 +1,178 @@ +#include +#include +#include +#include + +#include + +extern void ctest_typecodes (void); + +/* Do sanity checking on the CFI_type_* macros. In particular, make sure + that if two type codes have the same value, they represent objects of the + same size. */ + +struct tc_info +{ + CFI_type_t typecode; + char *name; + size_t size; + int extension; +}; + +static struct tc_info tc_table[] = +{ + /* Extension types. + Note there is no portable C equivalent type for CFI_type_ucs4_char type + (4-byte Unicode characters), so this is kind of hacky... */ +#if CFI_type_int128_t > 0 + { CFI_type_int128_t, "CFI_type_int128_t", + sizeof (__int128), 1 }, + { CFI_type_int_least128_t, "CFI_type_int_least128_t", + sizeof (__int128), 1 }, + { CFI_type_int_fast128_t, "CFI_type_int_fast128_t", + sizeof (__int128), 1 }, +#endif +#if CFI_type_ucs4_char > 0 + { CFI_type_ucs4_char, "CFI_type_ucs4_char", 4, 1 }, +#endif +#if CFI_type_float128 > 0 + { CFI_type_float128, "CFI_type_float128", + sizeof (_Float128), 1 }, + { CFI_type_float128_Complex, "CFI_type_float128_Complex", + sizeof (_Float128 _Complex), 1 }, +#endif +#if CFI_type_cfunptr > 0 + { CFI_type_cfunptr, "CFI_type_cfunptr", + sizeof (void (*)(void)), 1 }, +#endif + + /* Standard types. */ + { CFI_type_signed_char, "CFI_type_signed_char", + sizeof (signed char), 0, }, + { CFI_type_short, "CFI_type_short", + sizeof (short), 0 }, + { CFI_type_int, "CFI_type_int", + sizeof (int), 0 }, + { CFI_type_long, "CFI_type_long", + sizeof (long), 0 }, + { CFI_type_long_long, "CFI_type_long_long", + sizeof (long long), 0 }, + { CFI_type_size_t, "CFI_type_size_t", + sizeof (size_t), 0 }, + { CFI_type_int8_t, "CFI_type_int8_t", + sizeof (int8_t), 0 }, + { CFI_type_int16_t, "CFI_type_int16_t", + sizeof (int16_t), 0 }, + { CFI_type_int32_t, "CFI_type_int32_t", + sizeof (int32_t), 0 }, + { CFI_type_int64_t, "CFI_type_int64_t", + sizeof (int64_t), 0 }, + { CFI_type_int_least8_t, "CFI_type_int_least8_t", + sizeof (int_least8_t), 0 }, + { CFI_type_int_least16_t, "CFI_type_int_least16_t", + sizeof (int_least16_t), 0 }, + { CFI_type_int_least32_t, "CFI_type_int_least32_t", + sizeof (int_least32_t), 0 }, + { CFI_type_int_least64_t, "CFI_type_int_least64_t", + sizeof (int_least64_t), 0 }, + { CFI_type_int_fast8_t, "CFI_type_int_fast8_t", + sizeof (int_fast8_t), 0 }, + { CFI_type_int_fast16_t, "CFI_type_int_fast16_t", + sizeof (int_fast16_t), 0 }, + { CFI_type_int_fast32_t, "CFI_type_int_fast32_t", + sizeof (int_fast32_t), 0 }, + { CFI_type_int_fast64_t, "CFI_type_int_fast64_t", + sizeof (int_fast64_t), 0 }, + { CFI_type_intmax_t, "CFI_type_intmax_t", + sizeof (intmax_t), 0 }, + { CFI_type_intptr_t, "CFI_type_intptr_t", + sizeof (intptr_t), 0 }, + { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t", + sizeof (ptrdiff_t), 0 }, + { CFI_type_float, "CFI_type_float", + sizeof (float), 0 }, + { CFI_type_double, "CFI_type_double", + sizeof (double), 0 }, + { CFI_type_long_double, "CFI_type_long_double", + sizeof (long double), 0 }, + { CFI_type_float_Complex, "CFI_type_float_Complex", + sizeof (float _Complex), 0 }, + { CFI_type_double_Complex, "CFI_type_double_Complex", + sizeof (double _Complex), 0 }, + { CFI_type_long_double_Complex, "CFI_type_long_double_Complex", + sizeof (long double _Complex), 0 }, + { CFI_type_Bool, "CFI_type_Bool", + sizeof (_Bool), 0 }, + { CFI_type_char, "CFI_type_char", + sizeof (char), 0 }, + { CFI_type_cptr, "CFI_type_cptr", + sizeof (void *), 0 }, + { CFI_type_struct, "CFI_type_struct", 0, 0 }, + { CFI_type_other, "CFI_type_other", -1, 0, } +}; + +void +ctest_typecodes (void) +{ + int ncodes = sizeof (tc_table) / sizeof (struct tc_info); + int i, j; + int bad = 0; + + for (i = 0; i < ncodes; i++) + for (j = i + 1; j < ncodes; j++) + if (tc_table[i].typecode == tc_table[j].typecode + && tc_table[i].typecode > 0 + && (tc_table[i].size != tc_table[j].size)) + { + fprintf (stderr, + "type codes have the same value %d but different sizes\n", + (int) tc_table[i].typecode); + fprintf (stderr, " %s size %d\n", + tc_table[i].name, (int) tc_table[i].size); + fprintf (stderr, " %s size %d\n", + tc_table[j].name, (int) tc_table[j].size); + bad = 1; + } + + /* TS29113 Section 8.3.4: The value for CFI_type_other shall be negative + and distinct from all other type specifiers. If a C type is not + interoperable with a Fortran type and kind supported by the + Fortran processor, its macro shall evaluate to a negative value. + Otherwise, the value for an intrinsic type shall be positive. + + In the case of GCC, we expect that all the standard intrinsic + types are supported by both Fortran and C, so they should all be + positive except for CFI_type_other. Non-standard ones may have a + value -2. */ + + for (i = 0; i < ncodes; i++) + { + if (tc_table[i].typecode == CFI_type_other) + { + if (tc_table[i].typecode >= 0) + { + fprintf (stderr, "%s value %d is not negative\n", + tc_table[i].name, (int)tc_table[i].typecode); + bad = 1; + } + if (strcmp (tc_table[i].name, "CFI_type_other")) + { + fprintf (stderr, "%s has the same value %d as CFI_type_other\n", + tc_table[i].name, (int)CFI_type_other); + bad = 1; + } + } + else if (tc_table[i].typecode == -2 && tc_table[i].extension) + /* Unsupported extension type on this target; this is OK */ + ; + else if (tc_table[i].typecode <= 0) + { + fprintf (stderr, "%s value %d is not positive\n", + tc_table[i].name, (int)tc_table[i].typecode); + bad = 1; + } + } + + if (bad) + abort (); +} Index: Fortran/gfortran/regression/c-interop/typecodes-sanity.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-sanity.f90 @@ -0,0 +1,24 @@ +! PR 101305 +! { dg-do run } +! { dg-additional-sources "typecodes-sanity-c.c" } +! { dg-additional-options "-g" } +! +! This program does sanity checking on the CFI_type_* macros. All +! of the interesting things happen on the C side. + +program testit + use iso_c_binding + implicit none + + integer, parameter :: ucs4 = selected_char_kind ('ISO_10646') + + interface + + subroutine ctest_typecodes () bind (c) + end subroutine + + end interface + + call ctest_typecodes () + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-basic-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-basic-c.c @@ -0,0 +1,168 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest_int1 (CFI_cdesc_t *arg_int, + CFI_cdesc_t *arg_short, + CFI_cdesc_t *arg_long, + CFI_cdesc_t *arg_long_long, + CFI_cdesc_t *arg_signed_char); + +extern void ctest_int2 (CFI_cdesc_t *arg_int8, + CFI_cdesc_t *arg_int16, + CFI_cdesc_t *arg_int32, + CFI_cdesc_t *arg_int64); + +extern void ctest_int3 (CFI_cdesc_t *arg_least8, + CFI_cdesc_t *arg_least16, + CFI_cdesc_t *arg_least32, + CFI_cdesc_t *arg_least64); + +extern void ctest_int4 (CFI_cdesc_t *arg_fast8, + CFI_cdesc_t *arg_fast16, + CFI_cdesc_t *arg_fast32, + CFI_cdesc_t *arg_fast64); + +extern void ctest_int5 (CFI_cdesc_t *arg_size, + CFI_cdesc_t *arg_intmax, + CFI_cdesc_t *arg_intptr, + CFI_cdesc_t *arg_ptrdiff); + +extern void ctest_real (CFI_cdesc_t *arg_float, + CFI_cdesc_t *arg_double); + +extern void ctest_complex (CFI_cdesc_t *arg_float_complex, + CFI_cdesc_t *arg_double_complex); + +extern void ctest_misc (CFI_cdesc_t *arg_bool, + CFI_cdesc_t *arg_cptr, + CFI_cdesc_t *arg_cfunptr, + CFI_cdesc_t *arg_struct); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_pointer) + abort (); + if (a->base_addr != NULL) + abort (); + if (a->rank != 0) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + + +/* Test that the basic integer types correspond correctly. */ +void +ctest_int1 (CFI_cdesc_t *arg_int, + CFI_cdesc_t *arg_short, + CFI_cdesc_t *arg_long, + CFI_cdesc_t *arg_long_long, + CFI_cdesc_t *arg_signed_char) +{ + check (arg_int, sizeof (int), CFI_type_int); + check (arg_short, sizeof (short), CFI_type_short); + check (arg_long, sizeof (long), CFI_type_long); + check (arg_long_long, sizeof (long long int), CFI_type_long_long); + check (arg_signed_char, sizeof (signed char), CFI_type_signed_char); +} + +/* Test the integer types of explicit sizes. */ +void +ctest_int2 (CFI_cdesc_t *arg_int8, + CFI_cdesc_t *arg_int16, + CFI_cdesc_t *arg_int32, + CFI_cdesc_t *arg_int64) +{ + check (arg_int8, sizeof (int8_t), CFI_type_int8_t); + check (arg_int16, sizeof (int16_t), CFI_type_int16_t); + check (arg_int32, sizeof (int32_t), CFI_type_int32_t); + check (arg_int64, sizeof (int64_t), CFI_type_int64_t); +} + +/* Check the int_least*_t types. */ + +void +ctest_int3 (CFI_cdesc_t *arg_least8, + CFI_cdesc_t *arg_least16, + CFI_cdesc_t *arg_least32, + CFI_cdesc_t *arg_least64) +{ + check (arg_least8, sizeof (int_least8_t), CFI_type_int_least8_t); + check (arg_least16, sizeof (int_least16_t), CFI_type_int_least16_t); + check (arg_least32, sizeof (int_least32_t), CFI_type_int_least32_t); + check (arg_least64, sizeof (int_least64_t), CFI_type_int_least64_t); +} + +/* Check the int_fast*_t types. */ +void +ctest_int4 (CFI_cdesc_t *arg_fast8, + CFI_cdesc_t *arg_fast16, + CFI_cdesc_t *arg_fast32, + CFI_cdesc_t *arg_fast64) +{ + check (arg_fast8, sizeof (int_fast8_t), CFI_type_int_fast8_t); + check (arg_fast16, sizeof (int_fast16_t), CFI_type_int_fast16_t); + check (arg_fast32, sizeof (int_fast32_t), CFI_type_int_fast32_t); + check (arg_fast64, sizeof (int_fast64_t), CFI_type_int_fast64_t); +} + +/* Check the "purposeful" integer types. */ +void +ctest_int5 (CFI_cdesc_t *arg_size, + CFI_cdesc_t *arg_intmax, + CFI_cdesc_t *arg_intptr, + CFI_cdesc_t *arg_ptrdiff) +{ + check (arg_size, sizeof (size_t), CFI_type_size_t); + check (arg_intmax, sizeof (intmax_t), CFI_type_intmax_t); + check (arg_intptr, sizeof (intptr_t), CFI_type_intptr_t); + check (arg_ptrdiff, sizeof (ptrdiff_t), CFI_type_ptrdiff_t); +} + +/* Check the floating-point types. */ +void +ctest_real (CFI_cdesc_t *arg_float, + CFI_cdesc_t *arg_double) +{ + check (arg_float, sizeof (float), CFI_type_float); + check (arg_double, sizeof (double), CFI_type_double); +} + +/* Likewise for the complex types. */ +void +ctest_complex (CFI_cdesc_t *arg_float_complex, + CFI_cdesc_t *arg_double_complex) +{ + check (arg_float_complex, sizeof (float _Complex), + CFI_type_float_Complex); + check (arg_double_complex, sizeof (double _Complex), + CFI_type_double_Complex); +} + +/* Misc types. */ +void +ctest_misc (CFI_cdesc_t *arg_bool, + CFI_cdesc_t *arg_cptr, + CFI_cdesc_t *arg_cfunptr, + CFI_cdesc_t *arg_struct) +{ + struct m + { + int i, j; + }; + + check (arg_bool, sizeof (_Bool), CFI_type_Bool); + check (arg_cptr, sizeof (void *), CFI_type_cptr); + check (arg_struct, sizeof (struct m), CFI_type_struct); +} Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-basic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-basic.f90 @@ -0,0 +1,160 @@ +! PR 101305 +! PR 100917 +! xfailed due to PR 101308 +! { dg-do run } +! { dg-additional-sources "typecodes-scalar-basic-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that kind constants in the ISO_C_BINDING +! module result in the right type field in arguments passed by descriptor, +! also matching the size of the corresponding C type. We use pointers +! to force the use of a descriptor. +! +! Some types are tested in their own testcases to allow conditionalization +! for target-specific support or xfailing to track bugs. + +module mm + use iso_c_binding + + type, bind (c) :: s + integer(C_INT) :: i, j + end type +end module + +program testit + use iso_c_binding + use mm + implicit none + + interface + + subroutine ctest_int1 (arg_int, arg_short, arg_long, arg_long_long, & + arg_signed_char) bind (c) + use iso_c_binding + integer(C_INT), pointer :: arg_int + integer(C_SHORT), pointer :: arg_short + integer(C_LONG), pointer :: arg_long + integer(C_LONG_LONG), pointer :: arg_long_long + integer(C_SIGNED_CHAR), pointer :: arg_signed_char + end subroutine + + subroutine ctest_int2 (arg_int8, arg_int16, arg_int32, arg_int64) bind (c) + use iso_c_binding + integer(C_INT8_T), pointer :: arg_int8 + integer(C_INT16_T), pointer :: arg_int16 + integer(C_INT32_T), pointer :: arg_int32 + integer(C_INT64_T), pointer :: arg_int64 + end subroutine + + subroutine ctest_int3 (arg_least8, arg_least16, arg_least32, & + arg_least64) bind (c) + use iso_c_binding + integer(C_INT_LEAST8_T), pointer :: arg_least8 + integer(C_INT_LEAST16_T), pointer :: arg_least16 + integer(C_INT_LEAST32_T), pointer :: arg_least32 + integer(C_INT_LEAST64_T), pointer :: arg_least64 + end subroutine + + subroutine ctest_int4 (arg_fast8, arg_fast16, arg_fast32, & + arg_fast64) bind (c) + use iso_c_binding + integer(C_INT_FAST8_T), pointer :: arg_fast8 + integer(C_INT_FAST16_T), pointer :: arg_fast16 + integer(C_INT_FAST32_T), pointer :: arg_fast32 + integer(C_INT_FAST64_T), pointer :: arg_fast64 + end subroutine + + subroutine ctest_int5 (arg_size, arg_intmax, arg_intptr, & + arg_ptrdiff) bind (c) + use iso_c_binding + integer(C_SIZE_T), pointer :: arg_size + integer(C_INTMAX_T), pointer :: arg_intmax + integer(C_INTPTR_T), pointer :: arg_intptr + integer(C_PTRDIFF_T), pointer :: arg_ptrdiff + end subroutine + + subroutine ctest_real (arg_float, arg_double) bind (c) + use iso_c_binding + real(C_FLOAT), pointer :: arg_float + real(C_DOUBLE), pointer :: arg_double + end subroutine + + subroutine ctest_complex (arg_float_complex, arg_double_complex) & + bind (c) + use iso_c_binding + complex(C_FLOAT_COMPLEX), pointer :: arg_float_complex + complex(C_DOUBLE_COMPLEX), pointer :: arg_double_complex + end subroutine + + subroutine ctest_misc (arg_bool, arg_cptr, arg_cfunptr, arg_struct) & + bind (c) + use iso_c_binding + use mm + logical(C_BOOL), pointer :: arg_bool + type(C_PTR), pointer :: arg_cptr + type(C_FUNPTR), pointer :: arg_cfunptr + type(s), pointer :: arg_struct + end subroutine + + end interface + + integer(C_INT), pointer :: var_int + integer(C_SHORT), pointer :: var_short + integer(C_LONG), pointer :: var_long + integer(C_LONG_LONG), pointer :: var_long_long + integer(C_SIGNED_CHAR), pointer :: var_signed_char + integer(C_INT8_T), pointer :: var_int8 + integer(C_INT16_T), pointer :: var_int16 + integer(C_INT32_T), pointer :: var_int32 + integer(C_INT64_T), pointer :: var_int64 + integer(C_INT_LEAST8_T), pointer :: var_least8 + integer(C_INT_LEAST16_T), pointer :: var_least16 + integer(C_INT_LEAST32_T), pointer :: var_least32 + integer(C_INT_LEAST64_T), pointer :: var_least64 + integer(C_INT_FAST8_T), pointer :: var_fast8 + integer(C_INT_FAST16_T), pointer :: var_fast16 + integer(C_INT_FAST32_T), pointer :: var_fast32 + integer(C_INT_FAST64_T), pointer :: var_fast64 + integer(C_SIZE_T), pointer :: var_size + integer(C_INTMAX_T), pointer :: var_intmax + integer(C_INTPTR_T), pointer :: var_intptr + integer(C_PTRDIFF_T), pointer :: var_ptrdiff + real(C_FLOAT), pointer :: var_float + real(C_DOUBLE), pointer :: var_double + complex(C_FLOAT_COMPLEX), pointer :: var_float_complex + complex(C_DOUBLE_COMPLEX), pointer :: var_double_complex + logical(C_BOOL), pointer :: var_bool + type(C_PTR), pointer :: var_cptr + type(C_FUNPTR), pointer :: var_cfunptr + type(s), pointer :: var_struct + + nullify (var_int, var_short, var_long, var_long_long, var_signed_char) + call ctest_int1 (var_int, var_short, var_long, var_long_long, & + var_signed_char) + + nullify (var_int8, var_int16, var_int32, var_int64) + call ctest_int2 (var_int8, var_int16, var_int32, var_int64) + + nullify (var_least8, var_least16, var_least32, var_least64) + call ctest_int3 (var_least8, var_least16, var_least32, var_least64) + + nullify (var_fast8, var_fast16, var_fast32, var_fast64) + call ctest_int4 (var_fast8, var_fast16, var_fast32, var_fast64) + + nullify (var_size, var_intmax, var_intptr, var_ptrdiff) + call ctest_int5 (var_size, var_intmax, var_intptr, var_ptrdiff) + + nullify (var_float, var_double) + call ctest_real (var_float, var_double) + + nullify (var_float_complex, var_double_complex) + call ctest_complex (var_float_complex, var_double_complex) + + nullify (var_bool, var_cptr, var_cfunptr, var_struct) + call ctest_misc (var_bool, var_cptr, var_cfunptr, var_struct) + + ! FIXME: how do you pass something that corresponds to CFI_type_other? + ! The Fortran front end complains if you try to pass something that + ! isn't interoperable, such as a derived type object without bind(c). + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-float128-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-float128-c.c @@ -0,0 +1,38 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_float128, + CFI_cdesc_t *arg_complex128); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_pointer) + abort (); + if (a->base_addr != NULL) + abort (); + if (a->rank != 0) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_float128, + CFI_cdesc_t *arg_complex128) +{ + check (arg_float128, sizeof (_Float128), CFI_type_float128); + check (arg_complex128, sizeof (_Float128) * 2, + CFI_type_float128_Complex); +} + Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-float128.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-float128.f90 @@ -0,0 +1,34 @@ +! xfailed due to PR 101308 +! PR 101305 +! PR 100914 +! { dg-do run } +! { dg-require-effective-target fortran_real_c_float128 } +! { dg-additional-sources "typecodes-scalar-float128-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that the vendor extension kind constants provided by +! gfortran's ISO_C_BINDING module result in the right type field in +! arguments passed by descriptor,also matching the size of the corresponding +! C type. We use pointers to force the use of a descriptor. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_float128, arg_complex128) bind (c) + use iso_c_binding + real(C_FLOAT128), pointer :: arg_float128 + complex(C_FLOAT128_COMPLEX), pointer :: arg_complex128 + end subroutine + + end interface + + real(C_FLOAT128), pointer :: var_float128 + complex(C_FLOAT128_COMPLEX), pointer :: var_complex128 + + nullify (var_float128, var_complex128) + call ctest (var_float128, var_complex128) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-int128-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-int128-c.c @@ -0,0 +1,41 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_int128, + CFI_cdesc_t *arg_least128, + CFI_cdesc_t *arg_fast128); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_pointer) + abort (); + if (a->base_addr != NULL) + abort (); + if (a->rank != 0) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_int128, + CFI_cdesc_t *arg_least128, + CFI_cdesc_t *arg_fast128) +{ + check (arg_int128, sizeof (__int128), CFI_type_int128_t); + check (arg_least128, sizeof (__int128), CFI_type_int_least128_t); + check (arg_fast128, sizeof (__int128), CFI_type_int_fast128_t); +} + + Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-int128.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-int128.f90 @@ -0,0 +1,35 @@ +! PR 101305 +! xfailed due to PR 101308 +! { dg-do run } +! { dg-require-effective-target fortran_integer_16 } +! { dg-additional-sources "typecodes-scalar-int128-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that 128-bit integer kind constants provided by +! gfortran's ISO_C_BINDING module result in the right type field in +! arguments passed by descriptor, also matching the size of the corresponding +! C type. We use pointers to force the use of a descriptor. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_int128, arg_least128, arg_fast128) bind (c) + use iso_c_binding + integer(C_INT128_T), pointer :: arg_int128 + integer(C_INT_LEAST128_T), pointer :: arg_least128 + integer(C_INT_FAST128_T), pointer :: arg_fast128 + end subroutine + + end interface + + integer(C_INT128_T), pointer :: var_int128 + integer(C_INT_LEAST128_T), pointer :: var_least128 + integer(C_INT_FAST128_T), pointer :: var_fast128 + + nullify (var_int128, var_least128, var_fast128) + call ctest (var_int128, var_least128, var_fast128) + +end program Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-longdouble-c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-longdouble-c.c @@ -0,0 +1,37 @@ +#include +#include +#include +#include + +#include +#include "dump-descriptors.h" + +extern void ctest (CFI_cdesc_t *arg_long_double, + CFI_cdesc_t *arg_long_double_complex); + +/* Sanity check the type info in the descriptor a. */ + +static void +check (CFI_cdesc_t *a, size_t size, int typecode) +{ + dump_CFI_cdesc_t (a); + if (a->attribute != CFI_attribute_pointer) + abort (); + if (a->base_addr != NULL) + abort (); + if (a->rank != 0) + abort (); + if (size && a->elem_len != size) + abort (); + if (a->type != typecode) + abort (); +} + +void +ctest (CFI_cdesc_t *arg_long_double, + CFI_cdesc_t *arg_long_double_complex) +{ + check (arg_long_double, sizeof (long double), CFI_type_long_double); + check (arg_long_double_complex, sizeof (long double _Complex), + CFI_type_long_double_Complex); +} Index: Fortran/gfortran/regression/c-interop/typecodes-scalar-longdouble.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/typecodes-scalar-longdouble.f90 @@ -0,0 +1,33 @@ +! xfailed due to PR 101308 +! PR 101305 +! PR 100917 +! { dg-do run } +! { dg-additional-sources "typecodes-scalar-longdouble-c.c dump-descriptors.c" } +! { dg-additional-options "-g" } +! +! This program tests that long double kind constants in the ISO_C_BINDING +! module result in the right type field in arguments passed by descriptor, +! also matching the size of the corresponding C type. We use pointers +! to force the use of a descriptor. + +program testit + use iso_c_binding + implicit none + + interface + + subroutine ctest (arg_long_double, arg_long_double_complex) bind (c) + use iso_c_binding + real(C_LONG_DOUBLE), pointer :: arg_long_double + complex(C_LONG_DOUBLE_COMPLEX), pointer :: arg_long_double_complex + end subroutine + + end interface + + real(C_LONG_DOUBLE), pointer :: var_long_double + complex(C_LONG_DOUBLE_COMPLEX), pointer :: var_long_double_complex + + nullify (var_long_double, var_long_double_complex) + call ctest (var_long_double, var_long_double_complex) + +end program Index: Fortran/gfortran/regression/c-interop/ubound-bindc.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ubound-bindc.f90 @@ -0,0 +1,129 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.3 UBOUND +! +! The description of the intrinsic function UBOUND in ISO/IEC +! 1539-1:2010 is changed for an assumed-rank object that is associated +! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY), +! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with +! KIND omitted from LBOUND if it was omitted from UBOUND. +! +! NOTE 6.2 +! If LBOUND or UBOUND is invoked for an assumed-rank object that is +! associated with a scalar and DIM is absent, the result is a zero-sized +! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object +! that is associated with a scalar if DIM is present because the rank of +! a scalar is zero and DIM must be ≥ 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call testit2(x1, shape(x1)) + call test1 (y1) + call testit2(y1, shape(y1)) + p1 => x1 + call testit2(p1, shape(p1)) + call testit2p(p1, lbound(p1), shape(p1)) + call test1 (p1) + p1(77:) => x1 + call testit2p(p1, [77], shape(p1)) + allocate (a1(5)) + call testit2(a1, shape(a1)) + call testit2a(a1, lbound(a1), shape(a1)) + call test1 (a1) + deallocate(a1) + allocate (a1(-38:5)) + call test1 (a1) + call testit2(a1, shape(a1)) + call testit2a(a1, [-38], shape(a1)) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test some scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a) bind(c) + integer :: a(..) + integer :: r + r = rank(a) + if (any (lbound (a) .ne. 1)) stop 101 + if (ubound (a, r) .ne. -1) stop 102 + end subroutine + + subroutine testit2(a, shape) bind(c) + integer :: a(..) + integer :: shape(:) + if (rank(a) /= size(shape)) stop 111 + if (any (lbound(a) /= 1)) stop 112 + if (any (ubound(a) /= shape)) stop 113 + end subroutine + + subroutine testit2a(a,lbound2, shape2) bind(c) + integer, allocatable :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 121 + if (any (lbound(a) /= lbound2)) stop 122 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123 + if (any (shape(a) /= shape2)) stop 124 + if (sum (shape(a)) /= size(a)) stop 125 + end subroutine + + subroutine testit2p(a, lbound2, shape2) bind(c) + integer, pointer :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 131 + if (any (lbound(a) /= lbound2)) stop 132 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133 + if (any (shape(a) /= shape2)) stop 134 + if (sum (shape(a)) /= size(a)) stop 135 + end subroutine + + subroutine test0 (a) bind(c) + integer :: a(..) + if (rank (a) .ne. 0) stop 141 + if (size (lbound (a)) .ne. 0) stop 142 + if (size (ubound (a)) .ne. 0) stop 143 + end subroutine + + subroutine test1 (a) bind(c) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) bind(c) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ubound-poly.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ubound-poly.f90 @@ -0,0 +1,145 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.3 UBOUND +! +! The description of the intrinsic function UBOUND in ISO/IEC +! 1539-1:2010 is changed for an assumed-rank object that is associated +! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY), +! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with +! KIND omitted from LBOUND if it was omitted from UBOUND. +! +! NOTE 6.2 +! If LBOUND or UBOUND is invoked for an assumed-rank object that is +! associated with a scalar and DIM is absent, the result is a zero-sized +! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object +! that is associated with a scalar if DIM is present because the rank of +! a scalar is zero and DIM must be ≥ 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. +! +! This is like ubound.f90, but using polymorphic arrays instead of integer +! arrays. + +module m + type :: t + integer :: id + real :: xyz(3) + end type +end module + +program test + use m + + ! Define some arrays for testing. + type(t), target :: x1(5) + type(t) :: y1(0:9) + class(t), pointer :: p1(:) + class(t), allocatable :: a1(:) + type(t), target :: x3(2,3,4) + type(t) :: y3(0:1,-3:-1,4) + class(t), pointer :: p3(:,:,:) + type(t), allocatable :: a3(:,:,:) + type(t) :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call testit2(x1, shape(x1)) + call test1 (y1) + call testit2(y1, shape(y1)) + p1 => x1 + call testit2(p1, shape(p1)) + call testit2p(p1, lbound(p1), shape(p1)) + call test1 (p1) + p1(77:) => x1 + call testit2p(p1, [77], shape(p1)) + allocate (a1(5)) + call testit2(a1, shape(a1)) + call testit2a(a1, lbound(a1), shape(a1)) + call test1 (a1) + deallocate(a1) + allocate (a1(-38:5)) + call test1 (a1) + call testit2(a1, shape(a1)) + call testit2a(a1, [-38], shape(a1)) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test some scalars. + call test0 (x) + call test0 (x1(1)) + +contains + + subroutine testit (a) + use m + class(t) :: a(..) + integer :: r + r = rank(a) + if (any (lbound (a) .ne. 1)) stop 101 + if (ubound (a, r) .ne. -1) stop 102 + end subroutine + + subroutine testit2(a, shape) + use m + class(t) :: a(..) + integer :: shape(:) + if (rank(a) /= size(shape)) stop 111 + if (any (lbound(a) /= 1)) stop 112 + if (any (ubound(a) /= shape)) stop 113 + end subroutine + + subroutine testit2a(a,lbound2, shape2) + use m + class(t), allocatable :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 121 + if (any (lbound(a) /= lbound2)) stop 122 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123 + if (any (shape(a) /= shape2)) stop 124 + if (sum (shape(a)) /= size(a)) stop 125 + end subroutine + + subroutine testit2p(a, lbound2, shape2) + use m + class(t), pointer :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 131 + if (any (lbound(a) /= lbound2)) stop 132 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133 + if (any (shape(a) /= shape2)) stop 134 + if (sum (shape(a)) /= size(a)) stop 135 + end subroutine + + subroutine test0 (a) + use m + class(t) :: a(..) + if (rank (a) .ne. 0) stop 141 + if (size (lbound (a)) .ne. 0) stop 142 + if (size (ubound (a)) .ne. 0) stop 143 + end subroutine + + subroutine test1 (a) + use m + class(t) :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + use m + integer :: l1, u1, l2, u2 + class(t) :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/c-interop/ubound.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/c-interop/ubound.f90 @@ -0,0 +1,129 @@ +! { dg-do run } +! +! TS 29113 +! 6.4.3 UBOUND +! +! The description of the intrinsic function UBOUND in ISO/IEC +! 1539-1:2010 is changed for an assumed-rank object that is associated +! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY), +! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with +! KIND omitted from LBOUND if it was omitted from UBOUND. +! +! NOTE 6.2 +! If LBOUND or UBOUND is invoked for an assumed-rank object that is +! associated with a scalar and DIM is absent, the result is a zero-sized +! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object +! that is associated with a scalar if DIM is present because the rank of +! a scalar is zero and DIM must be ≥ 1. +! +! The idea here is that the main program passes some arrays to a test +! subroutine with an assumed-size dummy, which in turn passes that to a +! subroutine with an assumed-rank dummy. + +program test + + ! Define some arrays for testing. + integer, target :: x1(5) + integer :: y1(0:9) + integer, pointer :: p1(:) + integer, allocatable :: a1(:) + integer, target :: x3(2,3,4) + integer :: y3(0:1,-3:-1,4) + integer, pointer :: p3(:,:,:) + integer, allocatable :: a3(:,:,:) + integer :: x + + ! Test the 1-dimensional arrays. + call test1 (x1) + call testit2(x1, shape(x1)) + call test1 (y1) + call testit2(y1, shape(y1)) + p1 => x1 + call testit2(p1, shape(p1)) + call testit2p(p1, lbound(p1), shape(p1)) + call test1 (p1) + p1(77:) => x1 + call testit2p(p1, [77], shape(p1)) + allocate (a1(5)) + call testit2(a1, shape(a1)) + call testit2a(a1, lbound(a1), shape(a1)) + call test1 (a1) + deallocate(a1) + allocate (a1(-38:5)) + call test1 (a1) + call testit2(a1, shape(a1)) + call testit2a(a1, [-38], shape(a1)) + + ! Test the multi-dimensional arrays. + call test3 (x3, 1, 2, 1, 3) + call test3 (y3, 0, 1, -3, -1) + p3 => x3 + call test3 (p3, 1, 2, 1, 3) + allocate (a3(2,3,4)) + call test3 (a3, 1, 2, 1, 3) + + ! Test some scalars. + call test0 (x) + call test0 (-1) + call test0 (x1(1)) + +contains + + subroutine testit (a) + integer :: a(..) + integer :: r + r = rank(a) + if (any (lbound (a) .ne. 1)) stop 101 + if (ubound (a, r) .ne. -1) stop 102 + end subroutine + + subroutine testit2(a, shape) + integer :: a(..) + integer :: shape(:) + if (rank(a) /= size(shape)) stop 111 + if (any (lbound(a) /= 1)) stop 112 + if (any (ubound(a) /= shape)) stop 113 + end subroutine + + subroutine testit2a(a,lbound2, shape2) + integer, allocatable :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 121 + if (any (lbound(a) /= lbound2)) stop 122 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123 + if (any (shape(a) /= shape2)) stop 124 + if (sum (shape(a)) /= size(a)) stop 125 + end subroutine + + subroutine testit2p(a, lbound2, shape2) + integer, pointer :: a(..) + integer :: lbound2(:), shape2(:) + if (rank(a) /= size(shape2)) stop 131 + if (any (lbound(a) /= lbound2)) stop 132 + if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133 + if (any (shape(a) /= shape2)) stop 134 + if (sum (shape(a)) /= size(a)) stop 135 + end subroutine + + subroutine test0 (a) + integer :: a(..) + if (rank (a) .ne. 0) stop 141 + if (size (lbound (a)) .ne. 0) stop 142 + if (size (ubound (a)) .ne. 0) stop 143 + end subroutine + + subroutine test1 (a) + integer :: a(*) + + call testit (a) + end subroutine + + subroutine test3 (a, l1, u1, l2, u2) + implicit none + integer :: l1, u1, l2, u2 + integer :: a(l1:u1, l2:u2, *) + + call testit (a) + end subroutine + +end program Index: Fortran/gfortran/regression/coarray/alloc_comp_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/alloc_comp_1.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! +! Allocatable scalar corrays were mishandled (ICE) +! +type t + integer, allocatable :: caf[:] +end type t +type(t) :: a +allocate (a%caf[3:*]) +a%caf = 7 +if (a%caf /= 7) STOP 1 +if (any (lcobound (a%caf) /= [ 3 ]) & + .or. ucobound (a%caf, dim=1) /= num_images ()+2) & + STOP 2 +deallocate (a%caf) +end Index: Fortran/gfortran/regression/coarray/alloc_comp_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/alloc_comp_2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/56929 +! +! Contributed by Damian Rouson +! +! Allocatable scalar corrays were mishandled (ICE) +! +module parent_coarray_component + type parent + real, allocatable :: dummy[:] + end type + type, extends(parent) :: child + end type +contains + subroutine do_something(this) + class(child) this + end +end Index: Fortran/gfortran/regression/coarray/alloc_comp_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/alloc_comp_3.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! +! PR fortran/60881 +! +! Contributed by Damian Rouson +! +! Was ICEing before +! +program main + implicit none + type co_object + logical :: defined=.false. + real, allocatable :: dummy_to_facilitate_extension[:] + end type + type, extends(co_object) :: global_field + end type + type(global_field) T + call assign_local_field(T) +contains + subroutine assign_local_field(lhs) + type(global_field) lhs + end subroutine +end program Index: Fortran/gfortran/regression/coarray/alloc_comp_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/alloc_comp_4.f90 @@ -0,0 +1,21 @@ +! { dg-do run } + +! Contributed by Damian Rouson + +program main + + implicit none + + type mytype + integer, allocatable :: indices(:) + end type + + type(mytype), save :: object[*] + integer :: me + + me=this_image() + allocate(object%indices(me)) + object%indices = 42 + + if ( any( object[me]%indices(:) /= 42 ) ) STOP 1 +end program Index: Fortran/gfortran/regression/coarray/alloc_comp_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/alloc_comp_5.f90 @@ -0,0 +1,17 @@ +! { dg-do run } + +program Jac + type Domain + integer :: n=64 + integer,allocatable :: endsi(:) + end type + type(Domain),allocatable :: D[:,:,:] + + allocate(D[2,2,*]) + allocate(D%endsi(2), source = 0) + ! No caf-runtime call needed her. + D%endsi(2) = D%n + if (any(D%endsi /= [ 0, 64])) error stop + deallocate(D) +end program + Index: Fortran/gfortran/regression/coarray/allocate_errgmsg.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/allocate_errgmsg.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Check handling of errmsg. +! +implicit none +integer, allocatable :: a[:], b(:)[:], c, d(:) +integer :: stat +character(len=300) :: str + +allocate(a[*], b(1)[*], c, d(2), stat=stat) + +str = repeat('X', len(str)) +allocate(a[*], stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + STOP 1 + +str = repeat('Y', len(str)) +allocate(b(2)[*], stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + STOP 2 + +str = repeat('Q', len(str)) +allocate(c, stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + STOP 3 + +str = repeat('P', len(str)) +allocate(d(3), stat=stat, errmsg=str) +!print *, stat, trim(str) +if (stat == 0 .or. str /= "Attempt to allocate an allocated object") & + STOP 4 + +end Index: Fortran/gfortran/regression/coarray/array_temporary-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/array_temporary-1.f90 @@ -0,0 +1,13 @@ +! PR fortran/99010 +! +! Follow-up to PR fortran/98913 +! +! Contributed by G. Steinmetz +! +program p + integer :: x[*] + x = this_image() + if ( this_image() == 2 ) then + x = x[1] + end if +end Index: Fortran/gfortran/regression/coarray/array_temporary.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/array_temporary.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-additional-options "-Warray-temporaries" } +! +! PR fortran/98913 +! +! Contributed by Jorge D'Elia +! +! Did create an array temporary for local access to coarray +! (but not for identical noncoarray use). +! + +program test + implicit none + integer, parameter :: iin = kind (1) + integer, parameter :: idp = kind (1.0d0) + real (kind=idp), allocatable :: AA (:,:)[:] + real (kind=idp), allocatable :: BB (:,:) + real (kind=idp), allocatable :: UU (:) + integer (kind=iin) :: nn, n1, n2 + integer (kind=iin) :: j, k, k1 + ! + nn = 5 + n1 = 1 + n2 = 10 + ! + allocate (AA (1:nn,n1:n2)[*]) + allocate (BB (1:nn,n1:n2)) + allocate (UU (1:nn)) + ! + k = 1 + k1 = k + 1 + ! + AA = 1.0_idp + BB = 1.0_idp + UU = 2.0_idp + + ! AA - coarrays + ! No temporary needed: + do j = 1, nn + AA (k1:nn,j) = AA (k1:nn,j) - UU (k1:nn) * AA (k,j) ! { dg-bogus "Creating array temporary" } + end do + do j = 1, nn + AA (k1:nn,j) = AA (k1:nn,j) - UU (k1:nn) * AA (k,j) - UU(k) * AA (k1-1:nn-1,j) ! { dg-bogus "Creating array temporary" } + end do + do j = 1, nn + AA (k1:nn,j) = AA (k1:nn,j) - UU (k1:nn) * AA (k,j) - UU(k) * AA (k1+1:nn+1,j) ! { dg-bogus "Creating array temporary" } + end do + + ! But: + do j = 1, nn + AA (k1:nn,j) = AA (k1-1:nn-1,j) - UU (k1:nn) * AA (k,j) - UU(k) * AA (k1+1:nn+1,j) ! { dg-warning "Creating array temporary" } + end do + + ! BB - no coarrays + ! No temporary needed: + do j = 1, nn + BB (k1:nn,j) = BB (k1:nn,j) - UU (k1:nn) * BB (k,j) ! { dg-bogus "Creating array temporary" } + end do + do j = 1, nn + BB (k1:nn,j) = BB (k1:nn,j) - UU (k1:nn) * BB (k,j) - UU(k) * BB (k1-1:nn-1,j) ! { dg-bogus "Creating array temporary" } + end do + do j = 1, nn + BB (k1:nn,j) = BB (k1:nn,j) - UU (k1:nn) * BB (k,j) - UU(k) * BB (k1+1:nn+1,j) ! { dg-bogus "Creating array temporary" } + end do + + ! But: + do j = 1, nn + BB (k1:nn,j) = BB (k1-1:nn-1,j) - UU (k1:nn) * BB (k,j) - UU(k) * BB (k1+1:nn+1,j) ! { dg-warning "Creating array temporary" } + end do + + deallocate (AA) + deallocate (BB) + deallocate (UU) +end program test Index: Fortran/gfortran/regression/coarray/atomic_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/atomic_1.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! Basic atomic def/ref test +! + +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none +integer(atomic_int_kind) :: a(1)[*] +logical(atomic_logical_kind) :: c[*] +intrinsic :: atomic_define +intrinsic :: atomic_ref +integer(8) :: b +logical(1) :: d + +call atomic_define(a(1), 7_2) +call atomic_ref(b, a(1)) +if (b /= a(1)) STOP 1 + +call atomic_define(c, .false.) +call atomic_ref(d, c[this_image()]) +if (d .neqv. .false.) STOP 2 +call atomic_define(c[this_image()], .true.) +call atomic_ref(d, c) +if (d .neqv. .true.) STOP 3 +end Index: Fortran/gfortran/regression/coarray/atomic_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/atomic_2.f90 @@ -0,0 +1,653 @@ +! { dg-do run } +! +use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind +implicit none + +intrinsic :: atomic_define +intrinsic :: atomic_ref +intrinsic :: atomic_cas +intrinsic :: atomic_add +intrinsic :: atomic_and +intrinsic :: atomic_or +intrinsic :: atomic_xor +intrinsic :: atomic_fetch_add +intrinsic :: atomic_fetch_and +intrinsic :: atomic_fetch_or +intrinsic :: atomic_fetch_xor +integer(atomic_int_kind) :: caf[*], var, var3 +logical(atomic_logical_kind) :: caf_log[*], var2 +integer :: stat, i + +caf = 0 +caf_log = .false. +sync all + +if (this_image() == 1) then + call atomic_define(caf[num_images()], 5, stat=stat) + if (stat /= 0) STOP 1 + call atomic_define(caf_log[num_images()], .true., stat=stat) + if (stat /= 0) STOP 2 +end if +sync all + +if (this_image() == num_images()) then + if (caf /= 5) STOP 3 + if (.not. caf_log) STOP 4 + var = 99 + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var /= 5) STOP 5 + var2 = .false. + call atomic_ref(var2, caf_log, stat=stat) + if (stat /= 0 .or. .not. var2) STOP 6 +end if +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 5) STOP 7 +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. .not. var2) STOP 8 +sync all + +! ADD +caf = 0 +sync all + +call atomic_add(caf, this_image(), stat=stat) +if (stat /= 0) STOP 9 +do i = 1, num_images() + call atomic_add(caf[i], 1, stat=stat) + if (stat /= 0) STOP 10 + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var < this_image()) STOP 11 +end do +sync all + +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 12 +do i = 1, num_images() + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= num_images() + i) STOP 13 +end do +sync all + +! AND(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 14 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 15 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 16 + end if + end do +end if +sync all + +! AND(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 17 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 18 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 19 + end if + end do +end if +sync all + +! AND(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_and(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 20 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 21 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 22 + end if + end do +end if +sync all + +! OR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 23 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 24 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 25 + end if + end do +end if +sync all + +! OR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 26 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 27 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 28 + end if + end do +end if +sync all + +! OR(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_or(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 29 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 30 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 31 + end if + end do +end if +sync all + +! XOR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 32 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 33 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 34 + end if + end do +end if +sync all + +! XOR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 35 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 36 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 37 + end if + end do +end if +sync all + +! XOR(3) +caf = 0 +do i = 1, storage_size(caf)-2, 2 + caf = shiftl(1, i) + var3 = shiftl(1, i) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat) + if (stat /= 0) STOP 38 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 39 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 40 + end if + end do +end if +sync all + +! ADD +caf = 0 +sync all +var = -99 +call atomic_fetch_add(caf, this_image(), var, stat=stat) +if (stat /= 0 .or. var < 0) STOP 41 +if (num_images() == 1 .and. var /= 0) STOP 42 +do i = 1, num_images() + var = -99 + call atomic_fetch_add(caf[i], 1, var, stat=stat) + if (stat /= 0 .or. var < 0) STOP 43 + call atomic_ref(var, caf, stat=stat) + if (stat /= 0 .or. var < this_image()) STOP 44 +end do +sync all + +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= num_images() + this_image()) STOP 45 +do i = 1, num_images() + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= num_images() + i) STOP 46 +end do +sync all + + +! AND(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = 99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var /= 0) STOP 47 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 48 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 49 + end if + end do +end if +sync all + +! AND(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var == shiftl(1, this_image())) STOP 50 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 51 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 52 + end if + end do +end if +sync all + +! AND(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) STOP 53 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = iand(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 54 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 55 + end if + end do +end if +sync all + + + +! OR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) STOP 56 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 57 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 58 + end if + end do +end if +sync all + +! OR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 59 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 60 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 61 + end if + end do +end if +sync all + +! OR(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) STOP 62 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ior(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 63 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 64 + end if + end do +end if +sync all + + +! XOR(1) +caf = 0 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) STOP 65 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = 0 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 66 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 67 + end if + end do +end if +sync all + +! XOR(2) +caf = -1 +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. (var < 0 .and. var /= -1)) STOP 68 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + var3 = -1 + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 69 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 70 + end if + end do +end if +sync all + +! XOR(3) +caf = 0 +var3 = 0 +do i = 1, storage_size(caf)-2, 2 + caf = ior(shiftl(1, i), caf) + var3 = ior(shiftl(1, i), var3) +end do +sync all + +if (this_image() < storage_size(caf)-2) then + do i = this_image(), min(num_images(), storage_size(caf)-2) + var = -99 + call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat) + if (stat /= 0 .or. var <= 0) STOP 71 + end do +end if +sync all + +if (this_image() < storage_size(caf)-2) then + do i = 1, min(num_images(), storage_size(caf)-2) + var3 = ieor(var3, shiftl(1, i)) + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 72 + if (i == this_image()) then + call atomic_ref(var, caf[i], stat=stat) + if (stat /= 0 .or. var /= var3) STOP 73 + end if + end do +end if +sync all + +! CAS +caf = 9 +caf_log = .true. +sync all + +if (this_image() == 1) then + call atomic_cas(caf[num_images()], compare=5, new=3, old=var, stat=stat) + if (stat /= 0 .or. var /= 9) STOP 74 + call atomic_ref(var, caf[num_images()], stat=stat) + if (stat /= 0 .or. var /= 9) STOP 75 +end if +sync all + +if (this_image() == num_images() .and. caf /= 9) STOP 76 +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 9) STOP 77 +sync all + +if (this_image() == 1) then + call atomic_cas(caf[num_images()], compare=9, new=3, old=var, stat=stat) + if (stat /= 0 .or. var /= 9) STOP 78 + call atomic_ref(var, caf[num_images()], stat=stat) + if (stat /= 0 .or. var /= 3) STOP 79 +end if +sync all + +if (this_image() == num_images() .and. caf /= 3) STOP 80 +call atomic_ref(var, caf[num_images()], stat=stat) +if (stat /= 0 .or. var /= 3) STOP 81 +sync all + + +if (this_image() == 1) then + call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) STOP 82 + call atomic_ref(var2, caf_log[num_images()], stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) STOP 83 +end if +sync all + +if (this_image() == num_images() .and. caf_log .neqv. .true.) STOP 84 +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. var2 .neqv. .true.) STOP 85 +sync all + +if (this_image() == 1) then + call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat) + if (stat /= 0 .or. var2 .neqv. .true.) STOP 86 + call atomic_ref(var2, caf_log[num_images()], stat=stat) + if (stat /= 0 .or. var2 .neqv. .false.) STOP 87 +end if +sync all + +if (this_image() == num_images() .and. caf_log .neqv. .false.) STOP 88 +call atomic_ref(var2, caf_log[num_images()], stat=stat) +if (stat /= 0 .or. var2 .neqv. .false.) STOP 89 +end Index: Fortran/gfortran/regression/coarray/caf.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/caf.exp @@ -0,0 +1,112 @@ +# Copyright (C) 2011-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . +# +# Contributed by Tobias Burnus + + +# Test coarray support. +# +# For the compilation tests, all files are compiles with the +# option -fcoarray=single and with -fcoarray=lib +# +# For the link and execution tests, for -fcoarray=lib the +# libcaf_single library is linked. Additionally, with the +# required settings another CAF library is used. + +# Load procedures from common libraries. +load_lib gfortran-dg.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_FFLAGS +if ![info exists DEFAULT_FFLAGS] then { + set DEFAULT_FFLAGS " -pedantic-errors" +} + +dg-init + +global runtests +global DG_TORTURE_OPTIONS torture_with_loops + +torture-init +set-torture-options $DG_TORTURE_OPTIONS + +global gfortran_test_path +global gfortran_aux_module_flags +set gfortran_test_path $srcdir/$subdir +set gfortran_aux_module_flags $DEFAULT_FFLAGS +proc dg-compile-aux-modules { args } { + global gfortran_test_path + global gfortran_aux_module_flags + if { [llength $args] != 2 } { + error "dg-compile-aux-modules: needs one argument" + return + } + + set level [info level] + if { [info procs dg-save-unknown] != [list] } { + rename dg-save-unknown dg-save-unknown-level-$level + } + + dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags + # cleanup-modules is intentionally not invoked here. + + if { [info procs dg-save-unknown-level-$level] != [list] } { + rename dg-save-unknown-level-$level dg-save-unknown + } +} + +# Add -latomic only where supported. Assume built-in support elsewhere. +set maybe_atomic_lib "" +if [check_effective_target_libatomic_available] { + set maybe_atomic_lib "-latomic" +} + +# Main loop. +foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $test] then { + continue + } + +# Enable if you want to test several options: +# # look if this is dg-do-run test, in which case +# # we cycle through the option list, otherwise we don't +# if [expr [search_for $test "dg-do run"]] { +# set option_list $torture_with_loops +# } else { +# set option_list [list { -O } ] +# } + set option_list [list { -O2 } ] + + set nshort [file tail [file dirname $test]]/[file tail $test] + list-module-names $test + + foreach flags $option_list { + verbose "Testing $nshort (single), $flags" 1 + set gfortran_aux_module_flags "-fcoarray=single $flags" + dg-test $test "-fcoarray=single $flags $maybe_atomic_lib" "" + cleanup-modules "" + } + + foreach flags $option_list { + verbose "Testing $nshort (libcaf_single), $flags" 1 + set gfortran_aux_module_flags "-fcoarray=lib $flags -lcaf_single" + dg-test $test "-fcoarray=lib $flags -lcaf_single $maybe_atomic_lib" "" + cleanup-modules "" + } +} +torture-finish +dg-finish Index: Fortran/gfortran/regression/coarray/coarray_allocated.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/coarray_allocated.f90 @@ -0,0 +1,55 @@ +! { dg-do run } +! { dg-additional-options "-fdump-tree-original" } +! PR fortran/93834 - ICE in trans_caf_is_present + +program p + type t + integer, allocatable :: x[:,:,:] + end type t + integer, allocatable :: a[:] + type(t) :: c + if (allocated (a)) stop 1 + if (allocated (c%x)) stop 2 + + ! The coindexed scalar (!) variable is regarded as allocatable but + ! we can check the value on any image of the team as they are + ! established collectively. As tested by the dump, we do it on + ! this_image (). + ! + ! For this reason, -fcoarray=single and -fcoarray=lib give the + ! same result + if (allocated (a[1])) stop 3 + if (allocated (c%x[1,2,3])) stop 4 + + ! Allocate collectively + allocate(a[*]) + allocate(c%x[4,10,*]) + + if (.not. allocated (a)) stop 5 + if (.not. allocated (c%x)) stop 6 + if (.not. allocated (a[1])) stop 7 + if (.not. allocated (c%x[1,2,3])) stop 8 + + ! Dellocate collectively + deallocate(a) + deallocate(c%x) + + if (allocated (a)) stop 9 + if (allocated (c%x)) stop 10 + if (allocated (a[1])) stop 11 + if (allocated (c%x[1,2,3])) stop 12 +end + +! twice == 0 for .not. allocated' (coindexed vs. not) +! four times != for allocated (before alloc after dealloc, coindexed and not) + +! There are also == 0 and != 0 for (de)allocate checks with -fcoarray=single but those +! aren't prefixed by '(integer(kind=4) *)' + +! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) a.data != 0B" 4 "original" } } +! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) c.x.data != 0B" 4 "original" } } +! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) a.data == 0B" 2 "original" } } +! { dg-final { scan-tree-dump-times "\\(integer\\(kind=4\\) \\*\\) c.x.data == 0B" 2 "original" } } + +! Expected: always local access and never a call to _gfortran_caf_get +! { dg-final { scan-tree-dump-not "caf_get" "original" } } Index: Fortran/gfortran/regression/coarray/codimension.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/codimension.f90 @@ -0,0 +1,49 @@ +! { dg-do run } +! +! Based on coarray_lib_token_4.f90 but checking whether the bounds +! are correctly handled. +! +program test_caf + implicit none + integer, allocatable :: A(:)[:] + integer, save :: B(3)[*] + integer :: i + + allocate (A(3)[*]) + A = [1, 2, 3 ] + B = [9, 7, 4 ] + call foo (A, A, test=1) + call foo (A(2:3), B, test=2) + call foo (B, A, test=3) +contains + subroutine foo(x, y, test) + integer :: x(:)[*] + integer, contiguous :: y(:)[*] + integer :: test + integer :: i, j + call bar (x) + call expl (y) + i = lcobound(x, dim=1) + j = ucobound(x, dim=1) + if (i /= 1 .or. j /= num_images()) STOP 1 + i = lcobound(y, dim=1) + j = ucobound(y, dim=1) + if (i /= 1 .or. j /= num_images()) STOP 2 + end subroutine foo + + subroutine bar(y) + integer :: y(:)[*] + integer :: i, j + i = lcobound(y, dim=1) + j = ucobound(y, dim=1) + if (i /= 1 .or. j /= num_images()) STOP 3 + end subroutine bar + + subroutine expl(z) + integer :: z(*)[*] + integer :: i, j + i = lcobound(z, dim=1) + j = ucobound(z, dim=1) + if (i /= 1 .or. j /= num_images()) STOP 4 + end subroutine expl +end program test_caf Index: Fortran/gfortran/regression/coarray/codimension_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/codimension_2.f90 @@ -0,0 +1,14 @@ +! { dg-do link } +! { dg-additional-sources "codimension_2a.f90 codimension_2b.f90" } +! +! To be used with codimension_2a.f90 +! Check that the coarray declared in the module is accessible +! by doing a link test +! +! Contributed by Alessandro Fanfarillo. +! +module global_coarrays + implicit none + integer,parameter :: n=10 + integer :: b(10)[*] +end module global_coarrays Index: Fortran/gfortran/regression/coarray/codimension_2a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/codimension_2a.f90 @@ -0,0 +1,29 @@ +! { dg-do compile { target { ! *-*-* } } } +! SKIP THIS FILE +! +! Used by codimension_2.f90 +! +! Check that the coarray declared in the module is accessible +! by doing a link test +! +! Contributed by Alessandro Fanfarillo. +! +program testmod + use global_coarrays + implicit none + external ttest + + integer :: me + + me = this_image() + + b = me + + if(me==1) then + b(:) = b(:)[2] + write(*,*) b + elseif (me == 3) then + call ttest() + end if + +end program testmod Index: Fortran/gfortran/regression/coarray/codimension_2b.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/codimension_2b.f90 @@ -0,0 +1,13 @@ +! { dg-do compile { target { ! *-*-* } } } +! SKIP THIS FILE +! +! Used by codimension_2.f90 +! +! Additional file to check that using the module doesn't generate +! a token symbol. (The module is also used by codimension_2.f90.) +! +subroutine ttest + use global_coarrays + implicit none + b(:) = b(:)[2] +end Index: Fortran/gfortran/regression/coarray/codimension_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/codimension_3.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! PR fortran/84135 +! +! Co-contributed by G. Steinmetz +! +! Ensure that coarray shape remains correct +! after merging the shape from 'dimension' +! +program p + integer :: i + integer, dimension(3) :: x[2,*] + data (x(i:i+2:i+1), i=1,2) /1,2,3/ + integer, dimension(3) :: y[2,3,-3:4,5,7:*] = [1,2,3] + integer :: z, z2[2:4,7:9,-2:2,-7:8,-4:*] + codimension :: z[2:4,7:9,-2:2,-7:8,-4:*] + integer, codimension[1:*] :: z3[2:4,7:9,-2:2,-7:8,-4:*] + dimension :: z(1:2,-3:-2,7:7), z2(1:2,-3:-2,7:7), z3(1:2,-3:-2,7:7) + integer, codimension[2:4,7:9,-2:2,-7:8,-4:*], dimension(1:2,-3:-2,7:7) :: z4 + integer, codimension[*], dimension(1:2,-3:-2,7:7) :: z5[2:4,7:9,-2:2,-7:8,-4:*] + integer, codimension[2:4,7:9,-2:2,-7:8,-4:*], dimension(3) :: z6(1:2,-3:-2,7:7) + integer, codimension[*], dimension(4) :: z7(1:2,-3:-2,7:7)[2:4,7:9,-2:2,-7:8,-4:*] + + if (any (lcobound(x) /= [1, 1])) stop 1 + if (any (lcobound(y) /= [1, 1, -3, 1, 7])) stop 3 + if (any (lcobound(z) /= [2,7,-2,-7,-4])) stop 4 + if (any (lcobound(z2) /= lcobound(z))) stop 4 + if (any (lcobound(z3) /= lcobound(z))) stop 5 + if (any (lcobound(z4) /= lcobound(z))) stop 6 + if (any (lcobound(z5) /= lcobound(z))) stop 7 + if (any (lcobound(z6) /= lcobound(z))) stop 8 + if (any (lcobound(z7) /= lcobound(z))) stop 9 + + if (any (lbound(x) /= [1])) stop 11 + if (any (lbound(y) /= [1])) stop 12 + if (any (lbound(z) /= [1,-3,7])) stop 13 + if (any (lbound(z2) /= lbound(z))) stop 14 + if (any (lbound(z3) /= lbound(z))) stop 15 + if (any (lbound(z4) /= lbound(z))) stop 16 + if (any (lbound(z5) /= lbound(z))) stop 17 + if (any (lbound(z6) /= lbound(z))) stop 18 + if (any (lbound(z7) /= lbound(z))) stop 19 + + if (any (ubound(x) /= [3])) stop 21 + if (any (ubound(y) /= [3])) stop 22 + if (any (ubound(z) /= [2,-2,7])) stop 23 + if (any (ubound(z2) /= ubound(z))) stop 24 + if (any (ubound(z3) /= ubound(z))) stop 25 + if (any (ubound(z4) /= ubound(z))) stop 26 + if (any (ubound(z5) /= ubound(z))) stop 27 + if (any (ubound(z6) /= ubound(z))) stop 28 + if (any (ubound(z7) /= ubound(z))) stop 29 + + if (any (ucobound(z2) /= ucobound(z))) stop 31 + if (any (ucobound(z3) /= ucobound(z))) stop 32 + if (any (ucobound(z4) /= ucobound(z))) stop 33 + if (any (ucobound(z5) /= ucobound(z))) stop 34 + if (any (ucobound(z6) /= ucobound(z))) stop 35 + if (any (ucobound(z7) /= ucobound(z))) stop 36 + + if (num_images() == 1) then + if (any (ucobound(x) /= [2, lbound(x,dim=1)])) stop 37 + if (any (ucobound(y) /= [2, 3, 4, 5, 7])) stop 38 + if (any (ucobound(z) /= [4,9,2,8,-4])) stop 39 + else + if (ucobound(x, dim=1) /= 2) stop 41 + if (ucobound(y, dim=1) /= 2) stop 42 + if (ucobound(y, dim=2) /= 3) stop 43 + if (ucobound(y, dim=3) /= 4) stop 44 + if (ucobound(y, dim=4) /= 5) stop 45 + if (ucobound(z, dim=1) /= 4) stop 46 + if (ucobound(z, dim=2) /= 9) stop 47 + if (ucobound(z, dim=3) /= 2) stop 48 + if (ucobound(z, dim=4) /= 8) stop 49 + endif +end Index: Fortran/gfortran/regression/coarray/coindexed_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/coindexed_1.f90 @@ -0,0 +1,1459 @@ +! { dg-do run } +! +! +program test + implicit none + call char_test() +contains +subroutine char_test() + character(len=3, kind=1), save :: str1a[*], str1b(5)[*] + character(len=7, kind=1), save :: str2a[*], str2b(5)[*] + character(len=3, kind=4), save :: ustr1a[*], ustr1b(5)[*] + character(len=7, kind=4), save :: ustr2a[*], ustr2b(5)[*] + + ! ---------- Assign to coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a[1] = str1a + end if + sync all + if (this_image() == 1) then + if (str2a /= 1_"abc ") STOP 1 + else + if (str2a /= 1_"XXXXXXX") STOP 2 + end if + + ! SCALAR - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2a = 4_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a[1] = ustr1a + end if + sync all + if (this_image() == 1) then + if (ustr2a /= 4_"abc ") STOP 3 + else + if (ustr2a /= 4_"XXXXXXX") STOP 4 + end if + + ! SCALAR - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a[1] = str2a + end if + sync all + if (this_image() == 1) then + if (str1a /= 1_"abc") STOP 5 + else + if (str1a /= 1_"XXX") STOP 6 + end if + + ! SCALAR - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + ustr1a = 4_"XXX" + if (this_image() == num_images()) then + ustr1a[1] = ustr2a + end if + sync all + if (this_image() == 1) then + if (ustr1a /= 4_"abc") STOP 7 + else + if (ustr1a /= 4_"XXX") STOP 8 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = str1b + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 9 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 10 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = ustr1b + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 11 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 12 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = str2b + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 13 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 14 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = ustr2b + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 15 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 16 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = str1a + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 17 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 18 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = ustr1a + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 19 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 20 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = str2a + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 21 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 22 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = ustr2a + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 23 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 24 + end if + + ! ---------- Take from a coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a = str1a[1] + end if + sync all + if (this_image() == num_images()) then + if (str2a /= 1_"abc ") STOP 25 + else + if (str2a /= 1_"XXXXXXX") STOP 26 + end if + + ! SCALAR - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2a = 4_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a = ustr1a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2a /= 4_"abc ") STOP 27 + else + if (ustr2a /= 4_"XXXXXXX") STOP 28 + end if + + ! SCALAR - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a = str2a[1] + end if + sync all + if (this_image() == num_images()) then + if (str1a /= 1_"abc") STOP 29 + else + if (str1a /= 1_"XXX") STOP 30 + end if + + ! SCALAR - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + ustr1a = 4_"XXX" + if (this_image() == num_images()) then + ustr1a = ustr2a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1a /= 4_"abc") STOP 31 + else + if (ustr1a /= 4_"XXX") STOP 32 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b = str1b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 33 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 34 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b = ustr1b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 35 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 36 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b = str2b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 37 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 38 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b = ustr2b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 39 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 40 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b = str1a[1] + end if + sync all + if (this_image() == num_images()) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 41 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 42 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b = ustr1a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 43 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 44 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b = str2a[1] + end if + sync all + if (this_image() == num_images()) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 45 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 46 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b = ustr2a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 47 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 48 + end if + + + ! ---------- coindexed to coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a[1] = str1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2a /= 1_"abc ") STOP 49 + else + if (str2a /= 1_"XXXXXXX") STOP 50 + end if + + ! SCALAR - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2a = 4_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a[1] = ustr1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2a /= 4_"abc ") STOP 51 + else + if (ustr2a /= 4_"XXXXXXX") STOP 52 + end if + + ! SCALAR - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a[1] = str2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1a /= 1_"abc") STOP 53 + else + if (str1a /= 1_"XXX") STOP 54 + end if + + ! SCALAR - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + ustr1a = 4_"XXX" + if (this_image() == num_images()) then + ustr1a[1] = ustr2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1a /= 4_"abc") STOP 55 + else + if (ustr1a /= 4_"XXX") STOP 56 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = str1b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 57 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 58 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = ustr1b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 59 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 60 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = str2b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 61 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 62 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = ustr2b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 63 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 64 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = str1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 65 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 66 + end if + + ! contiguous ARRAY - kind 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = ustr1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 67 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 68 + end if + + ! contiguous ARRAY - kind 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = str2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 69 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 70 + end if + + ! contiguous ARRAY - kind 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = ustr2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 71 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 72 + end if + + ! ============== char1 <-> char4 ===================== + + ! ---------- Assign to coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str1a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a[1] = ustr1a + end if + sync all + if (this_image() == 1) then + if (str2a /= 1_"abc ") STOP 73 + else + if (str2a /= 1_"XXXXXXX") STOP 74 + end if + + ! SCALAR - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 4_"abc" + ustr2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a[1] = str1a + end if + sync all + if (this_image() == 1) then + if (ustr2a /= 4_"abc ") STOP 75 + else + if (ustr2a /= 4_"XXXXXXX") STOP 76 + end if + + ! SCALAR - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a[1] = ustr2a + end if + sync all + if (this_image() == 1) then + if (str1a /= 1_"abc") STOP 77 + else + if (str1a /= 1_"XXX") STOP 78 + end if + + ! SCALAR - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 4_"abcde" + ustr1a = 1_"XXX" + if (this_image() == num_images()) then + ustr1a[1] = str2a + end if + sync all + if (this_image() == 1) then + if (ustr1a /= 4_"abc") STOP 79 + else + if (ustr1a /= 4_"XXX") STOP 80 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = ustr1b + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 81 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 82 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = str1b + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 83 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 84 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = ustr2b + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 85 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 86 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = str2b + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 87 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 88 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = ustr1a + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 89 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 90 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = str1a + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 91 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 92 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = ustr2a + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 93 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 94 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = str2a + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 95 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 96 + end if + + ! ---------- Take from a coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a = ustr1a[1] + end if + sync all + if (this_image() == num_images()) then + if (str2a /= 1_"abc ") STOP 97 + else + if (str2a /= 1_"XXXXXXX") STOP 98 + end if + + ! SCALAR - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + ustr2a = 4_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a = str1a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2a /= 4_"abc ") STOP 99 + else + if (ustr2a /= 4_"XXXXXXX") STOP 100 + end if + + ! SCALAR - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a = ustr2a[1] + end if + sync all + if (this_image() == num_images()) then + if (str1a /= 1_"abc") STOP 101 + else + if (str1a /= 1_"XXX") STOP 102 + end if + + ! SCALAR - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcde" + ustr1a = 4_"XXX" + if (this_image() == num_images()) then + ustr1a = str2a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1a /= 4_"abc") STOP 103 + else + if (ustr1a /= 4_"XXX") STOP 104 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b = ustr1b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 105 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 106 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b = str1b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 107 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 108 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b = ustr2b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 109 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 110 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b = str2b(:)[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 111 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 112 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b = ustr1a[1] + end if + sync all + if (this_image() == num_images()) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 113 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 114 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b = str1a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 115 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 116 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b = ustr2a[1] + end if + sync all + if (this_image() == num_images()) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 117 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 118 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b = str2a[1] + end if + sync all + if (this_image() == num_images()) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 119 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 120 + end if + + + ! ---------- coindexed to coindexed variable ------------- + + ! - - - - - scalar = scalar + + ! SCALAR - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str2a = 1_"XXXXXXX" + if (this_image() == num_images()) then + str2a[1] = ustr1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2a /= 1_"abc ") STOP 121 + else + if (str2a /= 1_"XXXXXXX") STOP 122 + end if + + ! SCALAR - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + ustr2a = 4_"XXXXXXX" + if (this_image() == num_images()) then + ustr2a[1] = str1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2a /= 4_"abc ") STOP 123 + else + if (ustr2a /= 4_"XXXXXXX") STOP 124 + end if + + ! SCALAR - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcde" + str1a = 1_"XXX" + if (this_image() == num_images()) then + str1a[1] = ustr2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1a /= 1_"abc") STOP 125 + else + if (str1a /= 1_"XXX") STOP 126 + end if + + ! SCALAR - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcde" + ustr1a = 4_"XXX" + if (this_image() == num_images()) then + ustr1a[1] = str2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1a /= 4_"abc") STOP 127 + else + if (ustr1a /= 4_"XXX") STOP 128 + end if + + ! - - - - - array = array + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1b(1) = 4_"abc" + ustr1b(2) = 4_"def" + ustr1b(3) = 4_"gjh" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = ustr1b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"def " & + .or. str2b(3) /= 1_"gjh ") STOP 129 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 130 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1b(1) = 1_"abc" + str1b(2) = 1_"def" + str1b(3) = 1_"gjh" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = str1b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"def " & + .or. ustr2b(3) /= 4_"gjh ") STOP 131 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 132 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2b(1) = 4_"abcdefg" + ustr2b(2) = 4_"hijklmn" + ustr2b(3) = 4_"opqrstu" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = ustr2b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"hij" & + .or. str1b(3) /= 1_"opq") STOP 133 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 134 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2b(1) = 1_"abcdefg" + str2b(2) = 1_"hijklmn" + str2b(3) = 1_"opqrstu" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = str2b(:)[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"hij" & + .or. ustr1b(3) /= 4_"opq") STOP 135 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 136 + end if + + ! - - - - - array = scalar + + ! contiguous ARRAY - kind 1 <- 4 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr1a = 4_"abc" + str2b(1) = 1_"XXXXXXX" + str2b(2) = 1_"YYYYYYY" + str2b(3) = 1_"ZZZZZZZ" + if (this_image() == num_images()) then + str2b(:)[1] = ustr1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str2b(1) /= 1_"abc " .or. str2b(2) /= 1_"abc " & + .or. str2b(3) /= 1_"abc ") STOP 137 + else + if (str2b(1) /= 1_"XXXXXXX" .or. str2b(2) /= 1_"YYYYYYY" & + .or. str2b(3) /= 1_"ZZZZZZZ") STOP 138 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with padding + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str1a = 1_"abc" + ustr2b(1) = 4_"XXXXXXX" + ustr2b(2) = 4_"YYYYYYY" + ustr2b(3) = 4_"ZZZZZZZ" + if (this_image() == num_images()) then + ustr2b(:)[1] = str1a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr2b(1) /= 4_"abc " .or. ustr2b(2) /= 4_"abc " & + .or. ustr2b(3) /= 4_"abc ") STOP 139 + else + if (ustr2b(1) /= 4_"XXXXXXX" .or. ustr2b(2) /= 4_"YYYYYYY" & + .or. ustr2b(3) /= 4_"ZZZZZZZ") STOP 140 + end if + + ! contiguous ARRAY - kind 1 <- 4 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + ustr2a = 4_"abcdefg" + str1b(1) = 1_"XXX" + str1b(2) = 1_"YYY" + str1b(3) = 1_"ZZZ" + if (this_image() == num_images()) then + str1b(:)[1] = ustr2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (str1b(1) /= 1_"abc" .or. str1b(2) /= 1_"abc" & + .or. str1b(3) /= 1_"abc") STOP 141 + else + if (str1b(1) /= 1_"XXX" .or. str1b(2) /= 1_"YYY" & + .or. str1b(3) /= 1_"ZZZ") STOP 142 + end if + + ! contiguous ARRAY - kind 4 <- 1 - with trimming + str1a = 1_"zzz"; str1b = 1_"zzz"; ustr1a = 4_"zzz"; ustr1b = 4_"zzz" + str2a = 1_"zzzzzzzz"; str2b = 1_"zzzzzzzz" + ustr2a = 4_"zzzzzzzz"; ustr2b = 4_"zzzzzzzz" + str2a = 1_"abcdefg" + ustr1b(1) = 4_"XXX" + ustr1b(2) = 4_"YYY" + ustr1b(3) = 4_"ZZZ" + if (this_image() == num_images()) then + ustr1b(:)[1] = str2a[mod(1, num_images())+1] + end if + sync all + if (this_image() == 1) then + if (ustr1b(1) /= 4_"abc" .or. ustr1b(2) /= 4_"abc" & + .or. ustr1b(3) /= 4_"abc") STOP 143 + else + if (ustr1b(1) /= 4_"XXX" .or. ustr1b(2) /= 4_"YYY" & + .or. ustr1b(3) /= 4_"ZZZ") STOP 144 + end if + +end subroutine char_test +end program test Index: Fortran/gfortran/regression/coarray/collectives_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/collectives_1.f90 @@ -0,0 +1,44 @@ +! { dg-do run } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + intrinsic co_min + intrinsic co_sum + call test_min + call test_max + call test_sum +contains + subroutine test_max + integer :: val + val = this_image () + call co_max (val, result_image=1) + if (this_image() == 1) then + !write(*,*) "Maximal value", val + if (val /= num_images()) STOP 1 + end if + end subroutine test_max + + subroutine test_min + integer :: val + val = this_image () + call co_min (val, result_image=1) + if (this_image() == 1) then + !write(*,*) "Minimal value", val + if (val /= 1) STOP 2 + end if + end subroutine test_min + + subroutine test_sum + integer :: val, n + val = this_image () + call co_sum (val, result_image=1) + if (this_image() == 1) then + !write(*,*) "The sum is ", val + n = num_images() + if (val /= (n**2 + n)/2) STOP 3 + end if + end subroutine test_sum +end program test Index: Fortran/gfortran/regression/coarray/collectives_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/collectives_2.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! CO_SUM/CO_MIN/CO_MAX +! +program test + implicit none + intrinsic co_max + intrinsic co_min + intrinsic co_sum + integer :: val(3), tmp_val(3) + integer :: vec(3) + vec = [2,3,1] + if (this_image() == 1) then + val(1) = 42 + else + val(1) = -99 + endif + val(2) = this_image() + if (this_image() == num_images()) then + val(3) = -55 + else + val(3) = 101 + endif + tmp_val = val + call test_min + val = tmp_val + call test_max + val = tmp_val + call test_sum +contains + subroutine test_max + integer :: tmp + call co_max (val(::2)) + if (num_images() > 1) then + if (any (val /= [42, this_image(), 101])) STOP 1 + else + if (any (val /= [42, this_image(), -55])) STOP 2 + endif + + val = tmp_val + call co_max (val(:)) + if (num_images() > 1) then + if (any (val /= [42, num_images(), 101])) STOP 3 + else + if (any (val /= [42, num_images(), -55])) STOP 4 + endif + end subroutine test_max + + subroutine test_min + call co_min (val, result_image=num_images()) + if (this_image() == num_images()) then + !write(*,*) "Minimal value", val + if (num_images() > 1) then + if (any (val /= [-99, 1, -55])) STOP 5 + else + if (any (val /= [42, 1, -55])) STOP 6 + endif + else + if (any (val /= tmp_val)) STOP 7 + endif + end subroutine test_min + + subroutine test_sum + integer :: n + n = 88 + call co_sum (val, result_image=1, stat=n) + if (n /= 0) STOP 8 + if (this_image() == 1) then + n = num_images() + !write(*,*) "The sum is ", val + if (any (val /= [42 + (n-1)*(-99), (n**2 + n)/2, -55+(n-1)*101])) STOP 9 + else + if (any (val /= tmp_val)) STOP 10 + end if + end subroutine test_sum +end program test Index: Fortran/gfortran/regression/coarray/collectives_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/collectives_3.f90 @@ -0,0 +1,136 @@ +! { dg-do run } +! +! CO_BROADCAST +! +program test + implicit none + intrinsic co_broadcast + + type t + integer :: i + character(len=1) :: c + real(8) :: x(3), y(3) + end type t + + integer :: i, j(10), stat + complex :: a(5,5) + character(kind=1, len=5) :: str1, errstr + character(kind=4, len=8) :: str2(2) + type(t) :: dt(4) + + i = 1 + j = 55 + a = 99.0 + str1 = 1_"XXXXX" + str2 = 4_"YYYYYYYY" + dt = t(1, 'C', [1.,2.,3.], [3,3,3]) + errstr = "ZZZZZ" + + if (this_image() == num_images()) then + i = 2 + j = 66 + a = -99.0 + str1 = 1_"abcd" + str2 = 4_"12 3 4 5" + dt = t(-1, 'a', [3.,1.,8.], [99,24,5]) + end if + sync all + + call co_broadcast(i, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 1 + if (errstr /= "ZZZZZ") STOP 2 + if (i /= 2) STOP 3 + + call co_broadcast(j, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 4 + if (errstr /= "ZZZZZ") STOP 5 + if (any (j /= 66)) STOP 1 + + call co_broadcast(a, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 6 + if (errstr /= "ZZZZZ") STOP 7 + if (any (a /= -99.0)) STOP 2 + + call co_broadcast(str1, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 8 + if (errstr /= "ZZZZZ") STOP 9 + if (str1 /= "abcd") STOP 10 + + call co_broadcast(str2, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 11 + if (errstr /= "ZZZZZ") STOP 12 + if (any (str2 /= 4_"12 3 4 5")) STOP 3 + + call co_broadcast(dt, source_image=num_images(), stat=stat, errmsg=errstr) + if (stat /= 0) STOP 13 + if (errstr /= "ZZZZZ") STOP 14 + if (any (dt(:)%i /= -1)) STOP 15 + if (any (dt(:)%c /= 'a')) STOP 16 + if (any (dt(:)%x(1) /= 3.)) STOP 17 + if (any (dt(:)%x(2) /= 1.)) STOP 18 + if (any (dt(:)%x(3) /= 8.)) STOP 19 + if (any (dt(:)%y(1) /= 99.)) STOP 20 + if (any (dt(:)%y(2) /= 24.)) STOP 21 + if (any (dt(:)%y(3) /= 5.)) STOP 22 + + sync all + dt = t(1, 'C', [1.,2.,3.], [3,3,3]) + sync all + if (this_image() == num_images()) then + str2 = 4_"001122" + dt(2:4) = t(-2, 'i', [9.,2.,3.], [4,44,321]) + end if + + call co_broadcast(str2(::2), source_image=num_images(), stat=stat, & + errmsg=errstr) + if (stat /= 0) STOP 23 + if (errstr /= "ZZZZZ") STOP 24 + if (str2(1) /= 4_"001122") STOP 25 + if (this_image() == num_images()) then + if (str2(1) /= 4_"001122") STOP 26 + else + if (str2(2) /= 4_"12 3 4 5") STOP 27 + end if + + call co_broadcast(dt(2::2), source_image=num_images(), stat=stat, & + errmsg=errstr) + if (stat /= 0) STOP 28 + if (errstr /= "ZZZZZ") STOP 29 + if (this_image() == num_images()) then + if (any (dt(1:1)%i /= 1)) STOP 30 + if (any (dt(1:1)%c /= 'C')) STOP 31 + if (any (dt(1:1)%x(1) /= 1.)) STOP 32 + if (any (dt(1:1)%x(2) /= 2.)) STOP 33 + if (any (dt(1:1)%x(3) /= 3.)) STOP 34 + if (any (dt(1:1)%y(1) /= 3.)) STOP 35 + if (any (dt(1:1)%y(2) /= 3.)) STOP 36 + if (any (dt(1:1)%y(3) /= 3.)) STOP 37 + + if (any (dt(2:)%i /= -2)) STOP 38 + if (any (dt(2:)%c /= 'i')) STOP 39 + if (any (dt(2:)%x(1) /= 9.)) STOP 40 + if (any (dt(2:)%x(2) /= 2.)) STOP 41 + if (any (dt(2:)%x(3) /= 3.)) STOP 42 + if (any (dt(2:)%y(1) /= 4.)) STOP 43 + if (any (dt(2:)%y(2) /= 44.)) STOP 44 + if (any (dt(2:)%y(3) /= 321.)) STOP 45 + else + if (any (dt(1::2)%i /= 1)) STOP 46 + if (any (dt(1::2)%c /= 'C')) STOP 47 + if (any (dt(1::2)%x(1) /= 1.)) STOP 48 + if (any (dt(1::2)%x(2) /= 2.)) STOP 49 + if (any (dt(1::2)%x(3) /= 3.)) STOP 50 + if (any (dt(1::2)%y(1) /= 3.)) STOP 51 + if (any (dt(1::2)%y(2) /= 3.)) STOP 52 + if (any (dt(1::2)%y(3) /= 3.)) STOP 53 + + if (any (dt(2::2)%i /= -2)) STOP 54 + if (any (dt(2::2)%c /= 'i')) STOP 55 + if (any (dt(2::2)%x(1) /= 9.)) STOP 56 + if (any (dt(2::2)%x(2) /= 2.)) STOP 57 + if (any (dt(2::2)%x(3) /= 3.)) STOP 58 + if (any (dt(2::2)%y(1) /= 4.)) STOP 59 + if (any (dt(2::2)%y(2) /= 44.)) STOP 60 + if (any (dt(2::2)%y(3) /= 321.)) STOP 61 + endif +end program test Index: Fortran/gfortran/regression/coarray/collectives_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/collectives_4.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! CO_REDUCE +! +implicit none (type, external) +intrinsic :: co_reduce +integer :: stat +integer :: i4, i4_2, i + +i4 = 21 * this_image() +i4_2 = 21 +do i = 2, num_images() + i4_2 = i4_2 * 21 * i +end do +call co_reduce(i4, op_i4, stat=stat) +if (stat /= 0) STOP 1 +if (i4_2 /= i4) STOP 2 + +contains + pure integer function op_i4(a,b) + integer, value :: a, b + op_i4 = a * b + end function op_i4 +end Index: Fortran/gfortran/regression/coarray/cosubscript_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/cosubscript_1.f90 @@ -0,0 +1,66 @@ +! { dg-do run } +! +! From the HPCTools Group of University of Houston +! +! For a coindexed object, its cosubscript list determines the image +! index in the same way that a subscript list determines the subscript +! order value for an array element + +! Run at least with 3 images for the normal checking code +! Modified to also accept a single or two images +program cosubscript_test + implicit none + + integer, parameter :: X = 3, Y = 2 + integer, parameter :: P = 1, Q = -1 + integer :: me + integer :: i,j,k + + integer :: scalar[0:P, -1:Q, *] + + integer :: dim3_max, counter + logical :: is_err + + is_err = .false. + me = this_image() + scalar = me + dim3_max = num_images() / ( (P+1)*(Q+2) ) + + sync all + + if (num_images() == 1) then + k = 1 + j = -1 + i = 0 + if (scalar[i,j,k] /= this_image()) STOP 1 + stop "OK" + else if (num_images() == 2) then + k = 1 + j = -1 + counter = 0 + do i = 0,P + counter = counter+1 + if (counter /= scalar[i,j,k]) STOP 1 + end do + stop "OK" + end if + + ! ******* SCALAR *********** + counter = 0 + do k = 1, dim3_max + do j = -1,Q + do i = 0,P + counter = counter+1 + if (counter /= scalar[i,j,k]) then + print * , "Error in cosubscript translation scalar" + print * , "[", i,",",j,",",k,"] = ",scalar[i,j,k],"/=",counter + is_err = .true. + end if + end do + end do + end do + + if (is_err) then + STOP 2 + end if +end program cosubscript_test Index: Fortran/gfortran/regression/coarray/data_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/data_1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! +! PR fortran/71068 +! +! Contributed by Gerhard Steinmetz +! +program p + integer :: a(2)[*] + data a(1)[1] /1/ ! { dg-error "cannot have a coindex" } + data a(2)[1] /2/ ! { dg-error "cannot have a coindex" } +end Index: Fortran/gfortran/regression/coarray/dummy_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/dummy_1.f90 @@ -0,0 +1,70 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! Check whether assumed-shape's cobounds are properly handled +! + implicit none + integer :: B(1)[*] + integer :: C(8:11)[-3:10,43:*] + integer, allocatable :: D(:)[:,:] + + allocate (D(20)[2:3,5:*]) + + call sub (B,5) + call sub (C,3) + call sub (D,3) + + call sub2 (B, -3) + call sub2 (C, 44) + call sub2 (D, 44) + + call sub3 (B) + call sub3 (C) + call sub3 (D) + + call sub4 (B) + call sub4 (C) + call sub4 (D) + + call sub5 (D) + contains + + subroutine sub(A,n) + integer :: n + integer :: A(n:)[n:2*n,3*n:*] + if (lbound(A,dim=1) /= n) STOP 1 + if (any (lcobound(A) /= [n, 3*n])) STOP 2 + if (ucobound(A, dim=1) /= 2*n) STOP 3 + end subroutine sub + + subroutine sub2(A,n) + integer :: n + integer :: A(:)[-n:*] + if (lbound(A,dim=1) /= 1) STOP 4 + if (lcobound(A, dim=1) /= -n) STOP 5 + end subroutine sub2 + + subroutine sub3(A) + integer :: A(:)[0,*] + if (lbound(A,dim=1) /= 1) STOP 6 + if (lcobound(A, dim=1) /= 1) STOP 7 + if (ucobound(A, dim=1) /= 0) STOP 8 + if (lcobound(A, dim=2) /= 1) STOP 9 + end subroutine sub3 + + subroutine sub4(A) + integer :: A(:)[*] + if (lbound(A,dim=1) /= 1) STOP 10 + if (lcobound(A, dim=1) /= 1) STOP 11 + end subroutine sub4 + + subroutine sub5(A) + integer, allocatable :: A(:)[:,:] + + if (lbound(A,dim=1) /= 1) STOP 12 + if (lcobound(A, dim=1) /= 2) STOP 13 + if (ucobound(A, dim=1) /= 3) STOP 14 + if (lcobound(A, dim=2) /= 5) STOP 15 + end subroutine sub5 + end Index: Fortran/gfortran/regression/coarray/dummy_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/dummy_2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! +! PR fortran/99817 +! +! Contributed by G. Steinmetz +! +subroutine s1 (x) + character(*) :: x(*)[*] +end + +subroutine s2 (x) + character(*), dimension(*), codimension[*] :: x + integer :: i + i = len(x) +end + +subroutine s3 (x, y) + character(*), dimension(:) :: x[*] + character(*) :: y +end + +subroutine s4 (x, y, z) + character(*), dimension(:) :: x[2, *] + character(*), dimension(*) :: y + character(*) :: z +end Index: Fortran/gfortran/regression/coarray/event_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/event_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Run-time test for EVENT_TYPE +! +use iso_fortran_env, only: event_type +implicit none + +type(event_type), save :: var[*] +integer :: count, stat + +count = -42 +call event_query (var, count) +if (count /= 0) STOP 1 + +stat = 99 +event post (var, stat=stat) +if (stat /= 0) STOP 2 +call event_query(var, count, stat=stat) +if (count /= 1 .or. stat /= 0) STOP 3 + +stat = 99 +event post (var[this_image()]) +call event_query(var, count) +if (count /= 2) STOP 4 + +stat = 99 +event wait (var) +call event_query(var, count) +if (count /= 1) STOP 5 + +stat = 99 +event post (var) +call event_query(var, count) +if (count /= 2) STOP 6 + +stat = 99 +event post (var) +call event_query(var, count) +if (count /= 3) STOP 7 + +stat = 99 +event wait (var, until_count=2) +call event_query(var, count) +if (count /= 1) STOP 8 + +stat = 99 +event wait (var, stat=stat, until_count=1) +if (stat /= 0) STOP 9 +call event_query(event=var, stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 10 +end Index: Fortran/gfortran/regression/coarray/event_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/event_2.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! Run-time test for EVENT_TYPE +! +use iso_fortran_env, only: event_type +implicit none + +type(event_type), save, allocatable :: var(:)[:] +integer :: count, stat + +allocate(var(3)[*]) + +count = -42 +call event_query (var(1), count) +if (count /= 0) STOP 1 +call event_query (var(1), count) +if (count /= 0) STOP 2 +call event_query (var(2), count) +if (count /= 0) STOP 3 +call event_query (var(3), count) +if (count /= 0) STOP 4 + +stat = 99 +event post (var(2), stat=stat) +if (stat /= 0) STOP 5 +call event_query (var(1), count) +if (count /= 0) STOP 6 +call event_query(var(2), count, stat=stat) +if (count /= 1 .or. stat /= 0) STOP 7 +call event_query (var(3), count) +if (count /= 0) STOP 8 + +stat = 99 +event post (var(2)[this_image()]) +call event_query(var(1), count) +if (count /= 0) STOP 9 +call event_query(var(2), count) +if (count /= 2) STOP 10 +call event_query(var(2), count) +if (count /= 2) STOP 11 +call event_query(var(3), count) +if (count /= 0) STOP 12 + +stat = 99 +event wait (var(2)) +call event_query(var(1), count) +if (count /= 0) STOP 13 +call event_query(var(2), count) +if (count /= 1) STOP 14 +call event_query(var(3), count) +if (count /= 0) STOP 15 + +stat = 99 +event post (var(2)) +call event_query(var(1), count) +if (count /= 0) STOP 16 +call event_query(var(2), count) +if (count /= 2) STOP 17 +call event_query(var(3), count) +if (count /= 0) STOP 18 + +stat = 99 +event post (var(2)) +call event_query(var(1), count) +if (count /= 0) STOP 19 +call event_query(var(2), count) +if (count /= 3) STOP 20 +call event_query(var(3), count) +if (count /= 0) STOP 21 + +stat = 99 +event wait (var(2), until_count=2) +call event_query(var(1), count) +if (count /= 0) STOP 22 +call event_query(var(2), count) +if (count /= 1) STOP 23 +call event_query(var(3), count) +if (count /= 0) STOP 24 + +stat = 99 +event wait (var(2), stat=stat, until_count=1) +if (stat /= 0) STOP 25 +call event_query(event=var(1), stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 26 +call event_query(event=var(2), stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 27 +call event_query(event=var(3), stat=stat, count=count) +if (count /= 0 .or. stat /= 0) STOP 28 +end Index: Fortran/gfortran/regression/coarray/event_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/event_3.f08 @@ -0,0 +1,20 @@ +! { dg-do run } +! +! Check PR fortran/70696 is fixed. + +program global_event + use iso_fortran_env, only : event_type + implicit none + type(event_type), save :: x[*] + + call exchange + contains + subroutine exchange + integer :: cnt + event post(x[1]) + event post(x[1]) + call event_query(x, cnt) + if (cnt /= 2) error stop 1 + event wait(x, until_count=2) + end subroutine +end Index: Fortran/gfortran/regression/coarray/event_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/event_4.f08 @@ -0,0 +1,12 @@ +! { dg-do run } +! +! Check that pr 70697 is fixed. + +program event_4 + use iso_fortran_env + integer :: nc(1) + type(event_type) done[*] + nc(1) = 1 + event post(done[1]) + event wait(done,until_count=nc(1)) +end Index: Fortran/gfortran/regression/coarray/fail_image_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/fail_image_1.f08 @@ -0,0 +1,10 @@ +! { dg-do compile } + +program fail_image_statement_1 + implicit none + + fail image ! OK + fail image (1) ! { dg-error "Syntax error in FAIL IMAGE statement at \\(1\\)" } + +end program fail_image_statement_1 + Index: Fortran/gfortran/regression/coarray/fail_image_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/fail_image_2.f08 @@ -0,0 +1,10 @@ +! { dg-do run } + +program fail_image_statement_2 + implicit none + + fail image ! OK + error stop "This statement should not be reached." + +end program fail_image_statement_2 + Index: Fortran/gfortran/regression/coarray/failed_images_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/failed_images_1.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } + +program test_failed_images_1 + implicit none + + integer, allocatable :: fi(:) + real :: r + integer :: i + + fi = failed_images() ! OK + fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" } + fi = failed_images(KIND=1) ! OK + fi = failed_images(KIND=4) ! OK + fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" } + fi = failed_images(KIND=r) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be INTEGER" } + fi = failed_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" } + fi = failed_images(KIND=42) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" } + +end program test_failed_images_1 + Index: Fortran/gfortran/regression/coarray/failed_images_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/failed_images_2.f08 @@ -0,0 +1,17 @@ +! { dg-do run } + +program test_failed_images_2 + implicit none + + integer, allocatable :: fi(:) + integer(kind=1), allocatable :: sfi(:) + + fi = failed_images() + if (size(fi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=1) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + sfi = failed_images(KIND=8) + if (size(sfi) > 0) error stop "failed_images result shall be empty array" + +end program test_failed_images_2 + Index: Fortran/gfortran/regression/coarray/get_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/get_array.f90 @@ -0,0 +1,288 @@ +! { dg-do run } +! +! This program does a correctness check for +! ... = ARRAY[idx] and ... = SCALAR[idx] +! + + +! +! FIXME: two/three has to be modified, test has to be checked and +! diagnostic has to be removed +! + +program main + implicit none + integer, parameter :: n = 3 + integer, parameter :: m = 4 + + ! Allocatable coarrays + call one(-5, 1) + call one(0, 0) + call one(1, -5) + call one(0, -11) + + ! Static coarrays + call two() + call three() +contains + subroutine one(lb1, lb2) + integer, value :: lb1, lb2 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, allocatable :: caf(:,:)[:] + integer, allocatable :: a(:,:), b(:,:), c(:,:) + + allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], & + a(lb1:n+lb1-1, lb2:m+lb2-1), & + b(lb1:n+lb1-1, lb2:m+lb2-1), & + c(lb1:n+lb1-1, lb2:m+lb2-1)) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + c(:,:) = caf(:,:)[num_images()] + if (any (a /= c)) then + STOP 1 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + if (any (a /= c)) then + STOP 2 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (c /= a)) then + STOP 3 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine one + + subroutine two() + integer, parameter :: lb1 = -5, lb2 = 1 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + c(:,:) = caf(:,:)[num_images()] + if (any (a /= c)) then + STOP 4 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + if (any (a /= c)) then + STOP 5 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (c /= a)) then + STOP 6 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine two + + subroutine three() + integer, parameter :: lb1 = 0, lb2 = 0 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: c(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + c(:,:) = caf(:,:)[num_images()] + if (any (a /= c)) then + STOP 7 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + c(i,j) = caf(i,j)[num_images()] + end do + end do + if (any (a /= c)) then + STOP 8 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + c = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + c(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (c /= a)) then + STOP 9 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine three +end program main Index: Fortran/gfortran/regression/coarray/get_to_indexed_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/get_to_indexed_array_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } + +! Test that index vector on lhs of caf-expression works correctly. + +program pr81773 + + integer, parameter :: ndim = 5 + integer :: i + integer :: vec(ndim) = -1 + integer :: res(ndim)[*] = [ (i, i=1, ndim) ] + type T + integer :: padding + integer :: dest(ndim) + integer :: src(ndim) + end type + + type(T) :: dest + type(T), allocatable :: caf[:] + + vec([ndim, 3, 1]) = res(1:3)[1] + if (any (vec /= [ 3, -1, 2, -1, 1])) stop 1 + + dest = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] ) + dest%dest([ 4,3,2 ]) = res(3:5)[1] + if (any (dest%dest /= [-1, 5, 4, 3, -1])) stop 2 + + vec(:) = -1 + allocate(caf[*], source = T(42, [ ( -1, i = 1, ndim ) ], [ ( i - 2, i = ndim, 1, -1) ] )) + vec([ 5,3,2 ]) = caf[1]%src(2:4) + if (any (vec /= [ -1, 0, 1, -1, 2])) stop 3 +end + Index: Fortran/gfortran/regression/coarray/get_to_indirect_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/get_to_indirect_array.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! +! Test that pr81773/fortran is fixed. + +program get_to_indexed_array + + integer, parameter :: ndim = 5 + integer :: i + integer :: vec(1:ndim) = 0 + integer :: indx(1:2) = [3, 2] + integer :: mat(1:ndim, 1:ndim) = 0 + integer :: res(1:ndim)[*]=[ (i, i=1, ndim) ] + + ! No sync needed, because this test always is running on single image + vec([ndim , 1]) = res(1:2)[1] + if (vec(1) /= res(2) .or. vec(ndim) /= res(1)) then + print *,"vec: ", vec, " on image: ", this_image() + stop 1 + end if + + mat(2:3,[indx(:)]) = reshape(res(1:4)[1], [2, 2]) + if (any(mat(2:3, 3:2:-1) /= reshape(res(1:4), [2,2]))) then + print *, "mat: ", mat, " on image: ", this_image() + stop 2 + end if +end + +! vim:ts=2:sts=2:sw=2: Index: Fortran/gfortran/regression/coarray/image_index_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/image_index_1.f90 @@ -0,0 +1,99 @@ +! { dg-do run } +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:] +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +allocate(a(1)[3:3, -4:-3, 88:*]) +allocate(b(2)[-1:0,0:*]) +allocate(c(3,3)[*]) + +index1 = image_index(a, [3, -4, 88] ) +index2 = image_index(b, [-1, 0] ) +index3 = image_index(c, [1] ) +if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 1 + + +index1 = image_index(a, [3, -3, 88] ) +index2 = image_index(b, [0, 0] ) +index3 = image_index(c, [2] ) + +if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 2 +if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 3 + + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 4 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 5 + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 6 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 7 + +call test(1, a,b,c) + +! The following test is in honour of the F2008 standard: +deallocate(a) +allocate(a (10) [10, 0:9, 0:*]) + +index1 = image_index(a, [1, 0, 0] ) +index2 = image_index(a, [3, 1, 2] ) ! = 213, yeah! +index3 = image_index(a, [3, 1, 0] ) ! = 13 + +if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 8 +if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) & + STOP 9 +if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) & + STOP 10 + + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*] + + index1 = image_index(a, [3, -4, 88] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 11 + + + index1 = image_index(a, [3, -3, 88] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 12 + if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 13 +end subroutine test +end program test_image_index Index: Fortran/gfortran/regression/coarray/image_index_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/image_index_2.f90 @@ -0,0 +1,76 @@ +! { dg-do run } +! +! Scalar coarray +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, save :: d[-1:3, *] +integer, save :: e[-1:-1, 3:*] + +one = num_images() == 1 + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 1 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 2 + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 3 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 4 + +call test(1, e, d, e) +call test(2, e, d, e) + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a[3*n:3*n, -4*n:-3*n, 88*n:*], b[-1*n:0*n,0*n:*], c[*] + + index1 = image_index(a, [3*n, -4*n, 88*n] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + + if (n == 1) then + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 5 + else if (num_images() == 1) then + if (index1 /= 1 .or. index2 /= 0 .or. index3 /= 1) STOP 6 + else + if (index1 /= 1 .or. index2 /= 2 .or. index3 /= 1) STOP 7 + end if + + index1 = image_index(a, [3*n, -3*n, 88*n] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 8 + if (n == 1 .and. num_images() == 2) then + if (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2) & + STOP 9 + else if (n == 2 .and. num_images() == 2) then + if (index1 /= 0 .or. index2 /= 0 .or. index3 /= 2) & + STOP 10 + end if +end subroutine test +end program test_image_index Index: Fortran/gfortran/regression/coarray/image_index_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/image_index_3.f90 @@ -0,0 +1,103 @@ +! { dg-do run } +! { dg-options "-fdefault-integer-8" } +! +! As image_index_1.f90 but with -fdefault-integer-8 +! PR fortran/51682 +! +! Run-time test for IMAGE_INDEX with cobounds only known at +! the compile time, suitable for any number of NUM_IMAGES() +! For compile-time cobounds, the -fcoarray=lib version still +! needs to run-time evalulation if image_index returns > 1 +! as image_index is 0 if the index would exceed num_images(). +! +! Please set num_images() to >= 13, if possible. +! +! PR fortran/18918 +! + +program test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:] +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +allocate(a(1)[3:3, -4:-3, 88:*]) +allocate(b(2)[-1:0,0:*]) +allocate(c(3,3)[*]) + +index1 = image_index(a, [3, -4, 88] ) +index2 = image_index(b, [-1, 0] ) +index3 = image_index(c, [1] ) +if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 1 + + +index1 = image_index(a, [3, -3, 88] ) +index2 = image_index(b, [0, 0] ) +index3 = image_index(c, [2] ) + +if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 2 +if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 3 + + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 4 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 5 + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 6 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 7 + +call test(1, a,b,c) + +! The following test is in honour of the F2008 standard: +deallocate(a) +allocate(a (10) [10, 0:9, 0:*]) + +index1 = image_index(a, [1, 0, 0] ) +index2 = image_index(a, [3, 1, 2] ) ! = 213, yeah! +index3 = image_index(a, [3, 1, 0] ) ! = 13 + +if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 8 +if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) & + STOP 9 +if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) & + STOP 10 + + +contains +subroutine test(n, a, b, c) + integer :: n + integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*] + + index1 = image_index(a, [3, -4, 88] ) + index2 = image_index(b, [-1, 0] ) + index3 = image_index(c, [1] ) + if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) STOP 11 + + + index1 = image_index(a, [3, -3, 88] ) + index2 = image_index(b, [0, 0] ) + index3 = image_index(c, [2] ) + + if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) & + STOP 12 + if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) & + STOP 13 +end subroutine test +end program test_image_index Index: Fortran/gfortran/regression/coarray/image_status_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/image_status_1.f08 @@ -0,0 +1,26 @@ +! { dg-do compile } + +program test_image_status_1 + implicit none + + integer :: isv + integer(kind=1) :: k1 + integer(kind=2) :: k2 + integer(kind=4) :: k4 + integer(kind=8) :: k8 + + isv = image_status(1) ! Ok + isv = image_status(-1) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" } + isv = image_status(0) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" } + isv = image_status(.true.) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be INTEGER" } + isv = image_status([1,2,3]) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be a scalar" } + isv = image_status(k1) ! Ok + isv = image_status(k2) ! Ok + isv = image_status(k4) ! Ok + isv = image_status(k8) ! Ok + isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" } + isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } + isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" } + +end program test_image_status_1 + Index: Fortran/gfortran/regression/coarray/image_status_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/image_status_2.f08 @@ -0,0 +1,12 @@ +! { dg-do run } + +program test_image_status_2 + use iso_fortran_env , only : STAT_STOPPED_IMAGE + implicit none + + if (image_status(1) /= 0) error stop "Image 1 should report OK." + if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped." + if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped." + +end program test_image_status_2 + Index: Fortran/gfortran/regression/coarray/lib_realloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/lib_realloc_1.f90 @@ -0,0 +1,29 @@ +! { dg-do run } +! +! Test that for CAF components _gfortran_caf_deregister is called +! Test that norealloc happens for CAF components during assignment +! +module m +type t + integer, allocatable :: CAF[:] +end type t +end module m + +program main +use m +type(t), target :: x,y +integer, pointer :: ptr +allocate(x%caf[*], y%caf[*]) +ptr => y%caf +ptr = 6 +if (.not.allocated(x%caf)) STOP 1 +if (.not.allocated(y%caf)) STOP 2 +if (y%caf /= 6) STOP 3 +x = y +if (x%caf /= 6) STOP 4 +if (.not. associated (ptr,y%caf)) STOP 5 +if (associated (ptr,x%caf)) STOP 6 +ptr = 123 +if (y%caf /= 123) STOP 7 +if (x%caf /= 6) STOP 8 +end program main Index: Fortran/gfortran/regression/coarray/lock_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/lock_1.f90 @@ -0,0 +1,32 @@ +! { dg-do run } +! +! LOCK/UNLOCK check +! +! PR fortran/18918 +! + +use iso_fortran_env +implicit none + +type(lock_type) :: lock[*] +integer :: stat +logical :: acquired + +LOCK(lock) +UNLOCK(lock) + +stat = 99 +LOCK(lock, stat=stat) +if (stat /= 0) STOP 1 +stat = 99 +UNLOCK(lock, stat=stat) +if (stat /= 0) STOP 2 + +if (this_image() == 1) then + acquired = .false. + LOCK (lock[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 3 + UNLOCK (lock[1]) +end if +end + Index: Fortran/gfortran/regression/coarray/lock_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/lock_2.f90 @@ -0,0 +1,89 @@ +! { dg-do run } +! +! LOCK/UNLOCK check +! +! PR fortran/18918 +! + +use iso_fortran_env +implicit none + +type(lock_type), allocatable :: lock1[:] +type(lock_type), allocatable :: lock2(:,:)[:] +type(lock_type) :: lock3(4)[*] +integer :: stat +logical :: acquired + +allocate(lock1[*]) +allocate(lock2(2,2)[*]) + +LOCK(lock1) +UNLOCK(lock1) + +LOCK(lock2(1,1)) +LOCK(lock2(2,2)) +UNLOCK(lock2(1,1)) +UNLOCK(lock2(2,2)) + +LOCK(lock3(3)) +LOCK(lock3(4)) +UNLOCK(lock3(3)) +UNLOCK(lock3(4)) + +stat = 99 +LOCK(lock1, stat=stat) +if (stat /= 0) STOP 1 + +LOCK(lock2(1,1), stat=stat) +if (stat /= 0) STOP 2 +LOCK(lock2(2,2), stat=stat) +if (stat /= 0) STOP 3 + +LOCK(lock3(3), stat=stat) +if (stat /= 0) STOP 4 +LOCK(lock3(4), stat=stat) +if (stat /= 0) STOP 5 + +stat = 99 +UNLOCK(lock1, stat=stat) +if (stat /= 0) STOP 6 + +UNLOCK(lock2(1,1), stat=stat) +if (stat /= 0) STOP 7 +UNLOCK(lock2(2,2), stat=stat) +if (stat /= 0) STOP 8 + +UNLOCK(lock3(3), stat=stat) +if (stat /= 0) STOP 9 +UNLOCK(lock3(4), stat=stat) +if (stat /= 0) STOP 10 + +if (this_image() == 1) then + acquired = .false. + LOCK (lock1[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 11 + + acquired = .false. + LOCK (lock2(1,1)[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 12 + + acquired = .false. + LOCK (lock2(2,2)[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 13 + + acquired = .false. + LOCK (lock3(3)[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 14 + + acquired = .false. + LOCK (lock3(4)[this_image()], acquired_lock=acquired) + if (.not. acquired) STOP 15 + + UNLOCK (lock1[1]) + UNLOCK (lock2(1,1)[1]) + UNLOCK (lock2(2,2)[1]) + UNLOCK (lock3(3)[1]) + UNLOCK (lock3(4)[1]) +end if +end + Index: Fortran/gfortran/regression/coarray/move_alloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/move_alloc_1.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! +! PR fortran/53526 +! +! Check handling of move_alloc with coarrays +! +implicit none +integer, allocatable :: u[:], v[:], w(:)[:,:], x(:)[:,:] + +allocate (u[4:*]) +call move_alloc (u, v) +if (allocated (u)) STOP 1 +if (lcobound (v, dim=1) /= 4) STOP 2 +if (ucobound (v, dim=1) /= 3 + num_images()) STOP 3 + +allocate (w(-2:3)[4:5,-1:*]) +call move_alloc (w, x) +if (allocated (w)) STOP 4 +if (lbound (x, dim=1) /= -2) STOP 5 +if (ubound (x, dim=1) /= 3) STOP 6 +if (any (lcobound (x) /= [4, -1])) STOP 7 +if (any (ucobound (x) /= [5, -2 + (num_images()+1)/2])) STOP 8 + +end Index: Fortran/gfortran/regression/coarray/poly_run_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/poly_run_1.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! +! Test for polymorphic coarrays +! +type t +end type t +class(t), allocatable :: A(:)[:,:] +allocate (A(2)[1:4,-5:*]) +if (any (lcobound(A) /= [1, -5])) STOP 1 +if (num_images() == 1) then + if (any (ucobound(A) /= [4, -5])) STOP 2 +else + if (ucobound(A,dim=1) /= 4) STOP 3 +end if +if (allocated(A)) i = 5 +call s(A) +!call st(A) ! FIXME + +contains + +subroutine s(x) + class(t),allocatable :: x(:)[:,:] + if (any (lcobound(x) /= [1, -5])) STOP 4 + if (num_images() == 1) then + if (any (ucobound(x) /= [4, -5])) STOP 5 + else + if (ucobound(x,dim=1) /= 4) STOP 6 + end if +end subroutine s + +subroutine st(x) + class(t) :: x(:)[4,2:*] +! FIXME +! if (any (lcobound(x) /= [1, 2])) STOP 7 +! if (lcobound(x, dim=1) /= 1) STOP 8 +! if (lcobound(x, dim=2) /= 2) STOP 9 +! if (this_image() == 1) then +! if (any (this_image(x) /= lcobound(x))) STOP 10 +! if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11 +! if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12 +! end if +! if (num_images() == 1) then +! if (any (ucobound(x) /= [4, 2])) STOP 13 +! if (ucobound(x, dim=1) /= 4) STOP 14 +! if (ucobound(x, dim=2) /= 2) STOP 15 +! else +! if (ucobound(x,dim=1) /= 4) STOP 16 +! end if +end subroutine st +end + Index: Fortran/gfortran/regression/coarray/poly_run_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/poly_run_2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Test for polymorphic coarrays +! +type t +end type t +class(t), allocatable :: A[:,:] +allocate (A[1:4,-5:*]) +if (allocated(A)) stop +if (any (lcobound(A) /= [1, -5])) STOP 1 +if (num_images() == 1) then + if (any (ucobound(A) /= [4, -5])) STOP 2 +else + if (ucobound(A,dim=1) /= 4) STOP 3 +end if +if (allocated(A)) i = 5 +call s(A) +call st(A) +contains +subroutine s(x) + class(t) :: x[4,2:*] + if (any (lcobound(x) /= [1, 2])) STOP 4 + if (num_images() == 1) then + if (any (ucobound(x) /= [4, 2])) STOP 5 + else + if (ucobound(x,dim=1) /= 4) STOP 6 + end if +end subroutine s +subroutine st(x) + class(t) :: x[:,:] + if (any (lcobound(x) /= [1, -5])) STOP 7 + if (num_images() == 1) then + if (any (ucobound(x) /= [4, -5])) STOP 8 + else + if (ucobound(x,dim=1) /= 4) STOP 9 + end if +end subroutine st +end + Index: Fortran/gfortran/regression/coarray/poly_run_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/poly_run_3.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! +! Check that the bounds of polymorphic coarrays is +! properly handled. +! +type t +end type t +class(t), allocatable :: a(:)[:] +class(t), allocatable :: b[:], d[:] + +allocate(a(1)[*]) +if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & + STOP 1 +if (any (lcobound(a) /= 1)) STOP 2 +if (any (ucobound(a) /= this_image())) STOP 3 +deallocate(a) + +allocate(b[*]) +if (this_image() == 1 .and. any (this_image(b) /= lcobound(b))) & + STOP 4 +if (any (lcobound(b) /= 1)) STOP 5 +if (any (ucobound(b) /= this_image())) STOP 6 +deallocate(b) + +allocate(a(1)[-10:*]) +if (this_image() == 1 .and. any (this_image(a) /= lcobound(a))) & + STOP 7 +if (any (lcobound(a) /= -10)) STOP 8 +if (any (ucobound(a) /= -11+this_image())) STOP 9 +deallocate(a) + +allocate(d[23:*]) +if (this_image() == 1 .and. any (this_image(d) /= lcobound(d))) & + STOP 10 +if (any (lcobound(d) /= 23)) STOP 11 +if (any (ucobound(d) /= 22+this_image())) STOP 12 +deallocate(d) + +end Index: Fortran/gfortran/regression/coarray/pr107441-caf.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/pr107441-caf.f90 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! PR fortran/107441 +! Check that with -fcoarray=lib, coarray metadata arguments are passed +! in the right order to procedures. +! +! Contributed by M.Morin + +program p + integer :: ci[*] + ci = 17 + call s(1, ci, "abcd") +contains + subroutine s(ra, ca, c) + integer :: ra, ca[*] + character(*) :: c + ca[1] = 13 + if (ra /= 1) stop 1 + if (this_image() == 1) then + if (ca /= 13) stop 2 + else + if (ca /= 17) stop 3 + end if + if (len(c) /= 4) stop 4 + if (c /= "abcd") stop 5 + end subroutine s +end program p Index: Fortran/gfortran/regression/coarray/pr93671.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/pr93671.f90 @@ -0,0 +1,24 @@ +! { dg-do run } + +! PR/fortran 93671 - ICE on intrinsic assignment to allocatable derived-type +! component of coarray + + type flux_planes + integer, allocatable :: normals + end type + + type package + type(flux_planes) surface_fluxes(1) + end type + + type(package) mail[*], halo_data + + halo_data%surface_fluxes(1)%normals = 1 + mail = halo_data + + if (any(size(mail%surface_fluxes) /= [1]) .OR. & + mail%surface_fluxes(1)%normals /= 1) then + stop 1 + end if +end + Index: Fortran/gfortran/regression/coarray/ptr_comp_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/ptr_comp_1.f08 @@ -0,0 +1,36 @@ +! { dg-do run } + +program alloc_comp + type t + integer, pointer :: z + end type + type(t), save :: obj[*] + integer, allocatable, target :: i[:] + + if (associated(obj%z)) error stop "'z' should not be associated yet." + allocate (obj%z) + call f(obj) + if (associated(obj%z)) error stop "'z' should not be associated anymore." + + allocate(i[*], SOURCE=42) + obj%z => i + if (.not. allocated(i)) error stop "'i' no longer allocated." + i = 15 + if (obj%z /= 15) error stop "'obj%z' is deep copy and not pointer." + + nullify (obj%z) + if (.not. allocated(i)) error stop "'i' should still be allocated." + if (associated(obj%z)) error stop "'obj%z' should not be associated anymore." + + obj%z => i + call f(obj) + ! One can not say anything about i here. The memory should be deallocated, but + ! the pointer in i is still set. + if (associated(obj%z)) error stop "'obj%z' should not be associated anymore." +contains + subroutine f(x) + type(t) :: x[*] + if ( associated(x%z) ) deallocate(x%z) + end subroutine +end program + Index: Fortran/gfortran/regression/coarray/ptr_comp_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/ptr_comp_2.f08 @@ -0,0 +1,36 @@ +! { dg-do run } + +program ptr_comp + type t + integer, pointer :: z(:) + end type + type(t), save :: obj[*] + integer, allocatable, target :: i(:)[:] + + if (associated(obj%z)) error stop "'z' should not be associated yet." + allocate (obj%z(5)) + call f(obj) + if (associated(obj%z)) error stop "'z' should not be associated anymore." + + allocate(i(7)[*], SOURCE=42) + obj%z => i + if (.not. allocated(i)) error stop "'i' no longer allocated." + i = 15 + if (any(obj%z(:) /= 15)) error stop "'obj%z' is deep copy and not pointer." + + nullify (obj%z) + if (.not. allocated(i)) error stop "'i' should still be allocated." + if (associated(obj%z)) error stop "'obj%z' should not be associated anymore." + + obj%z => i + call f(obj) + ! One can not say anything about i here. The memory should be deallocated, but + ! the pointer in i is still set. + if (associated(obj%z)) error stop "'obj%z' should not be associated anymore." +contains + subroutine f(x) + type(t) :: x[*] + if ( associated(x%z) ) deallocate(x%z) + end subroutine +end program + Index: Fortran/gfortran/regression/coarray/ptr_comp_3.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/ptr_comp_3.f08 @@ -0,0 +1,22 @@ +! { dg-do run } + +! Contributed by Damian Rouson +! Same like coarray/alloc_comp_4 + +program main + + implicit none + + type mytype + integer, pointer :: indices(:) + end type + + type(mytype), save :: object[*] + integer :: me + + me=this_image() + allocate(object%indices(me)) + object%indices = 42 + + if ( any( object[me]%indices(:) /= 42 ) ) STOP 1 +end program Index: Fortran/gfortran/regression/coarray/ptr_comp_4.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/ptr_comp_4.f08 @@ -0,0 +1,20 @@ +! { dg-do run } + +! Same like coarray/alloc_comp_5 but for pointer comp. + +program Jac + type Domain + integer :: n=64 + integer, pointer :: endsi(:) + end type + type(Domain),allocatable :: D[:,:,:] + + allocate(D[2,2,*]) + allocate(D%endsi(2), source = 0) + ! No caf-runtime call needed her. + D%endsi(2) = D%n + if (any(D%endsi /= [ 0, 64])) error stop + deallocate(D%endsi) + deallocate(D) +end program + Index: Fortran/gfortran/regression/coarray/registering_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/registering_1.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! Check whether registering coarrays works +! +module m + integer :: a(1)[*] = 7 +end module m + +use m +if (any (a /= 7)) STOP 1 +a = 88 +if (any (a /= 88)) STOP 2 + + block + integer :: b[*] = 8494 + if (b /= 8494) STOP 3 + end block + +if (any (a /= 88)) STOP 4 +call test () +end + +subroutine test() + real :: z[*] = sqrt(2.0) + if (z /= sqrt(2.0)) STOP 5 + call sub1() +contains + subroutine sub1 + real :: r[4,*] = -1 + if (r /= -1) STOP 1 + r = 10 + if (r /= 10) STOP 2 + end subroutine sub1 + + subroutine uncalled() + integer :: not_refed[2:*] = 784 + if (not_refed /= 784) STOP 6 + end subroutine uncalled +end subroutine test Index: Fortran/gfortran/regression/coarray/scalar_alloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/scalar_alloc_1.f90 @@ -0,0 +1,68 @@ +! { dg-do run } +! +implicit none +integer, allocatable :: A[:], B[:,:] +integer :: n1, n2, n3 + +if (allocated (a)) STOP 1 +if (allocated (b)) STOP 2 + +allocate(a[*]) +a = 5 + this_image () +if (a[this_image ()] /= 5 + this_image ()) STOP 1 + +a[this_image ()] = 8 - 2*this_image () +if (a[this_image ()] /= 8 - 2*this_image ()) STOP 2 + +if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) & + STOP 3 +deallocate(a) + +allocate(a[4:*]) +a[this_image ()] = 8 - 2*this_image () + +if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) & + STOP 4 + +n1 = -1 +n2 = 5 +n3 = 3 +allocate (B[n1:n2, n3:*]) +if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) & + STOP 5 +call sub(A, B) + +if (allocated (a)) STOP 6 +if (.not.allocated (b)) STOP 7 + +call two(.true.) +call two(.false.) + +! automatically deallocate "B" +contains + subroutine sub(x, y) + integer, allocatable :: x[:], y[:,:] + + if (any (lcobound(y) /= [-1, 3]) .or. lcobound(y, dim=2) /= n3) & + STOP 8 + if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) & + STOP 9 + if (x[this_image ()] /= 8 - 2*this_image ()) STOP 3 + deallocate(x) + end subroutine sub + + subroutine two(init) + logical, intent(in) :: init + integer, allocatable, SAVE :: a[:] + + if (init) then + if (allocated(a)) STOP 10 + allocate(a[*]) + a = 45 + else + if (.not. allocated(a)) STOP 11 + if (a /= 45) STOP 12 + deallocate(a) + end if + end subroutine two +end Index: Fortran/gfortran/regression/coarray/scalar_alloc_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/scalar_alloc_2.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! +! Check whether registering allocatable coarrays works +! +type position + real :: x, y, z +end type position + +integer, allocatable :: a[:] +type(position), allocatable :: p[:] + +allocate(a[*]) +a = 7 + +allocate(p[*]) +p%x = 11 +p%y = 13 +p%z = 15 + +if (a /= 7) STOP 1 +a = 88 +if (a /= 88) STOP 2 + +if (p%x /= 11) STOP 3 +p%x = 17 +if (p%x /= 17) STOP 4 + + block + integer, allocatable :: b[:] + + allocate(b[*]) + b = 8494 + + if (b /= 8494) STOP 5 + end block + +if (a /= 88) STOP 6 +call test () +end + +subroutine test() + type velocity + real :: x, y, z + end type velocity + + real, allocatable :: z[:] + type(velocity), allocatable :: v[:] + + allocate(z[*]) + z = sqrt(2.0) + + allocate(v[*]) + v%x = 21 + v%y = 23 + v%z = 25 + + if (z /= sqrt(2.0)) STOP 7 + if (v%x /= 21) STOP 8 + +end subroutine test Index: Fortran/gfortran/regression/coarray/send_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/send_array.f90 @@ -0,0 +1,407 @@ +! { dg-do run } +! +! This program does a correctness check for +! ARRAY[idx] = SCALAR, ARRAY[idx] = ARRAY and SCALAR[idx] = SCALAR +! +program main + implicit none + integer, parameter :: n = 3 + integer, parameter :: m = 4 + + ! Allocatable coarrays + call one(-5, 1) + call one(0, 0) + call one(1, -5) + call one(0, -11) + + ! Static coarrays + call two() + call three() +contains + subroutine one(lb1, lb2) + integer, value :: lb1, lb2 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, allocatable :: caf(:,:)[:] + integer, allocatable :: a(:,:), b(:,:) + + allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], & + a(lb1:n+lb1-1, lb2:m+lb2-1), & + b(lb1:n+lb1-1, lb2:m+lb2-1)) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = SCALAR + caf = -42 + a = -42 + a(:,:) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(lb1, lb2) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 1 + end if + sync all + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + a(:,:) = b(:, :) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(:, :) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 2 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + a(i,j) = b(i,j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + a(i,j) = b(i,j) + end do + end do + sync all + if (this_image() == 1) then + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 3 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = SCALAR + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(lb1, lb2) + end if + sync all + + ! ARRAY = ARRAY + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + end if + sync all + + if (this_image() == num_images()) then + if (any (a /= caf)) then + print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", & + lb2,":",m+lb2-1 + print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, & + ", ", j,":",j_e,":",j_s*i_sgn2 + print *, i + print *, a + print *, caf + print *, a-caf + STOP 4 + endif + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine one + + subroutine two() + integer, parameter :: lb1 = -5, lb2 = 1 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = SCALAR + caf = -42 + a = -42 + a(:,:) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(lb1, lb2) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 5 + end if + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + a(:,:) = b(:, :) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(:, :) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 6 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + a(i,j) = b(i,j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + a(i,j) = b(i,j) + end do + end do + sync all + if (this_image() == 1) then + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 7 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = SCALAR + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(lb1, lb2) + end if + sync all + + ! ARRAY = ARRAY + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + end if + sync all + + if (this_image() == num_images()) then + if (any (a /= caf)) then + print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", & + lb2,":",m+lb2-1 + print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, & + ", ", j,":",j_e,":",j_s*i_sgn2 + print *, i + print *, a + print *, caf + print *, a-caf + STOP 8 + endif + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine two + + subroutine three() + integer, parameter :: lb1 = 0, lb2 = 0 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = SCALAR + caf = -42 + a = -42 + a(:,:) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(lb1, lb2) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 9 + end if + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + a(:,:) = b(:, :) + sync all + if (this_image() == 1) then + caf(:,:)[num_images()] = b(:, :) + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 10 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + a(i,j) = b(i,j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + a(i,j) = b(i,j) + end do + end do + sync all + if (this_image() == 1) then + do j = lb2, m+lb2-1 + do i = n+lb1-1, 1, -2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + do j = lb2, m+lb2-1 + do i = 1, n+lb1-1, 2 + caf(i,j)[num_images()] = b(i, j) + end do + end do + end if + sync all + if (this_image() == num_images()) then + if (any (a /= caf)) & + STOP 11 + end if + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = SCALAR + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(lb1, lb2) + end if + sync all + + ! ARRAY = ARRAY + caf = -42 + a = -42 + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + sync all + if (this_image() == 1) then + caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + end if + sync all + + if (this_image() == num_images()) then + if (any (a /= caf)) then + print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", & + lb2,":",m+lb2-1 + print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, & + ", ", j,":",j_e,":",j_s*i_sgn2 + print *, i + print *, a + print *, caf + print *, a-caf + STOP 12 + endif + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine three +end program main Index: Fortran/gfortran/regression/coarray/send_char_array_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/send_char_array_1.f90 @@ -0,0 +1,54 @@ +!{ dg-do run } + +program send_convert_char_array + + implicit none + + character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_scal + character(kind=1, len=:), allocatable :: str_k1_scal + character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_scal + character(kind=4, len=:), allocatable :: str_k4_scal + + character(kind=1, len=:), allocatable, codimension[:] :: co_str_k1_arr(:) + character(kind=1, len=:), allocatable :: str_k1_arr(:) + character(kind=4, len=:), allocatable, codimension[:] :: co_str_k4_arr(:) + character(kind=4, len=:), allocatable :: str_k4_arr(:) + + allocate(str_k1_scal, SOURCE='abcdefghij') + allocate(str_k4_scal, SOURCE=4_'abcdefghij') + allocate(character(len=20)::co_str_k1_scal[*]) ! allocate syncs here + allocate(character(kind=4, len=20)::co_str_k4_scal[*]) ! allocate syncs here + + allocate(str_k1_arr, SOURCE=['abc', 'EFG', 'klm', 'NOP']) + allocate(str_k4_arr, SOURCE=[4_'abc', 4_'EFG', 4_'klm', 4_'NOP']) + allocate(character(len=5)::co_str_k1_arr(4)[*]) + allocate(character(kind=4, len=5)::co_str_k4_arr(4)[*]) + + ! First check send/copy to self + co_str_k1_scal[this_image()] = str_k1_scal + if (co_str_k1_scal /= str_k1_scal // ' ') STOP 1 + + co_str_k4_scal[this_image()] = str_k4_scal + if (co_str_k4_scal /= str_k4_scal // 4_' ') STOP 2 + + co_str_k4_scal[this_image()] = str_k1_scal + if (co_str_k4_scal /= str_k4_scal // 4_' ') STOP 3 + + co_str_k1_scal[this_image()] = str_k4_scal + if (co_str_k1_scal /= str_k1_scal // ' ') STOP 4 + + co_str_k1_arr(:)[this_image()] = str_k1_arr + if (any(co_str_k1_arr /= ['abc ', 'EFG ', 'klm ', 'NOP '])) STOP 5 + + co_str_k4_arr(:)[this_image()] = [4_'abc', 4_'EFG', 4_'klm', 4_'NOP']! str_k4_arr + if (any(co_str_k4_arr /= [4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 6 + + co_str_k4_arr(:)[this_image()] = str_k1_arr + if (any(co_str_k4_arr /= [ 4_'abc ', 4_'EFG ', 4_'klm ', 4_'NOP '])) STOP 7 + + co_str_k1_arr(:)[this_image()] = str_k4_arr + if (any(co_str_k1_arr /= ['abc ', 'EFG ', 'klm ', 'NOP '])) STOP 8 + +end program send_convert_char_array + +! vim:ts=2:sts=2:sw=2: Index: Fortran/gfortran/regression/coarray/sendget_array.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/sendget_array.f90 @@ -0,0 +1,288 @@ +! { dg-do run } +! +! This program does a correctness check for +! ARRAY[idx] = ARRAY[idx] and SCALAR[idx] = SCALAR[idx] +! + + +! +! FIXME: two/three has to be modified, test has to be checked and +! diagnostic has to be removed +! + +program main + implicit none + integer, parameter :: n = 3 + integer, parameter :: m = 4 + + ! Allocatable coarrays + call one(-5, 1) + call one(0, 0) + call one(1, -5) + call one(0, -11) + + ! Static coarrays + call two() + call three() +contains + subroutine one(lb1, lb2) + integer, value :: lb1, lb2 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, allocatable :: caf(:,:)[:], caf2(:,:)[:] + integer, allocatable :: a(:,:), b(:,:) + + allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], & + caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*], & + a(lb1:n+lb1-1, lb2:m+lb2-1), & + b(lb1:n+lb1-1, lb2:m+lb2-1)) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + caf2(:,:)[this_image()] = caf(:,:)[num_images()] + if (any (a /= caf2)) then + STOP 1 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + if (any (a /= caf2)) then + STOP 2 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (caf2 /= a)) then + STOP 3 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine one + + subroutine two() + integer, parameter :: lb1 = -5, lb2 = 1 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + caf2(:,:)[this_image()] = caf(:,:)[num_images()] + if (any (a /= caf2)) then + STOP 4 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + if (any (a /= caf2)) then + STOP 5 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (caf2 /= a)) then + STOP 6 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine two + + subroutine three() + integer, parameter :: lb1 = 0, lb2 = 0 + + integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s + integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: caf2(lb1:n+lb1-1, lb2:m+lb2-1)[*] + integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1) + integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1) + + b = reshape([(i*33, i = 1, size(b))], shape(b)) + + ! Whole array: ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(:,:) = b(:,:) + caf2(:,:)[this_image()] = caf(:,:)[num_images()] + if (any (a /= caf2)) then + STOP 7 + end if + sync all + + ! Scalar assignment + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + do j = lb2, m+lb2-1 + do i = n+lb1-1, lb1, -2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + do j = lb2, m+lb2-1 + do i = lb1, n+lb1-1, 2 + a(i,j) = b(i,j) + caf2(i,j)[this_image()] = caf(i,j)[num_images()] + end do + end do + if (any (a /= caf2)) then + STOP 8 + end if + sync all + + ! Array sections with different ranges and pos/neg strides + do i_sgn1 = -1, 1, 2 + do i_sgn2 = -1, 1, 2 + do i=lb1, n+lb1-1 + do i_e=lb1, n+lb1-1 + do i_s=1, n + do j=lb2, m+lb2-1 + do j_e=lb2, m+lb2-1 + do j_s=1, m + ! ARRAY = ARRAY + caf = -42 + a = -42 + caf2 = -42 + if (this_image() == num_images()) then + caf(:,:) = b(:,:) + endif + sync all + a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) & + = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) + caf2(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[this_image()] & + = caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[num_images()] + if (any (caf2 /= a)) then + STOP 9 + end if + sync all + end do + end do + end do + end do + end do + end do + end do + end do + end subroutine three +end program main Index: Fortran/gfortran/regression/coarray/stopped_images_1.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/stopped_images_1.f08 @@ -0,0 +1,20 @@ +! { dg-do compile } + +program test_stopped_images_1 + implicit none + + integer, allocatable :: gi(:) + real :: r + integer :: i + + gi = stopped_images() ! OK + gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" } + gi = stopped_images(KIND=1) ! OK + gi = stopped_images(KIND=4) ! OK + gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" } + gi = stopped_images(KIND=r) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be INTEGER" } + gi = stopped_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" } + gi = stopped_images(KIND=42) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" } + +end program test_stopped_images_1 + Index: Fortran/gfortran/regression/coarray/stopped_images_2.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/stopped_images_2.f08 @@ -0,0 +1,17 @@ +! { dg-do run } + +program test_stopped_images_2 + implicit none + + integer, allocatable :: si(:) + integer(kind=1), allocatable :: ssi(:) + + si = stopped_images() + if (size(si) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=1) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + ssi = stopped_images(KIND=8) + if (size(ssi) > 0) error stop "stopped_images result shall be empty array" + +end program test_stopped_images_2 + Index: Fortran/gfortran/regression/coarray/subobject_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/subobject_1.f90 @@ -0,0 +1,43 @@ +! { dg-do run } +! +! PR fortran/50420 +! Coarray subobjects were not accepted as valid coarrays + + integer :: i + integer, parameter :: la = 4, lb = 5, lc = 8 + integer, parameter :: init(la) = -4 + (/ (i, i=1,la) /) + + type t + integer :: i + end type t + type t2 + type(t), allocatable :: a[:] + end type t2 + type t3 + type(t), allocatable :: a(:)[:] + end type t3 + + type(t2) :: b + type(t3) :: c + + allocate(b%a[lb:*]) + b%a%i = 7 + if (b%a%i /= 7) STOP 1 + if (any (lcobound(b%a) /= (/ lb /))) STOP 2 + if (ucobound(b%a, dim=1) /= num_images() + lb - 1) STOP 3 + if (any (lcobound(b%a%i) /= (/ lb /))) STOP 4 + if (ucobound(b%a%i, dim=1) /= num_images() + lb - 1) STOP 5 + allocate(c%a(la)[lc:*]) + c%a%i = init + if (any(c%a%i /= init)) STOP 6 + if (any (lcobound(c%a) /= (/ lc /))) STOP 7 + if (ucobound(c%a, dim=1) /= num_images() + lc - 1) STOP 8 + if (any (lcobound(c%a%i) /= (/ lc /))) STOP 9 + if (ucobound(c%a%i, dim=1) /= num_images() + lc - 1) STOP 10 + if (c%a(2)%i /= init(2)) STOP 11 + if (any (lcobound(c%a(2)) /= (/ lc /))) STOP 12 + if (ucobound(c%a(2), dim=1) /= num_images() + lc - 1) STOP 13 + if (any (lcobound(c%a(2)%i) /= (/ lc /))) STOP 14 + if (ucobound(c%a(2)%i, dim=1) /= num_images() + lc - 1) STOP 15 + deallocate(b%a, c%a) +end Index: Fortran/gfortran/regression/coarray/sync_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/sync_1.f90 @@ -0,0 +1,64 @@ +! { dg-do run } +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n +character(len=30) :: str +critical +end critical +myCr: critical +end critical myCr + +! +! Test SYNC ALL +! +sync all +sync all ( ) +sync all (errmsg=str) + +n = 5 +sync all (stat=n) +if (n /= 0) STOP 1 + +n = 5 +sync all (stat=n,errmsg=str) +if (n /= 0) STOP 2 + + +! +! Test SYNC MEMORY +! +sync memory +sync memory ( ) +sync memory (errmsg=str) + +n = 5 +sync memory (stat=n) +if (n /= 0) STOP 3 + +n = 5 +sync memory (errmsg=str,stat=n) +if (n /= 0) STOP 4 + + +! +! Test SYNC IMAGES +! +sync images (*) +if (this_image() == 1) then + sync images (1) + sync images (1, errmsg=str) + sync images ([1]) +end if + +n = 5 +sync images (*, stat=n) +if (n /= 0) STOP 5 + +n = 5 +sync images (*,errmsg=str,stat=n) +if (n /= 0) STOP 6 + +end Index: Fortran/gfortran/regression/coarray/sync_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/sync_3.f90 @@ -0,0 +1,75 @@ +! { dg-do run } +! { dg-options "-fcheck=all" } +! { dg-shouldfail "Invalid image number -1 in SYNC IMAGES" } +! +! As sync_1, but with bounds checking enabled. +! PR fortran/52161 +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n +character(len=30) :: str +critical +end critical +myCr: critical +end critical myCr + +! +! Test SYNC ALL +! +sync all +sync all ( ) +sync all (errmsg=str) + +n = 5 +sync all (stat=n) +if (n /= 0) STOP 1 + +n = 5 +sync all (stat=n,errmsg=str) +if (n /= 0) STOP 2 + + +! +! Test SYNC MEMORY +! +sync memory +sync memory ( ) +sync memory (errmsg=str) + +n = 5 +sync memory (stat=n) +if (n /= 0) STOP 3 + +n = 5 +sync memory (errmsg=str,stat=n) +if (n /= 0) STOP 4 + + +! +! Test SYNC IMAGES +! +sync images (*) +if (this_image() == 1) then + sync images (1) + sync images (1, errmsg=str) + sync images ([1]) +end if + +n = 5 +sync images (*, stat=n) +if (n /= 0) STOP 5 + +n = 5 +sync images (*,errmsg=str,stat=n) +if (n /= 0) STOP 6 + +n = -1 +sync images ( num_images() ) +sync images (n) ! Invalid: "-1" + +end + +! { dg-output "Fortran runtime error: Invalid image number -1 in SYNC IMAGES" } Index: Fortran/gfortran/regression/coarray/this_image_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/this_image_1.f90 @@ -0,0 +1,196 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! this_image(coarray) run test, +! expecially for num_images > 1 +! +! Tested are values up to num_images == 8, +! higher values are OK, but not tested for +! +implicit none +integer :: a(1)[2:2, 3:4, 7:*] +integer :: b(:)[:, :,:] +allocatable :: b +integer :: i + +if (this_image(A, dim=1) /= 2) STOP 1 +i = 1 +if (this_image(A, dim=i) /= 2) STOP 2 + +select case (this_image()) + case (1) + if (this_image(A, dim=2) /= 3) STOP 3 + if (this_image(A, dim=3) /= 7) STOP 4 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 5 + i = 3 + if (this_image(A, dim=i) /= 7) STOP 6 + if (any (this_image(A) /= [2,3,7])) STOP 7 + + case (2) + if (this_image(A, dim=2) /= 4) STOP 8 + if (this_image(A, dim=3) /= 7) STOP 9 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 10 + i = 3 + if (this_image(A, dim=i) /= 7) STOP 11 + if (any (this_image(A) /= [2,4,7])) STOP 12 + + case (3) + if (this_image(A, dim=2) /= 3) STOP 13 + if (this_image(A, dim=3) /= 8) STOP 14 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 15 + i = 3 + if (this_image(A, dim=i) /= 8) STOP 16 + if (any (this_image(A) /= [2,3,8])) STOP 17 + + case (4) + if (this_image(A, dim=2) /= 4) STOP 18 + if (this_image(A, dim=3) /= 8) STOP 19 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 20 + i = 3 + if (this_image(A, dim=i) /= 8) STOP 21 + if (any (this_image(A) /= [2,4,8])) STOP 22 + + case (5) + if (this_image(A, dim=2) /= 3) STOP 23 + if (this_image(A, dim=3) /= 9) STOP 24 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 25 + i = 3 + if (this_image(A, dim=i) /= 9) STOP 26 + if (any (this_image(A) /= [2,3,9])) STOP 27 + + case (6) + if (this_image(A, dim=2) /= 4) STOP 28 + if (this_image(A, dim=3) /= 9) STOP 29 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 30 + i = 3 + if (this_image(A, dim=i) /= 9) STOP 31 + if (any (this_image(A) /= [2,4,9])) STOP 32 + + case (7) + if (this_image(A, dim=2) /= 3) STOP 33 + if (this_image(A, dim=3) /= 10) STOP 34 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 35 + i = 3 + if (this_image(A, dim=i) /= 10) STOP 36 + if (any (this_image(A) /= [2,3,10])) STOP 37 + + case (8) + if (this_image(A, dim=2) /= 4) STOP 38 + if (this_image(A, dim=3) /= 10) STOP 39 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 40 + i = 3 + if (this_image(A, dim=i) /= 10) STOP 41 + if (any (this_image(A) /= [2,4,10])) STOP 42 +end select + + +allocate (b(3)[-1:0,2:4,*]) + +select case (this_image()) + case (1) + if (this_image(B, dim=1) /= -1) STOP 43 + if (this_image(B, dim=2) /= 2) STOP 44 + if (this_image(B, dim=3) /= 1) STOP 45 + i = 1 + if (this_image(B, dim=i) /= -1) STOP 46 + i = 2 + if (this_image(B, dim=i) /= 2) STOP 47 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 48 + if (any (this_image(B) /= [-1,2,1])) STOP 49 + + case (2) + if (this_image(B, dim=1) /= 0) STOP 50 + if (this_image(B, dim=2) /= 2) STOP 51 + if (this_image(B, dim=3) /= 1) STOP 52 + i = 1 + if (this_image(B, dim=i) /= 0) STOP 53 + i = 2 + if (this_image(B, dim=i) /= 2) STOP 54 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 55 + if (any (this_image(B) /= [0,2,1])) STOP 56 + + case (3) + if (this_image(B, dim=1) /= -1) STOP 57 + if (this_image(B, dim=2) /= 3) STOP 58 + if (this_image(B, dim=3) /= 1) STOP 59 + i = 1 + if (this_image(B, dim=i) /= -1) STOP 60 + i = 2 + if (this_image(B, dim=i) /= 3) STOP 61 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 62 + if (any (this_image(B) /= [-1,3,1])) STOP 63 + + case (4) + if (this_image(B, dim=1) /= 0) STOP 64 + if (this_image(B, dim=2) /= 3) STOP 65 + if (this_image(B, dim=3) /= 1) STOP 66 + i = 1 + if (this_image(B, dim=i) /= 0) STOP 67 + i = 2 + if (this_image(B, dim=i) /= 3) STOP 68 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 69 + if (any (this_image(B) /= [0,3,1])) STOP 70 + + case (5) + if (this_image(B, dim=1) /= -1) STOP 71 + if (this_image(B, dim=2) /= 4) STOP 72 + if (this_image(B, dim=3) /= 1) STOP 73 + i = 1 + if (this_image(B, dim=i) /= -1) STOP 74 + i = 2 + if (this_image(B, dim=i) /= 4) STOP 75 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 76 + if (any (this_image(B) /= [-1,4,1])) STOP 77 + + case (6) + if (this_image(B, dim=1) /= 0) STOP 78 + if (this_image(B, dim=2) /= 4) STOP 79 + if (this_image(B, dim=3) /= 1) STOP 80 + i = 1 + if (this_image(B, dim=i) /= 0) STOP 81 + i = 2 + if (this_image(B, dim=i) /= 4) STOP 82 + i = 3 + if (this_image(B, dim=i) /= 1) STOP 83 + if (any (this_image(B) /= [0,4,1])) STOP 84 + + case (7) + if (this_image(B, dim=1) /= -1) STOP 85 + if (this_image(B, dim=2) /= 2) STOP 86 + if (this_image(B, dim=3) /= 2) STOP 87 + i = 1 + if (this_image(B, dim=i) /= -1) STOP 88 + i = 2 + if (this_image(B, dim=i) /= 2) STOP 89 + i = 3 + if (this_image(B, dim=i) /= 2) STOP 90 + if (any (this_image(B) /= [-1,2,2])) STOP 91 + + case (8) + if (this_image(B, dim=1) /= 0) STOP 92 + if (this_image(B, dim=2) /= 2) STOP 93 + if (this_image(B, dim=3) /= 2) STOP 94 + i = 1 + if (this_image(B, dim=i) /= 0) STOP 95 + i = 2 + if (this_image(B, dim=i) /= 2) STOP 96 + i = 3 + if (this_image(B, dim=i) /= 2) STOP 97 + if (any (this_image(B) /= [0,2,2])) STOP 98 +end select + +end Index: Fortran/gfortran/regression/coarray/this_image_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/coarray/this_image_2.f90 @@ -0,0 +1,125 @@ +! { dg-do run } +! +! PR fortran/18918 +! +! Version for scalar coarrays +! +! this_image(coarray) run test, +! expecially for num_images > 1 +! +! Tested are values up to num_images == 8, +! higher values are OK, but not tested for +! +implicit none +integer :: a[2:2, 3:4, 7:*] +integer :: i + +if (this_image(A, dim=1) /= 2) STOP 1 +i = 1 +if (this_image(A, dim=i) /= 2) STOP 2 + +select case (this_image()) + case (1) + if (this_image(A, dim=2) /= 3) STOP 3 + if (this_image(A, dim=3) /= 7) STOP 4 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 5 + i = 3 + if (this_image(A, dim=i) /= 7) STOP 6 + if (any (this_image(A) /= [2,3,7])) STOP 7 + + case (2) + if (this_image(A, dim=2) /= 4) STOP 8 + if (this_image(A, dim=3) /= 7) STOP 9 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 10 + i = 3 + if (this_image(A, dim=i) /= 7) STOP 11 + if (any (this_image(A) /= [2,4,7])) STOP 12 + + case (3) + if (this_image(A, dim=2) /= 3) STOP 13 + if (this_image(A, dim=3) /= 8) STOP 14 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 15 + i = 3 + if (this_image(A, dim=i) /= 8) STOP 16 + if (any (this_image(A) /= [2,3,8])) STOP 17 + + case (4) + if (this_image(A, dim=2) /= 4) STOP 18 + if (this_image(A, dim=3) /= 8) STOP 19 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 20 + i = 3 + if (this_image(A, dim=i) /= 8) STOP 21 + if (any (this_image(A) /= [2,4,8])) STOP 22 + + case (5) + if (this_image(A, dim=2) /= 3) STOP 23 + if (this_image(A, dim=3) /= 9) STOP 24 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 25 + i = 3 + if (this_image(A, dim=i) /= 9) STOP 26 + if (any (this_image(A) /= [2,3,9])) STOP 27 + + case (6) + if (this_image(A, dim=2) /= 4) STOP 28 + if (this_image(A, dim=3) /= 9) STOP 29 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 30 + i = 3 + if (this_image(A, dim=i) /= 9) STOP 31 + if (any (this_image(A) /= [2,4,9])) STOP 32 + + case (7) + if (this_image(A, dim=2) /= 3) STOP 33 + if (this_image(A, dim=3) /= 10) STOP 34 + i = 2 + if (this_image(A, dim=i) /= 3) STOP 35 + i = 3 + if (this_image(A, dim=i) /= 10) STOP 36 + if (any (this_image(A) /= [2,3,10])) STOP 37 + + case (8) + if (this_image(A, dim=2) /= 4) STOP 38 + if (this_image(A, dim=3) /= 10) STOP 39 + i = 2 + if (this_image(A, dim=i) /= 4) STOP 40 + i = 3 + if (this_image(A, dim=i) /= 10) STOP 41 + if (any (this_image(A) /= [2,4,10])) STOP 42 +end select + +contains + +subroutine test_image_index +implicit none +integer :: index1, index2, index3 +logical :: one + +integer, save :: d(2)[-1:3, *] +integer, save :: e(2)[-1:-1, 3:*] + +one = num_images() == 1 + +index1 = image_index(d, [-1, 1] ) +index2 = image_index(d, [0, 1] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 43 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 44 + +index1 = image_index(e, [-1, 3] ) +index2 = image_index(e, [-1, 4] ) + +if (one .and. (index1 /= 1 .or. index2 /= 0)) & + STOP 45 +if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) & + STOP 46 + +end subroutine test_image_index + +end Index: Fortran/gfortran/regression/debug/debug.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/debug.exp @@ -0,0 +1,41 @@ +# Copyright (C) 2008-2023 Free Software Foundation, Inc. + +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free +# Software Foundation; either version 3, or (at your option) any later +# version. +# +# GCC is distributed in the hope that it will be useful, but WITHOUT ANY +# WARRANTY; without even the implied warranty of MERCHANTABILITY or +# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +# for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp +load_lib gfortran.exp + +# Debugging testsuite proc +proc gfortran-debug-dg-test { prog do_what extra_tool_flags } { + return [gfortran-dg-test $prog $do_what $extra_tool_flags] +} + +# Initialize `dg'. +dg-init + +# Main loop. + +gfortran_init + +gfortran-dg-debug-runtest gfortran_target_compile trivial.f "" \ + [lsort [glob -nocomplain $srcdir/$subdir/*.\[fS\]]] + +# All done. +dg-finish Index: Fortran/gfortran/regression/debug/pr35154-dwarf2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/pr35154-dwarf2.f @@ -0,0 +1,38 @@ +C Test program for common block debugging. G. Helffrich 11 July 2004. +C { dg-do compile } +C { dg-skip-if "DWARF-2 only" { "*-*-*" } { "*" } { "-gdwarf-2" } } +C { dg-skip-if "DWARF-2 only" { "*-*-*" } { "-g1" } { "" } } +C { dg-options "-dA -gno-strict-dwarf" } + common i,j + common /label/l,m + i = 1 + j = 2 + k = 3 + l = 4 + m = 5 + call sub + end + subroutine sub + common /label/l,m + logical first + save n + data first /.true./ + if (first) then + n = 0 + first = .false. + endif + n = n + 1 + l = l + 1 + return + end + +C { dg-final { scan-assembler "DIE\[^\n\]*DW_TAG_common_block" } } +C { dg-final { scan-assembler "(DW_AT_name: \"__BLNK__\"|\"__BLNK__\[^\n\]*\"\[^\n\]*DW_AT_name)" } } +C { dg-final { scan-assembler "DIE\[^\n\]*DW_TAG_variable" } } +C { dg-final { scan-assembler "\"i\[^\n\]*\"\[^\n\]*DW_AT_name" } } +C { dg-final { scan-assembler "\"j\[^\n\]*\"\[^\n\]*DW_AT_name" } } +C { dg-final { scan-assembler "DIE\[^\n\]*DW_TAG_common_block" } } +C { dg-final { scan-assembler "(DW_AT_name: \"label\"|\"label\[^\n\]*\"\[^\n\]*DW_AT_name)" } } +C { dg-final { scan-assembler "DIE\[^\n\]*DW_TAG_variable" } } +C { dg-final { scan-assembler "\"l\[^\n\]*\"\[^\n\]*DW_AT_name" } } +C { dg-final { scan-assembler "\"m\[^\n\]*\"\[^\n\]*DW_AT_name" } } Index: Fortran/gfortran/regression/debug/pr37738.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/pr37738.f @@ -0,0 +1,31 @@ +C PR debug/37738 +C { dg-do compile } +C { dg-skip-if "DWARF-2 only" { "*-*-*" } { "*" } { "-gdwarf-2" } } +C { dg-skip-if "DWARF-2 only" { "*-*-*" } { "-g1" } { "" } } +C { dg-options "-dA -gno-strict-dwarf" } + + subroutine a + integer*4 a_i, c_i + common /block/a_i, c_i + a_i = 1 + c_i = 4 + end subroutine a + subroutine b + integer*4 b_i + common /block/b_i, d_i + b_i = 2 + d_i = 5 + end subroutine b + subroutine c + integer*4 a_i, c_i + common /block/a_i, c_i + if (a_i .ne. 2) STOP 1 + if (c_i .ne. 5) STOP 2 + end subroutine c + program abc + call a + call b + call c + end program abc + +C { dg-final { scan-assembler-times "DIE\[^\n\]*DW_TAG_common_block" 3 } } Index: Fortran/gfortran/regression/debug/pr43166.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/pr43166.f @@ -0,0 +1,14 @@ +C PR debug/43166 +C { dg-do compile } +C { dg-options "-O" } + SUBROUTINE FOO () + INTEGER V1 + COMMON // V1 + END + SUBROUTINE BAR () + INTEGER V0,V1,V2,V3 + COMMON // V1(4),V2(85,4),V3 + DO V3=1,V1(1) + V0=V2(V3,1) + END DO + END Index: Fortran/gfortran/regression/debug/pr46756.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/pr46756.f @@ -0,0 +1,30 @@ +C PR debug/46756, reduced from ../20010519-1.f +C { dg-do compile } +C { dg-options "-O -fcompare-debug" } + + LOGICAL QDISK,QDW,QCMPCT + LOGICAL LNOMA,LRAISE,LSCI,LBIG + ASSIGN 801 TO I800 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 800 + 801 CONTINUE + ASSIGN 761 TO I760 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + 761 CONTINUE + IF(LSCI) THEN + DO I=1,LENCM + ENDDO + ENDIF + DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX)) + IF(.NOT.QDW) THEN + ASSIGN 641 to I640 ! { dg-warning "Deleted feature: ASSIGN" "Deleted feature: ASSIGN" } + GOTO 640 + 641 CONTINUE + ENDIF + ENDDO + GOTO 700 + 640 CONTINUE + GOTO I640 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + 700 CONTINUE + GOTO I760 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + 800 CONTINUE + GOTO I800 ! { dg-warning "Deleted feature: Assigned" "Assigned GO TO" } + END Index: Fortran/gfortran/regression/debug/trivial.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/debug/trivial.f @@ -0,0 +1,2 @@ + program trivial + end Index: Fortran/gfortran/regression/g77/12002.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/12002.f @@ -0,0 +1,6 @@ +C PR middle-end/12002 +C { dg-do compile } + COMPLEX TE1 + TE1=-2. + TE1=TE1+TE1 + END Index: Fortran/gfortran/regression/g77/12632.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/12632.f @@ -0,0 +1,6 @@ +C { dg-do compile } +C { dg-options "-fbounds-check" } + INTEGER I(1) + I(2) = 0 ! { dg-warning "out of bounds" "out of bounds" } + END + Index: Fortran/gfortran/regression/g77/13037.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/13037.f @@ -0,0 +1,59 @@ +c { dg-do run } +c PR optimization/13037 +c Contributed by Kirill Smelkov +c bug symptom: zeta(kkzc) seems to reference to zeta(kkzc-1) instead +c with gcc-3.2.2 it is OK, so it is a regression. +c + subroutine bug1(expnt) + implicit none + + double precision zeta + common /bug1_area/zeta(3) + + double precision expnt(3) + + + integer k, kkzc + + kkzc=0 + do k=1,3 + kkzc = kkzc + 1 + zeta(kkzc) = expnt(k) + enddo + +c the following line activates the bug + call bug1_activator(kkzc) + end + + +c dummy subroutine + subroutine bug1_activator(inum) + implicit none + integer inum + end + + +c test driver + program test_bug1 + implicit none + + double precision zeta + common /bug1_area/zeta(3) + + double precision expnt(3) + + zeta(1) = 0.0d0 + zeta(2) = 0.0d0 + zeta(3) = 0.0d0 + + expnt(1) = 1.0d0 + expnt(2) = 2.0d0 + expnt(3) = 3.0d0 + + call bug1(expnt) + if ((zeta(1).ne.1) .or. (zeta(2).ne.2) .or. (zeta(3).ne.3)) then + STOP 1 + endif + + end + Index: Fortran/gfortran/regression/g77/13060.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/13060.f @@ -0,0 +1,14 @@ +c { dg-do compile } + subroutine geo2() + implicit none + + integer ms,n,ne(2) + + ne(1) = 1 + ne(2) = 2 + ms = 1 + + call call_me(ne(1)*ne(1)) + + n = ne(ms) + end Index: Fortran/gfortran/regression/g77/1832.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/1832.f @@ -0,0 +1,9 @@ +c { dg-do run } +! { dg-options "-std=legacy" } +! + character*5 string + write(string, *) "a " + if (string .ne. ' a') STOP 1 +C-- The leading space is normal for list-directed output + + end Index: Fortran/gfortran/regression/g77/19981119-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19981119-0.f @@ -0,0 +1,41 @@ +c { dg-do run } +* X-Delivered: at request of burley on mescaline.gnu.org +* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET) +* From: "B. Yanchitsky" +* To: fortran@gnu.org +* Subject: Bug report +* MIME-Version: 1.0 +* Content-Type: TEXT/PLAIN; charset=US-ASCII +* +* There is a trouble with g77 on Alpha. +* My configuration: +* Digital Personal Workstation 433au, +* Digital Unix 4.0D, +* GNU Fortran 0.5.23 and GNU C 2.8.1. +* +* The following program treated successfully but crashed when running. +* +* C --- PROGRAM BEGIN ------- +* + subroutine sub(N,u) + integer N + double precision u(-N:N,-N:N) + +C vvvv CRASH HERE vvvvv + u(-N,N)=0d0 + return + end + + + program bug + integer N + double precision a(-10:10,-10:10) + data a/441*1d0/ + N=10 + call sub(N,a) + if (a(-N,N) .ne. 0d0) STOP 1 + end +* +* C --- PROGRAM END ------- +* +* Good luck! Index: Fortran/gfortran/regression/g77/19981216-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19981216-0.f @@ -0,0 +1,92 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +* Resent-From: Craig Burley +* Resent-To: craig@jcb-sc.com +* X-Delivered: at request of burley on mescaline.gnu.org +* Date: Wed, 16 Dec 1998 18:31:24 +0100 +* From: Dieter Stueken +* Organization: con terra GmbH +* To: fortran@gnu.org +* Subject: possible bug +* Content-Type: text/plain; charset=iso-8859-1 +* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085 +* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2 +* +* Hi, +* +* I'm about to compile a very old, very ugly Fortran program. +* For one part I got: +* +* f77: Internal compiler error: program f771 got fatal signal 6 +* +* instead of any detailed error message. I was able to break down the +* problem to the following source fragment: +* +* ------------------------------------------- + PROGRAM WAP + + integer(kind=8) ios + character*80 name + + name = 'blah' + open(unit=8,status='unknown',file=name,form='formatted', + F iostat=ios) + + END +* ------------------------------------------- +* +* The problem seems to be caused by the "integer(kind=2) ios" declaration. +* So far I solved it by simply using a plain integer instead. +* +* I'm running gcc on a Linux system compiled/installed +* with no special options: +* +* -> g77 -v +* g77 version 0.5.23 +* Driving: g77 -v -c -xf77-version /dev/null -xnone +* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs +* gcc version 2.8.1 +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef +* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__ +* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional +* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__ +* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null +* /dev/null +* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF) +* #include "..." search starts here: +* #include <...> search starts here: +* /usr/local/include +* /usr/i686-pc-linux-gnulibc1/include +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include +* /usr/include +* End of search list. +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version +* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s +* /dev/null +* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version +* 2.8.1. +* GNU Fortran Front End version 0.5.23 +* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s +* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1 +* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911 +* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o +* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o +* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc +* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o +* /usr/lib/crtn.o +* /tmp/cca24911 +* __G77_LIBF77_VERSION__: 0.5.23 +* @(#)LIBF77 VERSION 19970919 +* __G77_LIBI77_VERSION__: 0.5.23 +* @(#) LIBI77 VERSION pjw,dmg-mods 19980405 +* __G77_LIBU77_VERSION__: 0.5.23 +* @(#) LIBU77 VERSION 19970919 +* +* +* Regards, Dieter. +* -- +* Dieter Stüken, con terra GmbH, Münster +* stueken@conterra.de stueken@qgp.uni-muenster.de +* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken +* (0)251-980-2027 (0)251-83-334974 Index: Fortran/gfortran/regression/g77/19990218-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990218-0.f @@ -0,0 +1,14 @@ +c { dg-do compile } + program test + double precision a,b,c + data a,b/1.0d-46,1.0d0/ + c=fun(a,b) ! { dg-error "Return type mismatch of function" } + print*,'in main: fun=',c + end + double precision function fun(a,b) + double precision a,b + print*,'in sub: a,b=',a,b + fun=a*b + print*,'in sub: fun=',fun + return + end Index: Fortran/gfortran/regression/g77/19990218-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990218-1.f @@ -0,0 +1,25 @@ +c { dg-do compile } +c +c g77 used to warn for this case +c 19990218-1.f: In program `test': +c 19990218-1.f:13: +c double precision function fun(a,b) +c 1 +c 19990218-1.f:23: (continued): +c c=fun(a,b) +c 2 +c Global name `fun' at (2) has different type at (1) [info -f g77 M GLOBALS] +c + double precision function fun(a,b) + double precision a,b + print*,'in sub: a,b=',a,b + fun=a*b + print*,'in sub: fun=',fun + return + end + program test + double precision a,b,c + data a,b/1.0d-46,1.0d0/ + c=fun(a,b) ! { dg-error "Return type mismatch of function" } + print*,'in main: fun=',c + end Index: Fortran/gfortran/regression/g77/19990305-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990305-0.f @@ -0,0 +1,56 @@ +c { dg-do compile } +* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST) +* From: Denes Molnar +* To: fortran@gnu.org +* Subject: f771 gets fatal signal 6 +* Content-Type: TEXT/PLAIN; charset=US-ASCII +* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f +* +* Hi, +* +* +* Comiling object from the source code below WORKS FINE with +* 'g77 -o hwuci2 -c hwuci2.F' +* but FAILS with fatal signal 6 +* 'g77 -o hwuci2 -O -c hwuci2.F' +* +* Any explanations? +* +* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1). +* +* +* Denes Molnar +* +* %%%%%%%%%%%%%%%%%%%%%%%%% +* %the source: +* %%%%%%%%%%%%%%%%%%%%%%%%% +* +CDECK ID>, HWUCI2. +*CMZ :- -23/08/94 13.22.29 by Mike Seymour +*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles +C----------------------------------------------------------------------- + FUNCTION HWUCI2(A,B,Y0) +C----------------------------------------------------------------------- +C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0) +C----------------------------------------------------------------------- + IMPLICIT NONE + complex(kind=8) HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4 + DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF + EXTERNAL HWULI2 + COMMON/SMALL/EPSI + PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0) + IF(B.EQ.ZERO)THEN + HWUCI2=CMPLX(ZERO,ZERO) + ELSE + Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B)) + Y2=ONE-Y1 + Z1=Y0/(Y0-Y1) + Z2=(Y0-ONE)/(Y0-Y1) + Z3=Y0/(Y0-Y2) + Z4=(Y0-ONE)/(Y0-Y2) + HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4) + ENDIF + RETURN + END +* +* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Index: Fortran/gfortran/regression/g77/19990313-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990313-0.f @@ -0,0 +1,34 @@ +c { dg-do run } +* To: craig@jcb-sc.com +* Subject: Re: G77 and KIND=2 +* Content-Type: text/plain; charset=us-ascii +* From: Dave Love +* Date: 03 Mar 1999 18:20:11 +0000 +* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000" +* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3 +* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0 +* +* ISTM that there is a real problem printing integer(kind=8) (on x86): +* +* $ cat x.f +*[modified for test suite] + integer(kind=8) foo, bar + data r/4e10/ + foo = 4e10 + bar = r + if (foo .ne. bar) STOP 1 + end +* $ g77 x.f && ./a.out +* 1345294336 +* 123 +* $ f2c x.f && g77 x.c && ./a.out +* x.f: +* MAIN: +* 40000000000 +* 123 +* $ +* +* Gdb shows the upper half of the buffer passed to do_lio is zeroed in +* the g77 case. +* +* I've forgotten how the code generation happens. Index: Fortran/gfortran/regression/g77/19990313-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990313-1.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + double precision r + data r/4d10/ + foo = 4d10 + bar = r + if (foo .ne. bar) STOP 1 + end Index: Fortran/gfortran/regression/g77/19990313-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990313-2.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + complex c + data c/(4e10,0)/ + foo = 4e10 + bar = c + if (foo .ne. bar) STOP 1 + end Index: Fortran/gfortran/regression/g77/19990313-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990313-3.f @@ -0,0 +1,8 @@ +c { dg-do run } + integer(kind=8) foo, bar + complex(kind=8) c + data c/(4d10,0)/ + foo = 4d10 + bar = c + if (foo .ne. bar) STOP 1 + end Index: Fortran/gfortran/regression/g77/19990419-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990419-0.f @@ -0,0 +1,8 @@ +c { dg-do compile } +* Test case Toon submitted, cut down to expose the one bug. +* Belongs in compile/. + SUBROUTINE INIERS1 + IMPLICIT LOGICAL(L) + COMMON/COMIOD/ NHIERS1, LERS1 + inquire(nhiers1, exist=lers1) + END Index: Fortran/gfortran/regression/g77/19990419-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990419-1.f @@ -0,0 +1,22 @@ +c { dg-do run } +* Test DO WHILE, to make sure it fully reevaluates its expression. +* Belongs in execute/. + common /x/ ival + j = 0 + do while (i() .eq. 1) + j = j + 1 + if (j .gt. 5) STOP 1 + end do + if (j .ne. 4) STOP 2 + if (ival .ne. 5) STOP 3 + end + function i() + common /x/ ival + ival = ival + 1 + i = 10 + if (ival .lt. 5) i = 1 + end + block data + common /x/ ival + data ival/0/ + end Index: Fortran/gfortran/regression/g77/19990502-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990502-0.f @@ -0,0 +1,67 @@ +c { dg-do compile } +* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm +* Precedence: bulk +* Sender: owner-egcs-bugs@egcs.cygnus.com +* From: Norbert Conrad +* Subject: egcs g77 19990524pre Internal compiler error in `print_operand' +* To: egcs-bugs@egcs.cygnus.com +* Date: Mon, 31 May 1999 11:46:52 +0200 (CET) +* Content-Type: text/plain; charset=US-ASCII +* X-UIDL: 9a00095a5fe4d774b7223de071157374 +* +* Hi, +* +* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524 +* on an i686-pc-linux-gnu. The program below gives an internal compiler error. +* +* +* Script started on Mon May 31 11:30:01 1999 +* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f +* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515) +* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs +* gcc version gcc-2.95 19990524 (prerelease) +* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s +* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease). +* GNU Fortran Front End version 0.5.24-19990515 +* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405 +* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'. +* See for details. +* lx{g010}:/tmp>cat e3.f + SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 ) + DOUBLE PRECISION SMALL2, TOL2 + DOUBLE PRECISION EE( * ), QQ( * ) + INTEGER ICONV, N, OFF + DOUBLE PRECISION QEMAX, XINF + EXTERNAL DLASQ3 + INTRINSIC MAX, SQRT + XINF = 0.0D0 + ICONV = 0 + IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN + END IF + IF( EE( N-2 ).LE.MAX( XINF, SMALL2, + $ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN + QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) + END IF + IF( N.EQ.0 ) THEN + IF( OFF.EQ.0 ) THEN + RETURN + ELSE + XINF =0.0D0 + END IF + ELSE IF( N.EQ.2 ) THEN + END IF + CALL DLASQ3(ICONV) + END +* lx{g010}:/tmp>exit +* +* Script done on Mon May 31 11:30:23 1999 +* +* Best regards, +* +* Norbert. +* -- +* Norbert Conrad phone: ++49 641 9913021 +* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de +* Heinrich-Buff-Ring 44 +* 35392 Giessen +* Germany Index: Fortran/gfortran/regression/g77/19990502-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990502-1.f @@ -0,0 +1,7 @@ +c { dg-do compile } + SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY) + INTEGER(kind=2) IGAMS(2,NADC) + in = 1 + do while (in.le.nadc.and.IGAMS(2,in).le.in) + enddo + END Index: Fortran/gfortran/regression/g77/19990525-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990525-0.f @@ -0,0 +1,53 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm +* Precedence: bulk +* Sender: owner-egcs-bugs@egcs.cygnus.com +* From: "Bjorn R. Bjornsson" +* Subject: g77 char expr. as arg to subroutine bug +* To: egcs-bugs@egcs.cygnus.com +* Date: Tue, 25 May 1999 14:45:56 +0000 (GMT) +* Content-Type: text/plain; charset=US-ASCII +* X-UIDL: 06000c94269ed6dfe826493e52a818b9 +* +* The following bug is in all snapshots starting +* from April 18. I have only tested this on Alpha linux, +* and with FFECOM_FASTER_ARRAY_REFS set to 1. +* +* Run the following through g77: +* + subroutine a + character*2 string1 + character*2 string2 + character*4 string3 + string1 = 's1' + string2 = 's2' +c +c the next 2 lines are ok. + string3 = (string1 // string2) + call b(string1//string2) +c +c this line gives gcc/f/com.c:10660: failed assertion `hook' + call b((string1//string2)) + end +* +* the output from: +* +* /usr/local/egcs-19990418/bin/g77 --verbose -c D.f +* +* is: +* +* on egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (from FSF-g77 version 0.5.24-19990418) +* Reading specs from /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/specs +* gcc version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) +* /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/f771 D.f -quiet -dumpbase D.f -version -fversion -o /tmp/ccNpaaaa.s +* GNU F77 version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (alphaev56-unknown-linux-gnu) compiled by GNU C version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental). +* GNU Fortran Front End version 0.5.24-19990418 +* ../../../egcs-19990418/gcc/f/com.c:10351: failed assertion `hook' +* g77: Internal compiler error: program f771 got fatal signal 6 +* +* Yours, +* +* Bjorn R. Bjornsson +* brb@halo.hi.is Index: Fortran/gfortran/regression/g77/19990826-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990826-0.f @@ -0,0 +1,20 @@ +c { dg-do run } +* From: niles@fan745.gsfc.nasa.gov +* To: fortran@gnu.org +* Cc: niles@fan745.gsfc.nasa.gov +* Subject: problem with DNINT() on Linux/Alpha. +* Date: Sun, 06 Jun 1999 16:39:35 -0400 +* X-UIDL: 6aa9208d7bda8b6182a095dfd37016b7 + + IF (DNINT(0.0D0) .NE. 0.) STOP 1 + STOP + END + +* Result on Linux/i386: " 0." (and every other computer!) +* Result on Linux/alpha: " 3.6028797E+16" + +* It seems to work fine if I change it to the generic NINT(). Probably +* a name pollution problem in the new C library, but it seems bad. no? + +* Thanks, +* Rick Niles. Index: Fortran/gfortran/regression/g77/19990826-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990826-1.f @@ -0,0 +1,287 @@ +c { dg-do compile } +* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST) +* From: Jonathan Ravens +* To: gcc-bugs@gcc.gnu.org +* Subject: g77 bug report +* X-UIDL: a0bf5ecc21487cde48d9104983ab04d6 + +! This fortran source will not compile - if the penultimate elseif block is 0 +! included then the message appears : +! +! /usr/src/egcs//gcc-2.95.1/gcc/f/stw.c:308: failed assertion `b->uses_ > 0' +! g77: Internal compiler error: program f771 got fatal signal 6 +! +! The command was : g77 -c +! +! The OS is Red Hat 6, and the output from uname -a is +! Linux grfw1452.gns.cri.nz 2.2.5-15 #1 Mon Apr 19 23:00:46 EDT 1999 i686 unknown +! +! The configure script I used was +! /usr/src/egcs/gcc/gcc-2.95.1/configure --enable-languages=f77 i585-unknown-linux +! +! I was installing 2.95 because under EGCS 2.1.1 none of my code was working +! with optimisation turned on, and there were still bugs with no optimisation +! (all of which code works fine under g77 0.5.21 and Sun/IBM/Dec/HP fortrans). +! +! The version of g77 is : +! +!g77 version 2.95.1 19990816 (release) (from FSF-g77 version 0.5.25 19990816 (release)) + + program main + if (i.eq.1) then + call abc(1) + else if (i.eq. 1) then + call abc( 1) + else if (i.eq. 2) then + call abc( 2) + else if (i.eq. 3) then + call abc( 3) + else if (i.eq. 4) then + call abc( 4) + else if (i.eq. 5) then + call abc( 5) + else if (i.eq. 6) then + call abc( 6) + else if (i.eq. 7) then + call abc( 7) + else if (i.eq. 8) then + call abc( 8) + else if (i.eq. 9) then + call abc( 9) + else if (i.eq. 10) then + call abc( 10) + else if (i.eq. 11) then + call abc( 11) + else if (i.eq. 12) then + call abc( 12) + else if (i.eq. 13) then + call abc( 13) + else if (i.eq. 14) then + call abc( 14) + else if (i.eq. 15) then + call abc( 15) + else if (i.eq. 16) then + call abc( 16) + else if (i.eq. 17) then + call abc( 17) + else if (i.eq. 18) then + call abc( 18) + else if (i.eq. 19) then + call abc( 19) + else if (i.eq. 20) then + call abc( 20) + else if (i.eq. 21) then + call abc( 21) + else if (i.eq. 22) then + call abc( 22) + else if (i.eq. 23) then + call abc( 23) + else if (i.eq. 24) then + call abc( 24) + else if (i.eq. 25) then + call abc( 25) + else if (i.eq. 26) then + call abc( 26) + else if (i.eq. 27) then + call abc( 27) + else if (i.eq. 28) then + call abc( 28) + else if (i.eq. 29) then + call abc( 29) + else if (i.eq. 30) then + call abc( 30) + else if (i.eq. 31) then + call abc( 31) + else if (i.eq. 32) then + call abc( 32) + else if (i.eq. 33) then + call abc( 33) + else if (i.eq. 34) then + call abc( 34) + else if (i.eq. 35) then + call abc( 35) + else if (i.eq. 36) then + call abc( 36) + else if (i.eq. 37) then + call abc( 37) + else if (i.eq. 38) then + call abc( 38) + else if (i.eq. 39) then + call abc( 39) + else if (i.eq. 40) then + call abc( 40) + else if (i.eq. 41) then + call abc( 41) + else if (i.eq. 42) then + call abc( 42) + else if (i.eq. 43) then + call abc( 43) + else if (i.eq. 44) then + call abc( 44) + else if (i.eq. 45) then + call abc( 45) + else if (i.eq. 46) then + call abc( 46) + else if (i.eq. 47) then + call abc( 47) + else if (i.eq. 48) then + call abc( 48) + else if (i.eq. 49) then + call abc( 49) + else if (i.eq. 50) then + call abc( 50) + else if (i.eq. 51) then + call abc( 51) + else if (i.eq. 52) then + call abc( 52) + else if (i.eq. 53) then + call abc( 53) + else if (i.eq. 54) then + call abc( 54) + else if (i.eq. 55) then + call abc( 55) + else if (i.eq. 56) then + call abc( 56) + else if (i.eq. 57) then + call abc( 57) + else if (i.eq. 58) then + call abc( 58) + else if (i.eq. 59) then + call abc( 59) + else if (i.eq. 60) then + call abc( 60) + else if (i.eq. 61) then + call abc( 61) + else if (i.eq. 62) then + call abc( 62) + else if (i.eq. 63) then + call abc( 63) + else if (i.eq. 64) then + call abc( 64) + else if (i.eq. 65) then + call abc( 65) + else if (i.eq. 66) then + call abc( 66) + else if (i.eq. 67) then + call abc( 67) + else if (i.eq. 68) then + call abc( 68) + else if (i.eq. 69) then + call abc( 69) + else if (i.eq. 70) then + call abc( 70) + else if (i.eq. 71) then + call abc( 71) + else if (i.eq. 72) then + call abc( 72) + else if (i.eq. 73) then + call abc( 73) + else if (i.eq. 74) then + call abc( 74) + else if (i.eq. 75) then + call abc( 75) + else if (i.eq. 76) then + call abc( 76) + else if (i.eq. 77) then + call abc( 77) + else if (i.eq. 78) then + call abc( 78) + else if (i.eq. 79) then + call abc( 79) + else if (i.eq. 80) then + call abc( 80) + else if (i.eq. 81) then + call abc( 81) + else if (i.eq. 82) then + call abc( 82) + else if (i.eq. 83) then + call abc( 83) + else if (i.eq. 84) then + call abc( 84) + else if (i.eq. 85) then + call abc( 85) + else if (i.eq. 86) then + call abc( 86) + else if (i.eq. 87) then + call abc( 87) + else if (i.eq. 88) then + call abc( 88) + else if (i.eq. 89) then + call abc( 89) + else if (i.eq. 90) then + call abc( 90) + else if (i.eq. 91) then + call abc( 91) + else if (i.eq. 92) then + call abc( 92) + else if (i.eq. 93) then + call abc( 93) + else if (i.eq. 94) then + call abc( 94) + else if (i.eq. 95) then + call abc( 95) + else if (i.eq. 96) then + call abc( 96) + else if (i.eq. 97) then + call abc( 97) + else if (i.eq. 98) then + call abc( 98) + else if (i.eq. 99) then + call abc( 99) + else if (i.eq. 100) then + call abc( 100) + else if (i.eq. 101) then + call abc( 101) + else if (i.eq. 102) then + call abc( 102) + else if (i.eq. 103) then + call abc( 103) + else if (i.eq. 104) then + call abc( 104) + else if (i.eq. 105) then + call abc( 105) + else if (i.eq. 106) then + call abc( 106) + else if (i.eq. 107) then + call abc( 107) + else if (i.eq. 108) then + call abc( 108) + else if (i.eq. 109) then + call abc( 109) + else if (i.eq. 110) then + call abc( 110) + else if (i.eq. 111) then + call abc( 111) + else if (i.eq. 112) then + call abc( 112) + else if (i.eq. 113) then + call abc( 113) + else if (i.eq. 114) then + call abc( 114) + else if (i.eq. 115) then + call abc( 115) + else if (i.eq. 116) then + call abc( 116) + else if (i.eq. 117) then + call abc( 117) + else if (i.eq. 118) then + call abc( 118) + else if (i.eq. 119) then + call abc( 119) + else if (i.eq. 120) then + call abc( 120) + else if (i.eq. 121) then + call abc( 121) + else if (i.eq. 122) then + call abc( 122) + else if (i.eq. 123) then + call abc( 123) + else if (i.eq. 124) then + call abc( 124) + else if (i.eq. 125) then !< Miscompiles if present + call abc( 125) !< + +c else if (i.eq. 126) then +c call abc( 126) + endif + end Index: Fortran/gfortran/regression/g77/19990826-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990826-2.f @@ -0,0 +1,36 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +* From: "Billinghurst, David (RTD)" +* Subject: RE: single precision complex bug in g77 - was Testing g77 with LA +* PACK 3.0 +* Date: Thu, 8 Jul 1999 00:55:11 +0100 +* X-UIDL: b00d9d8081a36fef561b827d255dd4a5 + +* Here is a slightly simpler and neater test case + + program labug3 + implicit none + +* This program gives the wrong answer on mips-sgi-irix6.5 +* when compiled with g77 from egcs-19990629 (gcc 2.95 prerelease) +* Get a = 0.0 when it should be 1.0 +* +* Works with: -femulate-complex +* egcs-1.1.2 +* +* Originally derived from LAPACK 3.0 test suite. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 8 July 1999 +* + complex one, z + real a, f1 + f1(z) = real(z) + one = (1.,0.) + a = f1(one) + if ( abs(a-1.0) .gt. 1.0e-5 ) then + write(6,*) 'A should be 1.0 but it is',a + STOP 1 + end if + end Index: Fortran/gfortran/regression/g77/19990826-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990826-3.f @@ -0,0 +1,321 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +* Date: Thu, 19 Aug 1999 10:02:32 +0200 +* From: Frederic Devernay +* Organization: ISTAR +* X-Accept-Language: French, fr, en +* To: gcc-bugs@gcc.gnu.org +* Subject: g77 2.95 bug (Internal compiler error in `final_scan_insn') +* X-UIDL: 08443f5c374ffa382a05573281482f4f + +* Here's a bug that happens only when I compile with -O (disappears with +* -O2) + +* > g77 -v --save-temps -O -c pcapop.f +* g77 version 2.95 19990728 (release) (from FSF-g77 version 0.5.25 +* 19990728 (release)) +* Reading specs from +* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/specs +* gcc version 2.95 19990728 (release) +* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/f771 pcapop.f -quiet +* -dumpbase pcapop.f -O -version -fversion -o pcapop.s +* GNU F77 version 2.95 19990728 (release) (sparc-sun-solaris2.6) compiled +* by GNU C version 2.95 19990728 (release). +* GNU Fortran Front End version 0.5.25 19990728 (release) +* pcapop.f: In subroutine `pcapop': +* pcapop.f:291: Internal compiler error in `final_scan_insn', at +* final.c:2920 +* Please submit a full bug report. +* See for instructions. + +C* PCAPOP + SUBROUTINE PCAPOP(M1,M2,L1,L2,NMEM,N1,N2,IB,IBB,K3,TF,TS,TC,TTO) + DIMENSION NVA(6),C(6),I(6) +C +C CALCUL DES PARAMETRES OPTIMAUX N1 N2 IB IBB +C + TACC=.035 + TTRANS=.000004 + RAD=.000001 + RMI=.000001 + RMU=.0000015 + RDI=.000003 + RTE=.000003 + REQ=.000005 + VY1=3*RTE+RDI+8*REQ+3*(RAD+RMI+RMU) + VY2=REQ+2*RAD + AR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ)) +C VARIATION DE L1,L2, +C + TTOTOP=1.E+10 + N1CO=0 + N2CO=0 + IBCO=0 + IBBCO=0 + K3CO=0 + TESOP=0. + TCOP=0. + TFOP=0. + INUN=7 + INDE=7 + IF(M1.LT.128)INUN=6 + IF(M1.LT.64)INUN=5 + IF(M1.LT.32)INUN=4 + IF(M2.LT.128)INDE=6 + IF(M2.LT.64)INDE=5 + IF(M2.LT.32)INDE=4 + DO 3 NUN =3,INUN + DO 3 NDE=3,INDE + N10=2**NUN + N20=2**NDE + NDIF=(N10-N20) + NDIF=IABS(NDIF) +C POUR AVOIR CES RESULTATS FAIRE TOURNER LE PROGRAMME VEFFT1 + TCFFTU=0. + IF(N10.EQ.128.AND.N20.EQ.128)TCFFTU=3.35 + IF(N10.EQ.64.AND.N20.EQ.64)TCFFTU=.70 + IF(N10.EQ.32.AND.N20.EQ.32)TCFFTU=.138 + IF(N10.EQ.16.AND.N20.EQ.16)TCFFTU=.0332 + IF(N10.EQ.8.AND.N20.EQ.8)TCFFTU=.00688 + IF(NDIF.EQ.64)TCFFTU=1.566 + IF(NDIF.EQ.96)TCFFTU=.709 + IF(NDIF.EQ.112)TCFFTU=.349 + IF(NDIF.EQ.120)TCFFTU=.160 + IF(NDIF.EQ.32)TCFFTU=.315 + IF(NDIF.EQ.48)TCFFTU=.154 + IF(NDIF.EQ.56)TCFFTU=.07 + IF(NDIF.EQ.16)TCFFTU=.067 + IF(NDIF.EQ.24)TCFFTU=.030 + IF(NDIF.EQ.8)TCFFTU=.016 + N30=N10-L1+1 + N40=N20-L2+1 + WW=VY1+N30*VY2 + NDOU=2*N10*N20 + IF((N10.LT.L1).OR.(N20.LT.L2)) GOTO 3 + NB=NMEM-NDOU-N20*(L1-1) + NVC=2*N10*(N20-1)+M1 + IF(NB.LT.(NVC)) GOTO 3 + CALL VALENT(M1,N30,K1) + CALL VALENT(M2,N40,K2) + IS=K1/2 + IF((2*IS).NE.K1)K1=K1+1 + TFF=TCFFTU*K1*K2 + CALL VALENT(M2,N40,JOFI) + IF(NB.GE.(K1*N20*N30+2*N20*(L1-1))) GOTO 4 + TIOOP=1.E+10 + IC=1 +18 IB1=2*IC + MAX=(NB-2*N20*(L1-1))/(N20*N30) + IN=MAX/2 + IF(MAX.NE.2*IN) MAX=MAX-1 + K3=K1/IB1 + IBB1=K1-K3*IB1 + IOFI=M1/(IB1*N30) + IRZ=0 + IF(IOFI*IB1*N30.EQ.M1) GOTO1234 + IRZ=1 + IOFI=IOFI+1 + IF(IBB1.EQ.0) GOTO 1234 + IF(M1.EQ.((IOFI-1)*IB1*N30+IBB1*N30)) GOTO 1233 + IRZ=2 + GOTO 1234 +1233 IRZ=3 +1234 IBX1=IBB1 + IF(IBX1.EQ.0)IBX1=IB1 + AR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1-(IOFI-1)*IB1*N30)*2*(REQ+RAD)) + %+M2*(3*(REQ+RMU+RAD)+4*RMI+(M1-(IOFI-1)*IB1*N30)*(2*RAD+REQ) + %+(IOFI-1)*IB1*N30*(2*RMI+REQ+RAD)) + AR5=(JOFI-1)*(N20-L2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU)+REQ) + %*IOFI+(M2-(JOFI-1)*N40+L2-2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU + %)+REQ)*IOFI + WQ=((IOFI-1)*IB1+IBX1)*JOFI*WW + AT1=N20*WQ + AT2=N40*WQ + QW=JOFI*(VY1+VY2*IB1*N30) + AT3=IOFI*N40*QW + AT4=(IOFI-1)*N40*QW + AT5=JOFI*((IOFI-1)*N40*(IB1/IBX1)*(VY1+IBX1*N30*VY2) + %+N40*((IB1/IBX1)*(IOFI-1)+1)*(VY1+IBX1*N30*VY2)) + AT6=JOFI*((IOFI-1)*N40*(IB1/2)*(VY1+2*N30*VY2)+N40*( + %IB1*(IOFI-1)/2+IBX1/2)*(VY1+2*N30*VY2)) + T1=JOFI*N20*(L1-1)*REQ + T2=M1*(L2-1)*REQ + T3=JOFI*N20*IBX1*N30*(RAD+REQ) + T4=JOFI*((IOFI-1)*IB1*N30*N20*(2*RMI+REQ)+IBX1*N30*N20*(2*RMI+R + %EQ)) + T5=JOFI*((IOFI-1)*IB1/2+IBX1/2)*N20*N30*(2*RAD+REQ) + T6=2*JOFI*(((IOFI-1)*IB1+IBX1)*N20)*((5*(RMI+RMU)+4*RAD + %)+(L1-1)*(2*RAD+REQ)+N30*(2*RAD+REQ)) + T7=JOFI*2*((IOFI-1)*IB1+IBX1)*(L1-1)*(2*RAD+REQ) + T8=JOFI*N10*N20*((IOFI-1)*IB1/2+IBX1/2)*(3*REQ+9*RAD+4*RMU+RMI) + T9=N10*N20*JOFI*((IOFI-1)*IB1/2+IBX1/2)*(REQ+RMI)+M1*M2*(REQ+R + %DI+2*RAD) + T10=JOFI*((IOFI-1)*IB1/2+IBX1/2)*2*(3*RMU+2*(RMI+RAD)+N40*(3*RMI + %+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ))) + POI=JOFI + IF(POI.LE.2)POI=2 + TNRAN=(N40+(POI-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMI+RMU+RAD + %+REQ+N30*(2*RAD+2*REQ)*(IB1*(IOFI-1)+IBX1)) + IF(TNRAN.LT.0.)TNRAN=0. + TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10+TNRAN + NVA(1)=N40 + NVA(2)=N40 + NVA(3)=N20 + NVA(4)=N20 + NVA(5)=M2-(JOFI-1)*N40 + NVA(6)=NVA(5) + C(1)=FLOAT(IB1*N30)/FLOAT(M1) + C(2)=FLOAT(M1-(IOFI-1)*IB1*N30)/FLOAT(M1) + C(3)=C(1) + C(4)=C(2) + C(5)=C(1) + C(6)=C(2) + K=1 + P1=FLOAT(NB)/FLOAT(M1) +10 IP1=P1 + I(K)=1 + IF(IP1.GE.NVA(K)) GOTO 7 + P2=P1 + IP2=P2 +8 P2=P2-FLOAT(IP2)*C(K) + IP2=P2 + IF(IP2.EQ.0) GOTO 3 + IP1=IP1+IP2 + I(K)=I(K)+1 + IF(IP1.GE.NVA(K))GOTO 7 + GOTO 8 +7 IF(K.EQ.6) GOTO 11 + K=K+1 + GOTO 10 +11 IP1=0 + IP2=0 + IP3=0 + POFI=JOFI + IF(POFI.LE.2)POFI=2 + TIOL=(I(2)+(IOFI-1)*I(1)+(POFI-2)*(IOFI-1)*I(3)+(POFI- + %2)*I(4)+(IOFI-1)*I(5)+I(6))*TACC+(IOFI*M1*N40+(POFI-2)*IOFI* + %M1*N20+(M2-(JOFI-1)*N40+L2-1)*M1*IOFI)*TTRANS + IF(IBB1.EQ.0) GOTO 33 + IF(IB1.EQ.IBB1) GOTO 33 + IF(IBB1.EQ.2)GOTO 34 + IP3=1 + INL=NMEM/((IOFI-1)*IB1*N30+IBB1*N30) +55 IF(INL.GT.N40)INL=N40 + GOTO 35 +33 IF(IB1.GT.2) GOTO 36 + IF((M1-(IOFI-1)*IB1*N30).GE.N30) GOTO 36 +34 IP1=1 + INL=NMEM/(2*M1-(IOFI-1)*IB1*N30) + GOTO 55 +36 IP2=1 + INL=NMEM/(IOFI*IB1*N30) + IF(INL.GT.N40)INL=N40 +35 CALL VALENT(N40,INL,KN1) + CALL VALENT(M2-(JOFI-1)*N40,INL,KN2) + CALL VALENT(INL*IBB1,IB1,KN3) + CALL VALENT((N40-(KN1-1)*INL)*IBB1,IB1,KN4) + IF((IP1+IP2+IP3).NE.1) CALL ERMESF(14) + TIO1=0. + IF(IP3.EQ.1)TIO1=N30*M2*TTRANS*(IB1*(IOFI-1)+IBB1) + IF(IP1.EQ.1)TIO1=M1*M2*TTRANS + IF(IP2.EQ.1) TIO1=(IB1*N30*M2*IOFI*TTRANS) + TTIO=2.*TIO1+(KN1*IOFI*(JOFI-1)+KN2*IOFI+(KN1-1)*( + %JOFI-1)+IOFI*(JOFI-1)+KN2-1.+IOFI+(KN1*(JOFI-1)+KN2))*TACC + %+M1*M2*TTRANS+TIOL + IF((IP1.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3 + IF((IP1.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT4+AR1 + IF((IP2.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3 + IF((IP2.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT3+AR2 + IFOIS=IB1/IBX1 + IF((IP3.EQ.1).AND.(IFOIS*IBX1.EQ.IB1))TCPU=TCPU+AT1+AT2+AT5+AR2 + IF((IP3.EQ.1).AND.(IFOIS*IBX1.NE.IB1))TCPU=TCPU+AT1+AT2+AT6+AR2 + IF((IP1.EQ.1).AND.(IRZ.EQ.1))TCPU=TCPU+AR5 + IF((IP1.EQ.1).AND.(IRZ.EQ.2))TCPU=TCPU+AR5 + TTIOG=TTIO+TCPU + IF(TTIOG.LE.0.) GOTO 99 + IF(TTIOG.GE.TIOOP) GOTO 99 + IBOP=IB1 + IBBOP=IBB1 + K3OP=K3 + TIOOP=TTIOG + TIOOP1=TTIO + TIOOP2=TCPU +99 IF(IB1.GE.MAX)GOTO17 + IC=IC+1 + GOTO 18 +4 T1=JOFI*N20*(L1-1)*REQ + T2=M1*(L2-1)*REQ + T3=JOFI*N20*N30*(RAD+REQ)*K1 + T4=JOFI*(K1*N30*N20*(2*RMI+REQ)) + T5=JOFI*N20*N30*(2*RAD+REQ)*K1/2 + T6=2*JOFI*(K1*N20)*((5*RMI+RMU)+4*RAD+(L1-1)*(2*RAD+REQ)+N30*2* + %RAD+REQ) + T7=JOFI*2*K1*(L1-1)*(2*RAD+REQ) + T9=JOFI*N10*N20*K1*(REQ+RMI)/2+M1*M2*(REQ+RDI+2*RAD) + T8=JOFI*N10*N20*K1*(3*REQ+9*RAD+4*RMU+RMI)/2 + T10=JOFI*K1*(3*RMU+2*(RMI+RAD)+N40*(3*RMI + %+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ))) + PIO=JOFI + IF(PIO.LE.2)PIO=2 + TNR=(N40+(PIO-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMU+RMI+RAD+REQ+ + %N30*(2*RAD+2*REQ)*K1) + IF(TNR.LE.0.)TNR=0. + BT1=JOFI*N20*WW*K1 + BT2=JOFI*N40*WW*K1 + BT3=JOFI*N40*(VY1+K1*N30*VY2) + BR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1*2*(REQ+RAD)))+M2*(3*( + $REQ+RAD+RMU)+4*(RMI)+M1*(2*(RAD)+REQ)) + BR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ)) + TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10 + TCPU=TCPU+TNR+BT1+BT2 + LIOF=M1/(N30) + IRZ=0 + IF(LIOF*N30.EQ.M1) GOTO 2344 + IRZ=1 +2344 IF(IRZ.EQ.0)TCPU=TCPU+BT3 + IF(IRZ.NE.0)TCPU=TCPU+BT3+BR2 + TIOOP=2.*FLOAT(M1)*FLOAT(M2)*TTRANS+2.*FLOAT(K2)*TACC+TCPU + IBOP=1 + IBBOP=0 + K3OP=1 + TIOOP2=TCPU + TIOOP1=TIOOP-TCPU +17 TTOT=TIOOP+TFF + IF(TTOT.LE.0.) GOTO 3 + IF(TTOT.GE.TTOTOP)GOTO3 + N1CO=N10 + N2CO=N20 + IBCO=IBOP + IBBCO=IBBOP + K3CO=K3OP + TTOTOP=TTOT + TESOP=TIOOP1 + TCOP=TIOOP2 + TFOP=TFF +3 CONTINUE + + N1=N1CO + N2=N2CO + TTO=TTOTOP + IB=IBCO + IBB=IBBCO + K3=K3CO + TC=TCOP + TS=TESOP + TF=TFOP + TT=TCOP+TFOP + TWER=TTO-TT + IF(N1.EQ.0.OR.N2.EQ.0) CALL OUTSTR(0,'PAS DE PLACE MEMOIRE SUFFISA + $NTE POUR UNE MISE EN OEUVRE PAR BLOCS$') + IF(IB.NE.1)RETURN + IHJ=(M1/(N1-L1+1)) + IF(IHJ*(N1-L1+1).NE.M1)IHJ=IHJ+1 + IHJ1=IHJ/2 + IF(IHJ1*2.NE.IHJ)GOTO7778 + IB=IHJ + IBB=0 + RETURN +7778 IB=IHJ+1 + IBB=0 + RETURN + END Index: Fortran/gfortran/regression/g77/19990905-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990905-0.f @@ -0,0 +1,12 @@ +c { dg-do compile } +* =foo0.f in Burley's g77 test suite. +! Used to give "Variable 'm' cannot appear" "Variable 'm' cannot appear" +! after REAL a(m,n), as described in PR 16511. +! + subroutine sub(a) + equivalence (m,iarray(100)) + common /info/ iarray(1000) + equivalence (n,iarray(200)) + real a(m,n) + a(1,1) = a(2,2) + end Index: Fortran/gfortran/regression/g77/19990905-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990905-1.f @@ -0,0 +1,19 @@ +c { dg-do compile } +c +c g77 gave error +c 19990905-1.f: In subroutine `x': +c 19990905-1.f:15: +c common /foo/n +c 1 +c 19990905-1.f:18: (continued): +c call foo(a(1)) +c 2 +c Invalid declaration of or reference to symbol `foo' at (2) [initially seen at (1)] +* =foo7.f in Burley's g77 test suite. + subroutine x + real a(n) + common /foo/n ! { dg-error "is already being used as a COMMON" } + continue + entry y(a) + call foo(a(1)) ! { dg-error "is already being used as a COMMON" } + end Index: Fortran/gfortran/regression/g77/19990905-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/19990905-2.f @@ -0,0 +1,23 @@ +c { dg-do compile } +* =watson11.f in Burley's g77 test suite. +* Probably originally submitted by Ian Watson. +* Too small to worry about copyright issues, IMO, since it +* doesn't do anything substantive. + SUBROUTINE OUTDNS(A,B,LCONV) + IMPLICIT REAL(kind=8) (A-H,O-Z),INTEGER(I-N) + COMMON/ARRAYS/Z(64,8),AB(30,30),PAIRS(9,9),T(9,9),TEMP(9,9),C1(3), + > C2(3),AA(30),BB(30) + EQUIVALENCE (X1,C1(1)),(Y1,C1(2)),(Z1,C1(3)) + EQUIVALENCE (X2,C2(1)),(Y2,C2(2)),(Z2,C2(3)) + COMMON /CONTRL/ + > SHIFT,CONV,SCION,DIVERG, + > IOPT,KCNDO,KINDO,KMINDO,I2EINT,KOHNO,KSLATE, + > N,NG,NUMAT,NSEK,NELECS,NIT,OCCA,OCCB,NOLDAT,NOLDFN + INTEGER OCCA,OCCB + DIMENSION W(N),A(N,N),B(N,N) + DIMENSION BUF(100) + occb=5 + ENTRY INDNS (A,B) + 40 READ(IREAD) BUF + STOP + END Index: Fortran/gfortran/regression/g77/20000412-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000412-1.f @@ -0,0 +1,6 @@ +c { dg-do compile } + subroutine aap(k) + equivalence (i,r) + i = k + print*,r + end Index: Fortran/gfortran/regression/g77/20000503-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000503-1.f @@ -0,0 +1,25 @@ +c { dg-do run } +* +* Originally derived from LAPACK 3.0 test suite failure. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 23 February 2000 +* + INTEGER N, I, SLASQX + N = 20 + I = SLASQX( N ) + IF ( I .NE. 2*N ) THEN + WRITE(6,*) 'I = ', I, ' but should be ', 2*N + STOP 1 + END IF + END + + INTEGER FUNCTION SLASQX( N ) + INTEGER N, I0, I, K + I0 = 1 + DO I = 4*I0, 2*( I0+N-1 ), 4 + K = I + END DO + SLASQX = K + RETURN + END Index: Fortran/gfortran/regression/g77/20000511-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000511-1.f @@ -0,0 +1,22 @@ +c { dg-do compile } + subroutine saxpy(n,sa,sx,incx,sy,incy) +C +C constant times a vector plus a vector. +C uses unrolled loop for increments equal to one. +C jack dongarra, linpack, 3/11/78. +C modified 12/3/93, array(1) declarations changed to array(*) +C + real sx(*),sy(*),sa + integer i,incx,incy,ix,iy,m,mp1,n +C +C -ffast-math ICE provoked by this conditional + if(sa /= 0.0)then +C +C code for both increments equal to 1 +C + do i= 1,n + sy(i)= sy(i)+sa*sx(i) + enddo + endif + return + end Index: Fortran/gfortran/regression/g77/20000511-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000511-2.f @@ -0,0 +1,62 @@ +c { dg-do compile } + subroutine sgbcon(norm,n,kl,ku,ab,ldab,ipiv,anorm,rcond,work,iwork + &,info) +C +C -- LAPACK routine (version 3.0) -- +C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +C Courant Institute, Argonne National Lab, and Rice University +C September 30, 1994 +C +C .. Scalar Arguments .. + character norm + integer info,kl,ku,ldab,n + real anorm,rcond +C .. +C .. Array Arguments .. + integer ipiv(n),iwork(n) + real ab(ldab,n),work(n) +C .. +C +C Purpose +C ======= +C demonstrate g77 bug at -O -funroll-loops +C ===================================================================== +C +C .. Parameters .. + real one,zero + parameter(one= 1.0e+0,zero= 0.0e+0) +C .. +C .. Local Scalars .. + logical lnoti,onenrm + character normin + integer ix,j,jp,kase,kase1,kd,lm + real ainvnm,scale,smlnum,t +C .. +C .. External Functions .. + logical lsame + integer isamax + real sdot,slamch + externallsame,isamax,sdot,slamch +C .. +C .. External Subroutines .. + externalsaxpy,slacon,slatbs,srscl,xerbla +C .. +C .. Executable Statements .. +C +C Multiply by inv(L). +C + do j= 1,n-1 +C the following min() intrinsic provokes this bug + lm= min(kl,n-j) + jp= ipiv(j) + t= work(jp) + if(jp.ne.j)then +C but only when combined with this if block + work(jp)= work(j) + work(j)= t + endif +C and this subroutine call + call saxpy(lm,-t,ab(kd+1,j),1,work(j+1),1) + enddo + return + end Index: Fortran/gfortran/regression/g77/20000518.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000518.f @@ -0,0 +1,17 @@ +c { dg-do compile } + SUBROUTINE SORG2R( K, A, N, LDA ) +* ICE in `verify_wide_reg_1', at flow.c:2605 at -O2 +* g77 version 2.96 20000515 (experimental) on i686-pc-linux-gnu +* +* Originally derived from LAPACK 3.0 test suite failure. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 18 May 2000 + INTEGER I, K, LDA, N + REAL A( LDA, * ) + DO I = K, 1, -1 + IF( I.LT.N ) A( I, I ) = 1.0 + A( I, I ) = 1.0 + END DO + RETURN + END Index: Fortran/gfortran/regression/g77/20000601-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000601-1.f @@ -0,0 +1,29 @@ +c { dg-do compile } + SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB ) + +* PR fortran/275 +* ICE in `change_address', at emit-rtl.c:1589 with -O1 and above +* g77 version 2.96 20000530 (experimental) on mips-sgi-irix6.5/-mabi=64 +* +* Originally derived from LAPACK 3.0 test suite failure. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 1 June 2000 + + INTEGER KL, KU, LDAB, M + REAL AB( LDAB, * ) + + INTEGER J, JB, JJ, JP, KV, KM + REAL WORK13(65,64), WORK31(65,64) + KV = KU + KL + DO J = 1, M + JB = MIN( 1, M-J+1 ) + DO JJ = J, J + JB - 1 + KM = MIN( KL, M-JJ ) + JP = KM+1 + CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, + $ AB( KV+JP+JJ-J, J ), LDAB-1 ) + END DO + END DO + RETURN + END Index: Fortran/gfortran/regression/g77/20000601-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000601-2.f @@ -0,0 +1,28 @@ +c { dg-do compile } + SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB ) + +* Slightly modified version of 20000601-1.f that still ICES with +* CVS 20010118 g77 on mips-sgi-irix6.5/-mabi=64. +* +* Originally derived from LAPACK 3.0 test suite failure. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 18 January 2001 + + INTEGER KL, KU, LDAB, M + REAL AB( LDAB, * ) + + INTEGER J, JB, JJ, JP, KV, KM, F + REAL WORK13(65,64), WORK31(65,64) + KV = KU + KL + DO J = 1, M + JB = MIN( 1, M-J+1 ) + DO JJ = J, J + JB - 1 + KM = MIN( KL, M-JJ ) + JP = F( KM+1, AB( KV+1, JJ ) ) + CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, + $ AB( KV+JP+JJ-J, J ), LDAB-1 ) + END DO + END DO + RETURN + END Index: Fortran/gfortran/regression/g77/20000629-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000629-1.f @@ -0,0 +1,12 @@ +c { dg-do compile } + SUBROUTINE MIST(N, BETA) + IMPLICIT REAL(kind=8) (A-H,O-Z) + INTEGER IA, IQ, M1 + DIMENSION BETA(N) + DO 80 IQ=1,M1 + IF (BETA(IQ).EQ.0.0D0) GO TO 120 + 80 CONTINUE + 120 IF (IQ.NE.1) GO TO 160 + 160 M1 = IA(IQ) + RETURN + END Index: Fortran/gfortran/regression/g77/20000630-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20000630-2.f @@ -0,0 +1,12 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c + SUBROUTINE CHOUT(CHR,ICNT) +C ICE: failed assertion `expr != NULL' +C Reduced version of GNATS PR fortran/329 from trond.bo@dnmi.no + INTEGER CHR(ICNT) + CHARACTER*255 BUF + BUF(1:1)=CHAR(CHR(1)) + CALL FPUTC(1,BUF(1:1)) + RETURN + END Index: Fortran/gfortran/regression/g77/20001111.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20001111.f @@ -0,0 +1,13 @@ +c { dg-do run } + DOUBLE PRECISION VALUE(2), TOLD, BK + DATA VALUE /0D0, 1D0/ + DATA TOLD /0D0/ + DO I=1, 2 + BK = VALUE(I) + IF(BK .GT. TOLD) GOTO 10 + ENDDO + WRITE(*,*)'Error: BK = ', BK + STOP 1 + 10 CONTINUE + WRITE(*,*)'No Error: BK = ', BK + END Index: Fortran/gfortran/regression/g77/20010115.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010115.f @@ -0,0 +1,10 @@ +c { dg-do compile } +* GNATS PR Fortran/1636 + PRINT 42, 'HELLO' + 42 FORMAT(A) + CALL WORLD + END + SUBROUTINE WORLD + PRINT 42, 'WORLD' + 42 FORMAT(A) + END Index: Fortran/gfortran/regression/g77/20010116.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010116.f @@ -0,0 +1,41 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +* +* Derived from LAPACK 3.0 routine CHGEQZ +* Fails on i686-pc-cygwin with gcc-2.97 snapshots at -O2 and higher +* PR fortran/1645 +* +* David Billinghurst, (David.Billinghurst@riotinto.com) +* 14 January 2001 +* Rewritten by Toon Moene (toon@moene.indiv.nluug.nl) +* 15 January 2001 +* + COMPLEX A(5,5) + DATA A/25*(0.0,0.0)/ + A(4,3) = (0.05,0.2)/3.0E-7 + A(4,4) = (-0.03,-0.4) + A(5,4) = (-2.0E-07,2.0E-07) + CALL CHGEQZ( 5, A ) + END + SUBROUTINE CHGEQZ( N, A ) + COMPLEX A(N,N), X + ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) + DO J = 4, 2, -1 + I = J + TEMP = ABS1( A(J,J) ) + TEMP2 = ABS1( A( J+1, J ) ) + TEMPR = MAX( TEMP, TEMP2 ) + IF( TEMPR .LT. 1.0 .AND. TEMPR .NE. 0.0 ) THEN + TEMP = TEMP / TEMPR + TEMP2 = TEMP2 / TEMPR + END IF + IF ( ABS1(A(J,J-1))*TEMP2 .LE. TEMP ) GO TO 90 + END DO +c Should not reach here, but need a statement + PRINT* + 90 IF ( I .NE. 4 ) THEN + PRINT*,'I =', I, ' but should be 4' + STOP 1 + END IF + END Index: Fortran/gfortran/regression/g77/20010216-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010216-1.f @@ -0,0 +1,52 @@ +C Test for bug in reg-stack handling conditional moves. +C Reported by Tim Prince +C +C { dg-do run { target { { i?86-*-* x86_64-*-* } && ia32 } } } +C { dg-options "-ffast-math -march=pentiumpro" } + + double precision function foo(x, y) + implicit none + double precision x, y + double precision a, b, c, d + if (x /= y) then + if (x * y >= 0) then + a = abs(x) + b = abs(y) + c = max(a, b) + d = min(a, b) + foo = 1 - d/c + else + foo = 1 + end if + else + foo = 0 + end if + end + + program test + implicit none + + integer ntests + parameter (ntests=7) + double precision tolerance + parameter (tolerance=1.0D-6) + +C Each column is a pair of values to feed to foo, +C and its expected return value. + double precision a(ntests), b(ntests), x(ntests) + data a /1, -23, -1, 1, 9, 10, -9/ + data b /1, -23, 12, -12, 10, 9, -10/ + data x /0, 0, 1, 1, 0.1, 0.1, 0.1/ + + double precision foo + double precision result + integer i + + do i = 1, ntests + result = foo(a(i), b(i)) + if (abs(result - x(i)) > tolerance) then + print *, i, a(i), b(i), x(i), result + STOP 1 + end if + end do + end Index: Fortran/gfortran/regression/g77/20010321-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010321-1.f @@ -0,0 +1,9 @@ +c { dg-do compile } +# 1 "20010321-1.f" + SUBROUTINE TWOEXP +# 1 "include/implicit.h" 1 3 + IMPLICIT DOUBLE PRECISION (A-H) +# 3 "20010321-1.f" 2 3 + LOGICAL ANTI + ANTI = .FALSE. + END Index: Fortran/gfortran/regression/g77/20010426-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010426-1.f @@ -0,0 +1,3 @@ +c { dg-do run } + print*,cos(1.0) + end Index: Fortran/gfortran/regression/g77/20010426.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010426.f @@ -0,0 +1,7 @@ +c { dg-do compile } + function f(c) + implicit none + real(kind=8) c, f + f = sqrt(c) + return + end Index: Fortran/gfortran/regression/g77/20010430.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010430.f @@ -0,0 +1,21 @@ +c { dg-do run } + REAL DAT(2,5) + DO I = 1, 5 + DAT(1,I) = I*1.6356-NINT(I*1.6356) + DAT(2,I) = I + ENDDO + DO I = 1, 4 + DO J = I+1, 5 + IF (DAT(1,J) - DAT(1,I) .LT. 0.0) THEN + DO K = 1, 2 + TMP = DAT(K,I) + DAT(K,I) = DAT(K,J) + DAT(K,J) = TMP + ENDDO + ENDIF + ENDDO + ENDDO + DO I = 1, 4 + IF (DAT(1,I) .GT. DAT(1,I+1)) STOP 1 + ENDDO + END Index: Fortran/gfortran/regression/g77/20010519-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010519-1.f @@ -0,0 +1,1328 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +CHARMM Element source/dimb/nmdimb.src 1.1 +C.##IF DIMB + SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR, + 1 PARDDV,DDV,DDM,PARDDF,DDF,PARDDE,DDEV,DD1BLK, + 2 DD1BLL,NADD,LRAISE,DD1CMP,INBCMP,JNBCMP, + 3 NPAR,ATMPAR,ATMPAS,BLATOM,PARDIM,NFREG,NFRET, + 4 PARFRQ,CUTF1,ITMX,TOLDIM,IUNMOD,IUNRMD, + 5 LBIG,LSCI,ATMPAD,SAVF,NBOND,IB,JB,DDVALM) +C----------------------------------------------------------------------- +C 01-Jul-1992 David Perahia, Liliane Mouawad +C 15-Dec-1994 Herman van Vlijmen +C +C This is the main routine for the mixed-basis diagonalization. +C See: L.Mouawad and D.Perahia, Biopolymers (1993), 33, 599, +C and: D.Perahia and L.Mouawad, Comput. Chem. (1995), 19, 241. +C The method iteratively solves the diagonalization of the +C Hessian matrix. To save memory space, it uses a compressed +C form of the Hessian, which only contains the nonzero elements. +C In the diagonalization process, approximate eigenvectors are +C mixed with Cartesian coordinates to form a reduced basis. The +C Hessian is then diagonalized in the reduced basis. By iterating +C over different sets of Cartesian coordinates the method ultimately +C converges to the exact eigenvalues and eigenvectors (up to the +C requested accuracy). +C If no existing basis set is read, an initial basis will be created +C which consists of the low-frequency eigenvectors of diagonal blocks +C of the Hessian. +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/impnon.fcm' +C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA + IMPLICIT NONE +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/stream.fcm' + LOGICAL LOWER,QLONGL + INTEGER MXSTRM,POUTU + PARAMETER (MXSTRM=20,POUTU=6) + INTEGER NSTRM,ISTRM,JSTRM,OUTU,PRNLEV,WRNLEV,IOLEV + COMMON /CASE/ LOWER, QLONGL + COMMON /STREAM/ NSTRM,ISTRM,JSTRM(MXSTRM),OUTU,PRNLEV,WRNLEV,IOLEV +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/dimens.fcm' + INTEGER LARGE,MEDIUM,SMALL,REDUCE +C..##IF QUANTA +C..##ELIF T3D +C..##ELSE + PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120) +C..##ENDIF + PARAMETER (REDUCE=15000) + INTEGER SIZE +C..##IF XLARGE +C..##ELIF XXLARGE +C..##ELIF LARGE +C..##ELIF MEDIUM + PARAMETER (SIZE=MEDIUM) +C..##ELIF REDUCE +C..##ELIF SMALL +C..##ELIF XSMALL +C..##ENDIF +C..##IF MMFF + integer MAXDEFI + parameter(MAXDEFI=250) + INTEGER NAME0,NAMEQ0,NRES0,KRES0 + PARAMETER (NAME0=4,NAMEQ0=10,NRES0=4,KRES0=4) + integer MaxAtN + parameter (MaxAtN=55) + INTEGER MAXAUX + PARAMETER (MAXAUX = 10) +C..##ENDIF + INTEGER MAXCSP, MAXHSET +C..##IF HMCM + PARAMETER (MAXHSET = 200) +C..##ELSE +C..##ENDIF +C..##IF REDUCE +C..##ELSE + PARAMETER (MAXCSP = 500) +C..##ENDIF +C..##IF HMCM + INTEGER MAXHCM,MAXPCM,MAXRCM +C...##IF REDUCE +C...##ELSE + PARAMETER (MAXHCM=500) + PARAMETER (MAXPCM=5000) + PARAMETER (MAXRCM=2000) +C...##ENDIF +C..##ENDIF + INTEGER MXCMSZ +C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE +C..##ELSE + PARAMETER (MXCMSZ = 5000) +C..##ENDIF + INTEGER CHRSIZ + PARAMETER (CHRSIZ = SIZE) + INTEGER MAXATB +C..##IF REDUCE +C..##ELIF QUANTA +C..##ELSE + PARAMETER (MAXATB = 200) +C..##ENDIF + INTEGER MAXVEC +C..##IFN VECTOR PARVECT + PARAMETER (MAXVEC = 10) +C..##ELIF LARGE XLARGE XXLARGE +C..##ELIF MEDIUM +C..##ELIF SMALL REDUCE +C..##ELIF XSMALL +C..##ELSE +C..##ENDIF + INTEGER IATBMX + PARAMETER (IATBMX = 8) + INTEGER MAXHB +C..##IF LARGE XLARGE XXLARGE +C..##ELIF MEDIUM + PARAMETER (MAXHB = 8000) +C..##ELIF SMALL +C..##ELIF REDUCE XSMALL +C..##ELSE +C..##ENDIF + INTEGER MAXTRN,MAXSYM +C..##IFN NOIMAGES + PARAMETER (MAXTRN = 5000) + PARAMETER (MAXSYM = 192) +C..##ELSE +C..##ENDIF +C..##IF LONEPAIR (lonepair_max) + INTEGER MAXLP,MAXLPH +C...##IF REDUCE +C...##ELSE + PARAMETER (MAXLP = 2000) + PARAMETER (MAXLPH = 4000) +C...##ENDIF +C..##ENDIF (lonepair_max) + INTEGER NOEMAX,NOEMX2 +C..##IF REDUCE +C..##ELSE + PARAMETER (NOEMAX = 2000) + PARAMETER (NOEMX2 = 4000) +C..##ENDIF + INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF +C..##IF REDUCE +C..##ELIF MMFF CFF + PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600, + & MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000) +C..##ELIF YAMMP +C..##ELIF LARGE +C..##ELSE +C..##ENDIF + INTEGER MAXCN + PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2) + INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP + INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES + INTEGER MAXSEG, MAXGRP +C..##IF LARGE XLARGE XXLARGE +C..##ELIF MEDIUM + PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE, + & MAXP = 2*SIZE) + PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160, + & MAXRES = 14000) +C...##IF MCSS +C...##ELSE + PARAMETER (MAXSEG = 1000) +C...##ENDIF +C..##ELIF SMALL +C..##ELIF XSMALL +C..##ELIF REDUCE +C..##ELSE +C..##ENDIF +C..##IF NOIMAGES +C..##ELSE + PARAMETER (MAXAIM = 2*SIZE) + PARAMETER (MAXGRP = 2*SIZE/3) +C..##ENDIF + INTEGER REDMAX,REDMX2 +C..##IF REDUCE +C..##ELSE + PARAMETER (REDMAX = 20) + PARAMETER (REDMX2 = 80) +C..##ENDIF + INTEGER MXRTRS, MXRTA, MXRTB, MXRTT, MXRTP, MXRTI, MXRTX, + & MXRTHA, MXRTHD, MXRTBL, NICM + PARAMETER (MXRTRS = 200, MXRTA = 5000, MXRTB = 5000, + & MXRTT = 5000, MXRTP = 5000, MXRTI = 2000, +C..##IF YAMMP +C..##ELSE + & MXRTX = 5000, MXRTHA = 300, MXRTHD = 300, +C..##ENDIF + & MXRTBL = 5000, NICM = 10) + INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN +C..##IF REDUCE +C..##ELSE + PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3) +C..##ENDIF + INTEGER MAXSHK +C..##IF XSMALL +C..##ELIF REDUCE +C..##ELSE + PARAMETER (MAXSHK = SIZE*3/4) +C..##ENDIF + INTEGER SCRMAX +C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE +C..##ELSE + PARAMETER (SCRMAX = 5000) +C..##ENDIF +C..##IF TSM + INTEGER MXPIGG +C...##IF REDUCE +C...##ELSE + PARAMETER (MXPIGG=500) +C...##ENDIF + INTEGER MXCOLO,MXPUMB + PARAMETER (MXCOLO=20,MXPUMB=20) +C..##ENDIF +C..##IF ADUMB + INTEGER MAXUMP, MAXEPA, MAXNUM +C...##IF REDUCE +C...##ELSE + PARAMETER (MAXUMP = 10, MAXNUM = 4) +C...##ENDIF +C..##ENDIF + INTEGER MAXING + PARAMETER (MAXING=1000) +C..##IF MMFF + integer MAX_RINGSIZE, MAX_EACH_SIZE + parameter (MAX_RINGSIZE = 20, MAX_EACH_SIZE = 1000) + integer MAXPATHS + parameter (MAXPATHS = 8000) + integer MAX_TO_SEARCH + parameter (MAX_TO_SEARCH = 6) +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/number.fcm' + REAL(KIND=8) ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX, + & SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN, + & FIFTN, NINETN, TWENTY, THIRTY +C..##IF SINGLE +C..##ELSE + PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0, + & THREE = 3.D0, FOUR = 4.D0, FIVE = 5.D0, + & SIX = 6.D0, SEVEN = 7.D0, EIGHT = 8.D0, + & NINE = 9.D0, TEN = 10.D0, ELEVEN = 11.D0, + & TWELVE = 12.D0, THIRTN = 13.D0, FIFTN = 15.D0, + & NINETN = 19.D0, TWENTY = 20.D0, THIRTY = 30.D0) +C..##ENDIF + REAL(KIND=8) FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD, + & ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND, + & FTHSND,MEGA +C..##IF SINGLE +C..##ELSE + PARAMETER (FIFTY = 50.D0, SIXTY = 60.D0, SVNTY2 = 72.D0, + & EIGHTY = 80.D0, NINETY = 90.D0, HUNDRD = 100.D0, + & ONE2TY = 120.D0, ONE8TY = 180.D0, THRHUN = 300.D0, + & THR6TY=360.D0, NINE99 = 999.D0, FIFHUN = 1500.D0, + & THOSND = 1000.D0,FTHSND = 5000.D0, MEGA = 1.0D6) +C..##ENDIF + REAL(KIND=8) MINONE, MINTWO, MINSIX + PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0) + REAL(KIND=8) TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005, + & PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD, + & PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4 +C..##IF SINGLE +C..##ELSE + PARAMETER (TENM20 = 1.0D-20, TENM14 = 1.0D-14, TENM8 = 1.0D-8, + & TENM5 = 1.0D-5, PT0001 = 1.0D-4, PT0005 = 5.0D-4, + & PT001 = 1.0D-3, PT005 = 5.0D-3, PT01 = 0.01D0, + & PT02 = 0.02D0, PT05 = 0.05D0, PTONE = 0.1D0, + & PT125 = 0.125D0, SIXTH = ONE/SIX,PT25 = 0.25D0, + & THIRD = ONE/THREE,PTFOUR = 0.4D0, HALF = 0.5D0, + & PTSIX = 0.6D0, PT75 = 0.75D0, PT9999 = 0.9999D0, + & ONEPT5 = 1.5D0, TWOPT4 = 2.4D0) +C..##ENDIF + REAL(KIND=8) ANUM,FMARK + REAL(KIND=8) RSMALL,RBIG +C..##IF SINGLE +C..##ELSE + PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0) + PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20) +C..##ENDIF + REAL(KIND=8) RPRECI,RBIGST +C..##IF VAX DEC +C..##ELIF IBM +C..##ELIF CRAY +C..##ELIF ALPHA T3D T3E +C..##ELSE +C...##IF SINGLE +C...##ELSE + PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307) +C...##ENDIF +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/consta.fcm' + REAL(KIND=8) PI,RADDEG,DEGRAD,TWOPI + PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI) + PARAMETER (RADDEG=180.0D0/PI) + PARAMETER (DEGRAD=PI/180.0D0) + REAL(KIND=8) COSMAX + PARAMETER (COSMAX=0.9999999999D0) + REAL(KIND=8) TIMFAC + PARAMETER (TIMFAC=4.88882129D-02) + REAL(KIND=8) KBOLTZ + PARAMETER (KBOLTZ=1.987191D-03) + REAL(KIND=8) CCELEC +C..##IF AMBER +C..##ELIF DISCOVER +C..##ELSE + PARAMETER (CCELEC=332.0716D0) +C..##ENDIF + REAL(KIND=8) CNVFRQ + PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0)) + REAL(KIND=8) SPEEDL + PARAMETER (SPEEDL=2.99793D-02) + REAL(KIND=8) ATMOSP + PARAMETER (ATMOSP=1.4584007D-05) + REAL(KIND=8) PATMOS + PARAMETER (PATMOS = 1.D0 / ATMOSP ) + REAL(KIND=8) BOHRR + PARAMETER (BOHRR = 0.529177249D0 ) + REAL(KIND=8) TOKCAL + PARAMETER (TOKCAL = 627.5095D0 ) +C..##IF MMFF + REAL(KIND=8) MDAKCAL + parameter(MDAKCAL=143.9325D0) +C..##ENDIF + REAL(KIND=8) DEBYEC + PARAMETER ( DEBYEC = 2.541766D0 / BOHRR ) + REAL(KIND=8) ZEROC + PARAMETER ( ZEROC = 298.15D0 ) +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/exfunc.fcm' +C..##IF ACE +C..##ENDIF +C..##IF ADUMB +C..##ENDIF + CHARACTER(4) GTRMA, NEXTA4, CURRA4 + CHARACTER(6) NEXTA6 + CHARACTER(8) NEXTA8 + CHARACTER(20) NEXT20 + INTEGER ALLCHR, ALLSTK, ALLHP, DECODI, FIND52, + * GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL, + * ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF, + * INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF, + * LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL, + * PARNUM, PARINS, + * SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE +C..##IF ACE + * ,GETNNB +C..##ENDIF + LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE, + * HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5, + * ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA + REAL(KIND=8) DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8, + * RANUMB, R8VAL, RETVAL8, SUMVEC +C..##IF ADUMB + * ,UMFI +C..##ENDIF + EXTERNAL GTRMA, NEXTA4, CURRA4, NEXTA6, NEXTA8,NEXT20, + * ALLCHR, ALLSTK, ALLHP, DECODI, FIND52, + * GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL, + * ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF, + * INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF, + * LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL, + * PARNUM, PARINS, + * SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE, + * CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE, + * HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5, + * ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA, + * DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8, + * RANUMB, R8VAL, RETVAL8, SUMVEC +C..##IF ADUMB + * ,UMFI +C..##ENDIF +C..##IF ACE + * ,GETNNB +C..##ENDIF +C..##IFN NOIMAGES + INTEGER IMATOM + EXTERNAL IMATOM +C..##ENDIF +C..##IF MBOND +C..##ENDIF +C..##IF MMFF + INTEGER LEN_TRIM + EXTERNAL LEN_TRIM + CHARACTER(4) AtName + external AtName + CHARACTER(8) ElementName + external ElementName + CHARACTER(10) QNAME + external QNAME + integer IATTCH, IBORDR, CONN12, CONN13, CONN14 + integer LEQUIV, LPATH + integer nbndx, nbnd2, nbnd3, NTERMA + external IATTCH, IBORDR, CONN12, CONN13, CONN14 + external LEQUIV, LPATH + external nbndx, nbnd2, nbnd3, NTERMA + external find_loc + REAL(KIND=8) vangle, OOPNGL, TORNGL, ElementMass + external vangle, OOPNGL, TORNGL, ElementMass +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/stack.fcm' + INTEGER STKSIZ +C..##IFN UNICOS +C...##IF LARGE XLARGE +C...##ELIF MEDIUM REDUCE + PARAMETER (STKSIZ=4000000) +C...##ELIF SMALL +C...##ELIF XSMALL +C...##ELIF XXLARGE +C...##ELSE +C...##ENDIF + INTEGER LSTUSD,MAXUSD,STACK + COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ) +C..##ELSE +C..##ENDIF +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/heap.fcm' + INTEGER HEAPDM +C..##IFN UNICOS (unicos) +C...##IF XXLARGE (size) +C...##ELIF LARGE XLARGE (size) +C...##ELIF MEDIUM (size) +C....##IF T3D (t3d2) +C....##ELIF TERRA (t3d2) +C....##ELIF ALPHA (t3d2) +C....##ELIF T3E (t3d2) +C....##ELSE (t3d2) + PARAMETER (HEAPDM=2048000) +C....##ENDIF (t3d2) +C...##ELIF SMALL (size) +C...##ELIF REDUCE (size) +C...##ELIF XSMALL (size) +C...##ELSE (size) +C...##ENDIF (size) + INTEGER FREEHP,HEAPSZ,HEAP + COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM) + LOGICAL LHEAP(HEAPDM) + EQUIVALENCE (LHEAP,HEAP) +C..##ELSE (unicos) +C..##ENDIF (unicos) +C..##IF SAVEFCM (save) +C..##ENDIF (save) +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/fast.fcm' + INTEGER IACNB, NITCC, ICUSED, FASTER, LFAST, LMACH, OLMACH + INTEGER ICCOUNT, LOWTP, IGCNB, NITCC2 + INTEGER ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD + COMMON /FASTI/ FASTER, LFAST, LMACH, OLMACH, NITCC, NITCC2, + & ICUSED(MAXATC), ICCOUNT(MAXATC), LOWTP(MAXATC), + & IACNB(MAXAIM), IGCNB(MAXATC), + & ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/deriv.fcm' + REAL(KIND=8) DX,DY,DZ + COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM) +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/energy.fcm' + INTEGER LENENP, LENENT, LENENV, LENENA + PARAMETER (LENENP = 50, LENENT = 70, LENENV = 50, + & LENENA = LENENP + LENENT + LENENV ) + INTEGER TOTE, TOTKE, EPOT, TEMPS, GRMS, BPRESS, PJNK1, PJNK2, + & PJNK3, PJNK4, HFCTE, HFCKE, EHFC, EWORK, VOLUME, PRESSE, + & PRESSI, VIRI, VIRE, VIRKE, TEPR, PEPR, KEPR, KEPR2, + & DROFFA, + & XTLTE, XTLKE, XTLPE, XTLTEM, XTLPEP, XTLKEP, XTLKP2, + & TOT4, TOTK4, EPOT4, TEM4, MbMom, BodyT, PartT +C..##IF ACE + & , SELF, SCREEN, COUL ,SOLV, INTER +C..##ENDIF +C..##IF FLUCQ + & ,FQKIN +C..##ENDIF + PARAMETER (TOTE = 1, TOTKE = 2, EPOT = 3, TEMPS = 4, + & GRMS = 5, BPRESS = 6, PJNK1 = 7, PJNK2 = 8, + & PJNK3 = 9, PJNK4 = 10, HFCTE = 11, HFCKE = 12, + & EHFC = 13, EWORK = 11, VOLUME = 15, PRESSE = 16, + & PRESSI = 17, VIRI = 18, VIRE = 19, VIRKE = 20, + & TEPR = 21, PEPR = 22, KEPR = 23, KEPR2 = 24, + & DROFFA = 26, XTLTE = 27, XTLKE = 28, + & XTLPE = 29, XTLTEM = 30, XTLPEP = 31, XTLKEP = 32, + & XTLKP2 = 33, + & TOT4 = 37, TOTK4 = 38, EPOT4 = 39, TEM4 = 40, + & MbMom = 41, BodyT = 42, PartT = 43 +C..##IF ACE + & , SELF = 45, SCREEN = 46, COUL = 47, + & SOLV = 48, INTER = 49 +C..##ENDIF +C..##IF FLUCQ + & ,FQKIN = 50 +C..##ENDIF + & ) +C..##IF ACE +C..##ENDIF +C..##IF GRID +C..##ENDIF +C..##IF FLUCQ +C..##ENDIF + INTEGER BOND, ANGLE, UREYB, DIHE, IMDIHE, VDW, ELEC, HBOND, + & USER, CHARM, CDIHE, CINTCR, CQRT, NOE, SBNDRY, + & IMVDW, IMELEC, IMHBND, EWKSUM, EWSELF, EXTNDE, RXNFLD, + & ST2, IMST2, TSM, QMEL, QMVDW, ASP, EHARM, GEO, MDIP, + & PRMS, PANG, SSBP, BK4D, SHEL, RESD, SHAP, + & STRB, OOPL, PULL, POLAR, DMC, RGY, EWEXCL, EWQCOR, + & EWUTIL, PBELEC, PBNP, PINT, MbDefrm, MbElec, STRSTR, + & BNDBND, BNDTW, EBST, MBST, BBT, SST, GBEnr, GSBP +C..##IF HMCM + & , HMCM +C..##ENDIF +C..##IF ADUMB + & , ADUMB +C..##ENDIF + & , HYDR +C..##IF FLUCQ + & , FQPOL +C..##ENDIF + PARAMETER (BOND = 1, ANGLE = 2, UREYB = 3, DIHE = 4, + & IMDIHE = 5, VDW = 6, ELEC = 7, HBOND = 8, + & USER = 9, CHARM = 10, CDIHE = 11, CINTCR = 12, + & CQRT = 13, NOE = 14, SBNDRY = 15, IMVDW = 16, + & IMELEC = 17, IMHBND = 18, EWKSUM = 19, EWSELF = 20, + & EXTNDE = 21, RXNFLD = 22, ST2 = 23, IMST2 = 24, + & TSM = 25, QMEL = 26, QMVDW = 27, ASP = 28, + & EHARM = 29, GEO = 30, MDIP = 31, PINT = 32, + & PRMS = 33, PANG = 34, SSBP = 35, BK4D = 36, + & SHEL = 37, RESD = 38, SHAP = 39, STRB = 40, + & OOPL = 41, PULL = 42, POLAR = 43, DMC = 44, + & RGY = 45, EWEXCL = 46, EWQCOR = 47, EWUTIL = 48, + & PBELEC = 49, PBNP = 50, MbDefrm= 51, MbElec = 52, + & STRSTR = 53, BNDBND = 54, BNDTW = 55, EBST = 56, + & MBST = 57, BBT = 58, SST = 59, GBEnr = 60, + & GSBP = 65 +C..##IF HMCM + & , HMCM = 61 +C..##ENDIF +C..##IF ADUMB + & , ADUMB = 62 +C..##ENDIF + & , HYDR = 63 +C..##IF FLUCQ + & , FQPOL = 65 +C..##ENDIF + & ) + INTEGER VEXX, VEXY, VEXZ, VEYX, VEYY, VEYZ, VEZX, VEZY, VEZZ, + & VIXX, VIXY, VIXZ, VIYX, VIYY, VIYZ, VIZX, VIZY, VIZZ, + & PEXX, PEXY, PEXZ, PEYX, PEYY, PEYZ, PEZX, PEZY, PEZZ, + & PIXX, PIXY, PIXZ, PIYX, PIYY, PIYZ, PIZX, PIZY, PIZZ + PARAMETER ( VEXX = 1, VEXY = 2, VEXZ = 3, VEYX = 4, + & VEYY = 5, VEYZ = 6, VEZX = 7, VEZY = 8, + & VEZZ = 9, + & VIXX = 10, VIXY = 11, VIXZ = 12, VIYX = 13, + & VIYY = 14, VIYZ = 15, VIZX = 16, VIZY = 17, + & VIZZ = 18, + & PEXX = 19, PEXY = 20, PEXZ = 21, PEYX = 22, + & PEYY = 23, PEYZ = 24, PEZX = 25, PEZY = 26, + & PEZZ = 27, + & PIXX = 28, PIXY = 29, PIXZ = 30, PIYX = 31, + & PIYY = 32, PIYZ = 33, PIZX = 34, PIZY = 35, + & PIZZ = 36) + CHARACTER(4) CEPROP, CETERM, CEPRSS + COMMON /ANER/ CEPROP(LENENP), CETERM(LENENT), CEPRSS(LENENV) + LOGICAL QEPROP, QETERM, QEPRSS + COMMON /QENER/ QEPROP(LENENP), QETERM(LENENT), QEPRSS(LENENV) + REAL(KIND=8) EPROP, ETERM, EPRESS + COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV) +C..##IF SAVEFCM +C..##ENDIF + REAL(KIND=8) EPRPA, EPRP2A, EPRPP, EPRP2P, + & ETRMA, ETRM2A, ETRMP, ETRM2P, + & EPRSA, EPRS2A, EPRSP, EPRS2P + COMMON /ENACCM/ EPRPA(LENENP), ETRMA(LENENT), EPRSA(LENENV), + & EPRP2A(LENENP),ETRM2A(LENENT),EPRS2A(LENENV), + & EPRPP(LENENP), ETRMP(LENENT), EPRSP(LENENV), + & EPRP2P(LENENP),ETRM2P(LENENT),EPRS2P(LENENV) +C..##IF SAVEFCM +C..##ENDIF + INTEGER ECALLS, TOT1ST, TOT2ND + COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND + REAL(KIND=8) EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP, + & EAT0P, CORRP + COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA, + & FITP, DRIFTP, EAT0P, CORRP +C..##IF SAVEFCM +C..##ENDIF +C..##IF ACE +C..##ENDIF +C..##IF FLUCQ +C..##ENDIF +C..##IF ADUMB +C..##ENDIF +C..##IF GRID +C..##ENDIF +C..##IF FLUCQ +C..##ENDIF +C..##IF TSM + REAL(KIND=8) TSMTRM(LENENT),TSMTMP(LENENT) + COMMON /TSMENG/ TSMTRM,TSMTMP +C...##IF SAVEFCM +C...##ENDIF +C..##ENDIF + REAL(KIND=8) EHQBM + LOGICAL HQBM + COMMON /HQBMVAR/HQBM +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/dimb.fcm' +C..##IF DIMB (dimbfcm) + INTEGER NPARMX,MNBCMP,LENDSK + PARAMETER (NPARMX=1000,MNBCMP=300,LENDSK=200000) + INTEGER IJXXCM,IJXYCM,IJXZCM,IJYXCM,IJYYCM + INTEGER IJYZCM,IJZXCM,IJZYCM,IJZZCM + INTEGER IIXXCM,IIXYCM,IIXZCM,IIYYCM + INTEGER IIYZCM,IIZZCM + INTEGER JJXXCM,JJXYCM,JJXZCM,JJYYCM + INTEGER JJYZCM,JJZZCM + PARAMETER (IJXXCM=1,IJXYCM=2,IJXZCM=3,IJYXCM=4,IJYYCM=5) + PARAMETER (IJYZCM=6,IJZXCM=7,IJZYCM=8,IJZZCM=9) + PARAMETER (IIXXCM=1,IIXYCM=2,IIXZCM=3,IIYYCM=4) + PARAMETER (IIYZCM=5,IIZZCM=6) + PARAMETER (JJXXCM=1,JJXYCM=2,JJXZCM=3,JJYYCM=4) + PARAMETER (JJYZCM=5,JJZZCM=6) + INTEGER ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,PDD1CM,LENCMP + LOGICAL QDISK,QDW,QCMPCT + COMMON /DIMBI/ ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,LENCMP + COMMON /DIMBL/ QDISK,QDW,QCMPCT +C...##IF SAVEFCM +C...##ENDIF +C..##ENDIF (dimbfcm) +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C:::##INCLUDE '~/charmm_fcm/ctitla.fcm' + INTEGER MAXTIT + PARAMETER (MAXTIT=32) + INTEGER NTITLA,NTITLB + CHARACTER(80) TITLEA,TITLEB + COMMON /NTITLA/ NTITLA,NTITLB + COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT) +C..##IF SAVEFCM +C..##ENDIF +C----------------------------------------------------------------------- +C Passed variables + INTEGER NAT3,NADD,NPAR,NFREG,NFRET,BLATOM + INTEGER ATMPAR(2,*),ATMPAS(2,*),ATMPAD(2,*) + INTEGER BNBND(*),BIMAG(*) + INTEGER INBCMP(*),JNBCMP(*),PARDIM + INTEGER ITMX,IUNMOD,IUNRMD,SAVF + INTEGER NBOND,IB(*),JB(*) + REAL(KIND=8) X(*),Y(*),Z(*),AMASS(*),DDSCR(*) + REAL(KIND=8) DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*) + REAL(KIND=8) DDF(*),PARDDF(*),DDEV(*),PARDDE(*) + REAL(KIND=8) DD1BLK(*),DD1BLL(*),DD1CMP(*) + REAL(KIND=8) TOLDIM,DDVALM + REAL(KIND=8) PARFRQ,CUTF1 + LOGICAL LNOMA,LRAISE,LSCI,LBIG +C Local variables + INTEGER NATOM,NATP,NDIM,I,J,II,OLDFAS,OLDPRN,IUPD + INTEGER NPARC,NPARD,NPARS,NFCUT1,NFREG2,NFREG6 + INTEGER IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 + INTEGER IS1,IS2,IS3,IS4,JSPACE,JSP,DDSS,DD5 + INTEGER ISTRT,ISTOP,IPA1,IPA2,IRESF + INTEGER ATMPAF,INIDS,TRAROT + INTEGER SUBLIS,ATMCOR + INTEGER NFRRES,DDVBAS + INTEGER DDV2,DDVAL + INTEGER LENCM,NTR,NFRE,NFC,N1,N2,NFCUT,NSUBP + INTEGER SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6 + INTEGER DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ + INTEGER I620,I640,I660,I700,I720,I760,I800,I840,I880,I920 + REAL(KIND=8) CVGMX,TOLER + LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG +C Begin + QCALC=.TRUE. + LWDINI=.FALSE. + INIDS=0 + IS3=0 + IS4=0 + LPURG=.TRUE. + ITER=0 + NADD=0 + NFSAV=0 + TOLER=TENM5 + QDIAG=.TRUE. + CVGMX=HUNDRD + QMIX=.FALSE. + NATOM=NAT3/3 + NFREG6=(NFREG-6)/NPAR + NFREG2=NFREG/2 + NFRRES=(NFREG+6)/2 + IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'', + 1 'NFREG IS LARGER THAN PARDIM*3') +C +C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS + ASSIGN 801 TO I800 + GOTO 800 + 801 CONTINUE +C ALLOCATE-SPACE-FOR-DIAGONALIZATION + ASSIGN 721 TO I720 + GOTO 720 + 721 CONTINUE +C ALLOCATE-SPACE-FOR-REDUCED-BASIS + ASSIGN 761 TO I760 + GOTO 760 + 761 CONTINUE +C ALLOCATE-SPACE-FOR-OTHER-ARRAYS + ASSIGN 921 TO I920 + GOTO 920 + 921 CONTINUE +C +C Space allocation for working arrays of EISPACK +C diagonalization subroutines + IF(LSCI) THEN +C ALLOCATE-SPACE-FOR-LSCI + ASSIGN 841 TO I840 + GOTO 840 + 841 CONTINUE + ELSE +C ALLOCATE-DUMMY-SPACE-FOR-LSCI + ASSIGN 881 TO I880 + GOTO 880 + 881 CONTINUE + ENDIF + QMASWT=(.NOT.LNOMA) + IF(.NOT. QDISK) THEN + LENCM=INBCMP(NATOM-1)*9+NATOM*6 + DO I=1,LENCM + DD1CMP(I)=0.0 + ENDDO + OLDFAS=LFAST + QCMPCT=.TRUE. + LFAST = -1 + CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1) + LFAST=OLDFAS + QCMPCT=.FALSE. +C +C Mass weight DD1CMP matrix +C + CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM) + ELSE + CALL WRNDIE(-3,'','QDISK OPTION NOT SUPPORTED YET') +C DO I=1,LENDSK +C DD1CMP(I)=0.0 +C ENDDO +C OLDFAS=LFAST +C LFAST = -1 + ENDIF +C +C Fill DDV with six translation-rotation vectors +C + CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM) + CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1) + NTR=6 + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) ! { dg-warning "Type mismatch" } + PRNLEV=OLDPRN + IF(IUNRMD .LT. 0) THEN +C +C If no previous basis is read +C + IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR + 502 FORMAT(/' NMDIMB: Calculating initial basis from block ', + 1 'diagonals'/' NMDIMB: The number of blocks is ',I5/) + NFRET = 6 + DO I=1,NPAR + IS1=ATMPAR(1,I) + IS2=ATMPAR(2,I) + NDIM=(IS2-IS1+1)*3 + NFRE=NDIM + IF(NFRE.GT.NFREG6) NFRE=NFREG6 + IF(NFREG6.EQ.0) NFRE=1 + CALL FILUPT(HEAP(IUPD),NDIM) + CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD), + 1 IS1,IS2,NATOM) + IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR', + 1 'ENR',.TRUE.,1,ZERO,ZERO) +C +C Generate the lower section of the matrix and diagonalize +C +C..##IF EISPACK +C..##ENDIF + IH1=1 + NATP=NDIM+1 + IH2=IH1+NATP + IH3=IH2+NATP + IH4=IH3+NATP + IH5=IH4+NATP + IH6=IH5+NATP + IH7=IH6+NATP + IH8=IH7+NATP + CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3), + 1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD) +C..##IF EISPACK +C..##ENDIF +C +C Put the PARDDV vectors into DDV and replace the elements which do +C not belong to the considered partitioned region by zeros. +C + CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2) + IF(LSCI) THEN + DO J=1,NFRE + PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) + IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) + ENDDO + ELSE + DO J=1,NFRE + PARDDE(J)=DDS(J) + PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) + IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) + ENDDO + ENDIF + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,512) I + WRITE(OUTU,514) + WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE) + ENDIF + NFRET=NFRET+NFRE + IF(NFRET .GE. NFREG) GOTO 10 + ENDDO + 512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed') + 514 FORMAT(' NMDIMB: Frequencies'/) + 516 FORMAT(5(I4,F12.6)) + 10 CONTINUE +C +C Orthonormalize the eigenvectors +C + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) ! { dg-warning "Type mismatch" } + PRNLEV=OLDPRN +C +C Do reduced basis diagonalization using the DDV vectors +C and get eigenvectors of zero iteration +C + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,521) ITER + WRITE(OUTU,523) NFRET + ENDIF + 521 FORMAT(/' NMDIMB: Iteration number = ',I5) + 523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5) + IF(LBIG) THEN + IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD + 525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5) + REWIND (UNIT=IUNMOD) + LCARD=.FALSE. + CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS) + CALL SAVEIT(IUNMOD) + ELSE + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1) + ENDIF + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4, + 3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) +C +C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS +C + ASSIGN 621 TO I620 + GOTO 620 + 621 CONTINUE +C SAVE-MODES + ASSIGN 701 TO I700 + GOTO 700 + 701 CONTINUE + IF(ITER.EQ.ITMX) THEN + CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, + 1 DDVAL,JSPACE,TRAROT, + 2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6, + 3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF, + 4 ATMCOR,SUBLIS,LSCI,QDW,LBIG) + RETURN + ENDIF + ELSE +C +C Read in existing basis +C + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,531) + 531 FORMAT(/' NMDIMB: Calculations restarted') + ENDIF +C READ-MODES + ISTRT=1 + ISTOP=99999999 + LCARD=.FALSE. + LAPPE=.FALSE. + CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM, + 1 DDV,DDSCR,DDF,DDEV, + 2 IUNRMD,LAPPE,ISTRT,ISTOP) + NFRET=NDIM + IF(NFRET.GT.NFREG) THEN + NFRET=NFREG + CALL WRNDIE(-1,'', + 1 'Not enough space to hold the basis. Increase NMODes') + ENDIF +C PRINT-MODES + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,533) NFRET,IUNRMD + WRITE(OUTU,514) + WRITE(OUTU,516) (J,DDF(J),J=1,NFRET) + ENDIF + 533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5) + NFRRES=NFRET + ENDIF +C +C ------------------------------------------------- +C Here starts the mixed-basis diagonalization part. +C ------------------------------------------------- +C +C +C Check cut-off frequency +C + CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) +C TEST-NFCUT1 + IF(IUNRMD.LT.0) THEN + IF(NFCUT1*2-6.GT.NFREG) THEN + IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES) + NFCUT1=NFRRES + CUTF1=DDF(NFRRES) + ENDIF + ELSE + CUTF1=DDF(NFRRES) + ENDIF + 537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency' + 1 /' Cutoff frequency is decreased to',F9.3) +C +C Compute the new partioning of the molecule +C + CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES, + 1 PARDIM) + NPARS=NPARC + DO I=1,NPARC + ATMPAS(1,I)=ATMPAR(1,I) + ATMPAS(2,I)=ATMPAR(2,I) + ENDDO + IF(QDW) THEN + IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE. + IF(IPAR1.GE.IPAR2) LWDINI=.TRUE. + IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE. + IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE. + IF(ITER.EQ.0) LWDINI=.TRUE. + ENDIF + ITMX=ITMX+ITER + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,543) ITER,ITMX + IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2 + ENDIF + 543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/ + 1 ' NMDIMB: Iteration number to reach = ',I8) + 545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5) +C + IF(SAVF.LE.0) SAVF=NPARC + IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF + 547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5, + 1 ' iterations') +C +C If double windowing is defined, the original block sizes are divided +C in two. +C + IF(QDW) THEN + NSUBP=1 + CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX) + ATMPAF=ALLHP(INTEG4(NPARD*NPARD)) + ATMCOR=ALLHP(INTEG4(NATOM)) + DDVAL=ALLHP(IREAL8(NPARD*NPARD)) + CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM) + CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD, + 2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM) + SUBLIS=ALLHP(INTEG4(NSUBP*2)) + CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP) + CALL INIPAF(HEAP(ATMPAF),NPARD) +C +C Find out with which block to continue (double window method only) +C + IPA1=IPAR1 + IPA2=IPAR2 + IRESF=0 + IF(LWDINI) THEN + ITER=0 + LWDINI=.FALSE. + GOTO 500 + ENDIF + DO II=1,NSUBP + CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF), + 1 NPARD,QCALC) + IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500 + ENDDO + ENDIF + 500 CONTINUE +C +C Main loop. +C + DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX)) + IF(.NOT.QDW) THEN + ITER=ITER+1 + IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER + 553 FORMAT(/' NMDIMB: Iteration number = ',I8) + IF(INIDS.EQ.0) THEN + INIDS=1 + ELSE + INIDS=0 + ENDIF + CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX, + 1 DDF,NFREG,CUTF1,PARDIM,NFCUT1) +C DO-THE-DIAGONALISATIONS + ASSIGN 641 to I640 + GOTO 640 + 641 CONTINUE + QDIAG=.FALSE. +C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS + ASSIGN 622 TO I620 + GOTO 620 + 622 CONTINUE + QDIAG=.TRUE. +C SAVE-MODES + ASSIGN 702 TO I700 + GOTO 700 + 702 CONTINUE +C + ELSE + DO II=1,NSUBP + CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF), + 1 NPARD,QCALC) + IF(QCALC) THEN + IRESF=IRESF+1 + ITER=ITER+1 + IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER +C DO-THE-DWIN-DIAGONALISATIONS + ASSIGN 661 TO I660 + GOTO 660 + 661 CONTINUE + ENDIF + IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN + IRESF=0 + QDIAG=.FALSE. +C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS + ASSIGN 623 TO I620 + GOTO 620 + 623 CONTINUE + QDIAG=.TRUE. + IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600 +C SAVE-MODES + ASSIGN 703 TO I700 + GOTO 700 + 703 CONTINUE + ENDIF + ENDDO + ENDIF + ENDDO + 600 CONTINUE +C +C SAVE-MODES + ASSIGN 704 TO I700 + GOTO 700 + 704 CONTINUE + CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, + 1 DDVAL,JSPACE,TRAROT, + 2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6, + 3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF, + 4 ATMCOR,SUBLIS,LSCI,QDW,LBIG) + RETURN +C----------------------------------------------------------------------- +C INTERNAL PROCEDURES +C----------------------------------------------------------------------- +C TO DO-THE-DIAGONALISATIONS-WITH-RESIDUALS + 620 CONTINUE + IF(IUNRMD.LT.0) THEN + CALL SELNMD(DDF,NFRET,CUTF1,NFC) + N1=NFCUT1 + N2=(NFRET+6)/2 + NFCUT=MAX(N1,N2) + IF(NFCUT*2-6 .GT. NFREG) THEN + NFCUT=(NFREG+6)/2 + CUTF1=DDF(NFCUT) + IF(PRNLEV.GE.2) THEN + WRITE(OUTU,562) ITER + WRITE(OUTU,564) CUTF1 + ENDIF + ENDIF + ELSE + NFCUT=NFRET + NFC=NFRET + ENDIF + 562 FORMAT(/' NMDIMB: Not enough space to hold the residual vectors'/ + 1 ' into DDV array during iteration ',I5) + 564 FORMAT(' Cutoff frequency is changed to ',F9.3) +C +C do reduced diagonalization with preceding eigenvectors plus +C residual vectors +C + ISTRT=1 + ISTOP=NFCUT + CALL CLETR(DDV,HEAP(TRAROT),NAT3,ISTRT,ISTOP,NFCUT,DDEV,DDF) + CALL RNMTST(DDV,HEAP(DDVBAS),NAT3,DDSCR,DD1CMP,INBCMP,JNBCMP, + 2 7,NFCUT,CVGMX,NFCUT,NFC,QDIAG,LBIG,IUNMOD) + NFSAV=NFCUT + IF(QDIAG) THEN + NFRET=NFCUT*2-6 + IF(PRNLEV.GE.2) WRITE(OUTU,566) NFRET + 566 FORMAT(/' NMDIMB: Diagonalization with residual vectors. '/ + 1 ' Dimension of the reduced basis set'/ + 2 ' before orthonormalization = ',I5) + NFCUT=NFRET + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN + NFRET=NFCUT + IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET + 568 FORMAT(' after orthonormalization = ',I5) + IF(LBIG) THEN + IF(PRNLEV.GE.2) WRITE(OUTU,570) NFCUT,IUNMOD + 570 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5) + REWIND (UNIT=IUNMOD) + LCARD=.FALSE. + CALL WRTNMD(LCARD,1,NFCUT,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS) + CALL SAVEIT(IUNMOD) + ELSE + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) + ENDIF + QMIX=.FALSE. + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4, + 3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) + CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) + ENDIF + GOTO I620 +C +C----------------------------------------------------------------------- +C TO DO-THE-DIAGONALISATIONS + 640 CONTINUE + DO I=1,NPARC + NFCUT1=NFRRES + IS1=ATMPAR(1,I) + IS2=ATMPAR(2,I) + NDIM=(IS2-IS1+1)*3 + IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2 + 573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/ + 1 ' NMDIMB: Block limits: ',I5,2X,I5) + IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'', + 1 'Error in dimension of block') + NFRET=NFCUT1 + IF(NFRET.GT.NFREG) NFRET=NFREG + CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) + NFCUT1=NFCUT + CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2) + NFSAV=NFCUT1 + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) + NFRET=NDIM+NFCUT + QMIX=.TRUE. + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, + 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) + QMIX=.FALSE. + IF(NFCUT.GT.NFRRES) NFCUT=NFRRES + NFCUT1=NFCUT + NFRET=NFCUT + ENDDO + GOTO I640 +C +C----------------------------------------------------------------------- +C TO DO-THE-DWIN-DIAGONALISATIONS + 660 CONTINUE +C +C Store the DDV vectors into DDVBAS +C + NFCUT1=NFRRES + IS1=ATMPAD(1,IPAR1) + IS2=ATMPAD(2,IPAR1) + IS3=ATMPAD(1,IPAR2) + IS4=ATMPAD(2,IPAR2) + NDIM=(IS2-IS1+IS4-IS3+2)*3 + IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4 + 577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ', + 1 2I5/ + 2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5) + IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'', + 1 'Error in dimension of block') + NFRET=NFCUT1 + IF(NFRET.GT.NFREG) NFRET=NFREG +C +C Prepare the DDV vectors consisting of 6 translations-rotations +C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors +C spanning the atoms from IS1 to IS2 +C + CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) + NFCUT1=NFCUT + NFSAV=NFCUT1 + CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4) + OLDPRN=PRNLEV + PRNLEV=1 + CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) + PRNLEV=OLDPRN + CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) +C + NFRET=NDIM+NFCUT + QMIX=.TRUE. + CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, + 1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, + 2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, + 3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), + 4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), + 5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), + 6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) + QMIX=.FALSE. +C + IF(NFCUT.GT.NFRRES) NFCUT=NFRRES + NFCUT1=NFCUT + NFRET=NFCUT + GOTO I660 +C +C----------------------------------------------------------------------- +C TO SAVE-MODES + 700 CONTINUE + IF(PRNLEV.GE.2) WRITE(OUTU,583) IUNMOD + 583 FORMAT(/' NMDIMB: Saving the eigenvalues and eigenvectors to unit' + 1 ,I4) + REWIND (UNIT=IUNMOD) + ISTRT=1 + ISTOP=NFSAV + LCARD=.FALSE. + IF(PRNLEV.GE.2) WRITE(OUTU,585) NFSAV,IUNMOD + 585 FORMAT(' NMDIMB: ',I5,' modes are saved in unit',I5) + CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD, + 1 AMASS) + CALL SAVEIT(IUNMOD) + GOTO I700 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION + 720 CONTINUE + DDV2=ALLHP(IREAL8((PARDIM+3)*(PARDIM+3))) + JSPACE=IREAL8((PARDIM+4))*8 + JSP=IREAL8(((PARDIM+3)*(PARDIM+4))/2) + JSPACE=JSPACE+JSP + DDSS=ALLHP(JSPACE) + DD5=DDSS+JSPACE-JSP + GOTO I720 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS + 760 CONTINUE + IF(LBIG) THEN + DDVBAS=ALLHP(IREAL8(NAT3)) + ELSE + DDVBAS=ALLHP(IREAL8(NFREG*NAT3)) + ENDIF + GOTO I760 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS + 800 CONTINUE + TRAROT=ALLHP(IREAL8(6*NAT3)) + GOTO I800 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-LSCI + 840 CONTINUE + SCIFV1=ALLHP(IREAL8(PARDIM+3)) + SCIFV2=ALLHP(IREAL8(PARDIM+3)) + SCIFV3=ALLHP(IREAL8(PARDIM+3)) + SCIFV4=ALLHP(IREAL8(PARDIM+3)) + SCIFV6=ALLHP(IREAL8(PARDIM+3)) + DRATQ=ALLHP(IREAL8(PARDIM+3)) + ERATQ=ALLHP(IREAL8(PARDIM+3)) + E2RATQ=ALLHP(IREAL8(PARDIM+3)) + BDRATQ=ALLHP(IREAL8(PARDIM+3)) + INRATQ=ALLHP(INTEG4(PARDIM+3)) + GOTO I840 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI + 880 CONTINUE + SCIFV1=ALLHP(IREAL8(2)) + SCIFV2=ALLHP(IREAL8(2)) + SCIFV3=ALLHP(IREAL8(2)) + SCIFV4=ALLHP(IREAL8(2)) + SCIFV6=ALLHP(IREAL8(2)) + DRATQ=ALLHP(IREAL8(2)) + ERATQ=ALLHP(IREAL8(2)) + E2RATQ=ALLHP(IREAL8(2)) + BDRATQ=ALLHP(IREAL8(2)) + INRATQ=ALLHP(INTEG4(2)) + GOTO I880 +C +C----------------------------------------------------------------------- +C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS + 920 CONTINUE + IUPD=ALLHP(INTEG4(PARDIM+3)) + GOTO I920 +C.##ELSE +C.##ENDIF + END Index: Fortran/gfortran/regression/g77/20010610.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20010610.f @@ -0,0 +1,5 @@ +c { dg-do run } + DO I = 0, 255 + IF (ICHAR(CHAR(I)) .NE. I) STOP 1 + ENDDO + END Index: Fortran/gfortran/regression/g77/20020307-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20020307-1.f @@ -0,0 +1,23 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } + SUBROUTINE SWEEP + PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20) + REAL(KIND=8) B,W1,W2,BNORM,BINV,WT,W0,C1,C2,R1,R2 + DIMENSION B(MAXVEC,0:3),W1(MAXVEC,0:3),W2(MAXVEC,0:3) + DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC) + DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC) + DO 200 ILAT=1,2**IDIM + DO 200 I1=1,IDIM + DO 220 I2=1,IDIM + CALL INTACT(ILAT,I1,I1,W1) +220 CONTINUE + DO 310 IATT=1,IDIM + DO 311 I=1,100 + WT(I)=ONE + C1(I)*LOG(EPS+R1(I)) + IF( R2(I)**2 .LE. (ONE-WT(I)**2) )THEN + W0(I)=WT(I) + ENDIF +311 CONTINUE +310 CONTINUE +200 CONTINUE + END Index: Fortran/gfortran/regression/g77/20030326-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/20030326-1.f @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options -pedantic } +! PR fortran/9793 +! larson@w6yx.stanford.edu +! +! For gfortran, see PR 13490 +! + integer c + c = -2147483648_4 / (-1) ! { dg-error "too big for its kind" } + end Index: Fortran/gfortran/regression/g77/6177.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/6177.f @@ -0,0 +1,15 @@ +c { dg-do run } + program pr6177 +C +C Test case for PR optimization/6177. +C This bug (an ICE) originally showed up in file cblat2.f from LAPACK. +C + complex x + complex w(1) + intrinsic conjg + x = (2.0d0, 1.0d0) + w(1) = x + x = conjg(x) + w(1) = conjg(w(1)) + if (abs(x-w(1)) .gt. 1.0e-5) STOP 1 + end Index: Fortran/gfortran/regression/g77/7388.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/7388.f @@ -0,0 +1,12 @@ +C { dg-do run } +C { dg-options "-fbounds-check" } + character*25 buff(0:10) + character*80 line + integer i, m1, m2 + i = 1 + m1 = 1 + m2 = 7 + buff(i) = 'tcase0a' + write(line,*) buff(i)(m1:m2) + if (line .ne. ' tcase0a') STOP 1 + end Index: Fortran/gfortran/regression/g77/8485.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/8485.f @@ -0,0 +1,9 @@ +c { dg-do compile } +C Extracted from PR fortran/8485 + PARAMETER (PPMULT = 1.0E5) + INTEGER(kind=8) NWRONG + PARAMETER (NWRONG = 8) + PARAMETER (DDMULT = PPMULT * NWRONG) + PRINT 10, DDMULT +10 FORMAT (F10.3) + END Index: Fortran/gfortran/regression/g77/9263.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/9263.f @@ -0,0 +1,11 @@ +C { dg-do compile } + PARAMETER (Q=1) + PARAMETER (P=10) + INTEGER C(10),D(10),E(10),F(10) +C TERMINAL NOT INTEGER + DATA (C(I),I=1,P) /10*10/ ! { dg-error "End expression in DO loop" } +C START NOT INTEGER + DATA (D(I),I=Q,10) /10*10/ ! { dg-error "Start expression in DO loop" } +C INCREMENT NOT INTEGER + DATA (E(I),I=1,10,Q) /10*10/ ! { dg-error "Step expression in DO loop" } + END Index: Fortran/gfortran/regression/g77/947.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/947.f @@ -0,0 +1,13 @@ +c { dg-do run } + DIMENSION A(-5:5) + INTEGER(kind=1) IM5, IZ, IP5 + INTEGER(kind=2) IM1, IP1 + PARAMETER (IM5=-5, IM1=-1, IZ=0, IP1=1, IP5=5) + DATA A(IM5) /-5./, A(IM1) /-1./ + DATA A(IZ) /0./ + DATA A(IP5) /+5./, A(IP1) /+1./ + IF (A(IM5) .NE. -5. .OR. A(IM1) .NE. -1. .OR. + , A(IZ) .NE. 0. .OR. + , A(IP5) .NE. +5. .OR. A(IP1) .NE. +1. ) + , STOP 1 + END Index: Fortran/gfortran/regression/g77/960317-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/960317-1.f @@ -0,0 +1,104 @@ +c { dg-do compile } +* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST) +* From: Kate Hedstrom +* To: burley@gnu.ai.mit.edu +* Subject: g77 bug in assign +* +* I found some files in the NCAR graphics source code which used to +* compile with g77 and now don't. All contain the following combination +* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a +* Sun running SunOS 5.5 (slightly older g77), but compiles on an +* IBM/RS6000: +* +C + SUBROUTINE QUICK + SAVE +C + ASSIGN 101 TO JUMP ! { dg-warning "Deleted feature: ASSIGN" } + 101 Continue +C + RETURN + END +* +* Everything else in the NCAR distribution compiled, including quite a +* few C routines. +* +* Kate +* +* +* nemo% g77 -v -c quick.f +* gcc -v -c -xf77 quick.f +* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/specs +* gcc version 2.7.2 +* /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/f771 quick.f -fset-g77-defaults -quiet -dumpbase quick.f -version -fversion -o /usr/tmp/cca24166.s +* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.1. +* GNU Fortran Front End version 0.5.18-960314 compiled: Mar 16 1996 14:28:11 +* gcc: Internal compiler error: program f771 got fatal signal 11 +* +* +* nemo% gdb /usr/local/lib/gcc-lib/*/*/f771 core +* GDB is free software and you are welcome to distribute copies of it +* under certain conditions; type "show copying" to see the conditions. +* There is absolutely no warranty for GDB; type "show warranty" for details. +* GDB 4.14 (sparc-sun-sunos4.1.3), +* Copyright 1995 Free Software Foundation, Inc... +* Core was generated by `f771'. +* Program terminated with signal 11, Segmentation fault. +* Couldn't read input and local registers from core file +* find_solib: Can't read pathname for load map: I/O error +* +* Couldn't read input and local registers from core file +* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881 +* 7881 if ((ffesymbol_save (s) || ffe_is_saveall ()) +* (gdb) where +* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881 +* Error accessing memory address 0xefffefcc: Invalid argument. +* (gdb) +* +* +* ahab% g77 -v -c quick.f +* gcc -v -c -xf77 quick.f +* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/specs +* gcc version 2.7.2 +* /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase quick.f -version -fversion -o /var/tmp/cca003D2.s +* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.2. +* GNU Fortran Front End version 0.5.18-960304 compiled: Mar 5 1996 16:12:46 +* gcc: Internal compiler error: program f771 got fatal signal 11 +* +* +* ahab% !gdb +* gdb /usr/local/lib/gcc-lib/*/*/f771 core +* GDB is free software and you are welcome to distribute copies of it +* under certain conditions; type "show copying" to see the conditions. +* There is absolutely no warranty for GDB; type "show warranty" for details. +* GDB 4.15.1 (sparc-sun-solaris2.4), +* Copyright 1995 Free Software Foundation, Inc... +* Core was generated by +* `/usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase'. +* Program terminated with signal 11, Segmentation fault. +* Reading symbols from /usr/lib/libc.so.1...done. +* Reading symbols from /usr/lib/libdl.so.1...done. +* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963 +* Source file is more recent than executable. +* 7963 assert (st != NULL); +* (gdb) where +* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963 +* #1 0x38044 in ffecom_expr_ (expr=0x3a23c0, dest_tree=0x0, dest=0x0, dest_used=0x0, assignp=true) at f/com.c:2100 +* #2 0x489c8 in ffecom_expr_assign_w (expr=0x3a23c0) at f/com.c:10238 +* #3 0xe9228 in ffeste_R838 (label=0x3a1ba8, target=0x3a23c0) at f/ste.c:2769 +* #4 0xdae60 in ffestd_stmt_pass_ () at f/std.c:840 +* #5 0xdc090 in ffestd_exec_end () at f/std.c:1405 +* #6 0xcb534 in ffestc_shriek_subroutine_ (ok=true) at f/stc.c:4849 +* #7 0xd8f00 in ffestc_R1225 (name=0x0) at f/stc.c:12307 +* #8 0xcc808 in ffestc_end () at f/stc.c:5572 +* #9 0x9fa84 in ffestb_end3_ (t=0x3a19c8) at f/stb.c:3216 +* #10 0x9f30c in ffestb_end (t=0x3a19c8) at f/stb.c:2995 +* #11 0x98414 in ffesta_save_ (t=0x3a19c8) at f/sta.c:453 +* #12 0x997ec in ffesta_second_ (t=0x3a19c8) at f/sta.c:1178 +* #13 0x8ed84 in ffelex_send_token_ () at f/lex.c:1614 +* #14 0x8cab8 in ffelex_finish_statement_ () at f/lex.c:946 +* #15 0x91684 in ffelex_file_fixed (wf=0x397780, f=0x37a560) at f/lex.c:2946 +* #16 0x107a94 in ffe_file (wf=0x397780, f=0x37a560) at f/top.c:456 +* #17 0x96218 in yyparse () at f/parse.c:77 +* #18 0x10beac in compile_file (name=0xdffffaf7 "quick.f") at toplev.c:2239 +* #19 0x110dc0 in main (argc=9, argv=0xdffff994, envp=0xdffff9bc) at toplev.c:3927 Index: Fortran/gfortran/regression/g77/970125-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/970125-0.f @@ -0,0 +1,44 @@ +c { dg-do compile } +c +c { dg-additional-options "-w" } +c +C JCB comments: +C g77 doesn't accept the added line "integer(kind=7) ..." -- +C it crashes! +C +C It's questionable that g77 DTRT with regarding to passing +C %LOC() as an argument (thus by reference) and the new global +C analysis. I need to look into that further; my feeling is that +C passing %LOC() as an argument should be treated like passing an +C INTEGER(KIND=7) by reference, and no more specially than that +C (and that INTEGER(KIND=7) should be permitted as equivalent to +C INTEGER(KIND=1), INTEGER(KIND=2), or whatever, depending on the +C system's pointer size). +C +C The back end *still* has a bug here, which should be fixed, +C because, currently, what g77 is passing to it is, IMO, correct. + +C No options: +C ../../egcs/gcc/f/info.c:259: failed assertion `ffeinfo_types_[basictype][kindtype] != NULL' +C -fno-globals -O: +C ../../egcs/gcc/expr.c:7291: Internal compiler error in function expand_expr + +c Frontend bug fixed by JCB 1998-06-01 com.c &c changes. + + integer i4 + integer(kind=8) i8 + integer(kind=8) max4 + data max4/2147483647/ + i4 = %loc(i4) + i8 = %loc(i8) + print *, max4 + print *, i4, %loc(i4) + print *, i8, %loc(i8) + call foo(i4, %loc(i4), i8, %loc(i8)) ! { dg-error "Type mismatch in argument 'i8a' at .1.; passed INTEGER.8. to INTEGER.4." } + end + subroutine foo(i4, i4a, i8, i8a) + integer(kind=7) i4a, i8a ! { dg-error "Kind 7 not supported for type INTEGER" } + integer(kind=8) i8 + print *, i4, i4a + print *, i8, i8a + end Index: Fortran/gfortran/regression/g77/970625-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/970625-2.f @@ -0,0 +1,84 @@ +* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST) +* MIME-Version: 1.0 +* From: R.Hooft@EuroMail.com (Rob Hooft) +* To: g77-alpha@gnu.ai.mit.edu +* Subject: Re: testing 970624. +* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu> +* References: <199706251018.MAA21538@nu> +* <199706251027.GAA07892@churchy.gnu.ai.mit.edu> +* X-Mailer: VM 6.30 under Emacs 19.34.1 +* Content-Type: text/plain; charset=US-ASCII +* +* >>>>> "CB" == Craig Burley writes: +* +* CB> but OTOH I'd like to see more problems like this on other +* CB> applications, and especially other systems +* +* How about this one: An application that prints "112." on all +* compilers/platforms I have tested, except with the new g77 on ALPHA (I +* don't have the new g77 on any other platform here to test)? +* +* Application Appended. Source code courtesy of my boss..... +* Disclaimer: I do not know the right answer, or even whether there is a +* single right answer..... +* +* Regards, +* -- +* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ == +* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/ +* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ==== +* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! ============= +* +* nu[152]for% cat humor.f + PROGRAM SUBROUTINE + LOGICAL ELSE IF + INTEGER REAL, GO TO PROGRAM, WHILE, THEN, END DO + REAL FORMAT(2) + DATA IF,REAL,END DO,WHILE,FORMAT(2),I2/2,6,7,1,112.,1/ + DO THEN=1, END DO, WHILE + CALL = END DO - IF + PROGRAM = THEN - IF + ELSE IF = THEN .GT. IF + IF (THEN.GT.REAL) THEN + CALL FUNCTION PROGRAM (ELSE IF, GO TO PROGRAM, THEN) ! { dg-error "Type mismatch in argument" } + ELSE IF (ELSE IF) THEN + REAL = THEN + END DO + END IF + END DO + 10 FORMAT(I2/I2) = WHILE*REAL*THEN + IF (FORMAT(I2) .NE. FORMAT(I2+I2)) STOP 1 + END ! DO + SUBROUTINE FUNCTION PROGRAM (REAL,INTEGER, LOGICAL) + LOGICAL REAL + REAL LOGICAL + INTEGER INTEGER, STOP, RETURN, GO TO + ASSIGN 9 TO STOP ! { dg-warning "ASSIGN" } + ASSIGN = 9 + LOGICAL + ASSIGN 7 TO RETURN ! { dg-warning "ASSIGN" } + ASSIGN 9 TO GO TO ! { dg-warning "ASSIGN" } + GO TO = 5 + STOP = 8 + IF (.NOT.REAL) GOTO STOP ! { dg-warning "Assigned GOTO" } + IF (LOGICAL.GT.INTEGER) THEN + IF = LOGICAL +5 + IF (LOGICAL.EQ.5) ASSIGN 5 TO IF ! { dg-warning "ASSIGN" } + INTEGER=IF + ELSE + IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO ! { dg-warning "ASSIGN" } + ELSE = GO TO + END IF = ELSE + GO TO + IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN ! { dg-warning "Assigned GOTO" } + END IF + 5 CONTINUE + 7 LOGICAL=LOGICAL+STOP + 9 RETURN + END ! IF +* nu[153]for% f77 humor.f +* nu[154]for% ./a.out +* 112.0000 +* nu[155]for% f90 humor.f +* nu[156]for% ./a.out +* 112.0000 +* nu[157]for% g77 humor.f +* nu[158]for% ./a.out +* 40. Index: Fortran/gfortran/regression/g77/970816-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/970816-3.f @@ -0,0 +1,21 @@ +c { dg-do run } +* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) +* From: Claus Denk +* To: g77-alpha@gnu.ai.mit.edu +* Subject: 970811 report - segfault bug on alpha still there +*[...] +* Now, the bug that I reported some weeks ago is still there, I'll post +* the test program again: +* + PROGRAM TEST +C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with +C NSTART=1 on the second write. + PARAMETER (NSTART=1,NADD=NSTART+1) + REAL AB(NSTART:NSTART) + AB(NSTART)=1.0 + I=1 + J=2 + IND=I-J+NADD + write(*,*) AB(IND) + write(*,*) AB(I-J+NADD) + END Index: Fortran/gfortran/regression/g77/970915-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/970915-0.f @@ -0,0 +1,21 @@ +c { dg-do compile } +* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR +* node twice in a given top-level call to it. +* (JCB com.c patch of 1998-06-04.) + + SUBROUTINE TSTSIG11 + IMPLICIT COMPLEX (A-Z) + EXTERNAL gzi1,gzi2 + branch3 = sw2 / cw + . * ( rdw * (epsh*gzi1(A,B)-gzi2(A,B)) + . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) ) + . + (-1./2. + 2.*sw2/3.) / (sw*cw) + . * rdw * (epsh*gzi1(A,B)-gzi2(A,B) + . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) + . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) ) + . * rup * (epsh*gzi1(A,B)-gzi2(A,B) + . + rup * (epsh*gzi1(A,B)-gzi2(A,B)) ) + . * 4.*(3.-tw**2) * gzi2(A,B) + . + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B) + RETURN + END Index: Fortran/gfortran/regression/g77/971102-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/971102-1.f @@ -0,0 +1,12 @@ +c { dg-do run } + i=3 + j=0 + do i=i,5 + j = j+i + end do + do i=3,i + j = j+i + end do + if (i.ne.7) STOP 1 + print *, i,j + end Index: Fortran/gfortran/regression/g77/980310-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-1.f @@ -0,0 +1,29 @@ +c { dg-do compile } +C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4 +C To: egcs-bugs@cygnus.com +C Subject: backend case range problem/fix +C From: Dave Love +C Date: 02 Dec 1997 18:11:35 +0000 +C Message-ID: +C +C The following Fortran test case aborts the compiler because +C tree_int_cst_lt dereferences a null tree; this is a regression from +C gcc 2.7. + + INTEGER N + READ(*,*) N + SELECT CASE (N) + CASE (1:) + WRITE(*,*) 'case 1' + CASE (0) + WRITE(*,*) 'case 0' + END SELECT + END + +C The relevant change to cure this is: +C +C Thu Dec 4 06:34:40 1997 Richard Kenner +C +C * stmt.c (pushcase_range): Clean up handling of "infinite" values. +C + Index: Fortran/gfortran/regression/g77/980310-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-2.f @@ -0,0 +1,44 @@ +c { dg-do compile } +C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl +C +C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT) +C From: David Bristow +C To: egcs-bugs@cygnus.com +C Subject: g77 crashes compiling Dungeon +C Message-ID: +C +C The following small segment of Dungeon (the adventure that became the +C commercial hit Zork) causes an internal error in f771. The platform is +C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran +C 0.5.21-19970811) +C +C --cut here--cut here--cut here--cut here--cut here--cut here-- +C g77 --verbose -fugly -fvxt -c subr_.f +C g77 version 0.5.21-19970811 +C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm +C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs +C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental) +C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s +C f771: warning: -fugly is overloaded with meanings and likely to be removed; +C f771: warning: use only the specific -fugly-* options you need +C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental). +C GNU Fortran Front End version 0.5.21-19970811 +C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))' +C gcc: Internal compiler error: program f771 got fatal signal 6 +C --cut here--cut here--cut here--cut here--cut here--cut here-- +C +C Here's the FORTRAN code, it's basically a single subroutine from subr.f +C in the Dungeon source, slightly altered (the original calls RAN(), which +C doesn't exist in the g77 runtime) +C +C RND - Return a random integer mod n +C + INTEGER FUNCTION RND (N) + IMPLICIT INTEGER (A-Z) + REAL RAND + COMMON /SEED/ RNSEED + + RND = RAND(RNSEED)*FLOAT(N) + RETURN + + END Index: Fortran/gfortran/regression/g77/980310-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-3.f @@ -0,0 +1,261 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +c This demonstrates a problem with g77 and pic on x86 where +c egcs 1.0.1 and earlier will generate bogus assembler output. +c unfortunately, gas accepts the bogus acssembler output and +c generates code that almost works. +c + + +C Date: Wed, 17 Dec 1997 23:20:29 +0000 +C From: Joao Cardoso +C To: egcs-bugs@cygnus.com +C Subject: egcs-1.0 f77 bug on OSR5 +C When trying to compile the Fortran file that I enclose bellow, +C I got an assembler error: +C +C ./g77 -B./ -fpic -O -c scaleg.f +C /usr/tmp/cca002D8.s:123:syntax error at ( +C +C ./g77 -B./ -fpic -O0 -c scaleg.f +C /usr/tmp/cca002EW.s:246:invalid operand combination: leal +C +C Compiling without the -fpic flag runs OK. + + subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk) +c +c *****parameters: + integer igh,low,ma,mb,n + double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6) +c +c *****local variables: + integer i,ir,it,j,jc,kount,nr,nrp2 + double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor, + * ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc +c +c *****fortran functions: + double precision dabs, dlog10, dsign +c float +c +c *****subroutines called: +c none +c +c --------------------------------------------------------------- +c +c *****purpose: +c scales the matrices a and b in the generalized eigenvalue +c problem a*x = (lambda)*b*x such that the magnitudes of the +c elements of the submatrices of a and b (as specified by low +c and igh) are close to unity in the least squares sense. +c ref.: ward, r. c., balancing the generalized eigenvalue +c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981, +c 141-152. +c +c *****parameter description: +c +c on input: +c +c ma,mb integer +c row dimensions of the arrays containing matrices +c a and b respectively, as declared in the main calling +c program dimension statement; +c +c n integer +c order of the matrices a and b; +c +c a real(ma,n) +c contains the a matrix of the generalized eigenproblem +c defined above; +c +c b real(mb,n) +c contains the b matrix of the generalized eigenproblem +c defined above; +c +c low integer +c specifies the beginning -1 for the rows and +c columns of a and b to be scaled; +c +c igh integer +c specifies the ending -1 for the rows and columns +c of a and b to be scaled; +c +c cperm real(n) +c work array. only locations low through igh are +c referenced and altered by this subroutine; +c +c wk real(n,6) +c work array that must contain at least 6*n locations. +c only locations low through igh, n+low through n+igh, +c ..., 5*n+low through 5*n+igh are referenced and +c altered by this subroutine. +c +c on output: +c +c a,b contain the scaled a and b matrices; +c +c cscale real(n) +c contains in its low through igh locations the integer +c exponents of 2 used for the column scaling factors. +c the other locations are not referenced; +c +c wk contains in its low through igh locations the integer +c exponents of 2 used for the row scaling factors. +c +c *****algorithm notes: +c none. +c +c *****history: +c written by r. c. ward....... +c modified 8/86 by bobby bodenheimer so that if +c sum = 0 (corresponding to the case where the matrix +c doesn't need to be scaled) the routine returns. +c +c --------------------------------------------------------------- +c + if (low .eq. igh) go to 410 + do 210 i = low,igh + wk(i,1) = 0.0d0 + wk(i,2) = 0.0d0 + wk(i,3) = 0.0d0 + wk(i,4) = 0.0d0 + wk(i,5) = 0.0d0 + wk(i,6) = 0.0d0 + cscale(i) = 0.0d0 + cperm(i) = 0.0d0 + 210 continue +c +c compute right side vector in resulting linear equations +c + basl = dlog10(2.0d0) + do 240 i = low,igh + do 240 j = low,igh + tb = b(i,j) + ta = a(i,j) + if (ta .eq. 0.0d0) go to 220 + ta = dlog10(dabs(ta)) / basl + 220 continue + if (tb .eq. 0.0d0) go to 230 + tb = dlog10(dabs(tb)) / basl + 230 continue + wk(i,5) = wk(i,5) - ta - tb + wk(j,6) = wk(j,6) - ta - tb + 240 continue + nr = igh-low+1 + coef = 1.0d0/float(2*nr) + coef2 = coef*coef + coef5 = 0.5d0*coef2 + nrp2 = nr+2 + beta = 0.0d0 + it = 1 +c +c start generalized conjugate gradient iteration +c + 250 continue + ew = 0.0d0 + ewc = 0.0d0 + gamma = 0.0d0 + do 260 i = low,igh + gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6) + ew = ew + wk(i,5) + ewc = ewc + wk(i,6) + 260 continue + gamma = coef*gamma - coef2*(ew**2 + ewc**2) + + - coef5*(ew - ewc)**2 + if (it .ne. 1) beta = gamma / pgamma + t = coef5*(ewc - 3.0d0*ew) + tc = coef5*(ew - 3.0d0*ewc) + do 270 i = low,igh + wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t + cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc + 270 continue +c +c apply matrix to vector +c + do 300 i = low,igh + kount = 0 + sum = 0.0d0 + do 290 j = low,igh + if (a(i,j) .eq. 0.0d0) go to 280 + kount = kount+1 + sum = sum + cperm(j) + 280 continue + if (b(i,j) .eq. 0.0d0) go to 290 + kount = kount+1 + sum = sum + cperm(j) + 290 continue + wk(i,3) = float(kount)*wk(i,2) + sum + 300 continue + do 330 j = low,igh + kount = 0 + sum = 0.0d0 + do 320 i = low,igh + if (a(i,j) .eq. 0.0d0) go to 310 + kount = kount+1 + sum = sum + wk(i,2) + 310 continue + if (b(i,j) .eq. 0.0d0) go to 320 + kount = kount+1 + sum = sum + wk(i,2) + 320 continue + wk(j,4) = float(kount)*cperm(j) + sum + 330 continue + sum = 0.0d0 + do 340 i = low,igh + sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4) + 340 continue + if(sum.eq.0.0d0) return + alpha = gamma / sum +c +c determine correction to current iterate +c + cmax = 0.0d0 + do 350 i = low,igh + cor = alpha * wk(i,2) + if (dabs(cor) .gt. cmax) cmax = dabs(cor) + wk(i,1) = wk(i,1) + cor + cor = alpha * cperm(i) + if (dabs(cor) .gt. cmax) cmax = dabs(cor) + cscale(i) = cscale(i) + cor + 350 continue + if (cmax .lt. 0.5d0) go to 370 + do 360 i = low,igh + wk(i,5) = wk(i,5) - alpha*wk(i,3) + wk(i,6) = wk(i,6) - alpha*wk(i,4) + 360 continue + pgamma = gamma + it = it+1 + if (it .le. nrp2) go to 250 +c +c end generalized conjugate gradient iteration +c + 370 continue + do 380 i = low,igh + ir = wk(i,1) + dsign(0.5d0,wk(i,1)) + wk(i,1) = ir + jc = cscale(i) + dsign(0.5d0,cscale(i)) + cscale(i) = jc + 380 continue +c +c scale a and b +c + do 400 i = 1,igh + ir = wk(i,1) + fi = 2.0d0**ir + if (i .lt. low) fi = 1.0d0 + do 400 j =low,n + jc = cscale(j) + fj = 2.0d0**jc + if (j .le. igh) go to 390 + if (i .lt. low) go to 400 + fj = 1.0d0 + 390 continue + a(i,j) = a(i,j)*fi*fj + b(i,j) = b(i,j)*fi*fj + 400 continue + 410 continue + return +c +c last line of scaleg +c + end Index: Fortran/gfortran/regression/g77/980310-4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-4.f @@ -0,0 +1,348 @@ +c { dg-do compile } +C To: egcs-bugs@cygnus.com +C Subject: -fPIC problem showing up with fortran on x86 +C From: Dave Love +C Date: 19 Dec 1997 19:31:41 +0000 +C +C +C This illustrates a long-standing problem noted at the end of the g77 +C `Actual Bugs' info node and thought to be in the back end. Although +C the report is against gcc 2.7 I can reproduce it (specifically on +C redhat 4.2) with the 971216 egcs snapshot. +C +C g77 version 0.5.21 +C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone +C -lf2c -lm +C + +C ------------ + subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr, + * neval,ier,alist,blist,rlist,elist,iord,last) +C -------------------------------------------------- +C +C Modified Feb 1989 by Barry W. Brown to eliminate key +C as argument (use key=1) and to eliminate all Fortran +C output. +C +C Purpose: to make this routine usable from within S. +C +C -------------------------------------------------- +c***begin prologue dqage +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c integrand examinator, globally adaptive, +c gauss-kronrod +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-reslt).le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c key - integer +c key for choice of local integration rule +c a gauss-kronrod pair is used with +c 7 - 15 points if key.lt.2, +c 10 - 21 points if key = 2, +c 15 - 31 points if key = 3, +c 20 - 41 points if key = 4, +c 25 - 51 points if key = 5, +c 30 - 61 points if key.gt.5. +c +c limit - integer +c gives an upperbound on the number of subintervals +c in the partition of (a,b), limit.ge.1. +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for result and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value +c of limit. +c however, if this yields no improvement it +c is rather advised to analyze the integrand +c in order to determine the integration +c difficulties. if the position of a local +c difficulty can be determined(e.g. +c singularity, discontinuity within the +c interval) one will probably gain from +c splitting up the interval at this point +c and calling the integrator on the +c subranges. if possible, an appropriate +c special-purpose integrator should be used +c which is designed for handling the type of +c difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c = 3 extremely bad integrand behavior occurs +c at some points of the integration +c interval. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c result, abserr, neval, last, rlist(1) , +c elist(1) and iord(1) are set to zero. +c alist(1) and blist(1) are set to a and b +c respectively. +c +c alist - double precision +c vector of dimension at least limit, the first +c last elements of which are the left +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c blist - double precision +c vector of dimension at least limit, the first +c last elements of which are the right +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c rlist - double precision +c vector of dimension at least limit, the first +c last elements of which are the +c integral approximations on the subintervals +c +c elist - double precision +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension at least limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., +c elist(iord(k)) form a decreasing sequence, +c with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c last - integer +c number of subintervals actually produced in the +c subdivision process +c +c***references (none) +c***routines called d1mach,dqk15,dqk21,dqk31, +c dqk41,dqk51,dqk61,dqpsrt +c***end prologue dqage +c + double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b, + * blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach, + * epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, + * resabs,result,rlist,uflow + integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval, + * nrmax +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * rlist(limit) +c + external f +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest +c error estimate +c errmax - elist(maxerr) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqage + epmach = d1mach(4) + uflow = d1mach(1) +c +c test on validity of parameters +c ------------------------------ +c + ier = 0 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0d+00 + elist(1) = 0.0d+00 + iord(1) = 0 + if(epsabs.le.0.0d+00.and. + * epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6 + if(ier.eq.6) go to 999 +c +c first approximation to the integral +c ----------------------------------- +c + neval = 0 + call dqk15(f,a,b,result,abserr,defabs,resabs) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 +c +c test on accuracy. +c + errbnd = dmax1(epsabs,epsrel*dabs(result)) + if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs) + * .or.abserr.eq.0.0d+00) go to 60 +c +c initialization +c -------------- +c +c + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 +c +c main do-loop +c ------------ +c + do 30 last = 2,limit +c +c bisect the subinterval with the largest error estimate. +c + a1 = alist(maxerr) + b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + call dqk15(f,a1,b1,area1,error1,resabs,defab1) + call dqk15(f,a2,b2,area2,error2,resabs,defab2) +c +c improve previous approximations to integral +c and error and test for accuracy. +c + neval = neval+1 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 5 + if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) + * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 + 5 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = dmax1(epsabs,epsrel*dabs(area)) + if(errsum.le.errbnd) go to 8 +c +c test for roundoff error and eventually set error flag. +c + if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 +c +c set error flag in the case that the number of subintervals +c equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behavior +c at a point of the integration range. +c + if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03* + * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3 +c +c append the newly-created intervals to the list. +c + 8 if(error2.gt.error1) go to 10 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 20 + 10 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine dqpsrt to maintain the descending ordering +c in the list of error estimates and select the subinterval +c with the largest error estimate (to be bisected next). +c + 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax) +c ***jump out of do-loop + if(ier.ne.0.or.errsum.le.errbnd) go to 40 + 30 continue +c +c compute final result. +c --------------------- +c + 40 result = 0.0d+00 + do 50 k=1,last + result = result+rlist(k) + 50 continue + abserr = errsum + 60 neval = 30*neval+15 + 999 return + end Index: Fortran/gfortran/regression/g77/980310-6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-6.f @@ -0,0 +1,22 @@ +c { dg-do compile } +C From: Norbert Conrad +C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de> +C Subject: 971105 g77 bug +C To: egcs-bugs@cygnus.com +C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET) + +C I found a bug in g77 in snapshot 971105 + + subroutine ai (a) + dimension a(-1:*) + return + end +C ai.f: In subroutine `ai': +C ai.f:1: +C subroutine ai (a) +C ^ +C Array `a' at (^) is too large to handle +C +C This happens whenever the lower index boundary is negative and the upper index +C boundary is '*'. + Index: Fortran/gfortran/regression/g77/980310-7.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-7.f @@ -0,0 +1,51 @@ +c { dg-do compile } +C From: "David C. Doherty" +C Message-Id: <199711171846.MAA27947@uh.msc.edu> +C Subject: g77: auto arrays + goto = no go +C To: egcs-bugs@cygnus.com +C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST) + +C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love +C replied that he was able to reproduce it on rs6000-aix; not on +C others. He suggested that I send it to egcs-bugs. + +C Hi - I've observed the following behavior regarding +C automatic arrays and gotos. Seems similar to what I found +C in the docs about computed gotos (but not exactly the same). +C +C I suspect from the nature of the error msg that it's in the GBE. +C +C I'm using egcs-971105, under linux-ppc. +C +C I also observed the same in g77-0.5.19 (and gcc 2.7.2?). +C +C I'd appreciate any advice on this. thanks for the great work. +C -- +C >cat testg77.f + subroutine testg77(n, a) +c + implicit none +c + integer n + real a(n) + real b(n) + integer i +c + do i = 1, 10 + if (i .gt. 4) goto 100 + write(0, '(i2)')i + enddo +c + goto 200 +100 continue +200 continue +c + return + end +C >g77 -c testg77.f +C testg77.f: In subroutine `testg77': +C testg77.f:19: label `200' used before containing binding contour +C testg77.f:18: label `100' used before containing binding contour +C -- +C If I comment out the b(n) line or replace it with, e.g., b(10), +C it compiles fine. Index: Fortran/gfortran/regression/g77/980310-8.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980310-8.f @@ -0,0 +1,41 @@ +c { dg-do compile } +C To: egcs-bugs@cygnus.com +C Subject: egcs-g77 and array indexing +C Reply-To: etseidl@jutland.ca.sandia.gov +C Date: Wed, 26 Nov 1997 10:38:27 -0800 +C From: Edward Seidl +C +C I have some horrible spaghetti code I'm trying compile with egcs-g77, +C but it's puking on code like the example below. I have no idea if it's +C legal fortran or not, and I'm in no position to change it. All I do know +C is it compiles with a number of other compilers, including f2c and +C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122 +C I get the following (on both i686-pc-linux-gnu and +C alphaev56-unknown-linux-gnu): +C +Cfoo.f: In subroutine `foobar': +Cfoo.f:11: +C subroutine foobar(norb,nnorb) +C ^ +CArray `norb' at (^) is too large to handle + + program foo + implicit integer(A-Z) + dimension norb(6) + nnorb=6 + + call foobar(norb,nnorb) + + stop + end + + subroutine foobar(norb,nnorb) + implicit integer(A-Z) + dimension norb(-1:*) + + do 10 i=-1,nnorb-2 + norb(i) = i+999 + 10 continue + + return + end Index: Fortran/gfortran/regression/g77/980419-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980419-2.f @@ -0,0 +1,51 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +c SEGVs in loop.c with -O2. + + character*80 function nxtlin(lun,ierr,itok) + character onechr*1,twochr*2,thrchr*3 + itok=0 + do while (.true.) + read (lun,'(a)',iostat=ierr) nxtlin + if (nxtlin(1:1).ne.'#') then + ito=0 + do 10 it=1,79 + if (nxtlin(it:it).ne.' ' .and. nxtlin(it+1:it+1).eq.' ') + $ then + itast=0 + itstrt=0 + do itt=ito+1,it + if (nxtlin(itt:itt).eq.'*') itast=itt + enddo + itstrt=ito+1 + do while (nxtlin(itstrt:itstrt).eq.' ') + itstrt=itstrt+1 + enddo + if (itast.gt.0) then + nchrs=itast-itstrt + if (nchrs.eq.1) then + onechr=nxtlin(itstrt:itstrt) + read (onechr,*) itokn + elseif (nchrs.eq.2) then + twochr=nxtlin(itstrt:itstrt+1) + read (twochr,*) itokn + elseif (nchrs.eq.3) then + thrchr=nxtlin(itstrt:itstrt+2) + read (thrchr,*) itokn + elseif (nchrs.eq.4) then + thrchr=nxtlin(itstrt:itstrt+3) + read (thrchr,*) itokn + endif + itok=itok+itokn + else + itok=itok+1 + endif + ito=it+1 + endif + 10 continue + return + endif + enddo + return + end Index: Fortran/gfortran/regression/g77/980424-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980424-0.f @@ -0,0 +1,7 @@ +c { dg-do compile } +C crashes in subst_stack_regs_pat on x86-linux, in the "abort();" +C within the switch statement. + SUBROUTINE C(A) + COMPLEX A + WRITE(*,*) A.NE.CMPLX(0.0D0) + END Index: Fortran/gfortran/regression/g77/980427-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980427-0.f @@ -0,0 +1,9 @@ +c { dg-do compile } +c ../../egcs/gcc/f/com.c:938: failed assertion `TREE_CODE (TREE_TYPE (e)) == REAL_TYPE' +c Fixed by 28-04-1998 global.c (ffeglobal_ref_progunit_) change. + external b + call y(b) + end + subroutine x + a = b() + end Index: Fortran/gfortran/regression/g77/980519-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980519-2.f @@ -0,0 +1,51 @@ +c { dg-do compile } +* Date: Fri, 17 Apr 1998 14:12:51 +0200 +* From: Jean-Paul Jeannot +* Organization: GX Technology France +* To: egcs-bugs@cygnus.com +* Subject: identified bug in g77 on Alpha +* +* Dear Sir, +* +* You will find below the assembly code of a simple Fortran routine which +* crashes with segmentation fault when storing the first element +* in( jT_f-hd_T ) = Xsp +* whereas everything is fine when commenting this line. +* +* The assembly code (generated with +* -ffast-math -fexpensive-optimizations -fomit-frame-pointer -fno-inline +* or with -O5) +* uses a zapnot instruction to copy an address. +* BUT the zapnot parameter is 15 (copuing 4 bytes) instead of 255 (to copy +* 8 bytes). +* +* I guess this is typically a 64 bit issue. As, from my understanding, +* zapnots are used a lot to copy registers, this may create problems +* elsewhere. +* +* Thanks for your help +* +* Jean-Paul Jeannot +* + subroutine simul_trace( in, Xsp, Ysp, Xrcv, Yrcv ) + +c Next declaration added on transfer to gfortran testsuite + integer hd_S, hd_Z, hd_T + + common /Idim/ jT_f, jT_l, nT, nT_dim + common /Idim/ jZ_f, jZ_l, nZ, nZ_dim + common /Idim/ jZ2_f, jZ2_l, nZ2, nZ2_dim + common /Idim/ jzs_f, jzs_l, nzs, nzs_dim, l_amp + common /Idim/ hd_S, hd_Z, hd_T + common /Idim/ nlay, nlayz + common /Idim/ n_work + common /Idim/ nb_calls + + real Xsp, Ysp, Xrcv, Yrcv + real in( jT_f-hd_T : jT_l ) + + in( jT_f-hd_T ) = Xsp + in( jT_f-hd_T + 1 ) = Ysp + in( jT_f-hd_T + 2 ) = Xrcv + in( jT_f-hd_T + 3 ) = Yrcv + end Index: Fortran/gfortran/regression/g77/980520-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980520-1.f @@ -0,0 +1,9 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +c Produced a link error through not eliminating the unused statement +c function after 1998-05-15 change to gcc/toplev.c. It's in +c `execute' since it needs to link. +c Fixed by 1998-05-23 change to f/com.c. + values(i,j) = val((i-1)*n+j) + end Index: Fortran/gfortran/regression/g77/980615-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980615-0.f @@ -0,0 +1,12 @@ +c { dg-do compile } +* Fixed by JCB 1998-07-25 change to stc.c. + +* Date: Thu, 11 Jun 1998 22:35:20 -0500 +* From: Ian A Watson +* Subject: crash +* + CaLL foo(W) + END + SUBROUTINE foo(W) + yy(I)=A(I)Q(X) ! { dg-error "Unclassifiable statement" } +c { dg-error "end of file" "end of file" { target *-*-* } 0 } Index: Fortran/gfortran/regression/g77/980616-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980616-0.f @@ -0,0 +1,10 @@ +c { dg-do compile } +* Fixed by 1998-07-11 equiv.c change. +* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER' + +* Date: Mon, 15 Jun 1998 21:54:32 -0500 +* From: Ian A Watson +* Subject: Mangler Crash + EQUIVALENCE(I,glerf(P)) ! { dg-error "is a variable" "is a variable" } + COMMON /foo/ glerf(3) +c { dg-error "end of file" "end of file" { target *-*-* } 0 } Index: Fortran/gfortran/regression/g77/980628-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-0.f @@ -0,0 +1,62 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (r1(2), d1) + equivalence (r2(2), d2) + equivalence (r3(2), d3) + + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + + end + + subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (r1(1) .ne. 1.) STOP 1 + if (d1 .ne. 10.) STOP 2 + if (r1(4) .ne. 1.) STOP 3 + if (r1(5) .ne. 1.) STOP 4 + if (i1 .ne. 1) STOP 5 + if (r2(1) .ne. 2.) STOP 6 + if (d2 .ne. 20.) STOP 7 + if (r2(4) .ne. 2.) STOP 8 + if (r2(5) .ne. 2.) STOP 9 + if (i2 .ne. 2) STOP 10 + if (r3(1) .ne. 3.) STOP 11 + if (d3 .ne. 30.) STOP 12 + if (r3(4) .ne. 3.) STOP 13 + if (r3(5) .ne. 3.) STOP 14 + if (i3 .ne. 3) STOP 15 + + end Index: Fortran/gfortran/regression/g77/980628-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-1.f @@ -0,0 +1,63 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + save + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (r1(2), d1) + equivalence (r2(2), d2) + equivalence (r3(2), d3) + + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + + end + + subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (r1(1) .ne. 1.) STOP 1 + if (d1 .ne. 10.) STOP 2 + if (r1(4) .ne. 1.) STOP 3 + if (r1(5) .ne. 1.) STOP 4 + if (i1 .ne. 1) STOP 5 + if (r2(1) .ne. 2.) STOP 6 + if (d2 .ne. 20.) STOP 7 + if (r2(4) .ne. 2.) STOP 8 + if (r2(5) .ne. 2.) STOP 9 + if (i2 .ne. 2) STOP 10 + if (r3(1) .ne. 3.) STOP 11 + if (d3 .ne. 30.) STOP 12 + if (r3(4) .ne. 3.) STOP 13 + if (r3(5) .ne. 3.) STOP 14 + if (i3 .ne. 3) STOP 15 + + end Index: Fortran/gfortran/regression/g77/980628-10.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-10.f @@ -0,0 +1,59 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + save + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + equivalence (r1, c1(2)) + equivalence (r2, c2(2)) + equivalence (r3, c3(2)) + + c1(1) = '1' + r1 = 1. + c1(11) = '1' + c4 = '4' + c2(1) = '2' + r2 = 2. + c2(11) = '2' + c5 = '5' + c3(1) = '3' + r3 = 3. + c3(11) = '3' + c6 = '6' + + call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + + end + + subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + + if (c1(1) .ne. '1') STOP 1 + if (r1 .ne. 1.) STOP 2 + if (c1(11) .ne. '1') STOP 3 + if (c4 .ne. '4') STOP 4 + if (c2(1) .ne. '2') STOP 5 + if (r2 .ne. 2.) STOP 6 + if (c2(11) .ne. '2') STOP 7 + if (c5 .ne. '5') STOP 8 + if (c3(1) .ne. '3') STOP 9 + if (r3 .ne. 3.) STOP 10 + if (c3(11) .ne. '3') STOP 11 + if (c6 .ne. '6') STOP 12 + + end + Index: Fortran/gfortran/regression/g77/980628-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-2.f @@ -0,0 +1,57 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + equivalence (c1(2), r1) + equivalence (c2(2), r2) + equivalence (c3(2), r3) + + c1(1) = '1' + r1 = 1. + c1(11) = '1' + c4 = '4' + c2(1) = '2' + r2 = 2. + c2(11) = '2' + c5 = '5' + c3(1) = '3' + r3 = 3. + c3(11) = '3' + c6 = '6' + + call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + + end + + subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + + if (c1(1) .ne. '1') STOP 1 + if (r1 .ne. 1.) STOP 2 + if (c1(11) .ne. '1') STOP 3 + if (c4 .ne. '4') STOP 4 + if (c2(1) .ne. '2') STOP 5 + if (r2 .ne. 2.) STOP 6 + if (c2(11) .ne. '2') STOP 7 + if (c5 .ne. '5') STOP 8 + if (c3(1) .ne. '3') STOP 9 + if (r3 .ne. 3.) STOP 10 + if (c3(11) .ne. '3') STOP 11 + if (c6 .ne. '6') STOP 12 + + end Index: Fortran/gfortran/regression/g77/980628-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-3.f @@ -0,0 +1,59 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +c +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + save + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + equivalence (c1(2), r1) + equivalence (c2(2), r2) + equivalence (c3(2), r3) + + c1(1) = '1' + r1 = 1. + c1(11) = '1' + c4 = '4' + c2(1) = '2' + r2 = 2. + c2(11) = '2' + c5 = '5' + c3(1) = '3' + r3 = 3. + c3(11) = '3' + c6 = '6' + + call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + + end + + subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + + if (c1(1) .ne. '1') STOP 1 + if (r1 .ne. 1.) STOP 2 + if (c1(11) .ne. '1') STOP 3 + if (c4 .ne. '4') STOP 4 + if (c2(1) .ne. '2') STOP 5 + if (r2 .ne. 2.) STOP 6 + if (c2(11) .ne. '2') STOP 7 + if (c5 .ne. '5') STOP 8 + if (c3(1) .ne. '3') STOP 9 + if (r3 .ne. 3.) STOP 10 + if (c3(11) .ne. '3') STOP 11 + if (c6 .ne. '6') STOP 12 + + end Index: Fortran/gfortran/regression/g77/980628-7.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-7.f @@ -0,0 +1,63 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (d1, r1(2)) + equivalence (d2, r2(2)) + equivalence (d3, r3(2)) + + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + + end + + subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (r1(1) .ne. 1.) STOP 1 + if (d1 .ne. 10.) STOP 2 + if (r1(4) .ne. 1.) STOP 3 + if (r1(5) .ne. 1.) STOP 4 + if (i1 .ne. 1) STOP 5 + if (r2(1) .ne. 2.) STOP 6 + if (d2 .ne. 20.) STOP 7 + if (r2(4) .ne. 2.) STOP 8 + if (r2(5) .ne. 2.) STOP 9 + if (i2 .ne. 2) STOP 10 + if (r3(1) .ne. 3.) STOP 11 + if (d3 .ne. 30.) STOP 12 + if (r3(4) .ne. 3.) STOP 13 + if (r3(5) .ne. 3.) STOP 14 + if (i3 .ne. 3) STOP 15 + + end + Index: Fortran/gfortran/regression/g77/980628-8.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-8.f @@ -0,0 +1,64 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + save + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (d1, r1(2)) + equivalence (d2, r2(2)) + equivalence (d3, r3(2)) + + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + + end + + subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (r1(1) .ne. 1.) STOP 1 + if (d1 .ne. 10.) STOP 2 + if (r1(4) .ne. 1.) STOP 3 + if (r1(5) .ne. 1.) STOP 4 + if (i1 .ne. 1) STOP 5 + if (r2(1) .ne. 2.) STOP 6 + if (d2 .ne. 20.) STOP 7 + if (r2(4) .ne. 2.) STOP 8 + if (r2(5) .ne. 2.) STOP 9 + if (i2 .ne. 2) STOP 10 + if (r3(1) .ne. 3.) STOP 11 + if (d3 .ne. 30.) STOP 12 + if (r3(4) .ne. 3.) STOP 13 + if (r3(5) .ne. 3.) STOP 14 + if (i3 .ne. 3) STOP 15 + + end + Index: Fortran/gfortran/regression/g77/980628-9.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980628-9.f @@ -0,0 +1,58 @@ +c { dg-do run } +c { dg-options "-std=gnu" } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + equivalence (r1, c1(2)) + equivalence (r2, c2(2)) + equivalence (r3, c3(2)) + + c1(1) = '1' + r1 = 1. + c1(11) = '1' + c4 = '4' + c2(1) = '2' + r2 = 2. + c2(11) = '2' + c5 = '5' + c3(1) = '3' + r3 = 3. + c3(11) = '3' + c6 = '6' + + call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + + end + + subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) + implicit none + + character c1(11), c2(11), c3(11) + real r1, r2, r3 + character c4, c5, c6 + + if (c1(1) .ne. '1') STOP 1 + if (r1 .ne. 1.) STOP 2 + if (c1(11) .ne. '1') STOP 3 + if (c4 .ne. '4') STOP 4 + if (c2(1) .ne. '2') STOP 5 + if (r2 .ne. 2.) STOP 6 + if (c2(11) .ne. '2') STOP 7 + if (c5 .ne. '5') STOP 8 + if (c3(1) .ne. '3') STOP 9 + if (r3 .ne. 3.) STOP 10 + if (c3(11) .ne. '3') STOP 11 + if (c6 .ne. '6') STOP 12 + + end + Index: Fortran/gfortran/regression/g77/980701-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980701-0.f @@ -0,0 +1,73 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (r1, s1(2)) + equivalence (d1, r1(2)) + equivalence (r2, s2(2)) + equivalence (d2, r2(2)) + equivalence (r3, s3(2)) + equivalence (d3, r3(2)) + + s1(1) = 1. + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + s2(1) = 2. + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + s3(1) = 3. + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + + end + + subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (s1(1) .ne. 1.) STOP 1 + if (r1(1) .ne. 1.) STOP 2 + if (d1 .ne. 10.) STOP 3 + if (r1(4) .ne. 1.) STOP 4 + if (r1(5) .ne. 1.) STOP 5 + if (i1 .ne. 1) STOP 6 + if (s2(1) .ne. 2.) STOP 7 + if (r2(1) .ne. 2.) STOP 8 + if (d2 .ne. 20.) STOP 9 + if (r2(4) .ne. 2.) STOP 10 + if (r2(5) .ne. 2.) STOP 11 + if (i2 .ne. 2) STOP 12 + if (s3(1) .ne. 3.) STOP 13 + if (r3(1) .ne. 3.) STOP 14 + if (d3 .ne. 30.) STOP 15 + if (r3(4) .ne. 3.) STOP 16 + if (r3(5) .ne. 3.) STOP 17 + if (i3 .ne. 3) STOP 18 + + end Index: Fortran/gfortran/regression/g77/980701-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980701-1.f @@ -0,0 +1,73 @@ +c { dg-do run } +* g77 0.5.23 and previous had bugs involving too little space +* allocated for EQUIVALENCE and COMMON areas needing initial +* padding to meet alignment requirements of the system. + + call subr + end + + subroutine subr + implicit none + + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + integer i1, i2, i3 + equivalence (d1, r1(2)) + equivalence (r1, s1(2)) + equivalence (d2, r2(2)) + equivalence (r2, s2(2)) + equivalence (d3, r3(2)) + equivalence (r3, s3(2)) + + s1(1) = 1. + r1(1) = 1. + d1 = 10. + r1(4) = 1. + r1(5) = 1. + i1 = 1 + s2(1) = 2. + r2(1) = 2. + d2 = 20. + r2(4) = 2. + r2(5) = 2. + i2 = 2 + s3(1) = 3. + r3(1) = 3. + d3 = 30. + r3(4) = 3. + r3(5) = 3. + i3 = 3 + + call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + + end + + subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3) + implicit none + + real r1(5), r2(5), r3(5) + real s1(2), s2(2), s3(2) + double precision d1, d2, d3 + integer i1, i2, i3 + + if (s1(1) .ne. 1.) STOP 1 + if (r1(1) .ne. 1.) STOP 2 + if (d1 .ne. 10.) STOP 3 + if (r1(4) .ne. 1.) STOP 4 + if (r1(5) .ne. 1.) STOP 5 + if (i1 .ne. 1) STOP 6 + if (s2(1) .ne. 2.) STOP 7 + if (r2(1) .ne. 2.) STOP 8 + if (d2 .ne. 20.) STOP 9 + if (r2(4) .ne. 2.) STOP 10 + if (r2(5) .ne. 2.) STOP 11 + if (i2 .ne. 2) STOP 12 + if (s3(1) .ne. 3.) STOP 13 + if (r3(1) .ne. 3.) STOP 14 + if (d3 .ne. 30.) STOP 15 + if (r3(4) .ne. 3.) STOP 16 + if (r3(5) .ne. 3.) STOP 17 + if (i3 .ne. 3) STOP 18 + + end Index: Fortran/gfortran/regression/g77/980729-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/980729-0.f @@ -0,0 +1,6 @@ +c { dg-do compile } +c Got ICE on Alpha only with -mieee (currently not tested). +c Fixed by rth 1998-07-30 alpha.md change. + subroutine a(b,c) + b = max(b,c) + end Index: Fortran/gfortran/regression/g77/981117-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/981117-1.f @@ -0,0 +1,24 @@ +c { dg-do compile } +* egcs-bugs: +* From: Martin Kahlert +* Subject: ICE in g77 from egcs-19981109 +* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de> + +* As of 1998-11-17, fails -O2 -fomit-frame-pointer with +* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints: +* (insn 31 83 32 (set (reg:SF 8 %st(0)) +* (mult:SF (reg:SF 8 %st(0)) +* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil) +* (nil)) +* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn + +* Fixed sometime before 1998-11-21 -- don't know by which change. + + SUBROUTINE SSPTRD + PARAMETER (HALF = 0.5 ) + DO I = 1, N + CALL SSPMV(TAUI) + ALPHA = -HALF*TAUI + CALL SAXPY(ALPHA) + ENDDO + END Index: Fortran/gfortran/regression/g77/990115-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/990115-1.f @@ -0,0 +1,12 @@ +c { dg-do compile } +C Derived from lapack + SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, RWORK, INFO ) + COMPLEX(kind=8) WORK( * ) +c Following declaration added on transfer to gfortran testsuite. +c It is present in original lapack source + integer rank + DO 20 I = 1, RANK + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + END Index: Fortran/gfortran/regression/g77/README =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/README @@ -0,0 +1,208 @@ +The g77 testsuite is being transferred to the gfortran testsuite. +This file documents the status of each test case. + + Y Test has been transferred. + Y XFAIL This test has been transferred but fails + N This feature will not be supported by gfortran. + F This test fails with gfortran. Not transferred (yet). + ? We looked at this case, but haven't decided. + +Directory g77.dg + +12632.f Y +20010216-1.f Y +7388.f Y +f77-edit-apostrophe-out.f Y +f77-edit-colon-out.f Y +f77-edit-h-out.f Y +f77-edit-i-in.f Y +f77-edit-i-out.f Y +f77-edit-s-out.f Y XFAIL PR 16434 +f77-edit-slash-out.f Y +f77-edit-t-in.f Y XFAIL PR 16436 +f77-edit-t-out.f Y +f77-edit-x-out.f Y XFAIL PR 16435 +fbackslash.f ? +fcase-preserve.f ? +ff90-1.f ? +ffixed-form-1.f Y +ffixed-form-2.f Y +ffixed-line-length-0.f Y +ffixed-line-length-132.f Y +ffixed-line-length-7.f F PR 16465 +ffixed-line-length-72.f Y +ffixed-line-length-none.f Y +ffree-form-1.f Y +ffree-form-2.f Y +ffree-form-3.f Y +fno-backslash.f ? +fno-f90-1.f ? +fno-fixed-form-1.f ? +fno-onetrip.f ? +fno-typeless-boz.f ? +fno-underscoring.f Y +fno-vxt-1.f ? +fonetrip.f ? +ftypeless-boz.f ? +fugly-assumed.f ? +funderscoring.f Y +fvxt-1.f ? +pr3743-1.f ? +pr3743-2.f ? +pr3743-3.f ? +pr3743-4.f ? +pr5473.f ? +pr9258.f Y +strlen0.f Y + + +Directory g77.dg/bprob +g77-bprob-1.f + + +Directory g77.dg/gcov +gcov-1.f + +Directory g77.f-torture/compile +12002.f Y +13060.f Y +19990218-0.f Y +19990305-0.f Y +19990419-0.f Y +19990502-0.f Y +19990502-1.f Y +19990525-0.f Y +19990826-1.f Y +19990826-3.f Y +19990905-0.f Y XFAIL PR 16511 +19990905-2.f Y +20000412-1.f Y +20000511-1.f Y +20000511-2.f Y +20000518.f Y +20000601-1.f Y +20000601-2.f Y +20000629-1.f Y +20000630-2.f Y +20010115.f Y +20010321-1.f Y +20010426.f Y +20010519-1.f Y Add dg-warnings for ASSIGN +20020307-1.f Y +20030115-1.f Y Add dg-warnings for ASSIGN +20030326-1.f Y +8485.f Y +960317-1.f Y +970125-0.f Y Add dg-excess-errors. Investigate.later. +970915-0.f Y +980310-1.f Y +980310-2.f Y +980310-3.f Y +980310-4.f Y +980310-6.f Y +980310-7.f Y +980310-8.f Y +980419-2.f Y +980424-0.f Y +980427-0.f Y +980519-2.f Y Modify slightly +980729-0.f Y +981117-1.f Y +990115-1.f Y Declare variable RANK +alpha1.f Y Work around PR 16508 and PR 16509 +toon_1.f Y +xformat.f Y Add dg-warning for extension +cpp.F Y +cpp2.F Y + +g77.f-torture/execute +10197.f & 10197.x +13037.f Y +1832.f Y +19981119-0.f Y +19990313-0.f Y +19990313-1.f Y +19990313-2.f Y +19990313-3.f Y +19990325-0.f F Execution failure +19990325-1.f F Execution failure +19990419-1.f Y +19990826-0.f Y +19990826-2.f Y +20000503-1.f Y +20001111.f Y +20001201.f & 20001201.x +20010116.f Y +20010426.f renamed 20010426-1.f Y +20010430.f Y +20010610.f Y +5122.f - Assembler failure +6177.f Y +6367.f & 6367.x +947.f Y +970625-2.f Y Add dg-warnings and declare variables +970816-3.f Y +971102-1.f Y +980520-1.f Y +980628-0.f Y +980628-1.f Y +980628-10.f Y +980628-2.f Y +980628-3.f Y +980628-4.f & 980628-4.x +980628-5.f & 980628-5.x +980628-6.f & 980628-6.x +980628-7.f Y +980628-8.f Y +980628-9.f Y +980701-0.f Y +980701-1.f Y +alpha2.f & alpha2.x +auto0.f & auto0.x +auto1.f & auto1.x +cabs.f Y +claus.f Y +complex_1.f Y +cpp.F (Renamed cpp3.F) Y +cpp2.F - Compiler warnings +dcomplex.f Y +dnrm2.f Y Add dg-warning as required +erfc.f Y +exp.f Compiler warnings and fails +f90-intrinsic-bit.f F 16581 Compile errors +f90-intrinsic-mathematical.f Y +f90-intrinsic-numeric.f Y +int8421.f Y +intrinsic-f2c-z.f F Execution fail +intrinsic-unix-bessel.f Y +intrinsic-unix-erf.f Y +intrinsic-vax-cd.f F Execution fail +intrinsic77.f F PR 16580 Compiler ICE +io0.f & io0.x +io1.f & io1.x +labug1.f Y +large_vec.f Y +le.f Y +select.f Lots of compiler warnings +short.f Y +u77-test.f & u77-test.x + + +Directory g77.f-torture/noncompile +19981216-0.f Y Accepted by gfortran +19990218-1.f Y g77 issued warning. +19990826-4.f ? +19990905-1.f Y XFAIL 16520 gfortran ICE on invalid +9263.f Y +970626-2.f ? +980615-0.f Y +980616-0.f Y +check0.f Y +select_no_compile.f Y + + +Copyright (C) 2004-2023 Free Software Foundation, Inc. + +Copying and distribution of this file, with or without modification, +are permitted in any medium without royalty provided the copyright +notice and this notice are preserved. Index: Fortran/gfortran/regression/g77/alpha1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/alpha1.f @@ -0,0 +1,27 @@ +c { dg-do compile } + REAL(kind=8) A,B,C + REAL(kind=4) RARRAY(19) + DATA RARRAY /19*-1/ + INTEGER BOTTOM,RIGHT + INTEGER IARRAY(19) + DATA IARRAY /0,0,0,0,0,0,0,0,0,0,0,0,13,14,0,0,0,0,0/ + EQUIVALENCE (RARRAY(13),BOTTOM),(RARRAY(14),RIGHT) +C + IF(I.NE.0) call exit(1) +C gcc: Internal compiler error: program f771 got fatal signal 11 +C at this point! + END + +! previously g77.ftorture/compile/alpha1.f with following alpha1.x +! +!# This test fails compilation in cross-endian environments, for example as +!# below, with a "sorry" message. +! +!if { [ishost "i\[34567\]86-*-*"] } { +! if { [istarget "mmix-knuth-mmixware"] +! || [istarget "powerpc-*-*"] } { +! set torture_compile_xfail [istarget] +! } +!} +! +!return 0 Index: Fortran/gfortran/regression/g77/cabs.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cabs.f @@ -0,0 +1,15 @@ +c { dg-do run } + program cabs_1 + complex z0 + real r0 + complex(kind=8) z1 + real(kind=8) r1 + + z0 = cmplx(3.,4.) + r0 = cabs(z0) + if (r0 .ne. 5.) STOP 1 + + z1 = dcmplx(3.d0,4.d0) + r1 = zabs(z1) + if (r1 .ne. 5.d0) STOP 2 + end Index: Fortran/gfortran/regression/g77/check0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/check0.f @@ -0,0 +1,14 @@ +c { dg-do compile } +c { dg-options "-std=legacy" } +c +CCC Abort fixed by: +CCC1998-04-21 Jim Wilson +CCC +CCC * stmt.c (check_seenlabel): When search for line number note for +CCC warning, handle case where there is no such note. + logical l(10) + integer i(10) + goto (10,20),l ! { dg-error "Selection expression in computed GOTO" } + goto (10,20),i ! { dg-error "Selection expression in computed GOTO" } + 10 stop + 20 end Index: Fortran/gfortran/regression/g77/claus.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/claus.f @@ -0,0 +1,14 @@ +c { dg-do run } + PROGRAM TEST + REAL AB(3) + do i=1,3 + AB(i)=i + enddo + k=1 + n=2 + ind=k-n+2 + if (ind /= 1) STOP 1 + if (ab(ind) /= 1) STOP 2 + if (k-n+2 /= 1) STOP 3 + if (ab(k-n+2) /= 1) STOP 4 + END Index: Fortran/gfortran/regression/g77/complex_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/complex_1.f @@ -0,0 +1,19 @@ +c { dg-do run } + program complex_1 + complex z0, z1, z2 + + z0 = cmplx(0.,.5) + z1 = 1./z0 + if (z1 .ne. cmplx(0.,-2)) STOP 1 + + z0 = 10.*z0 + if (z0 .ne. cmplx(0.,5.)) STOP 2 + + z2 = cmplx(1.,2.) + z1 = z0/z2 + if (z1 .ne. cmplx(2.,1.)) STOP 3 + + z1 = z0*z2 + if (z1 .ne. cmplx(-10.,5.)) STOP 4 + end + Index: Fortran/gfortran/regression/g77/cpp.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp.F @@ -0,0 +1,10 @@ +c { dg-do compile } +C When run through the C preprocessor, the indentation of the +C CONTINUE line must not be mangled. + subroutine aap(a, n) + dimension a(n) + do 10 i = 1, n + a(i) = i + 10 continue + print *, a(1) + end Index: Fortran/gfortran/regression/g77/cpp2.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp2.F @@ -0,0 +1,8 @@ +c { dg-do compile } +C The preprocessor must not introduce a newline after +C the "a" when ARGUMENTS is expanded. + +#define ARGUMENTS a\ + + subroutine yada (ARGUMENTS) + end Index: Fortran/gfortran/regression/g77/cpp3.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp3.F @@ -0,0 +1,8 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c +! Some versions of cpp will delete "//'World' as a C++ comment. + character*40 title + title = 'Hello '//'World' + if (title .ne. 'Hello World') STOP 1 + end Index: Fortran/gfortran/regression/g77/cpp4.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp4.F @@ -0,0 +1,12 @@ +c { dg-do run } +C The preprocessor must not mangle Hollerith constants +C which contain apostrophes. + integer i + character(4) j + data i /4hbla'/ + write (j, '(4a)') i + if (j .ne. "bla'") STOP 1 + end + + ! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 } + ! { dg-warning "Conversion" "conversion" { target *-*-* } 6 } Index: Fortran/gfortran/regression/g77/cpp5.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp5.h @@ -0,0 +1,3 @@ + FUNCTION FOO() +#include "cpp5inc.h" + END FUNCTION Index: Fortran/gfortran/regression/g77/cpp5.F =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp5.F @@ -0,0 +1,4 @@ + ! { dg-do run } +#include "cpp5.h" + IF (FOO().NE.1) STOP 1 + END Index: Fortran/gfortran/regression/g77/cpp5inc.h =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp5inc.h @@ -0,0 +1 @@ + FOO = 1 Index: Fortran/gfortran/regression/g77/cpp6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/cpp6.f @@ -0,0 +1,20 @@ +# 1 "test.F" +# 1 "" +# 1 "" +# 1 "test.F" +! { dg-do compile } + +# 1 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + +# 1 "D234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 + PARAMETER (I=1) + +# 2 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 2 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 2 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 +# 3 "test.F" 2 + END Index: Fortran/gfortran/regression/g77/dcomplex.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/dcomplex.f @@ -0,0 +1,19 @@ +c { dg-do run } + program foo + complex(kind=8) z0, z1, z2 + + z0 = dcmplx(0.,.5) + z1 = 1./z0 + if (z1 .ne. dcmplx(0.,-2)) STOP 1 + + z0 = 10.*z0 + if (z0 .ne. dcmplx(0.,5.)) STOP 2 + + z2 = cmplx(1.,2.) + z1 = z0/z2 + if (z1 .ne. dcmplx(2.,1.)) STOP 3 + + z1 = z0*z2 + if (z1 .ne. dcmplx(-10.,5.)) STOP 4 + end + Index: Fortran/gfortran/regression/g77/dnrm2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/dnrm2.f @@ -0,0 +1,76 @@ +c { dg-do run } +c { dg-options "-fno-bounds-check" } +CCC g77 0.5.21 `Actual Bugs': +CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is +CCC specified compiling, for example, an old version of the `DNRM2' +CCC routine. The x87 coprocessor stack is being somewhat mismanaged +CCC in cases where assigned `GOTO' and `ASSIGN' are involved. +CCC +CCC Version 0.5.21 of `g77' contains an initial effort to fix the +CCC problem, but this effort is incomplete, and a more complete fix is +CCC planned for the next release. + +C Currently this test fails with (at least) `-O2 -funroll-loops' on +C i586-unknown-linux-gnulibc1. + +C (This is actually an obsolete version of dnrm2 -- consult the +c current Netlib BLAS.) + + integer i + double precision a(1:100), dnrm2 + do i=1,100 + a(i)=0.D0 + enddo + if (dnrm2(100,a,1) .ne. 0.0) STOP 1 + end + + double precision function dnrm2 ( n, dx, incx) + integer i, incx, ix, j, n, next + double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one + data zero, one /0.0d0, 1.0d0/ + data cutlo, cuthi / 8.232d-11, 1.304d19 / + j = 0 + if(n .gt. 0 .and. incx.gt.0) go to 10 + dnrm2 = zero + go to 300 + 10 assign 30 to next ! { dg-warning "ASSIGN" } + sum = zero + i = 1 + ix = 1 + 20 go to next,(30, 50, 70, 110) ! { dg-warning "Assigned GOTO" } + 30 if( dabs(dx(i)) .gt. cutlo) go to 85 + assign 50 to next ! { dg-warning "ASSIGN" } + xmax = zero + 50 if( dx(i) .eq. zero) go to 200 + if( dabs(dx(i)) .gt. cutlo) go to 85 + assign 70 to next ! { dg-warning "ASSIGN" } + go to 105 + 100 continue + ix = j + assign 110 to next ! { dg-warning "ASSIGN" } + sum = (sum / dx(i)) / dx(i) + 105 xmax = dabs(dx(i)) + go to 115 + 70 if( dabs(dx(i)) .gt. cutlo ) go to 75 + 110 if( dabs(dx(i)) .le. xmax ) go to 115 + sum = one + sum * (xmax / dx(i))**2 + xmax = dabs(dx(i)) + go to 200 + 115 sum = sum + (dx(i)/xmax)**2 + go to 200 + 75 sum = (sum * xmax) * xmax + 85 hitest = cuthi/float( n ) + do 95 j = ix,n + if(dabs(dx(i)) .ge. hitest) go to 100 + sum = sum + dx(i)**2 + i = i + incx + 95 continue + dnrm2 = dsqrt( sum ) + go to 300 + 200 continue + ix = ix + 1 + i = i + incx + if( ix .le. n ) go to 20 + dnrm2 = xmax * dsqrt(sum) + 300 continue + end Index: Fortran/gfortran/regression/g77/erfc.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/erfc.f @@ -0,0 +1,39 @@ +c { dg-do run } +c============================================== test.f + real x, y + real(kind=8) x1, y1 + x=0. + y = erfc(x) + if (y .ne. 1.) STOP 1 + + x=1.1 + y = erfc(x) + if (abs(y - .1197949) .ge. 1.e-6) STOP 2 + +c modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas. + x=8 + y = erfc(x) + if (y .gt. 1.2e-28) STOP 3 + + x1=0. + y1 = erfc(x1) + if (y1 .ne. 1.) STOP 4 + + x1=1.1d0 + y1 = erfc(x1) + if (abs(y1 - .1197949d0) .ge. 1.d-6) STOP 5 + + x1=10 + y1 = erfc(x1) + if (y1 .gt. 1.5d-44) STOP 6 + end +c================================================= +!output: +! 0. 1.875 +! 1.10000002 1.48958981 +! 10. 5.00220949E-06 +! +!The values should be: +!erfc(0)=1 +!erfc(1.1)= 0.1197949 +!erfc(10)<1.543115467311259E-044 Index: Fortran/gfortran/regression/g77/f77-edit-apostrophe-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-apostrophe-out.f @@ -0,0 +1,21 @@ +C Test Fortran 77 apostrophe edit descriptor +C (ANSI X3.9-1978 Section 13.5.1) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + 10 format('abcde') + 20 format('and an apostrophe -''-') + 30 format('''a leading apostrophe') + 40 format('a trailing apostrophe''') + 50 format('''and all of the above -''-''') + + write(*,10) ! { dg-output "abcde(\r*\n+)" } + write(*,20) ! { dg-output "and an apostrophe -'-(\r*\n+)" } + write(*,30) ! { dg-output "'a leading apostrophe(\r*\n+)" } + write(*,40) ! { dg-output "a trailing apostrophe'(\r*\n+)" } + write(*,50) ! { dg-output "'and all of the above -'-'(\r*\n+)" } + +C { dg-output "\$" } + end Index: Fortran/gfortran/regression/g77/f77-edit-colon-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-colon-out.f @@ -0,0 +1,9 @@ +C Test Fortran 77 colon edit descriptor +C (ANSI X3.9-1978 Section 13.5.5) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^123(\r*\n+)45(\r*\n+)\$" } + write(*,'((3(I1:)))') (I,I=1,5) + end Index: Fortran/gfortran/regression/g77/f77-edit-h-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-h-out.f @@ -0,0 +1,14 @@ +C Test Fortran 77 H edit descriptor +C (ANSI X3.9-1978 Section 13.5.2) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + 10 format(1H1) + 20 format(6H 6) + write(*,10) ! { dg-output "1(\r*\n+)" } + write(*,20) ! { dg-output " 6(\r*\n+)" } + write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\r*\n+)" } +C { dg-output "\$" } + end Index: Fortran/gfortran/regression/g77/f77-edit-i-in.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-i-in.f @@ -0,0 +1,24 @@ +C Test Fortran 77 I edit descriptor for input +C (ANSI X3.9-1978 Section 13.5.9.1) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-options "-std=legacy" } +C + + integer i,j + character*10 buf + + write(buf,'(A)') '1 -1' + + read(buf,'(I1)') i + if ( i.ne.1 ) STOP 1 + + read(buf,'(1X,I1)') i + if ( i.ne.0 ) STOP 2 + + read(buf,'(1X,I1,1X,I2)') i,j + if ( i.ne.0 .and. j.ne.-1 ) STOP 3 + + end Index: Fortran/gfortran/regression/g77/f77-edit-i-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-i-out.f @@ -0,0 +1,26 @@ +C Test Fortran 77 I edit descriptor for output +C (ANSI X3.9-1978 Section 13.5.9.1) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + + write(*,'(I1)') 1 ! { dg-output "1(\r*\n+)" } + write(*,'(I1)') -1 ! { dg-output "\\*(\r*\n+)" } + write(*,'(I2)') 2 ! { dg-output " 2(\r*\n+)" } + write(*,'(I2)') -2 ! { dg-output "-2(\r*\n+)" } + write(*,'(I3)') 3 ! { dg-output " 3(\r*\n+)" } + write(*,'(I3)') -3 ! { dg-output " -3(\r*\n+)" } + + write(*,'(I2.0)') 0 ! { dg-output " (\r*\n+)" } + write(*,'(I1.1)') 4 ! { dg-output "4(\r*\n+)" } + write(*,'(I1.1)') -4 ! { dg-output "\\*(\r*\n+)" } + write(*,'(I2.1)') 5 ! { dg-output " 5(\r*\n+)" } + write(*,'(I2.1)') -5 ! { dg-output "-5(\r*\n+)" } + write(*,'(I2.2)') 6 ! { dg-output "06(\r*\n+)" } + write(*,'(I2.2)') -6 ! { dg-output "\\*\\*(\r*\n+)" } + write(*,'(I3.2)') 7 ! { dg-output " 07(\r*\n+)" } + write(*,'(I3.2)') -7 ! { dg-output "-07(\r*\n+)" } + + end Index: Fortran/gfortran/regression/g77/f77-edit-s-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-s-out.f @@ -0,0 +1,20 @@ +C Test Fortran 77 S, SS and SP edit descriptors +C (ANSI X3.9-1978 Section 13.5.6) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + 10 format(SP,I3,1X,SS,I3) + 20 format(SP,I3,1X,SS,I3,SP,I3) + 30 format(SP,I3,1X,SS,I3,S,I3) + 40 format(SP,I3) + 50 format(SP,I2) + write(*,10) 10, 20 ! { dg-output "\\+10 20(\r*\n+)" } + write(*,20) 10, 20, 30 ! { dg-output "\\+10 20\\+30(\r*\n+)" } + write(*,30) 10, 20, 30 ! { dg-output "\\+10 20 30(\r*\n+)" } + write(*,40) 0 ! { dg-output " \\+0(\r*\n+)" } +C 15.5.9 - Note 5: When SP editing is in effect, the plus sign is not optional + write(*,50) 11 ! { dg-output "\\*\\*(\r*\n+)" } +C { dg-output "\$" } + end Index: Fortran/gfortran/regression/g77/f77-edit-slash-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-slash-out.f @@ -0,0 +1,9 @@ +C Test Fortran 77 colon slash descriptor +C (ANSI X3.9-1978 Section 13.5.4) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^123(\r*\n+)45(\r*\n+)\$" } + write(*,'(3(I1)/2(I1))') (I,I=1,5) + end Index: Fortran/gfortran/regression/g77/f77-edit-t-in.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-t-in.f @@ -0,0 +1,33 @@ +C Test Fortran 77 T edit descriptor for input +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-options "-std=legacy" } +C + integer i,j + real a,b,c,d,e + character*32 in + + in = '1234 8' + read(in,'(T3,I1)') i + if ( i.ne.3 ) STOP 1 + read(in,'(5X,TL4,I2)') i + if ( i.ne.23 ) STOP 2 + read(in,'(3X,I1,TR3,I1)') i,j + if ( i.ne.4 ) STOP 3 + if ( j.ne.8 ) STOP 4 + + in = ' 1.5 -12.62 348.75 1.0E-6' + 100 format(F6.0,TL6,I4,1X,I1,8X,I5,F3.0,T10,F5.0,T17,F6.0,TR2,F6.0) + read(in,100) a,i,j,k,b,c,d,e + if ( abs(a-1.5).gt.1.0e-5 ) STOP 5 + if ( i.ne.1 ) STOP 6 + if ( j.ne.5 ) STOP 7 + if ( k.ne.348 ) STOP 8 + if ( abs(b-0.75).gt.1.0e-5 ) STOP 9 + if ( abs(c-12.62).gt.1.0e-5 ) STOP 10 + if ( abs(d-348.75).gt.1.0e-4 ) STOP 11 + if ( abs(e-1.0e-6).gt.1.0e-11 ) STOP 12 + end Index: Fortran/gfortran/regression/g77/f77-edit-t-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-t-out.f @@ -0,0 +1,12 @@ +C Test Fortran 77 T edit descriptor +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + write(*,'(I4,T8,I1)') 1234,8 ! { dg-output "1234 8(\r*\n+)" } + write(*,'(I4,TR3,I1)') 1234,8 ! { dg-output "1234 8(\r*\n+)" } + write(*,'(I4,5X,TL2,I1)') 1234,8 ! { dg-output "1234 8(\r*\n+)" } +C { dg-output "\$" } + end Index: Fortran/gfortran/regression/g77/f77-edit-x-out.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f77-edit-x-out.f @@ -0,0 +1,12 @@ +C Test Fortran 77 X descriptor +C (ANSI X3.9-1978 Section 13.5.3.2) +C +C Origin: David Billinghurst +C +C { dg-do run } +C { dg-output "^" } + write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\r*\n+)" } +C Section 13.5.3 explains why there are no trailing blanks + write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\r*\n+)" } +C { dg-output "\$" } + end Index: Fortran/gfortran/regression/g77/f90-intrinsic-bit.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f90-intrinsic-bit.f @@ -0,0 +1,468 @@ +c { dg-do run } +c f90-intrinsic-bit.f +c +c Test Fortran 90 +c * intrinsic bit manipulation functions - Section 13.10.10 +c * bitcopy subroutine - Section 13.9.3 +c David Billinghurst +c +c Notes: +c * g77 only supports scalar arguments +c * third argument of ISHFTC is not optional in g77 + + logical fail + integer i, i2, ia, i3 + integer(kind=2) j, j2, j3, ja + integer(kind=1) k, k2, k3, ka + integer(kind=8) m, m2, m3, ma + + common /flags/ fail + fail = .false. + +c BIT_SIZE - Section 13.13.16 +c Determine BIT_SIZE by counting the bits + ia = 0 + i = 0 + i = not(i) + do while ( (i.ne.0) .and. (ia.lt.127) ) + ia = ia + 1 + i = ishft(i,-1) + end do + call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)') + ja = 0 + j = 0 + j = not(j) + do while ( (j.ne.0) .and. (ja.lt.127) ) + ja = ja + 1 + j = ishft(j,-1) + end do + call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer(2))') + ka = 0 + k = 0 + k = not(k) + do while ( (k.ne.0) .and. (ka.lt.127) ) + ka = ka + 1 + k = ishft(k,-1) + end do + call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer(1))') + ma = 0 + m = 0 + m = not(m) + do while ( (m.ne.0) .and. (ma.lt.127) ) + ma = ma + 1 + m = ishft(m,-1) + end do + call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer(8))') + +c BTEST - Section 13.13.17 + j = 7 + j2 = 3 + k = 7 + k2 = 3 + m = 7 + m2 = 3 + call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)') + call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer(2))') + call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer(1))') + call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer(8))') + call c_l(BTEST(j,3),.true.,'BTEST(integer(2),integer)') + call c_l(BTEST(j,j2),.true.,'BTEST(integer(2),integer(2))') + call c_l(BTEST(j,k2),.true.,'BTEST(integer(2),integer(1))') + call c_l(BTEST(j,m2),.true.,'BTEST(integer(2),integer(8))') + call c_l(BTEST(k,3),.true.,'BTEST(integer(1),integer)') + call c_l(BTEST(k,j2),.true.,'BTEST(integer(1),integer(2))') + call c_l(BTEST(k,k2),.true.,'BTEST(integer(1),integer(1))') + call c_l(BTEST(k,m2),.true.,'BTEST(integer(1),integer(8))') + call c_l(BTEST(m,3),.true.,'BTEST(integer(8),integer)') + call c_l(BTEST(m,j2),.true.,'BTEST(integer(8),integer(2))') + call c_l(BTEST(m,k2),.true.,'BTEST(integer(8),integer(1))') + call c_l(BTEST(m,m2),.true.,'BTEST(integer(8),integer(8))') + +c IAND - Section 13.13.40 + j = 3 + j2 = 1 + ja = 1 + k = 3 + k2 = 1 + ka = 1 + m = 3 + m2 = 1 + ma = 1 + call c_i(IAND(3,1),1,'IAND(integer,integer)') + call c_i2(IAND(j,j2),ja,'IAND(integer(2),integer(2)') + call c_i1(IAND(k,k2),ka,'IAND(integer(1),integer(1))') + call c_i8(IAND(m,m2),ma,'IAND(integer(8),integer(8))') + + +c IBCLR - Section 13.13.41 + j = 14 + j2 = 1 + ja = 12 + k = 14 + k2 = 1 + ka = 12 + m = 14 + m2 = 1 + ma = 12 + call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)') + call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer(2))') + call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer(1))') + call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer(8))') + call c_i2(IBCLR(j,1),ja,'IBCLR(integer(2),integer)') + call c_i2(IBCLR(j,j2),ja,'IBCLR(integer(2),integer(2))') + call c_i2(IBCLR(j,k2),ja,'IBCLR(integer(2),integer(1))') + call c_i2(IBCLR(j,m2),ja,'IBCLR(integer(2),integer(8))') + call c_i1(IBCLR(k,1),ka,'IBCLR(integer(1),integer)') + call c_i1(IBCLR(k,j2),ka,'IBCLR(integer(1),integer(2))') + call c_i1(IBCLR(k,k2),ka,'IBCLR(integer(1),integer(1))') + call c_i1(IBCLR(k,m2),ka,'IBCLR(integer(1),integer(8))') + call c_i8(IBCLR(m,1),ma,'IBCLR(integer(8),integer)') + call c_i8(IBCLR(m,j2),ma,'IBCLR(integer(8),integer(2))') + call c_i8(IBCLR(m,k2),ma,'IBCLR(integer(8),integer(1))') + call c_i8(IBCLR(m,m2),ma,'IBCLR(integer(8),integer(8))') + +c IBSET - Section 13.13.43 + j = 12 + j2 = 1 + ja = 14 + k = 12 + k2 = 1 + ka = 14 + m = 12 + m2 = 1 + ma = 14 + call c_i(IBSET(12,1),14,'IBSET(integer,integer)') + call c_i(IBSET(12,j2),14,'IBSET(integer,integer(2))') + call c_i(IBSET(12,k2),14,'IBSET(integer,integer(1))') + call c_i(IBSET(12,m2),14,'IBSET(integer,integer(8))') + call c_i2(IBSET(j,1),ja,'IBSET(integer(2),integer)') + call c_i2(IBSET(j,j2),ja,'IBSET(integer(2),integer(2))') + call c_i2(IBSET(j,k2),ja,'IBSET(integer(2),integer(1))') + call c_i2(IBSET(j,m2),ja,'IBSET(integer(2),integer(8))') + call c_i1(IBSET(k,1),ka,'IBSET(integer(1),integer)') + call c_i1(IBSET(k,j2),ka,'IBSET(integer(1),integer(2))') + call c_i1(IBSET(k,k2),ka,'IBSET(integer(1),integer(1))') + call c_i1(IBSET(k,m2),ka,'IBSET(integer(1),integer(8))') + call c_i8(IBSET(m,1),ma,'IBSET(integer(8),integer)') + call c_i8(IBSET(m,j2),ma,'IBSET(integer(8),integer(2))') + call c_i8(IBSET(m,k2),ma,'IBSET(integer(8),integer(1))') + call c_i8(IBSET(m,m2),ma,'IBSET(integer(8),integer(8))') + +c IEOR - Section 13.13.45 + j = 3 + j2 = 1 + ja = 2 + k = 3 + k2 = 1 + ka = 2 + m = 3 + m2 = 1 + ma = 2 + call c_i(IEOR(3,1),2,'IEOR(integer,integer)') + call c_i2(IEOR(j,j2),ja,'IEOR(integer(2),integer(2))') + call c_i1(IEOR(k,k2),ka,'IEOR(integer(1),integer(1))') + call c_i8(IEOR(m,m2),ma,'IEOR(integer(8),integer(8))') + +c ISHFT - Section 13.13.49 + i = 3 + i2 = 1 + i3 = 0 + ia = 6 + j = 3 + j2 = 1 + j3 = 0 + ja = 6 + k = 3 + k2 = 1 + k3 = 0 + ka = 6 + m = 3 + m2 = 1 + m3 = 0 + ma = 6 + call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)') + call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2') + call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3') + call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4') + call c_i2(ISHFT(j,j2),ja,'ISHFT(integer(2),integer(2))') + call c_i2(ISHFT(j,BIT_SIZE(j)),j3, + $ 'ISHFT(integer(2),integer(2)) 2') + call c_i2(ISHFT(j,-BIT_SIZE(j)),j3, + $ 'ISHFT(integer(2),integer(2)) 3') + call c_i2(ISHFT(j,0),j,'ISHFT(integer(2),integer(2)) 4') + call c_i1(ISHFT(k,k2),ka,'ISHFT(integer(1),integer(1))') + call c_i1(ISHFT(k,BIT_SIZE(k)),k3, + $ 'ISHFT(integer(1),integer(1)) 2') + call c_i1(ISHFT(k,-BIT_SIZE(k)),k3, + $ 'ISHFT(integer(1),integer(1)) 3') + call c_i1(ISHFT(k,0),k,'ISHFT(integer(1),integer(1)) 4') + call c_i8(ISHFT(m,m2),ma,'ISHFT(integer(8),integer(8))') + call c_i8(ISHFT(m,BIT_SIZE(m)),m3, + $ 'ISHFT(integer(8),integer(8)) 2') + call c_i8(ISHFT(m,-BIT_SIZE(m)),m3, + $ 'ISHFT(integer(8),integer(8)) 3') + call c_i8(ISHFT(m,0),m,'ISHFT(integer(8),integer(8)) 4') + +c ISHFTC - Section 13.13.50 +c The third argument is not optional in g77 + i = 3 + i2 = 2 + i3 = 3 + ia = 5 + j = 3 + j2 = 2 + j3 = 3 + ja = 5 + k = 3 + k2 = 2 + k3 = 3 + ka = 5 + m2 = 2 + m3 = 3 + ma = 5 +c test all the combinations of arguments + call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)') + call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer(2))') + call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer(1))') + call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer(8))') + call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer(2),integer)') + call c_i(ISHFTC(i,j2,j3),5, + & 'ISHFTC(integer,integer(2),integer(2))') + call c_i(ISHFTC(i,j2,k3),5, + & 'ISHFTC(integer,integer(2),integer(1))') + call c_i(ISHFTC(i,j2,m3),5, + & 'ISHFTC(integer,integer(2),integer(8))') + call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer(1),integer)') + call c_i(ISHFTC(i,k2,j3),5, + & 'ISHFTC(integer,integer(1),integer(2))') + call c_i(ISHFTC(i,k2,k3),5, + & 'ISHFTC(integer,integer(1),integer(1))') + call c_i(ISHFTC(i,k2,m3),5, + & 'ISHFTC(integer,integer(1),integer(8))') + call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer(8),integer)') + call c_i(ISHFTC(i,m2,j3),5, + & 'ISHFTC(integer,integer(8),integer(2))') + call c_i(ISHFTC(i,m2,k3),5, + & 'ISHFTC(integer,integer(8),integer(1))') + call c_i(ISHFTC(i,m2,m3),5, + & 'ISHFTC(integer,integer(8),integer(8))') + + call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer(2),integer,integer)') + call c_i2(ISHFTC(j,i2,j3),ja, + $ 'ISHFTC(integer(2),integer,integer(2))') + call c_i2(ISHFTC(j,i2,k3),ja, + $ 'ISHFTC(integer(2),integer,integer(1))') + call c_i2(ISHFTC(j,i2,m3),ja, + $ 'ISHFTC(integer(2),integer,integer(8))') + call c_i2(ISHFTC(j,j2,i3),ja, + $ 'ISHFTC(integer(2),integer(2),integer)') + call c_i2(ISHFTC(j,j2,j3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(2))') + call c_i2(ISHFTC(j,j2,k3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(1))') + call c_i2(ISHFTC(j,j2,m3),ja, + $ 'ISHFTC(integer(2),integer(2),integer(8))') + call c_i2(ISHFTC(j,k2,i3),ja, + $ 'ISHFTC(integer(2),integer(1),integer)') + call c_i2(ISHFTC(j,k2,j3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(2))') + call c_i2(ISHFTC(j,k2,k3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(1))') + call c_i2(ISHFTC(j,k2,m3),ja, + $ 'ISHFTC(integer(2),integer(1),integer(8))') + call c_i2(ISHFTC(j,m2,i3),ja, + $ 'ISHFTC(integer(2),integer(8),integer)') + call c_i2(ISHFTC(j,m2,j3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(2))') + call c_i2(ISHFTC(j,m2,k3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(1))') + call c_i2(ISHFTC(j,m2,m3),ja, + $ 'ISHFTC(integer(2),integer(8),integer(8))') + + call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer(1),integer,integer)') + call c_i1(ISHFTC(k,i2,j3),ka, + $ 'ISHFTC(integer(1),integer,integer(2))') + call c_i1(ISHFTC(k,i2,k3),ka, + $ 'ISHFTC(integer(1),integer,integer(1))') + call c_i1(ISHFTC(k,i2,m3),ka, + $ 'ISHFTC(integer(1),integer,integer(8))') + call c_i1(ISHFTC(k,j2,i3),ka, + $ 'ISHFTC(integer(1),integer(2),integer)') + call c_i1(ISHFTC(k,j2,j3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(2))') + call c_i1(ISHFTC(k,j2,k3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(1))') + call c_i1(ISHFTC(k,j2,m3),ka, + $ 'ISHFTC(integer(1),integer(2),integer(8))') + call c_i1(ISHFTC(k,k2,i3),ka, + $ 'ISHFTC(integer(1),integer(1),integer)') + call c_i1(ISHFTC(k,k2,j3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(2))') + call c_i1(ISHFTC(k,k2,k3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(1))') + call c_i1(ISHFTC(k,k2,m3),ka, + $ 'ISHFTC(integer(1),integer(1),integer(8))') + call c_i1(ISHFTC(k,m2,i3),ka, + $ 'ISHFTC(integer(1),integer(8),integer)') + call c_i1(ISHFTC(k,m2,j3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(2))') + call c_i1(ISHFTC(k,m2,k3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(1))') + call c_i1(ISHFTC(k,m2,m3),ka, + $ 'ISHFTC(integer(1),integer(8),integer(8))') + + call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer(8),integer,integer)') + call c_i8(ISHFTC(m,i2,j3),ma, + $ 'ISHFTC(integer(8),integer,integer(2))') + call c_i8(ISHFTC(m,i2,k3),ma, + $ 'ISHFTC(integer(8),integer,integer(1))') + call c_i8(ISHFTC(m,i2,m3),ma, + $ 'ISHFTC(integer(8),integer,integer(8))') + call c_i8(ISHFTC(m,j2,i3),ma, + $ 'ISHFTC(integer(8),integer(2),integer)') + call c_i8(ISHFTC(m,j2,j3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(2))') + call c_i8(ISHFTC(m,j2,k3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(1))') + call c_i8(ISHFTC(m,j2,m3),ma, + $ 'ISHFTC(integer(8),integer(2),integer(8))') + call c_i8(ISHFTC(m,k2,i3),ma, + $ 'ISHFTC(integer(8),integer(1),integer)') + call c_i8(ISHFTC(m,k2,j3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(2))') + call c_i8(ISHFTC(m,k2,k3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(1))') + call c_i8(ISHFTC(m,k2,m3),ma, + $ 'ISHFTC(integer(1),integer(8),integer(8))') + call c_i8(ISHFTC(m,m2,i3),ma, + $ 'ISHFTC(integer(8),integer(8),integer)') + call c_i8(ISHFTC(m,m2,j3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(2))') + call c_i8(ISHFTC(m,m2,k3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(1))') + call c_i8(ISHFTC(m,m2,m3),ma, + $ 'ISHFTC(integer(8),integer(8),integer(8))') + +c test the corner cases + call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i, + $ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer') + call c_i(ISHFTC(i,0,BIT_SIZE(i)),i, + $ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer') + call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i, + $ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer') + call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j, + $ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)') + call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j, + $ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer(2)') + call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j, + $ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)') + call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k, + $ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)') + call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k, + $ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer(1)') + call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k, + $ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)') + call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m, + $ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)') + call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m, + $ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer(8)') + call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m, + $ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)') + +c MVBITS - Section 13.13.74 + i = 6 + call MVBITS(7,2,2,i,0) + call c_i(i,5,'MVBITS 1') + j = 6 + j2 = 7 + ja = 5 + call MVBITS(j2,2,2,j,0) + call c_i2(j,ja,'MVBITS 2') + k = 6 + k2 = 7 + ka = 5 + call MVBITS(k2,2,2,k,0) + call c_i1(k,ka,'MVBITS 3') + m = 6 + m2 = 7 + ma = 5 + call MVBITS(m2,2,2,m,0) + call c_i8(m,ma,'MVBITS 4') + +c NOT - Section 13.13.77 +c Rather than assume integer sizes, mask off high bits + j = 21 + j2 = 31 + ja = 10 + k = 21 + k2 = 31 + ka = 10 + m = 21 + m2 = 31 + ma = 10 + call c_i(IAND(NOT(21),31),10,'NOT(integer)') + call c_i2(IAND(NOT(j),j2),ja,'NOT(integer(2))') + call c_i1(IAND(NOT(k),k2),ka,'NOT(integer(1))') + call c_i8(IAND(NOT(m),m2),ma,'NOT(integer(8))') + + if ( fail ) STOP 1 + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_l(i,j,label) +c Check if LOGICAL i equals j, and fail otherwise + logical i,j + character*(*) label + if ( i .eqv. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i(i,j,label) +c Check if INTEGER i equals j, and fail otherwise + integer i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i2(i,j,label) +c Check if INTEGER(kind=2) i equals j, and fail otherwise + integer(kind=2) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i1(i,j,label) +c Check if INTEGER(kind=1) i equals j, and fail otherwise + integer(kind=1) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i8(i,j,label) +c Check if INTEGER(kind=8) i equals j, and fail otherwise + integer(kind=8) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end Index: Fortran/gfortran/regression/g77/f90-intrinsic-mathematical.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f90-intrinsic-mathematical.f @@ -0,0 +1,138 @@ +c { dg-do run } +c f90-intrinsic-mathematical.f +c +c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and +c 13.13 +c David Billinghurst +c +c Notes: +c * g77 does not fully comply with F90. Noncompliances noted in comments. +c * Section 13.12: Specific names for intrinsic functions tested in +c intrinsic77.f + + logical fail + common /flags/ fail + fail = .false. + +c ACOS - Section 13.13.3 + call c_r(ACOS(0.54030231),1.0,'ACOS(real)') + call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)') + +c ASIN - Section 13.13.12 + call c_r(ASIN(0.84147098),1.0,'ASIN(real)') + call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)') + +c ATAN - Section 13.13.14 + call c_r(ATAN(1.5574077),1.0,'ATAN(real)') + call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)') + +c ATAN2 - Section 13.13.15 + call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)') + call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)') + +c COS - Section 13.13.22 + call c_r(COS(1.0),0.54030231,'COS(real)') + call c_d(COS(1.d0),0.54030231d0,'COS(double)') + call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)') + call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0), + $ 'COS(complex(kind=8))') + +c COSH - Section 13.13.23 + call c_r(COSH(1.0),1.5430806,'COSH(real)') + call c_d(COSH(1.d0),1.5430806d0,'COSH(double)') + +c EXP - Section 13.13.34 + call c_r(EXP(1.0),2.7182818,'EXP(real)') + call c_d(EXP(1.d0),2.7182818d0,'EXP(double)') + call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)') + call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0), + $ 'EXP(complex(kind=8))') + +c LOG - Section 13.13.59 + call c_r(LOG(10.0),2.3025851,'LOG(real)') + call c_d(LOG(10.d0),2.3025851d0,'LOG(double)') + call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)') + call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0), + $ 'LOG(complex(kind=8))') + +c LOG10 - Section 13.13.60 + call c_r(LOG10(10.0),1.0,'LOG10(real)') + call c_d(LOG10(10.d0),1.d0,'LOG10(double)') + +c SIN - Section 13.13.97 + call c_r(SIN(1.0),0.84147098,'SIN(real)') + call c_d(SIN(1.d0),0.84147098d0,'SIN(double)') + call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)') + call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0), + $ 'SIN(complex(kind=8))') + +c SINH - Section 13.13.98 + call c_r(SINH(1.0),1.175201,'SINH(real)') + call c_d(SINH(1.d0),1.175201d0,'SINH(double)') + +c SQRT - Section 13.13.102 + call c_r(SQRT(4.0),2.0,'SQRT(real)') + call c_d(SQRT(4.d0),2.d0,'SQRT(double)') + call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)') + call c_z(SQRT((4.d0,0.)),(2.d0,0.), + $ 'SQRT(complex(kind=8))') + +c TAN - Section 13.13.105 + call c_r(TAN(1.0),1.5574077,'TAN(real)') + call c_d(TAN(1.d0),1.5574077d0,'TAN(double)') + +c TANH - Section 13.13.106 + call c_r(TANH(1.0),0.76159416,'TANH(real)') + call c_d(TANH(1.d0),0.76159416d0,'TANH(double)') + + if ( fail ) STOP 1 + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_c(a,b,label) +c Check if COMPLEX a equals b, and fail otherwise + complex a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_z(a,b,label) +c Check if COMPLEX a equals b, and fail otherwise + complex(kind=8) a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end Index: Fortran/gfortran/regression/g77/f90-intrinsic-numeric.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/f90-intrinsic-numeric.f @@ -0,0 +1,283 @@ +c { dg-do run } +c f90-intrinsic-numeric.f +c +c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13 +c David Billinghurst +c +c Notes: +c * g77 does not fully comply with F90. Noncompliances noted in comments. +c * Section 13.12: Specific names for intrinsic functions tested in +c intrinsic77.f + + logical fail + integer(kind=2) j, j2, ja + integer(kind=1) k, k2, ka + + common /flags/ fail + fail = .false. + +c ABS - Section 13.13.1 + j = -9 + ja = 9 + k = j + ka = ja + call c_i(ABS(-7),7,'ABS(integer)') + call c_i2(ABS(j),ja,'ABS(integer(2))') + call c_i1(ABS(k),ka,'ABS(integer(1))') + call c_r(ABS(-7.),7.,'ABS(real)') + call c_d(ABS(-7.d0),7.d0,'ABS(double)') + call c_r(ABS((3.,-4.)),5.0,'ABS(complex)') + call c_d(ABS((3.d0,-4.d0)),5.0d0,'ABS(complex(kind=8))') + +c AIMAG - Section 13.13.6 + call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)') +c g77: AIMAG(complex(kind=8)) does not comply with F90 +c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(complex(kind=8))') + +c AINT - Section 13.13.7 + call c_r(AINT(2.783),2.0,'AINT(real) 1') + call c_r(AINT(-2.783),-2.0,'AINT(real) 2') + call c_d(AINT(2.783d0),2.0d0,'AINT(double precision) 1') + call c_d(AINT(-2.783d0),-2.0d0,'AINT(double precision) 2') +c Note: g77 does not support optional argument KIND + +c ANINT - Section 13.13.10 + call c_r(ANINT(2.783),3.0,'ANINT(real) 1') + call c_r(ANINT(-2.783),-3.0,'ANINT(real) 2') + call c_d(ANINT(2.783d0),3.0d0,'ANINT(double precision) 1') + call c_d(ANINT(-2.783d0),-3.0d0,'ANINT(double precision) 2') +c Note: g77 does not support optional argument KIND + +c CEILING - Section 13.13.18 +c Not implemented + +c CMPLX - Section 13.13.20 + j = 1 + ja = 2 + k = 1 + ka = 2 + call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)') + call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)') + call c_c(CMPLX(j),(1.,0.),'CMPLX(integer(2))') + call c_c(CMPLX(j,ja),(1.,2.),'CMPLX(integer(2), integer(2))') + call c_c(CMPLX(k),(1.,0.),'CMPLX(integer(1)') + call c_c(CMPLX(k,ka),(1.,2.),'CMPLX(integer(1), integer(1))') + call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)') + call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)') + call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)') + call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)') + call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(complex(kind=8))') +c NOTE: g77 does not support optional argument KIND + +c CONJG - Section 13.13.21 + call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)') + call c_z(CONJG((2.d0,-7.d0)),(2.d0,7.d0),'CONJG(complex(kind=8))') + +c DBLE - Section 13.13.27 + j = 5 + k = 5 + call c_d(DBLE(5),5.0d0,'DBLE(integer)') + call c_d(DBLE(j),5.0d0,'DBLE(integer(2))') + call c_d(DBLE(k),5.0d0,'DBLE(integer(1))') + call c_d(DBLE(5.),5.0d0,'DBLE(real)') + call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)') + call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)') + call c_d(DBLE((5.0d0,0.5d0)),5.0d0,'DBLE(complex(kind=8))') + +c DIM - Section 13.13.29 + j = -8 + j2 = -3 + ja = 0 + k = -8 + k2 = -3 + ka = 0 + call c_i(DIM(-8,-3),0,'DIM(integer)') + call c_i2(DIM(j,j2),ja,'DIM(integer(2))') + call c_i1(DIM(k,k2),ka,'DIM(integer(1)') + call c_r(DIM(-8.,-3.),0.,'DIM(real,real)') + call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)') + +c DPROD - Section 13.13.31 + call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)') + +c FLOOR - Section 13.13.36 +c Not implemented + +c INT - Section 13.13.47 + j = 5 + k = 5 + call c_i(INT(5),5,'INT(integer)') + call c_i(INT(j),5,'INT(integer(2))') + call c_i(INT(k),5,'INT(integer(1))') + call c_i(INT(5.01),5,'INT(real)') + call c_i(INT(5.01d0),5,'INT(double)') +c Note: Does not accept optional second argument KIND + +c MAX - Section 13.13.63 + j = 1 + j2 = 2 + ja = 2 + k = 1 + k2 = 2 + ka = 2 + call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)') + call c_i2(MAX(j,j2),ja,'MAX(integer(2),integer(2))') + call c_i1(MAX(k,k2),ka,'MAX(integer(1),integer(1))') + call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)') + call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)') + +c MIN - Section 13.13.68 + j = 1 + j2 = 2 + ja = 1 + k = 1 + k2 = 2 + ka = 1 + call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)') + call c_i2(MIN(j,j2),ja,'MIN(integer(2),integer(2))') + call c_i1(MIN(k,k2),ka,'MIN(integer(1),integer(1))') + call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)') + call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)') + +c MOD - Section 13.13.72 + call c_i(MOD(8,5),3,'MOD(integer,integer) 1') + call c_i(MOD(-8,5),-3,'MOD(integer,integer) 2') + call c_i(MOD(8,-5),3,'MOD(integer,integer) 3') + call c_i(MOD(-8,-5),-3,'MOD(integer,integer) 4') + j = 8 + j2 = 5 + ja = 3 + call c_i2(MOD(j,j2),ja,'MOD(integer(2),integer(2)) 1') + call c_i2(MOD(-j,j2),-ja,'MOD(integer(2),integer(2)) 2') + call c_i2(MOD(j,-j2),ja,'MOD(integer(2),integer(2)) 3') + call c_i2(MOD(-j,-j2),-ja,'MOD(integer(2),integer(2)) 4') + k = 8 + k2 = 5 + ka = 3 + call c_i1(MOD(k,k2),ka,'MOD(integer(1),integer(1)) 1') + call c_i1(MOD(-k,k2),-ka,'MOD(integer(1),integer(1)) 2') + call c_i1(MOD(k,-k2),ka,'MOD(integer(1),integer(1)) 3') + call c_i1(MOD(-k,-k2),-ka,'MOD(integer(1),integer(1)) 4') + call c_r(MOD(8.,5.),3.,'MOD(real,real) 1') + call c_r(MOD(-8.,5.),-3.,'MOD(real,real) 2') + call c_r(MOD(8.,-5.),3.,'MOD(real,real) 3') + call c_r(MOD(-8.,-5.),-3.,'MOD(real,real) 4') + call c_d(MOD(8.d0,5.d0),3.d0,'MOD(double,double) 1') + call c_d(MOD(-8.d0,5.d0),-3.d0,'MOD(double,double) 2') + call c_d(MOD(8.d0,-5.d0),3.d0,'MOD(double,double) 3') + call c_d(MOD(-8.d0,-5.d0),-3.d0,'MOD(double,double) 4') + +c MODULO - Section 13.13.73 +c Not implemented + +c NINT - Section 13.13.76 + call c_i(NINT(2.783),3,'NINT(real)') + call c_i(NINT(2.783d0),3,'NINT(double)') +c Optional second argument KIND not implemented + +c REAL - Section 13.13.86 + j = -2 + k = -2 + call c_r(REAL(-2),-2.0,'REAL(integer)') + call c_r(REAL(j),-2.0,'REAL(integer(2))') + call c_r(REAL(k),-2.0,'REAL(integer(1))') + call c_r(REAL(-2.0),-2.0,'REAL(real)') + call c_r(REAL(-2.0d0),-2.0,'REAL(double)') + call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)') +c REAL(complex(kind=8)) not implemented +c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(complex(kind=8))') + +c SIGN - Section 13.13.96 + j = -3 + j2 = 2 + ja = 3 + k = -3 + k2 = 2 + ka = 3 + call c_i(SIGN(-3,2),3,'SIGN(integer)') + call c_i2(SIGN(j,j2),ja,'SIGN(integer(2))') + call c_i1(SIGN(k,k2),ka,'SIGN(integer(1))') + call c_r(SIGN(-3.0,2.),3.,'SIGN(real,real)') + call c_d(SIGN(-3.d0,2.d0),3.d0,'SIGN(double,double)') + + if ( fail ) STOP 1 + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_i(i,j,label) +c Check if INTEGER i equals j, and fail otherwise + integer i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i2(i,j,label) +c Check if INTEGER(kind=2) i equals j, and fail otherwise + integer(kind=2) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_i1(i,j,label) +c Check if INTEGER(kind=1) i equals j, and fail otherwise + integer(kind=1) i,j + character*(*) label + if ( i .ne. j ) then + call failure(label) + write(6,*) 'Got ',i,' expected ', j + end if + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_c(a,b,label) +c Check if COMPLEX a equals b, and fail otherwise + complex a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_z(a,b,label) +c Check if COMPLEX a equals b, and fail otherwise + complex(kind=8) a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end Index: Fortran/gfortran/regression/g77/ffixed-form-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-form-1.f @@ -0,0 +1,6 @@ +! Test compiler flags: -ffixed-form +! Origin: David Billinghurst +! +! { dg-do compile } +! { dg-options "-ffixed-form" } + end Index: Fortran/gfortran/regression/g77/ffixed-form-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-form-2.f @@ -0,0 +1,12 @@ +! PR fortran/10843 +! Origin: Brad Davis +! +! { dg-do compile } +! { dg-options "-ffixed-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + GO TO = 55 + END + Index: Fortran/gfortran/regression/g77/ffixed-line-length-0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-line-length-0.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-0 +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-0" } +C The next line has length 257 + en d Index: Fortran/gfortran/regression/g77/ffixed-line-length-132.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-line-length-132.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-132 +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-132" } +c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 + en d* Index: Fortran/gfortran/regression/g77/ffixed-line-length-72.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-line-length-72.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-72 +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-72" } +c2345678901234567890123456789012345678901234567890123456789012345678901234567890 + en d* Index: Fortran/gfortran/regression/g77/ffixed-line-length-none.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffixed-line-length-none.f @@ -0,0 +1,7 @@ +C Test compiler flags: -ffixed-line-length-none +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-ffixed-line-length-none" } +C The next line has length 257 + en d Index: Fortran/gfortran/regression/g77/ffree-form-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffree-form-1.f @@ -0,0 +1,6 @@ +! Test compiler flags: -ffree-form +! Origin: David Billinghurst +! +! { dg-do compile } +! { dg-options "-ffree-form" } +end Index: Fortran/gfortran/regression/g77/ffree-form-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffree-form-2.f @@ -0,0 +1,11 @@ +! PR fortran/10843 +! Origin: Brad Davis +! +! { dg-do compile } +! { dg-options "-ffree-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + END + Index: Fortran/gfortran/regression/g77/ffree-form-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/ffree-form-3.f @@ -0,0 +1,20 @@ +! Test acceptance of keywords in free format +! Origin: David Billinghurst +! +! { dg-do compile } +! { dg-options "-ffree-form" } + integer i, j + i = 1 + if ( i .eq. 1 ) then + go = 2 + endif + if ( i .eq. 3 ) then + i = 4 + end if + do i = 1, 3 + j = i + end do + do j = 1, 3 + i = j + enddo + end Index: Fortran/gfortran/regression/g77/fno-underscoring.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/fno-underscoring.f @@ -0,0 +1,8 @@ +C Test compiler flags: -fno-underscoring +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-fno-underscoring" } + call aaabbbccc + end +C { dg-final { scan-assembler-not "aaabbbccc_" } } Index: Fortran/gfortran/regression/g77/funderscoring.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/funderscoring.f @@ -0,0 +1,8 @@ +C Test compiler flags: -funderscoring +C Origin: David Billinghurst +C +C { dg-do compile } +C { dg-options "-funderscoring" } + call aaabbbccc + end +C { dg-final { scan-assembler "aaabbbccc_" } } Index: Fortran/gfortran/regression/g77/int8421.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/int8421.f @@ -0,0 +1,21 @@ +c { dg-do run } + integer(kind=1) i1, i11 + integer(kind=2) i2, i22 + integer i, ii + integer(kind=4) i4, i44 + integer(kind=8) i8, i88 + real r, rr + real(kind=4) r4, r44 + double precision d, dd + real(kind=8) r8, r88 + parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1) + parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1) + if (i8 .ne. 15 ) STOP 1 + if (d .ne. 61.d0) STOP 2 + i11 = 1; i22 = 2; i44 = 4; ii = 5 + i88 = i + i4*i2 + i2*i1 + if (i88 .ne. i8) STOP 3 + rr = 3.0; r44 = 4.0; r88 = 8.0d0 + dd = i88*rr + r44*i22 + r88*i11 + if (dd .ne. d) STOP 4 + end Index: Fortran/gfortran/regression/g77/intrinsic-unix-bessel.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/intrinsic-unix-bessel.f @@ -0,0 +1,109 @@ +c { dg-do run } +c intrinsic-unix-bessel.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst +c + real x, a + double precision dx, da + integer i + integer(kind=2) j + integer(kind=1) k + integer(kind=8) m + logical fail + common /flags/ fail + fail = .false. + + x = 2.0 + dx = x + i = 2 + j = i + k = i + m = i +c BESJ0 - Bessel function of first kind of order zero + a = 0.22389077 + da = a + call c_r(BESJ0(x),a,'BESJ0(real)') + call c_d(BESJ0(dx),da,'BESJ0(double)') + call c_d(DBESJ0(dx),da,'DBESJ0(double)') + +c BESJ1 - Bessel function of first kind of order one + a = 0.57672480 + da = a + call c_r(BESJ1(x),a,'BESJ1(real)') + call c_d(BESJ1(dx),da,'BESJ1(double)') + call c_d(DBESJ1(dx),da,'DBESJ1(double)') + +c BESJN - Bessel function of first kind of order N + a = 0.3528340 + da = a + call c_r(BESJN(i,x),a,'BESJN(integer,real)') + call c_r(BESJN(j,x),a,'BESJN(integer(2),real)') + call c_r(BESJN(k,x),a,'BESJN(integer(1),real)') + call c_d(BESJN(i,dx),da,'BESJN(integer,double)') + call c_d(BESJN(j,dx),da,'BESJN(integer(2),double)') + call c_d(BESJN(k,dx),da,'BESJN(integer(1),double)') + call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)') + call c_d(DBESJN(j,dx),da,'DBESJN(integer(2),double)') + call c_d(DBESJN(k,dx),da,'DBESJN(integer(1),double)') + +c BESY0 - Bessel function of second kind of order zero + a = 0.51037567 + da = a + call c_r(BESY0(x),a,'BESY0(real)') + call c_d(BESY0(dx),da,'BESY0(double)') + call c_d(DBESY0(dx),da,'DBESY0(double)') + +c BESY1 - Bessel function of second kind of order one + a = 0.-0.1070324 + da = a + call c_r(BESY1(x),a,'BESY1(real)') + call c_d(BESY1(dx),da,'BESY1(double)') + call c_d(DBESY1(dx),da,'DBESY1(double)') + +c BESYN - Bessel function of second kind of order N + a = -0.6174081 + da = a + call c_r(BESYN(i,x),a,'BESYN(integer,real)') + call c_r(BESYN(j,x),a,'BESYN(integer(2),real)') + call c_r(BESYN(k,x),a,'BESYN(integer(1),real)') + call c_d(BESYN(i,dx),da,'BESYN(integer,double)') + call c_d(BESYN(j,dx),da,'BESYN(integer(2),double)') + call c_d(BESYN(k,dx),da,'BESYN(integer(1),double)') + call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)') + call c_d(DBESYN(j,dx),da,'DBESYN(integer(2),double)') + call c_d(DBESYN(k,dx),da,'DBESYN(integer(1),double)') + + if ( fail ) STOP 1 + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end Index: Fortran/gfortran/regression/g77/intrinsic-unix-erf.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/intrinsic-unix-erf.f @@ -0,0 +1,61 @@ +c { dg-do run } +c intrinsic-unix-erf.f +c +c Test Bessel function intrinsics. +c These functions are only available if provided by system +c +c David Billinghurst +c + real x, a + double precision dx, da + logical fail + common /flags/ fail + fail = .false. + + x = 0.6 + dx = x +c ERF - error function + a = 0.6038561 + da = a + call c_r(ERF(x),a,'ERF(real)') + call c_d(ERF(dx),da,'ERF(double)') + call c_d(DERF(dx),da,'DERF(double)') + +c ERFC - complementary error function + a = 1.0 - a + da = a + call c_r(ERFC(x),a,'ERFC(real)') + call c_d(ERFC(dx),da,'ERFC(double)') + call c_d(DERFC(dx),da,'DERFC(double)') + + if ( fail ) STOP 1 + end + + subroutine failure(label) +c Report failure and set flag + character*(*) label + logical fail + common /flags/ fail + write(6,'(a,a,a)') 'Test ',label,' FAILED' + fail = .true. + end + + subroutine c_r(a,b,label) +c Check if REAL a equals b, and fail otherwise + real a, b + character*(*) label + if ( abs(a-b) .gt. 1.0e-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end + + subroutine c_d(a,b,label) +c Check if DOUBLE PRECISION a equals b, and fail otherwise + double precision a, b + character*(*) label + if ( abs(a-b) .gt. 1.0d-5 ) then + call failure(label) + write(6,*) 'Got ',a,' expected ', b + end if + end Index: Fortran/gfortran/regression/g77/labug1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/labug1.f @@ -0,0 +1,58 @@ +c { dg-do run } + PROGRAM LABUG1 + +* This program core dumps on mips-sgi-irix6.2 when compiled +* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots +* with -O2 +* +* Originally derived from LAPACK test suite. +* Almost any change allows it to run. +* +* David Billinghurst, (David.Billinghurst@riotinto.com.au) +* 25 November 1998 +* +* .. Parameters .. + INTEGER LDA, LDE + PARAMETER ( LDA = 2500, LDE = 50 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + + INTEGER I, J, M, N + REAL V + COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE) + COMPLEX Z + + N=2 + M=1 +* + do i = 1, m + do j = 1, n + e(i,j) = czero + f(i,j) = czero + end do + end do +* + DO J = 1, N + DO I = 1, M + V = ABS( E(I,J) - F(I,J) ) + END DO + END DO + + CALL SUB2(M,Z) + + END + + subroutine SUB2(I,A) + integer i + complex a + end + + + + + + + + + + Index: Fortran/gfortran/regression/g77/large_vec.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/large_vec.f @@ -0,0 +1,4 @@ +c { dg-do run } + parameter (nmax=165000) + double precision x(nmax) + end Index: Fortran/gfortran/regression/g77/le.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/le.f @@ -0,0 +1,30 @@ +c { dg-do run } + program fool + + real foo + integer n + logical t + + foo = 2.5 + n = 5 + + t = (n > foo) + if (t .neqv. .true.) STOP 1 + t = (n >= foo) + if (t .neqv. .true.) STOP 2 + t = (n < foo) + if (t .neqv. .false.) STOP 3 + t = (n <= 5) + if (t .neqv. .true.) STOP 4 + t = (n >= 5 ) + if (t .neqv. .true.) STOP 5 + t = (n == 5) + if (t .neqv. .true.) STOP 6 + t = (n /= 5) + if (t .neqv. .false.) STOP 7 + t = (n /= foo) + if (t .neqv. .true.) STOP 8 + t = (n == foo) + if (t .neqv. .false.) STOP 9 + + end Index: Fortran/gfortran/regression/g77/pr105203.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/pr105203.f @@ -0,0 +1,20 @@ +C Test case for PR debug/105203 +C Origin: kmccarty@princeton.edu +C +C { dg-do compile } +C { dg-options "-O2 -fcompare-debug -ftracer -w" } +C { dg-additional-options "-fPIC" { target fpic } } + SUBROUTINE FOO (B) + + 10 CALL BAR (A) + ASSIGN 20 TO M + IF (100.LT.A) GOTO 10 + GOTO 40 +C + 20 IF (B.LT.ABS(A)) GOTO 10 + ASSIGN 30 TO M + GOTO 40 +C + 30 ASSIGN 10 TO M + 40 GOTO M,(10,20,30) + END Index: Fortran/gfortran/regression/g77/pr9258.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/pr9258.f @@ -0,0 +1,18 @@ +C Test case for PR/9258 +C Origin: kmccarty@princeton.edu +C +C { dg-do compile } + SUBROUTINE FOO (B) + + 10 CALL BAR (A) + ASSIGN 20 TO M !{ dg-warning "Deleted feature: ASSIGN" } + IF (100.LT.A) GOTO 10 + GOTO 40 +C + 20 IF (B.LT.ABS(A)) GOTO 10 + ASSIGN 30 TO M !{ dg-warning "Deleted feature: ASSIGN" } + GOTO 40 +C + 30 ASSIGN 10 TO M !{ dg-warning "Deleted feature: ASSIGN" } + 40 GOTO M,(10,20,30) !{ dg-warning "Deleted feature: Assigned GOTO" } + END Index: Fortran/gfortran/regression/g77/short.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/short.f @@ -0,0 +1,60 @@ +c { dg-do run } +c { dg-options "-std=legacy" } +c + program short + + parameter ( N=2 ) + common /chb/ pi,sig(0:N) + common /parm/ h(2,2) + +c initialize some variables + h(2,2) = 1117 + h(2,1) = 1178 + h(1,2) = 1568 + h(1,1) = 1621 + sig(0) = -1. + sig(1) = 0. + sig(2) = 1. + + call printout + stop + end + +c ****************************************************************** + + subroutine printout + parameter ( N=2 ) + common /chb/ pi,sig(0:N) + common /parm/ h(2,2) + dimension yzin1(0:N), yzin2(0:N) + +c function subprograms + z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.) + +c a four-way average of rhobar + do 260 k=0,N + yzin1(k) = 0.25 * + & ( z(2,2,k) + z(1,2,k) + + & z(2,1,k) + z(1,1,k) ) + 260 continue + +c another four-way average of rhobar + do 270 k=0,N + rtmp1 = z(2,2,k) + rtmp2 = z(1,2,k) + rtmp3 = z(2,1,k) + rtmp4 = z(1,1,k) + yzin2(k) = 0.25 * + & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 ) + 270 continue + + do k=0,N + if (yzin1(k) .ne. yzin2(k)) STOP 1 + enddo + if (yzin1(0) .ne. -1371.) STOP 2 + if (yzin1(1) .ne. -685.5) STOP 3 + if (yzin1(2) .ne. 0.) STOP 4 + + return + end + Index: Fortran/gfortran/regression/g77/strlen0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/strlen0.f @@ -0,0 +1,95 @@ +C Substring range checking test program, to check behavior with respect +C to X3J3/90.4 paragraph 5.7.1. +C +C Patches relax substring checking for subscript expressions in order to +C simplify coding (elimination of length checks for strings passed as +C parameters) and to avoid contradictory behavior of subscripted substring +C expressions with respect to unsubscripted string expressions. +C +C Key part of 5.7.1 interpretation comes down to statement that in the +C substring expression, +C v ( e1 : e2 ) +C 1 <= e1 <= e2 <= len to be valid, yet the expression +C v ( : ) +C is equivalent to +C v(1:len(v)) +C +C meaning that any statement that reads +C str = v // 'tail' +C (where v is a string passed as a parameter) would require coding as +C if (len(v) .gt. 0) then +C str = v // 'tail' +C else +C str = 'tail' +C endif +C to comply with the standard specification. Under the stricter +C interpretation, functions strcat and strlat would be incorrect as +C written for null values of str1 and/or str2. +C +C This code compiles and runs without error on +C SunOS 4.1.3 f77 (-C option) +C SUNWspro SPARCcompiler 4.2 f77 (-C option) +C (and with proposed patches, gcc-2.9.2 -fbounds-check except for test 6, +C which is a genuine, deliberate error - comment out to make further +C tests) +C +C { dg-do run } +C { dg-options "-fbounds-check" } +C +C G. Helffrich/Tokyo Inst. Technology Jul 24 2001 + + character str*8,strres*16,strfun*16,strcat*16,strlat*16 + + str='Hi there' + +C Test 1 - (current+patched) two char substring result + strres=strfun(str,1,2) + write(*,*) 'strres is ',strres + +C Test 2 - (current+patched) null string result + strres=strfun(str,5,4) + write(*,*) 'strres is ',strres + +C Test 3 - (current+patched) null string result + strres=strfun(str,8,7) + write(*,*) 'strres is ',strres + +C Test 4 - (current) error; (patched) null string result + strres=strfun(str,9,8) + write(*,*) 'strres is ',strres + +C Test 5 - (current) error; (patched) null string result + strres=strfun(str,1,0) + write(*,*) 'strres is ',strres + +C Test 6 - (current+patched) error +C strres=strfun(str,20,20) +C write(*,*) 'strres is ',strres + +C Test 7 - (current+patched) str result + strres=strcat(str,'') + write(*,*) 'strres is ',strres + +C Test 8 - (current) error; (patched) str result + strres=strlat('',str) + write(*,*) 'strres is ',strres + + end + + character*(*) function strfun(str,i,j) + character str*(*) + + strfun = str(i:j) + end + + character*(*) function strcat(str1,str2) + character str1*(*), str2*(*) + + strcat = str1 // str2 + end + + character*(*) function strlat(str1,str2) + character str1*(*), str2*(*) + + strlat = str1(1:len(str1)) // str2(1:len(str2)) + end Index: Fortran/gfortran/regression/g77/toon_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/toon_1.f @@ -0,0 +1,4 @@ +c { dg-do compile } + SUBROUTINE AAP(NOOT) + DIMENSION NOOT(*) + END Index: Fortran/gfortran/regression/g77/xformat.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/g77/xformat.f @@ -0,0 +1,4 @@ +c { dg-do compile } + PRINT 10, 2, 3 +10 FORMAT (I1, X, I1) ! { dg-warning "Extension: X descriptor" "Extension: X descriptor" } + END Index: Fortran/gfortran/regression/goacc-gomp/atomic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/atomic.f90 @@ -0,0 +1,48 @@ +! { dg-do compile } */ +! { dg-additional-options "-fdump-tree-original" } */ + +subroutine foo + !$omp requires atomic_default_mem_order(acq_rel) + integer :: i, v + + !$omp atomic read + i = v + + !$acc atomic read + i = v + + !$omp atomic write + i = v + + !$acc atomic write + i = v + + !$omp atomic update + i = i + 1 + + !$acc atomic update + i = i + 1 + + !$omp atomic capture + i = i + 1 + v = i + !$omp end atomic + + !$acc atomic capture + i = i + 1 + v = i + !$acc end atomic + + ! Valid in C/C++ since OpenACC 2.5 but not in Fortran: + ! !$acc atomic update capture + ! i = i + 1 + ! v = i + ! !$acc end atomic +end + +! { dg-final { scan-tree-dump-times "i = #pragma omp atomic read acquire" 1 "original" } } +! { dg-final { scan-tree-dump-times "i = #pragma omp atomic read relaxed" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 2 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 1 "original" } } Index: Fortran/gfortran/regression/goacc-gomp/depobj.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/depobj.f90 @@ -0,0 +1,11 @@ +! PR fortran/100642 +! Contributed by G. Steinmetz +program p + !use omp_lib, only: omp_depend_kind + use iso_c_binding, only: c_intptr_t + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer(omp_depend_kind) :: a, b + !$acc data + !$omp depobj(b) depend(out:a) ! { dg-error "The !\\\$OMP DEPOBJ directive cannot be specified within a !\\\$ACC DATA region" } + !$acc end data +end Index: Fortran/gfortran/regression/goacc-gomp/fixed-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/fixed-1.f @@ -0,0 +1,81 @@ +! { dg-additional-options "-fdump-tree-original -Wunused-variable" } + implicit none + integer :: a,b,c,d,e,f,g,h,i,j,k,ll + +c$bogus +!$bogus +*$bogus + +c$ bogus +!$ bogus +*$ bogus + +c$a23 bogus +!$ a bogus +*$12a bogus + +! The following should be parsed as OpenMP conditional sentinel +! If not, expect a unused-variable warning + +c$ a = 1 +!$ b = 2 +*$ c = 3 + +c$ 1 d = 4 +!$ 22 e = 5 +*$34 f = 6 + +c$ g = +c$ *7 +!$ 2 h = +*$ & 8 +*$ 3 i +!$ & = 9 + +c$ j +*$ &= +c$ *10 +!$ 5 k +*$ * = +c$ & 1 +*$ & 1 +*$9 9 ll +!$ & = +!$ * 12 + +c$ bogus +!$ bogus +*$ bogus + +c$bogus +!$bogus +*$bogus + +c$ acc bogus +!$ acc bogus +*$ acc bogus + +c$ omp bogus +!$ omp bogus +*$ omp bogus + end + +!{ dg-final { scan-tree-dump-times "a = 1;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "b = 2;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "c = 3;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "d = 4;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "e = 5;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "f = 6;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "g = 7;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "h = 8;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "i = 9;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "j = 10;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "k = 11;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "ll = 12;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000001:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000022:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000034:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000002:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000003:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000005:;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "__label_000099:;" 1 "original" } } Index: Fortran/gfortran/regression/goacc-gomp/free-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/free-1.f90 @@ -0,0 +1,34 @@ +! { dg-additional-options "-fdump-tree-original -Wunused-variable" } +implicit none +integer :: a,b,c,d,e,f,g,h + +!$bogus + + !$bogus +!$& bogus + !$& bogus + +!$ a = 1 +!$ b = 2 +!$ c = & +!$3 + +!$ d = & +!$&4 + + !$ e = 5 + !$ f = 6 + !$ g = & + !$7 + + !$ h = & +!$&8 + end + +!{ dg-final { scan-tree-dump-times "a = 1;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "b = 2;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "c = 3;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "d = 4;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "e = 5;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "f = 6;" 1 "original" } } +!{ dg-final { scan-tree-dump-times "g = 7;" 1 "original" } } Index: Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/goacc-gomp.exp @@ -0,0 +1,37 @@ +# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +if { ![check_effective_target_fopenacc] \ + || ![check_effective_target_fopenmp] } { + return +} + +# Initialize `dg'. +dg-init + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-fopenacc -fopenmp" + +# All done. +dg-finish Index: Fortran/gfortran/regression/goacc-gomp/mixed-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/mixed-1.f @@ -0,0 +1,23 @@ +! { dg-additional-options "-fdump-tree-original" } + + ! OMP PARALLEL gets parsed and is properly handled + ! But ACC& gives an error + ! [Before: an error is printed but OMP parses 'parallel loop ...'] + subroutine one + implicit none + integer i +!$omp parallel +!$acc& loop independent ! { dg-error "Wrong OpenMP continuation at .1.: expected !.OMP, got !.ACC" } + do i = 1, 5 + end do +!$omp end parallel + end + + ! [Before: Bogus 'Wrong OpenMP continuation' as it was read as continuation line!] + subroutine two +!$omp parallel +!$acc loop independent ! { dg-error "The !.ACC LOOP directive cannot be specified within a !.OMP PARALLEL region" } + do i = 1, 5 + end do +!$omp end parallel + end Index: Fortran/gfortran/regression/goacc-gomp/pr102330-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc-gomp/pr102330-1.f90 @@ -0,0 +1,35 @@ +! { dg-additional-options -fopt-info-omp-note } + +! { dg-additional-options --param=openacc-privatization=noisy } + +subroutine r1 + !$omp master taskloop simd + do i = 1, 8 + end do + !$acc parallel loop ! { dg-line l_compute1 } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute1 } + do i = 1, 8 + end do +end + +subroutine r2 + !$omp taskloop lastprivate(i) + do i = 1, 8 + end do + !$acc parallel loop ! { dg-line l_compute2 } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute2 } + do i = 1, 8 + end do +end + +subroutine r3 + i = 0 + !$omp task shared(i) + i = 1 + !$omp end task + !$omp taskwait + !$acc parallel loop ! { dg-line l_compute3 } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute3 } + do i = 1, 8 + end do +end Index: Fortran/gfortran/regression/goacc/acc_on_device-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/acc_on_device-1.f95 @@ -0,0 +1,21 @@ +! Have to enable optimizations, as otherwise builtins won't be expanded. +! { dg-additional-options "-O -fdump-rtl-expand -std=legacy" } + +logical function f () + implicit none + + external acc_on_device + logical (4) acc_on_device + + f = .false. + f = f .or. acc_on_device () + f = f .or. acc_on_device (1, 2) ! { dg-warning ".*" } + f = f .or. acc_on_device (3.14) + f = f .or. acc_on_device ("hello") + + return +end function f + +! Unsuitable to be handled as a builtin, so we're expecting four calls. +! { dg-final { scan-rtl-dump-times "\\\(call \[^\\n\]* acc_on_device" 4 "expand" } } + Index: Fortran/gfortran/regression/goacc/acc_on_device-2-off.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/acc_on_device-2-off.f95 @@ -0,0 +1,38 @@ +! Have to enable optimizations, as otherwise builtins won't be expanded. +! { dg-additional-options "-O -fdump-rtl-expand -fno-openacc" } + +module openacc_kinds + implicit none + + integer, parameter :: acc_device_kind = 4 + +end module openacc_kinds + +module openacc + use openacc_kinds + implicit none + + integer (acc_device_kind), parameter :: acc_device_host = 2 + + interface + function acc_on_device (dev) + use openacc_kinds + logical (4) :: acc_on_device + integer (acc_device_kind), intent (in) :: dev + end function acc_on_device + end interface +end module openacc + +logical (4) function f () + use openacc + implicit none + + integer (4), parameter :: dev = 2 + + f = acc_on_device (dev) + return +end function f + +! Without -fopenacc, we're expecting one call. +! { dg-final { scan-rtl-dump-times "\\\(call \[^\\n\]* acc_on_device" 1 "expand" } } + Index: Fortran/gfortran/regression/goacc/acc_on_device-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/acc_on_device-2.f95 @@ -0,0 +1,39 @@ +! Have to enable optimizations, as otherwise builtins won't be expanded. +! { dg-additional-options "-O -fdump-rtl-expand" } + +module openacc_kinds + implicit none + + integer, parameter :: acc_device_kind = 4 + +end module openacc_kinds + +module openacc + use openacc_kinds + implicit none + + integer (acc_device_kind), parameter :: acc_device_host = 2 + + interface + function acc_on_device (dev) + use openacc_kinds + logical (4) :: acc_on_device + integer (acc_device_kind), intent (in) :: dev + end function acc_on_device + end interface +end module openacc + +logical (4) function f () + use openacc + implicit none + + integer (4), parameter :: dev = 2 + + f = acc_on_device (dev) + return +end function f + +! With -fopenacc, we're expecting the builtin to be expanded, so no calls. +! TODO: not working. +! { dg-final { scan-rtl-dump-times "\\\(call \[^\\n\]* acc_on_device" 0 "expand" { xfail *-*-* } } } + Index: Fortran/gfortran/regression/goacc/array-reduction.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-reduction.f90 @@ -0,0 +1,74 @@ +program test + implicit none + integer a(10), i + + a(:) = 0 + + ! Array reductions. + + !$acc parallel reduction (+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end parallel + + !$acc parallel + !$acc loop reduction (+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end parallel + + !$acc kernels + !$acc loop reduction (+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end kernels + + ! Subarray reductions. + + !$acc parallel reduction (+:a(1:5)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end parallel + + !$acc parallel + !$acc loop reduction (+:a(1:5)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end parallel + + !$acc kernels + !$acc loop reduction (+:a(1:5)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a = a + 1 + end do + !$acc end kernels + + ! Reductions on array elements. + + !$acc parallel reduction (+:a(1)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a(1) = a(1) + 1 + end do + !$acc end parallel + + !$acc parallel + !$acc loop reduction (+:a(1)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a(1) = a(1) + 1 + end do + !$acc end parallel + + !$acc kernels + !$acc loop reduction (+:a(1)) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1, 10 + a(1) = a(1) + 1 + end do + !$acc end kernels + + print *, a +end program test Index: Fortran/gfortran/regression/goacc/array-with-dt-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-1.f90 @@ -0,0 +1,28 @@ +! { dg-additional-options -Wuninitialized } + +! Purpose of this testcase (from the commit log): +! This patch fixes lowering of derived-type mappings which select elements +! of arrays of derived types, and similar. These would previously lead +! to ICEs. + +! This testcase does not show any uninitialized warnings when compiled with -O +! (as done). For -O0, see testcase file 'array-with-dt-1a.f90'. + +type t + integer, allocatable :: A(:,:) +end type t + +type(t), allocatable :: b(:) + +! Remark: Semantically, the following line requires that 'b' +! is already present on the device. + +!$acc update host(b) + +! Remark: Semantically, the following lines require that b is allocated +! and present on the device. The last line also requires the same for 'A'. + +!$acc update host(b(:)) +!$acc update host(b(1)%A) +!$acc update host(b(1)%A(:,:)) +end Index: Fortran/gfortran/regression/goacc/array-with-dt-1a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-1a.f90 @@ -0,0 +1,27 @@ +! { dg-additional-options "-Wuninitialized -O0" } +! +! With -O0 only, 'may be uninitalized' warnings show up. +! For the original testcase, compiled with '-O', +! see testcase file 'array-with-dt-1a.f90' + +type t + integer, allocatable :: A(:,:) +end type t + +type(t), allocatable :: b(:) +! { dg-note {'b' declared here} {} { target *-*-* } .-1 } + +! Remark: Semantically, the following line requires that 'b' +! is already present on the device. + +!$acc update host(b) +! { dg-warning {'b\.dim\[0\]\.ubound' may be used uninitialized} {} { target *-*-* } .-1 } +! { dg-warning {'b\.dim\[0\]\.lbound' may be used uninitialized} {} { target *-*-* } .-2 } + +! Remark: Semantically, the following lines require that b is allocated +! and present on the device. The last line also requires the same for 'A'. + +!$acc update host(b(:)) +!$acc update host(b(1)%A) +!$acc update host(b(1)%A(:,:)) +end Index: Fortran/gfortran/regression/goacc/array-with-dt-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-2.f90 @@ -0,0 +1,15 @@ +! { dg-additional-options -Wuninitialized } + +type t + integer, allocatable :: A(:,:) +end type t + +type(t), allocatable :: b(:) +! { dg-note {'b' declared here} {} { target *-*-* } .-1 } + +!$acc update host(b(::2)) +! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 } +! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 } +!$acc update host(b(1)%A(::3,::4)) +end + Index: Fortran/gfortran/regression/goacc/array-with-dt-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-3.f90 @@ -0,0 +1,22 @@ +! { dg-additional-options -Wuninitialized } + +type t2 + integer :: A(200,200) +end type t2 +type t + integer, allocatable :: A(:,:) +end type t + +type(t2),allocatable :: c(:) +! { dg-note {'c' declared here} {} { target *-*-* } .-1 } +! { dg-note {'c\.offset' was declared here} {} { target *-*-* } .-2 } +type(t), allocatable :: d(:) +! { dg-note {'d' declared here} {} { target *-*-* } .-1 } +! { dg-note {'d\.offset' was declared here} {} { target *-*-* } .-2 } + +!$acc exit data delete(c(1)%A) +! { dg-warning {'c\.offset' is used uninitialized} {} { target *-*-* } .-1 } +!$acc exit data delete(d(1)%A) +! { dg-warning {'d\.offset' is used uninitialized} {} { target *-*-* } .-1 } + +end Index: Fortran/gfortran/regression/goacc/array-with-dt-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-4.f90 @@ -0,0 +1,23 @@ +! { dg-additional-options -Wuninitialized } + +type t4 + integer, allocatable :: quux(:) +end type t4 +type t3 + type(t4), pointer :: qux(:) +end type t3 +type t2 + type(t3), allocatable :: bar(:) +end type t2 +type t + type(t2), allocatable :: foo(:) +end type t + +type(t), allocatable :: c(:) +! { dg-note {'c' declared here} {} { target *-*-* } .-1 } + +!$acc enter data copyin(c(5)%foo(4)%bar(3)%qux(2)%quux(:)) +! { dg-warning {'c\.offset' is used uninitialized} {} { target *-*-* } .-1 } +!$acc exit data delete(c(5)%foo(4)%bar(3)%qux(2)%quux(:)) +! { dg-warning {'c\.offset' is used uninitialized} {} { target *-*-* } .-1 } +end Index: Fortran/gfortran/regression/goacc/array-with-dt-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-5.f90 @@ -0,0 +1,16 @@ +! { dg-additional-options -Wuninitialized } + +type t2 + integer :: bar +end type t2 +type t + type(t2), pointer :: foo +end type t + +type(t) :: c +! { dg-note {'c' declared here} {} { target *-*-* } .-1 } + +!$acc enter data copyin(c%foo) +! { dg-warning {'c\.foo' is used uninitialized} {} { target *-*-* } .-1 } + +end Index: Fortran/gfortran/regression/goacc/array-with-dt-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/array-with-dt-6.f90 @@ -0,0 +1,10 @@ +type t + integer :: i, j +end type t +type t2 + type(t) :: b(4) +end type +type(t2) :: var(10) +!$acc update host(var(3)%b(:)%j) ! { dg-error "not a proper array section" } +!$acc update host(var(3)%b%j) ! { dg-error "not a proper array section" } +end Index: Fortran/gfortran/regression/goacc/assumed.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/assumed.f95 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +module test +contains + subroutine assumed_size(a) + implicit none + integer :: a(*), i + !$acc declare device_resident (a) ! { dg-error "Assumed size" } + !$acc data copy (a) ! { dg-error "Assumed size" } + !$acc end data + !$acc data deviceptr (a) ! { dg-error "Assumed size" } + !$acc end data + !$acc parallel private (a) ! { dg-error "Assumed size" } + !$acc end parallel + !$acc host_data use_device (a) ! { dg-error "Assumed size" } + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "Assumed size" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) ! { dg-error "Assumed size" } + !$acc update host (a) ! { dg-error "Assumed size" } + !$acc update self (a) ! { dg-error "Assumed size" } + end subroutine assumed_size + subroutine assumed_rank(a) + implicit none + integer, intent(in) :: a(..) + integer :: i + !$acc declare device_resident (a) ! { dg-error "Assumed rank" } + !$acc data copy (a) ! { dg-error "Assumed rank" } + !$acc end data + !$acc data deviceptr (a) ! { dg-error "Assumed rank" } + !$acc end data + !$acc parallel private (a) ! { dg-error "Assumed rank" } + !$acc end parallel + !$acc host_data use_device (a) ! { dg-error "Assumed rank" } + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "Assumed rank" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) ! { dg-error "Assumed rank" } + !$acc update host (a) ! { dg-error "Assumed rank" } + !$acc update self (a) ! { dg-error "Assumed rank" } + end subroutine assumed_rank +end module test + +! { dg-error "Array 'a' is not permitted in reduction" "" { target "*-*-*" } 18 } +! { dg-error "Array 'a' is not permitted in reduction" "" { target "*-*-*" } 39 } Index: Fortran/gfortran/regression/goacc/asyncwait-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/asyncwait-1.f95 @@ -0,0 +1,91 @@ +! { dg-do compile } + +program asyncwait + integer, parameter :: N = 64 + real, allocatable :: a(:), b(:) + integer i + + allocate (a(N)) + allocate (b(N)) + + a(:) = 3.0 + b(:) = 0.0 + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1 2) ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1,) ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (,1) ! { dg-error "Invalid character in name" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1,2,) ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1,2 3) ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1,2,,) ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1 ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (*) ! { dg-error "Invalid character in name" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (a) ! { dg-error "ASYNC clause at \\\(1\\\) requires a scalar INTEGER expression" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (N) + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async (1.0) ! { dg-error "ASYNC clause at \\\(1\\\) requires a scalar INTEGER expression" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async () ! { dg-error "Invalid character in name at " } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) async + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel +end program asyncwait Index: Fortran/gfortran/regression/goacc/asyncwait-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/asyncwait-2.f95 @@ -0,0 +1,103 @@ +! { dg-do compile } + +program asyncwait + integer, parameter :: N = 64 + real, allocatable :: a(:), b(:) + integer i + + allocate (a(N)) + allocate (b(N)) + + a(:) = 3.0 + b(:) = 0.0 + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1 2) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1,) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (,1) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1,2,) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1,2 3) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1,2,,) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1 ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (*) ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (a) ! { dg-error "WAIT clause at \\\(1\\\) requires a scalar INTEGER expression" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (N) + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait (1.0) ! { dg-error "WAIT clause at \\\(1\\\) requires a scalar INTEGER expression" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait () ! { dg-error "Syntax error in OpenACC expression list" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) waitasync ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) asyncwait ! { dg-error "Failed to match clause" } + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel ! { dg-error "Unexpected \\\!\\\$ACC END PARALLEL" } + + !$acc parallel copyin (a(1:N)) copy (b(1:N)) wait + do i = 1, N + b(i) = a(i) + end do + !$acc end parallel +end program asyncwait Index: Fortran/gfortran/regression/goacc/asyncwait-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/asyncwait-3.f95 @@ -0,0 +1,41 @@ +! { dg-do compile } + +program asyncwait + integer, parameter :: N = 64 + real, allocatable :: a(:), b(:) + integer i + + allocate (a(N)) + allocate (b(N)) + + a(:) = 3.0 + b(:) = 0.0 + + !$acc wait (1 2) ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (1,) ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (,1) ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (1, 2, ) ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (1, 2, ,) ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (1 ! { dg-error "Syntax error in OpenACC expression list at" } + + !$acc wait (1, *) ! { dg-error "Invalid argument to \\\!\\\$ACC WAIT" } + + !$acc wait (1, a) ! { dg-error "WAIT clause at \\\(1\\\) requires a scalar INTEGER expression" } + + !$acc wait (a) ! { dg-error "WAIT clause at \\\(1\\\) requires a scalar INTEGER expression" } + + !$acc wait (N) + + !$acc wait (1.0) ! { dg-error "WAIT clause at \\\(1\\\) requires a scalar INTEGER expression" } + + !$acc wait 1 ! { dg-error "Failed to match clause" } + + !$acc wait N ! { dg-error "Failed to match clause" } + + !$acc wait (1) +end program asyncwait Index: Fortran/gfortran/regression/goacc/asyncwait-4.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/asyncwait-4.f95 @@ -0,0 +1,41 @@ +! { dg-do compile } + +program asyncwait + integer, parameter :: N = 64 + real, allocatable :: a(:), b(:) + integer i + + allocate (a(N)) + allocate (b(N)) + + a(:) = 3.0 + b(:) = 0.0 + + !$acc wait async (1 2) ! { dg-error "Failed to match clause" } + + !$acc wait async (1,) ! { dg-error "Failed to match clause" } + + !$acc wait async (,1) ! { dg-error "Invalid character in name" } + + !$acc wait async (1, 2, ) ! { dg-error "Failed to match clause" } + + !$acc wait async (1, 2, ,) ! { dg-error "Failed to match clause" } + + !$acc wait async (1 ! { dg-error "Failed to match clause" } + + !$acc wait async (1, *) ! { dg-error "Failed to match clause" } + + !$acc wait async (1, a) ! { dg-error "Failed to match clause" } + + !$acc wait async (a) ! { dg-error "ASYNC clause at \\\(1\\\) requires a scalar INTEGER expression" } + + !$acc wait async (N) + + !$acc wait async (1.0) ! { dg-error "ASYNC clause at \\\(1\\\) requires a scalar INTEGER expression" } + + !$acc wait async 1 ! { dg-error "Failed to match clause" } + + !$acc waitasync ! { dg-error "Failed to match clause" } + + !$acc wait,async ! { dg-error "Failed to match clause" } +end program asyncwait Index: Fortran/gfortran/regression/goacc/asyncwait-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/asyncwait-5.f @@ -0,0 +1,33 @@ +! Multiple OpenACC wait clauses. + +! { dg-additional-options "-fdump-tree-original" } + +!$ACC PARALLEL ASYNC (1) WAIT (14) +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(1\\) wait\\(14\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (2) WAIT (11, 12) WAIT(13) +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(2\\) wait\\(11\\) wait\\(12\\) wait\\(13\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (3) WAIT +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(3\\) wait\\(-1\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (4) WAIT (100) WAIT +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(4\\) wait\\(100\\) wait\\(-1\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (5) WAIT WAIT (101) +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(5\\) wait\\(-1\\) wait\\(101\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (6) WAIT WAIT (102, 103) WAIT WAIT +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(6\\) wait\\(-1\\) wait\\(102\\) wait\\(103\\) wait\\(-1\\) wait\\(-1\\)$" 1 "original" } } + +!$ACC PARALLEL ASYNC (7) WAIT (104) WAIT WAIT (105, 106) +!$ACC END PARALLEL +! { dg-final { scan-tree-dump-times "(?n)#pragma acc parallel async\\(7\\) wait\\(104\\) wait\\(-1\\) wait\\(105\\) wait\\(106\\)$" 1 "original" } } + + END Index: Fortran/gfortran/regression/goacc/atomic-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/atomic-1.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! +! PR fortran/93462 +! +! Contributed by G. Steinmetz +! +program p + integer :: n = 1 + integer :: a +!$acc atomic write + a = f(n) - f(n) +contains + integer function f(x) + integer, intent(in) :: x + f = x + end +end Index: Fortran/gfortran/regression/goacc/atomic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/atomic.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } + +subroutine foo + integer :: i, v + !$acc atomic read bar ! { dg-error "21: Unexpected junk after !.ACC ATOMIC statement" } + i = v + + !$acc atomic read write ! { dg-error "21: Unexpected junk after !.ACC ATOMIC statement" } + i = v + + !$acc atomic read seq_cst ! { dg-error "21: Unexpected junk after !.ACC ATOMIC statement" } + i = v + + !$acc atomic read relaxed ! { dg-error "21: Unexpected junk after !.ACC ATOMIC statement" } + i = v + + !$acc atomic update hint(1) ! { dg-error "23: Unexpected junk after !.ACC ATOMIC statement" } + i = i + 1 + + !$acc atomic update update capture ! { dg-error "23: Unexpected junk after !.ACC ATOMIC statement" } + i = i + 1 + v = i + + !$acc atomic update capture capture ! { dg-error "23: Unexpected junk after !.ACC ATOMIC statement" } + i = i + 1 + v = i + + !$acc atomic write capture ! { dg-error "22: Unexpected junk after !.ACC ATOMIC statement" } + i = 1 + + ! Valid in C/C++ since OpenACC 2.5 but not in Fortran: + !$acc atomic update capture ! { dg-error "23: Unexpected junk after !.ACC ATOMIC statement" } + i = i + 1 + v = i +end Index: Fortran/gfortran/regression/goacc/attach-descriptor.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/attach-descriptor.f90 @@ -0,0 +1,29 @@ +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + +program att + implicit none + type t + integer :: arr1(10) + integer, allocatable :: arr2(:) + end type t + type(t) :: myvar + integer, target :: tarr(10) + integer, pointer :: myptr(:) + + !$acc enter data attach(myvar%arr2, myptr) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc enter data map\\(attach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_enter_data map\\(attach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(attach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } + + !$acc exit data detach(myvar%arr2, myptr) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:myptr\\.data \\\[bias: 0\\\]\\)$" 1 "gimple" } } + + ! Test valid usage and processing of the finalize clause. + !$acc exit data detach(myvar%arr2, myptr) finalize +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(detach:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) myptr\\.data \\\[bias: 0\\\]\\) finalize;$" 1 "original" } } + ! For array-descriptor detaches, we no longer generate a "release" mapping + ! for the pointed-to data for gimplify.c to turn into "delete". Make sure + ! the mapping still isn't there. +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_detach:myvar\\.arr2 \\\[bias: 0\\\]\\) map\\(to:myptr \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(force_detach:myptr\\.data \\\[bias: 0\\\]\\) finalize$" 1 "gimple" } } + +end program att Index: Fortran/gfortran/regression/goacc/branch.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/branch.f95 @@ -0,0 +1,53 @@ +! { dg-do compile } + +program test + implicit none + + integer :: i + + if (.true.) then + !$acc parallel + end if ! { dg-error "Unexpected" } + !$acc end parallel + end if + + if (.true.) then + !$acc kernels + end if ! { dg-error "Unexpected" } + !$acc end kernels + end if + + !$acc parallel + if (.true.) then + !$acc end parallel ! { dg-error "Unexpected" } + end if + !$acc end parallel + + !$acc kernels + if (.true.) then + !$acc end kernels ! { dg-error "Unexpected" } + end if + !$acc end kernels + + !$acc parallel + if (.true.) then + end if + !$acc end parallel + + !$acc kernels + if (.true.) then + end if + !$acc end kernels + + if (.true.) then + !$acc parallel + !$acc end parallel + end if + + if (.true.) then + !$acc kernels + !$acc end kernels + end if + + +end program test \ No newline at end of file Index: Fortran/gfortran/regression/goacc/cache-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/cache-1.f95 @@ -0,0 +1,16 @@ +! OpenACC cache directive: valid usage. +! For execution testing, this file is "#include"d from +! libgomp/testsuite/libgomp.oacc-fortran/cache-1.f95. +! { dg-additional-options "-std=f2008" } + +program test + implicit none + integer :: i, d(10), e(5,13) + + do concurrent (i=1:5) + !$acc cache (d(1:3)) + !$acc cache (d(i:i+2)) + !$acc cache (e(1:3,2:4)) + !$acc cache (e(i:i+2,i+1:i+3)) + enddo +end Index: Fortran/gfortran/regression/goacc/cache-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/cache-2.f95 @@ -0,0 +1,12 @@ +! OpenACC cache directive: invalid usage. +! { dg-additional-options "-std=f2008" } + +program test + implicit none + integer :: i, d(10), e(5,13) + + do concurrent (i=1:5) + !$acc cache (d) ! { dg-error "" "TODO" { xfail *-*-* } } + !$acc cache (e) ! { dg-error "" "TODO" { xfail *-*-* } } + enddo +end Index: Fortran/gfortran/regression/goacc/classify-kernels-parloops.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-kernels-parloops.f95 @@ -0,0 +1,44 @@ +! Check offloaded function's attributes and classification for OpenACC +! kernels. + +! { dg-additional-options "--param openacc-kernels=parloops" } + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute1 } + ! { dg-optimized {assigned OpenACC gang loop parallelism} {} { target *-*-* } l_compute1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do + !$acc end kernels +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check that exactly one OpenACC kernels construct is analyzed, and that it +! can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 1 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is parallelized OpenACC kernels offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/classify-kernels-unparallelized-parloops.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-kernels-unparallelized-parloops.f95 @@ -0,0 +1,48 @@ +! Check offloaded function's attributes and classification for unparallelized +! OpenACC kernels. + +! { dg-additional-options "--param openacc-kernels=parloops" } + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + ! An "external" mapping of loop iterations/array indices makes the loop + ! unparallelizable. + integer, external :: f + + call setup(a, b) + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute1 } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute1 } + do i = 0, n - 1 + c(i) = a(f (i)) + b(f (i)) + end do + !$acc end kernels +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check that exactly one OpenACC kernels construct is analyzed, and that it +! can't be parallelized. +! { dg-final { scan-tree-dump-times "FAILED:" 1 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" } } +! { dg-final { scan-tree-dump-not "SUCCESS: may be parallelized" "parloops1" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is unparallelized OpenACC kernels offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/classify-kernels-unparallelized.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-kernels-unparallelized.f95 @@ -0,0 +1,49 @@ +! Check offloaded function's attributes and classification for unparallelized +! OpenACC kernels. + +! { dg-additional-options "--param openacc-kernels=decompose" } + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-all-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + ! An "external" mapping of loop iterations/array indices makes the loop + ! unparallelizable. + integer, external :: f + + call setup(a, b) + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute1 } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute1 } + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + do i = 0, n - 1 + c(i) = a(f (i)) + b(f (i)) + end do + !$acc end kernels +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check that exactly one OpenACC kernels construct is analyzed, and that it +! can't be parallelized. +! { dg-final { scan-tree-dump-times "FAILED:" 1 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" } } +! { dg-final { scan-tree-dump-not "SUCCESS: may be parallelized" "parloops1" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is unparallelized OpenACC kernels offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/classify-kernels.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-kernels.f95 @@ -0,0 +1,47 @@ +! Check offloaded function's attributes and classification for OpenACC +! kernels. + +! { dg-additional-options "--param openacc-kernels=decompose" } + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-all-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute1 } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'i' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute1 } */ + ! { dg-note {variable 'i' made addressable} {} { target *-*-* } l_compute1 } */ + ! { dg-optimized {assigned OpenACC gang loop parallelism} {} { target *-*-* } l_compute1 } + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do + !$acc end kernels +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check that exactly one OpenACC kernels construct is analyzed, and that it +! can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 1 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is parallelized OpenACC kernels offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/classify-parallel.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-parallel.f95 @@ -0,0 +1,35 @@ +! Check offloaded function's attributes and classification for OpenACC +! parallel. + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc parallel loop copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute_loop_i1 } + ! { dg-optimized {assigned OpenACC gang vector loop parallelism} {} { target *-*-* } l_compute_loop_i1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do + !$acc end parallel loop +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc parallel, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is OpenACC parallel offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc parallel, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/classify-routine-nohost.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-routine-nohost.f95 @@ -0,0 +1,40 @@ +! Check offloaded function's attributes and classification for OpenACC +! routine with 'nohost' clause. + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +subroutine ROUTINE + !$acc routine nohost worker + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc loop ! { dg-line l_loop_i1 } + ! { dg-bogus {optimized: assigned OpenACC [^\n\r]+ loop parallelism} {} { target *-*-* } l_loop_i1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do +end subroutine ROUTINE + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(0 1, 1 0, 1 0\\), omp declare target \\(nohost worker\\)\\)\\)" 1 "ompexp" } } + +! Check the offloaded function's classification. +! { dg-final { scan-tree-dump-times "(?n)Function is OpenACC routine level 1" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine' has 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine_' has 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine' discarded" 1 "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine_' discarded" 1 "oaccloops" { target offloading_enabled } } } +! { dg-final { scan-tree-dump-not "(?n)Compute dimensions" "oaccloops" } } +! { dg-final { scan-tree-dump-not "(?n)__attribute__\\(.*omp declare target \\(nohost" "oaccloops" } } +! { dg-final { scan-tree-dump-not "(?n)void routine \\(\\)" "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-not "(?n)void routine_ \\(\\)" "oaccloops" { target offloading_enabled } } } +!TODO See PR101551 for 'offloading_enabled' differences. Index: Fortran/gfortran/regression/goacc/classify-routine.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-routine.f95 @@ -0,0 +1,41 @@ +! Check offloaded function's attributes and classification for OpenACC +! routine. + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +subroutine ROUTINE + !$acc routine worker + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc loop ! { dg-line l_loop_i1 } + ! { dg-optimized {assigned OpenACC worker vector loop parallelism} {} { target *-*-* } l_loop_i1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do +end subroutine ROUTINE + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(0 1, 1 0, 1 0\\), omp declare target \\(worker\\)\\)\\)" 1 "ompexp" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is OpenACC routine level 1" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine' doesn't have 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine_' doesn't have 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine' not discarded" 1 "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'routine_' not discarded" 1 "oaccloops" { target offloading_enabled } } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(0 1, 1 1, 1 1\\), omp declare target \\(worker\\)\\)\\)" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)void routine \\(\\)" 1 "oaccloops" { target { ! offloading_enabled } } } } +! { dg-final { scan-tree-dump-times "(?n)void routine_ \\(\\)" 1 "oaccloops" { target offloading_enabled } } } +!TODO See PR101551 for 'offloading_enabled' differences. Index: Fortran/gfortran/regression/goacc/classify-serial.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/classify-serial.f95 @@ -0,0 +1,38 @@ +! Check offloaded function's attributes and classification for OpenACC +! serial. + +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-fdump-tree-ompexp" } +! { dg-additional-options "-fdump-tree-oaccloops" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i + + call setup(a, b) + + !$acc serial loop copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) ! { dg-line l_compute_loop_i1 } + ! { dg-bogus "\[Ww\]arning: region contains gang partitioned code but is not gang partitioned" "TODO 'serial'" { xfail *-*-* } l_compute_loop_i1 } + ! { dg-bogus "\[Ww\]arning: region contains worker partitioned code but is not worker partitioned" "" { target *-*-* } l_compute_loop_i1 } + ! { dg-bogus "\[Ww\]arning: region contains vector partitioned code but is not vector partitioned" "TODO 'serial'" { xfail *-*-* } l_compute_loop_i1 } + ! { dg-optimized {assigned OpenACC gang vector loop parallelism} {} { target *-*-* } l_compute_loop_i1 } + do i = 0, n - 1 + c(i) = a(i) + b(i) + end do + !$acc end serial loop +end program main + +! Check the offloaded function's attributes. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc serial, omp target entrypoint, noclone\\)\\)" 1 "ompexp" } } + +! Check the offloaded function's classification and compute dimensions (will +! always be 1 x 1 x 1 for non-offloading compilation). +! { dg-final { scan-tree-dump-times "(?n)Function is OpenACC serial offload" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)Compute dimensions \\\[1, 1, 1\\\]" 1 "oaccloops" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc function \\(1, 1, 1\\), oacc serial, omp target entrypoint, noclone\\)\\)" 1 "oaccloops" } } Index: Fortran/gfortran/regression/goacc/coarray.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/coarray.f95 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +! PR fortran/63861 + +module test +contains + subroutine oacc1(a) + implicit none + integer :: i + integer, codimension[*] :: a + !$acc declare device_resident (a) + !$acc data copy (a) + !$acc end data + !$acc data deviceptr (a) + !$acc end data + !$acc parallel private (a) + !$acc end parallel + !$acc host_data use_device (a) + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !$acc cache (a) ! { dg-error "" "TODO" { xfail *-*-* } } + enddo + !$acc end parallel loop + !$acc update device (a) + !$acc update host (a) + !$acc update self (a) + end subroutine oacc1 +end module test Index: Fortran/gfortran/regression/goacc/coarray_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/coarray_2.f90 @@ -0,0 +1,107 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=lib" } +! +! PR fortran/63861 + +module test +contains + subroutine oacc1(a) + implicit none + integer :: i + integer, codimension[*] :: a + !$acc declare device_resident (a) + !$acc data copy (a) + !$acc end data + !$acc data deviceptr (a) + !$acc end data + !$acc parallel private (a) + !$acc end parallel + !$acc host_data use_device (a) + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) + !$acc update host (a) + !$acc update self (a) + end subroutine oacc1 + + subroutine oacc2(a) + implicit none + integer :: i + integer, allocatable, codimension[:] :: a + !$acc declare device_resident (a) + !$acc data copy (a) + !$acc end data + !$acc parallel private (a) + !$acc end parallel +! FIXME: +! !$acc parallel loop reduction(+:a) +! This involves an assignment, which shall not reallocate +! the LHS variable. Version without reduction: + !$acc parallel loop + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) + !$acc update host (a) + !$acc update self (a) + end subroutine oacc2 + + subroutine oacc3(a) + implicit none + integer :: i + integer, codimension[*] :: a(:) + !$acc declare device_resident (a) + !$acc data copy (a) + !$acc end data + !$acc data deviceptr (a) + !$acc end data + !$acc parallel private (a) + !$acc end parallel + !$acc host_data use_device (a) + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) + !$acc update host (a) + !$acc update self (a) + end subroutine oacc3 + + subroutine oacc4(a) + implicit none + integer :: i + integer, allocatable, codimension[:] :: a(:) + !$acc declare device_resident (a) + !$acc data copy (a) + !$acc end data + !$acc parallel private (a) + !$acc end parallel + !$acc parallel loop reduction(+:a) ! { dg-error "Array 'a' is not permitted in reduction" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + enddo + !$acc end parallel loop + !$acc update device (a) + !$acc update host (a) + !$acc update self (a) + end subroutine oacc4 +end module test Index: Fortran/gfortran/regression/goacc/coindexed-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/coindexed-1.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } +! +subroutine check_coindexed() +implicit none +type t + integer :: i +end type t +type t2 + integer, allocatable :: i[:] + type(t), allocatable :: x[:] +end type t2 +type(t), allocatable :: A(:)[:], B(:)[:] +type(t) :: D(1)[*], E[*] +type(t2) :: C +save :: D, E + +! Coarrays are fine if they are local/not coindexed: + +!$acc enter data copyin(D(1)%i) +!$acc enter data copyin(A(1)) +!$acc enter data copyin(B(1)%i) +!$acc enter data copyin(C%i) +!$acc enter data copyin(C%x%i) +!$acc enter data copyin(C%i) +!$acc enter data copyin(C%x%i) + +! Does not like the '[' after the identifier: +!$acc enter data copyin(E[2]) ! { dg-error "Syntax error in OpenMP variable list" } + +!$acc enter data copyin(D(1)[2]%i) ! { dg-error "List item shall not be coindexed" } +!$acc enter data copyin(A(1)[4]) ! { dg-error "List item shall not be coindexed" } +!$acc enter data copyin(B(1)[4]%i) ! { dg-error "List item shall not be coindexed" } +!$acc enter data copyin(C%i[2]) ! { dg-error "List item shall not be coindexed" } +!$acc enter data copyin(C%x[4]%i) ! { dg-error "List item shall not be coindexed" } + +end Index: Fortran/gfortran/regression/goacc/combined-directives-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/combined-directives-3.f90 @@ -0,0 +1,26 @@ +! Verify the accuracy of the line number associated with combined constructs. +! See "../../c-c++-common/goacc/combined-directives-3.c". + +subroutine test + implicit none + integer x, y, z + + !$acc parallel loop seq auto ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + do x = 0, 10 + !$acc loop + do y = 0, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop gang auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + do x = 0, 10 + !$acc loop worker auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + do y = 0, 10 + !$acc loop vector + do z = 0, 10 + end do + end do + end do + !$acc end parallel loop +end subroutine test Index: Fortran/gfortran/regression/goacc/combined-directives.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/combined-directives.f90 @@ -0,0 +1,150 @@ +! Exercise combined OpenACC directives. + +! { dg-additional-options "-fdump-tree-gimple" } + +subroutine test + implicit none + integer a(100), i, j, y, z + + ! PARALLEL + + !$acc parallel loop collapse (2) + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop gang + do i = 1, 100 + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop seq + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop auto + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop tile (2, 3) + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end parallel loop + + !$acc parallel loop independent + do i = 1, 100 + end do + !$acc end parallel loop + + !$acc parallel loop private (z) + do i = 1, 100 + z = 0 + end do + !$acc end parallel loop + + !$acc parallel loop reduction (+:y) copy (y) + do i = 1, 100 + end do + !$acc end parallel loop + + ! KERNELS + + !$acc kernels loop collapse (2) + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop gang + do i = 1, 100 + end do + !$acc end kernels loop + + !$acc kernels loop worker + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop vector + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop seq + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop auto + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop tile (2, 3) + do i = 1, 100 + do j = 1, 10 + end do + end do + !$acc end kernels loop + + !$acc kernels loop independent + do i = 1, 100 + end do + !$acc end kernels loop + + !$acc kernels loop private (z) + do i = 1, 100 + z = 0 + end do + !$acc end kernels loop + + !$acc kernels loop reduction (+:y) copy (y) + do i = 1, 100 + end do + !$acc end kernels loop +end subroutine test + +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. collapse.2." 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. gang" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. worker" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. vector" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. seq" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. auto" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. private.j. tile.2, 3" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. independent" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "private.z" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "omp target oacc_\[^ \]+ map.tofrom:y" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "acc loop private.i. reduction..:y." 2 "gimple" } } Index: Fortran/gfortran/regression/goacc/combined_loop.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/combined_loop.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +! +! PR fortran/64726 +! +subroutine oacc1() + implicit none + integer :: i + integer :: a + !$acc parallel loop reduction(+:a) + do i = 1,5 + enddo + !$acc end parallel loop + !$acc kernels loop collapse(2) + do i = 2,6 + do a = 3,5 + enddo + enddo + !$acc end kernels loop +end subroutine oacc1 Index: Fortran/gfortran/regression/goacc/common-block-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/common-block-1.f90 @@ -0,0 +1,78 @@ +! Test data clauses involving common blocks and common block data. +! Specifically, validates early matching errors. + +subroutine subtest + implicit none + integer, parameter :: n = 10 + integer a(n), b(n), c, d(n), e + real*4 x(n), y(n), z, w(n), v + common /blockA/ a, c, x + common /blockB/ b, y, z + !$acc declare link(/blockA/, /blockB/, e, v) +end subroutine subtest + +program test + implicit none + integer, parameter :: n = 10 + integer a(n), b(n), c, d(n), e + real*4 x(n), y(n), z, w(n), v + common /blockA/ a, c, x + common /blockB/ b, y, z + + !$acc declare link(/blockA/, /blockB/, e, v) + + !$acc data copy(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data copyin(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data copyout(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data create(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data copyout(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data pcopy(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data pcopyin(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data pcopyout(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data pcreate(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data pcopyout(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc data no_create(/blockA/, /blockB/, e, v) + !$acc end data + + !$acc parallel private(/blockA/, /blockB/, e, v) + !$acc end parallel + + !$acc parallel firstprivate(/blockA/, /blockB/, e, v) + !$acc end parallel + + !$acc update device(/blockA/) + !$acc update self(/blockB/, v) + !$acc update host(/blockA/, e, /blockB/) + + !$acc enter data pcopyin(/blockA/, /blockB/, e, v) + !$acc exit data delete(/blockA/, /blockB/, e, v) + + + ! No /block/ permitted in present and deviceptr: + + !$acc data present(/blockA/, /blockB/, e, v) ! { dg-error "Syntax error in OpenMP variable list" } + !$acc end data ! { dg-error "Unexpected ..ACC END DATA statement" } + + !$acc data deviceptr(/blockA/, /blockB/, e, v) ! { dg-error "Syntax error in OpenMP variable list" } + !$acc end data ! { dg-error "Unexpected ..ACC END DATA statement" } +end program test Index: Fortran/gfortran/regression/goacc/common-block-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/common-block-2.f90 @@ -0,0 +1,57 @@ +! Test data clauses involving common blocks and common block data. +! Specifically, resolver errors such as duplicate data clauses. + +program test + implicit none + integer, parameter :: n = 10 + integer a(n), b(n), c, d(n), e + real*4 x(n), y(n), z, w(n), v + common /blockA/ a, c, x + common /blockB/ b, y, z + + !$acc data copy(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data copyin(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data copyout(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data create(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data copyout(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data pcopy(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data pcopyin(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data pcopyout(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data pcreate(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data pcopyout(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc data no_create(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end data + + !$acc parallel private(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end parallel + + !$acc parallel firstprivate(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } + !$acc end parallel + + !$acc update device(b, /blockA/, x) ! { dg-error "Symbol .x. present on multiple clauses" } + !$acc update self(z, /blockB/, v) ! { dg-error "Symbol .z. present on multiple clauses" } + !$acc update host(/blockA/, c) ! { dg-error "Symbol .c. present on multiple clauses" } + + !$acc enter data copyin(/blockB/, e, v, a, c, y) ! { dg-error "Symbol .y. present on multiple clauses" } + !$acc exit data delete(/blockA/, /blockB/, e, v, a) ! { dg-error "Symbol .a. present on multiple clauses" } +end program test Index: Fortran/gfortran/regression/goacc/common-block-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/common-block-3.f90 @@ -0,0 +1,63 @@ +! { dg-options "-fopenacc -fdump-tree-omplower" } + +! { dg-additional-options "--param=openacc-kernels=decompose" } + +! { dg-additional-options "-fopt-info-omp-all" } + +! { dg-additional-options "--param=openacc-privatization=noisy" } +! Prune a few: uninteresting, and potentially varying depending on GCC configuration (data types): +! { dg-prune-output {note: variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} } + +module consts + integer, parameter :: n = 100 +end module consts + +program main + use consts + implicit none + + integer :: i, j + real :: a(n) = 0, b(n) = 0, c, d, e(n) + real :: x(n) = 0, y(n), z + common /BLOCK/ a, b, c, j, d + common /KERNELS_BLOCK/ x, y, z + + c = 1.0 + !$acc parallel loop copy(/BLOCK/) ! { dg-line l1 } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l1 } + ! { dg-optimized {assigned OpenACC gang vector loop parallelism} {} { target *-*-* } l1 } + do i = 1, n + a(i) = b(i) + c + end do + !$acc kernels ! { dg-line l2 } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'i' in 'copy' clause requested to be made addressable} {} { target *-*-* } l2 } + ! { dg-note {variable 'i' made addressable} {} { target *-*-* } l2 } + ! { dg-note {variable 'c\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l2 } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l2 } + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + do i = 1, n + x(i) = y(i) + c + end do + !$acc end kernels +end program main + +! { dg-final { scan-tree-dump-times "omp target oacc_parallel .*map\\(tofrom:a \\\[len: 400\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_parallel .*map\\(tofrom:b \\\[len: 400\\\]\\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_parallel .*map\\(tofrom:c \\\[len: 4\\\]\\)" 1 "omplower" } } + +! { dg-final { scan-tree-dump-times "omp target oacc_data_kernels .*map\\(force_tofrom:i \\\[len: 4\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_kernels .*map\\(force_present:i \\\[len: 4\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_data_kernels .*map\\(tofrom:x \\\[len: 400\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_kernels .*map\\(force_present:x \\\[len: 400\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_data_kernels .*map\\(tofrom:y \\\[len: 400\\\]\\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_kernels .*map\\(force_present:y \\\[len: 400\\\]\\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_data_kernels .*map\\(force_tofrom:c \\\[len: 4\\\]\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "omp target oacc_kernels .*map\\(force_present:c \\\[len: 4\\\]\\)" 1 "omplower" } } + +! Expecting no mapping of un-referenced common-blocks variables + +! { dg-final { scan-tree-dump-not "map\\(.*:block" "omplower" } } +! { dg-final { scan-tree-dump-not "map\\(.*:kernels_block" "omplower" } } +! { dg-final { scan-tree-dump-not "map\\(.*:d " "omplower" } } +! { dg-final { scan-tree-dump-not "map\\(.*:e " "omplower" } } +! { dg-final { scan-tree-dump-not "map\\(.*:z " "omplower" } } Index: Fortran/gfortran/regression/goacc/continuation-free-form.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/continuation-free-form.f95 @@ -0,0 +1,23 @@ +! { dg-do compile } + +program test + implicit none + + integer :: i + real :: x + + !$acc parallel & + !$acc loop & ! continuation + !$acc & reduction(+:x) + + ! this line must be ignored + !$acc ! kernels + do i = 1,10 + x = x + 0.3 + enddo + ! continuation must begin with sentinel + !$acc end parallel & ! { dg-error "Unexpected junk" } + ! loop + + print *, x +end Index: Fortran/gfortran/regression/goacc/cray-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/cray-2.f95 @@ -0,0 +1,56 @@ +! { dg-additional-options "-fcray-pointer" } +! See also cray.f95. + +program test + call oacc1 +contains + subroutine oacc1 + implicit none + integer :: i + real :: pointee + pointer (ptr, pointee) + !$acc declare device_resident (pointee) + !$acc declare device_resident (ptr) + !$acc data copy (pointee) ! { dg-error "Cray pointee" } + !$acc end data + !$acc data deviceptr (pointee) ! { dg-error "Cray pointee" } + !$acc end data + !$acc parallel private (pointee) ! { dg-error "Cray pointee" } + !$acc end parallel + !$acc host_data use_device (pointee) ! { dg-error "Cray pointee" } + !$acc end host_data + !$acc parallel loop reduction(+:pointee) ! { dg-error "Cray pointee" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !$acc cache (pointee) ! { dg-error "Cray pointee" } + enddo + !$acc end parallel loop + !$acc update device (pointee) ! { dg-error "Cray pointee" } + !$acc update host (pointee) ! { dg-error "Cray pointee" } + !$acc update self (pointee) ! { dg-error "Cray pointee" } + !$acc data copy (ptr) + !$acc end data + !$acc data deviceptr (ptr) ! { dg-error "Cray pointer" } + !$acc end data + !$acc parallel private (ptr) + !$acc end parallel + !$acc host_data use_device (ptr) ! { dg-error "Cray pointer" } + !$acc end host_data + !$acc parallel loop reduction(+:ptr) ! { dg-error "Cray pointer" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !TODO: This must fail, as in openacc-1_0-branch. + !$acc cache (ptr) ! { dg-error "" "TODO" { xfail *-*-* } } + enddo + !$acc end parallel loop + !$acc update device (ptr) + !$acc update host (ptr) + !$acc update self (ptr) + end subroutine oacc1 +end program test Index: Fortran/gfortran/regression/goacc/cray.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/cray.f95 @@ -0,0 +1,55 @@ +! { dg-additional-options "-fcray-pointer" } +! See also cray-2.f95. + +module test +contains + subroutine oacc1 + implicit none + integer :: i + real :: pointee + pointer (ptr, pointee) + !$acc declare device_resident (pointee) + !$acc declare device_resident (ptr) + !$acc data copy (pointee) ! { dg-error "Cray pointee" } + !$acc end data + !$acc data deviceptr (pointee) ! { dg-error "Cray pointee" } + !$acc end data + !$acc parallel private (pointee) ! { dg-error "Cray pointee" } + !$acc end parallel + !$acc host_data use_device (pointee) ! { dg-error "Cray pointee" } + !$acc end host_data + !$acc parallel loop reduction(+:pointee) ! { dg-error "Cray pointee" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !$acc cache (pointee) ! { dg-error "Cray pointee" } + enddo + !$acc end parallel loop + !$acc update device (pointee) ! { dg-error "Cray pointee" } + !$acc update host (pointee) ! { dg-error "Cray pointee" } + !$acc update self (pointee) ! { dg-error "Cray pointee" } + !$acc data copy (ptr) + !$acc end data + !$acc data deviceptr (ptr) ! { dg-error "Cray pointer" } + !$acc end data + !$acc parallel private (ptr) + !$acc end parallel + !$acc host_data use_device (ptr) ! { dg-error "Cray pointer" } + !$acc end host_data + !$acc parallel loop reduction(+:ptr) ! { dg-error "Cray pointer" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !TODO: This must fail, as in openacc-1_0-branch. + !$acc cache (ptr) ! { dg-error "" "TODO" { xfail *-*-* } } + enddo + !$acc end parallel loop + !$acc update device (ptr) + !$acc update host (ptr) + !$acc update self (ptr) + end subroutine oacc1 +end module test Index: Fortran/gfortran/regression/goacc/critical.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/critical.f95 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-additional-options "-fcoarray=single" } + +module test +contains + subroutine oacc1 + implicit none + integer :: i, j + j = 0 + !$acc parallel + critical ! { dg-error "CRITICAL block inside of" } + j = j + 1 + end critical + !$acc end parallel + end subroutine oacc1 + + subroutine oacc2 + implicit none + integer :: i, j + j = 0 + critical + !$acc parallel ! { dg-error "OpenACC directive inside of" } + j = j + 1 + !$acc end parallel + end critical + end subroutine oacc2 +end module test \ No newline at end of file Index: Fortran/gfortran/regression/goacc/data-clauses.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/data-clauses.f95 @@ -0,0 +1,280 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +module test + implicit none +contains + + subroutine foo (vi, asa) + integer, value :: vi + integer :: i, ia(10) + complex :: c, ca(10) + real, target:: r + real :: ra(10) + real, pointer :: rp + real, dimension(:), allocatable :: aa + real, dimension(:) :: asa + type t + integer :: i + end type + type(t) :: ti + type(t), allocatable :: tia + type(t), target :: tit + type(t), pointer :: tip + rp => r + tip => tit + + !$acc parallel deviceptr (rp) ! { dg-error "POINTER" } + !$acc end parallel + !$acc parallel deviceptr (vi) ! { dg-error "VALUE" } + !$acc end parallel + !$acc parallel deviceptr (aa) ! { dg-error "ALLOCATABLE" } + !$acc end parallel + + !$acc parallel deviceptr (i, c, r, ia, ca, ra, asa, ti) + !$acc end parallel + !$acc kernels deviceptr (i, c, r, ia, ca, ra, asa, ti) + !$acc end kernels + !$acc data deviceptr (i, c, r, ia, ca, ra, asa, ti) + !$acc end data + + + !$acc parallel copy (tip) + !$acc end parallel + !$acc parallel copy (tia) + !$acc end parallel + !$acc parallel deviceptr (i) copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel copyin (tip) + !$acc end parallel + !$acc parallel copyin (tia) + !$acc end parallel + !$acc parallel deviceptr (i) copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel copyout (tip) + !$acc end parallel + !$acc parallel copyout (tia) + !$acc end parallel + !$acc parallel deviceptr (i) copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel create (tip) + !$acc end parallel + !$acc parallel create (tia) + !$acc end parallel + !$acc parallel deviceptr (i) create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel no_create (tip) + !$acc end parallel + !$acc parallel no_create (tia) + !$acc end parallel + !$acc parallel deviceptr (i) no_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) no_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) no_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) no_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel no_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels no_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data no_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel present (tip) + !$acc end parallel + !$acc parallel present (tia) + !$acc end parallel + !$acc parallel deviceptr (i) present (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) present (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) present (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) present (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel create (i) present (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel present (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels present (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data present (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel pcopy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc parallel pcopyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc parallel pcopyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc parallel pcreate (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + + + !$acc parallel present_or_copy (tip) + !$acc end parallel + !$acc parallel present_or_copy (tia) + !$acc end parallel + !$acc parallel deviceptr (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel create (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present (i) present_or_copy (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel present_or_copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels present_or_copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data present_or_copy (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel present_or_copyin (tip) + !$acc end parallel + !$acc parallel present_or_copyin (tia) + !$acc end parallel + !$acc parallel deviceptr (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel create (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copy (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel present_or_copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels present_or_copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data present_or_copyin (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel present_or_copyout (tip) + !$acc end parallel + !$acc parallel present_or_copyout (tia) + !$acc end parallel + !$acc parallel deviceptr (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel create (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copy (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copyin (i) present_or_copyout (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel present_or_copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels present_or_copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data present_or_copyout (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + + !$acc parallel present_or_create (tip) + !$acc end parallel + !$acc parallel present_or_create (tia) + !$acc end parallel + !$acc parallel deviceptr (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copy (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyin (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel copyout (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel create (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copy (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copyin (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + !$acc parallel present_or_copyout (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc end parallel + + !$acc parallel present_or_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end parallel + !$acc kernels present_or_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end kernels + !$acc data present_or_create (i, c, r, ia, ca, ra, asa, rp, ti, vi, aa) + !$acc end data + + end subroutine foo +end module test Index: Fortran/gfortran/regression/goacc/data-tree.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/data-tree.f95 @@ -0,0 +1,30 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +program test + implicit none + integer :: q, i, j, k, m, n, o, p, r, s, t, u, v, w + logical :: l = .true. + + !$acc data if(l) copy(i), copyin(j), copyout(k), create(m) & + !$acc no_create(n) & + !$acc present(o), pcopy(p), pcopyin(r), pcopyout(s), pcreate(t) & + !$acc deviceptr(u) + !$acc end data + +end program test +! { dg-final { scan-tree-dump-times "pragma acc data" 1 "original" } } + +! { dg-final { scan-tree-dump-times "if" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:i\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:j\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:k\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:m\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(no_alloc:n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(force_present:o\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:p\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:r\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:s\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:t\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "map\\(force_deviceptr:u\\)" 1 "original" } } Index: Fortran/gfortran/regression/goacc/declare-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/declare-1.f95 @@ -0,0 +1,16 @@ +! { dg-do compile } + +program test + implicit none + integer :: i + + !$acc declare copy(i) +contains + real function foo(n) + integer, value :: n + BLOCK + integer i + !$acc declare copy(i) ! { dg-error "is not allowed" } + END BLOCK + end function foo +end program test Index: Fortran/gfortran/regression/goacc/declare-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/declare-2.f95 @@ -0,0 +1,82 @@ + +module amod + implicit none + integer :: b(8) + + !$acc declare copy (b) ! { dg-error "Invalid clause in module" } + !$acc declare copyout (b) ! { dg-error "Invalid clause in module" } + !$acc declare present (b) ! { dg-error "Invalid clause in module" } + !$acc declare present_or_copy (b) ! { dg-error "Invalid clause in module" } + !$acc declare present_or_copyin (b) ! { dg-error "present on multiple" } + !$acc declare present_or_copyout (b) ! { dg-error "Invalid clause in module" } + !$acc declare present_or_create (b) ! { dg-error "present on multiple" } + !$acc declare deviceptr (b) ! { dg-error "Invalid clause in module" } + !$acc declare create (b) copyin (b) ! { dg-error "present on multiple" } +end module + +module amod2 +contains +subroutine asubr (a, b, c, d, e, f, g, h, i, j, k) + implicit none + integer, dimension(8) :: a, b, c, d, e, f, g, h, i, j, k + + !$acc declare copy (a) + !$acc declare copyout (b) + !$acc declare present (c) + !$acc declare present_or_copy (d) + !$acc declare present_or_copyin (e) + !$acc declare present_or_copyout (f) + !$acc declare present_or_create (g) + !$acc declare deviceptr (h) + !$acc declare create (j) copyin (k) +end subroutine +end module + +module bmod + + implicit none + integer :: a, b, c, d, e, f, g, h, i + common /data1/ a, b, c + common /data2/ d, e, f + common /data3/ g, h, i + !$acc declare link (a) ! { dg-error "element of a COMMON" } + !$acc declare link (/data1/) + !$acc declare link (a, b, c) ! { dg-error "element of a COMMON" } + !$acc declare link (/foo/) ! { dg-error "not found" } + !$acc declare device_resident (/data2/) + !$acc declare device_resident (/data3/) ! { dg-error "present on multiple clauses" } + !$acc declare device_resident (g, h, i) + +end module + +subroutine bsubr (foo) + implicit none + + integer, dimension (:) :: foo + + !$acc declare copy (foo) ! { dg-error "Assumed-size dummy array" } + !$acc declare copy (foo(1:2)) ! { dg-error "Assumed-size dummy array" } + +end subroutine bsubr + +subroutine multiline + integer :: b(8) + + !$acc declare copyin (b) ! { dg-error "present on multiple clauses" } + !$acc declare copyin (b) + +end subroutine multiline + +subroutine subarray + integer :: c(8) + + !$acc declare copy (c(1:2)) ! { dg-error "Array sections: 'c' not allowed" } + +end subroutine subarray + +program test + integer :: a(8) + + !$acc declare create (a) copyin (a) ! { dg-error "present on multiple clauses" } + +end program Index: Fortran/gfortran/regression/goacc/declare-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/declare-3.f95 @@ -0,0 +1,45 @@ +! Test valid usage of the OpenACC 'declare' directive. + +! { dg-additional-options "-fdump-tree-original" } + +module mod_a + implicit none + integer :: a + !$acc declare create (a) +end module + +module mod_b + implicit none + integer :: b + !$acc declare copyin (b) +end module + +module mod_d + implicit none + integer :: d + !$acc declare device_resident (d) +end module + +module mod_e + implicit none + integer :: e + !$acc declare link (e) +end module + +subroutine sub1 + use mod_a + use mod_b + use mod_d + use mod_e +end subroutine sub1 + +program test + use mod_a + use mod_b + use mod_d + use mod_e + + ! { dg-final { scan-tree-dump {(?n)#pragma acc data map\(force_alloc:d\) map\(force_to:b\) map\(force_alloc:a\)$} original } } +end program test + +! { dg-final { scan-tree-dump-times {#pragma acc data} 1 original } } Index: Fortran/gfortran/regression/goacc/deep-copy-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/deep-copy-2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + +! Test of attach/detach with "acc data", two clauses at once. + +program dtype + implicit none + integer, parameter :: n = 512 + type mytype + integer, allocatable :: a(:) + end type mytype + integer i + + type(mytype) :: var + + allocate(var%a(1:n)) + +!$acc data copy(var) copy(var%a) ! { dg-error "Symbol .var. has mixed component and non-component accesses" } + +!$acc data copy(var%a) copy(var) ! { dg-error "Symbol .var. has mixed component and non-component accesses" } + +!$acc parallel loop + do i = 1,n + var%a(i) = i + end do +!$acc end parallel loop + +!$acc end data + +!$acc end data + + do i = 1,n + if (i .ne. var%a(i)) stop 1 + end do + + deallocate(var%a) + +end program dtype Index: Fortran/gfortran/regression/goacc/default-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default-1.f95 @@ -0,0 +1,15 @@ +! OpenACC default clause: valid syntax. + +subroutine f1 + implicit none + + !$acc kernels default (none) + !$acc end kernels + !$acc parallel default (none) + !$acc end parallel + + !$acc kernels default (present) + !$acc end kernels + !$acc parallel default (present) + !$acc end parallel +end subroutine f1 Index: Fortran/gfortran/regression/goacc/default-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default-2.f @@ -0,0 +1,60 @@ +! OpenACC default clause: invalid syntax. + + SUBROUTINE F1 + IMPLICIT NONE + +!$ACC KERNELS DEFAULT ! { dg-error "Expected '\\(' after 'default" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT ! { dg-error "Expected '\\(' after 'default" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT ( ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT ( ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (, ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (, ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT () ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT () ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (,) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (,) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (FIRSTPRIVATE) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (FIRSTPRIVATE) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (PRIVATE) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (PRIVATE) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (SHARED) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (SHARED) ! { dg-error "Expected NONE or PRESENT in DEFAULT clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (NONE ! { dg-error "Failed to match clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (NONE ! { dg-error "Failed to match clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (NONE NONE) ! { dg-error "Failed to match clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (NONE NONE) ! { dg-error "Failed to match clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + +!$ACC KERNELS DEFAULT (NONE, NONE) ! { dg-error "Failed to match clause" } +!$ACC END KERNELS ! { dg-error "Unexpected" } +!$ACC PARALLEL DEFAULT (NONE, NONE) ! { dg-error "Failed to match clause" } +!$ACC END PARALLEL ! { dg-error "Unexpected" } + END SUBROUTINE F1 Index: Fortran/gfortran/regression/goacc/default-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default-3.f95 @@ -0,0 +1,18 @@ +! OpenACC default (none) clause. + +subroutine f1 + implicit none + integer :: f1_a = 2 + real, dimension (2) :: f1_b + + !$acc kernels default (none) ! { dg-message "enclosing OpenACC .kernels. construct" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .kernels. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .kernels. construct" "" { xfail *-*-* } .-1 } + !$acc end kernels + !$acc parallel default (none) ! { dg-message "enclosing OpenACC .parallel. construct" } + f1_b(1) & ! { dg-error ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } } + = f1_a; ! { dg-error ".f1_a. not specified in enclosing OpenACC .parallel. construct" } + ! { dg-bogus ".f1_b. not specified in enclosing OpenACC .parallel. construct" "" { xfail *-*-* } .-1 } + !$acc end parallel +end subroutine f1 Index: Fortran/gfortran/regression/goacc/default-4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default-4.f @@ -0,0 +1,57 @@ +! OpenACC default clause inside data construct. + +! { dg-additional-options "-fdump-tree-gimple" } + + SUBROUTINE F1 + IMPLICIT NONE + INTEGER :: F1_A = 2 + REAL, DIMENSION (2) :: F1_B + +!$ACC DATA COPYIN (F1_A) COPYOUT (F1_B) +! { dg-final { scan-tree-dump-times "omp target oacc_data map\\(to:f1_a \[^\\)\]+\\) map\\(from:f1_b" 1 "gimple" } } +!$ACC KERNELS +! { dg-final { scan-tree-dump-times "omp target oacc_kernels map\\(tofrom:f1_b \[^\\)\]+\\) map\\(tofrom:f1_a" 1 "gimple" } } + F1_B(1) = F1_A; +!$ACC END KERNELS +!$ACC PARALLEL +! { dg-final { scan-tree-dump-times "omp target oacc_parallel map\\(tofrom:f1_b \[^\\)\]+\\) map\\(tofrom:f1_a" 1 "gimple" } } + F1_B(1) = F1_A; +!$ACC END PARALLEL +!$ACC END DATA + END SUBROUTINE F1 + + SUBROUTINE F2 + IMPLICIT NONE + INTEGER :: F2_A = 2 + REAL, DIMENSION (2) :: F2_B + +!$ACC DATA COPYIN (F2_A) COPYOUT (F2_B) +! { dg-final { scan-tree-dump-times "omp target oacc_data map\\(to:f2_a \[^\\)\]+\\) map\\(from:f2_b" 1 "gimple" } } +!$ACC KERNELS DEFAULT (NONE) +! { dg-final { scan-tree-dump-times "omp target oacc_kernels default\\(none\\) map\\(tofrom:f2_b \[^\\)\]+\\) map\\(tofrom:f2_a" 1 "gimple" } } + F2_B(1) = F2_A; +!$ACC END KERNELS +!$ACC PARALLEL DEFAULT (NONE) +! { dg-final { scan-tree-dump-times "omp target oacc_parallel default\\(none\\) map\\(tofrom:f2_b \[^\\)\]+\\) map\\(tofrom:f2_a" 1 "gimple" } } + F2_B(1) = F2_A; +!$ACC END PARALLEL +!$ACC END DATA + END SUBROUTINE F2 + + SUBROUTINE F3 + IMPLICIT NONE + INTEGER :: F3_A = 2 + REAL, DIMENSION (2) :: F3_B + +!$ACC DATA COPYIN (F3_A) COPYOUT (F3_B) +! { dg-final { scan-tree-dump-times "omp target oacc_data map\\(to:f3_a \[^\\)\]+\\) map\\(from:f3_b" 1 "gimple" } } +!$ACC KERNELS DEFAULT (PRESENT) +! { dg-final { scan-tree-dump-times "omp target oacc_kernels default\\(present\\) map\\(tofrom:f3_b \[^\\)\]+\\) map\\(tofrom:f3_a" 1 "gimple" } } + F3_B(1) = F3_A; +!$ACC END KERNELS +!$ACC PARALLEL DEFAULT (PRESENT) +! { dg-final { scan-tree-dump-times "omp target oacc_parallel default\\(present\\) map\\(tofrom:f3_b \[^\\)\]+\\) map\\(tofrom:f3_a" 1 "gimple" } } + F3_B(1) = F3_A; +!$ACC END PARALLEL +!$ACC END DATA + END SUBROUTINE F3 Index: Fortran/gfortran/regression/goacc/default-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default-5.f @@ -0,0 +1,18 @@ +! OpenACC default (present) clause. + +! { dg-additional-options "-fdump-tree-gimple" } + + SUBROUTINE F1 + IMPLICIT NONE + INTEGER :: F1_A = 2 + REAL, DIMENSION (2) :: F1_B + +!$ACC KERNELS DEFAULT (PRESENT) +! { dg-final { scan-tree-dump-times "omp target oacc_kernels default\\(present\\) map\\(force_present:f1_b \[^\\)\]+\\) map\\(force_tofrom:f1_a" 1 "gimple" } } + F1_B(1) = F1_A; +!$ACC END KERNELS +!$ACC PARALLEL DEFAULT (PRESENT) +! { dg-final { scan-tree-dump-times "omp target oacc_parallel default\\(present\\) map\\(force_present:f1_b \[^\\)\]+\\) firstprivate\\(f1_a\\)" 1 "gimple" } } + F1_B(1) = F1_A; +!$ACC END PARALLEL + END SUBROUTINE F1 Index: Fortran/gfortran/regression/goacc/default_none.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/default_none.f95 @@ -0,0 +1,59 @@ +! Ensure that the internal array variables, offset, lbound, etc., don't +! trigger errors with default(none). + +! { dg-do compile } + +program main + implicit none + integer i + integer,parameter :: n = 100 + integer,allocatable :: a1(:), a2(:,:) + + allocate (a1 (n)) + allocate (a2 (-n:n,-n:n)) + a1 (:) = -1 + + !$acc parallel loop default(none) copy (a1(1:n)) + do i = 1,n + a1(i) = i + end do + !$acc end parallel loop + + call foo (a1) + call bar (a1, n) + call foobar (a2,n) + +contains + + subroutine foo (da1) + integer :: da1(n) + + !$acc parallel loop default(none) copy (da1(1:n)) + do i = 1,n + da1(i) = i*2 + end do + !$acc end parallel loop + end subroutine foo +end program main + +subroutine bar (da2,n) + integer :: n, da2(n) + integer i + + !$acc parallel loop default(none) copy (da2(1:n)) firstprivate(n) + do i = 1,n + da2(i) = i*3 + end do + !$acc end parallel loop +end subroutine bar + +subroutine foobar (da3,n) + integer :: n, da3(-n:n,-n:n) + integer i + + !$acc parallel loop default(none) copy (da3(-n:n,-n:n)) firstprivate(n) + do i = 1,n + da3(i,0) = i*3 + end do + !$acc end parallel loop +end subroutine foobar Index: Fortran/gfortran/regression/goacc/derived-chartypes-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-chartypes-1.f90 @@ -0,0 +1,131 @@ +! { dg-additional-options -Wuninitialized } + +type :: type1 + character(len=35) :: a +end type type1 + +type :: type2 + character(len=35), pointer :: b +end type type2 + +type :: aux1 + character(len=22) :: y +end type aux1 + +type, extends(aux1) :: aux + character(len=33) :: x +end type aux + +type :: type3 + class(aux), pointer :: c(:) +end type type3 + +type :: type4 + integer, pointer :: d(:) +end type type4 + +type :: type5 + type(aux1) :: e +end type type5 + +type :: type6 + type(aux1), pointer :: f +end type type6 + +type :: type7 + class(aux), pointer :: g +end type type7 + +type(type1) :: foo +type(type2) :: bar +type(type3) :: qux +type(type4) :: quux +type(type5) :: fred +type(type6) :: jim +type(type7) :: shiela + +type(type1), pointer :: pfoo +type(type2), pointer :: pbar +type(type3), pointer :: pqux +type(type4), pointer :: pquux +type(type5), pointer :: pfred +type(type6), pointer :: pjim +type(type7), pointer :: pshiela + +class(type1), pointer :: cfoo +class(type2), pointer :: cbar +class(type3), pointer :: cqux +class(type4), pointer :: cquux +class(type5), pointer :: cfred +class(type6), pointer :: cjim +class(type7), pointer :: cshiela + +class(type1), allocatable :: acfoo +class(type2), allocatable :: acbar +class(type3), allocatable :: acqux +class(type4), allocatable :: acquux +class(type5), allocatable :: acfred +class(type6), allocatable :: acjim +class(type7), allocatable :: acshiela + +!$acc enter data copyin(foo) +!$acc enter data copyin(foo%a) +!$acc enter data copyin(bar) +!$acc enter data copyin(bar%b) +!$acc enter data copyin(qux) +!$acc enter data copyin(qux%c) +!$acc enter data copyin(quux) +!$acc enter data copyin(quux%d) +!$acc enter data copyin(fred) +!$acc enter data copyin(fred%e) +!$acc enter data copyin(jim) +!$acc enter data copyin(jim%f) +!$acc enter data copyin(shiela) +!$acc enter data copyin(shiela%g) + +!$acc enter data copyin(pfoo) +!$acc enter data copyin(pfoo%a) +!$acc enter data copyin(pbar) +!$acc enter data copyin(pbar%b) +!$acc enter data copyin(pqux) +!$acc enter data copyin(pqux%c) +!$acc enter data copyin(pquux) +!$acc enter data copyin(pquux%d) +!$acc enter data copyin(pfred) +!$acc enter data copyin(pfred%e) +!$acc enter data copyin(pjim) +!$acc enter data copyin(pjim%f) +!$acc enter data copyin(pshiela) +!$acc enter data copyin(pshiela%g) + +!$acc enter data copyin(cfoo) +!$acc enter data copyin(cfoo%a) +!$acc enter data copyin(cbar) +!$acc enter data copyin(cbar%b) +!$acc enter data copyin(cqux) +!$acc enter data copyin(cqux%c) +!$acc enter data copyin(cquux) +!$acc enter data copyin(cquux%d) +!$acc enter data copyin(cfred) +!$acc enter data copyin(cfred%e) +!$acc enter data copyin(cjim) +!$acc enter data copyin(cjim%f) +!$acc enter data copyin(cshiela) +!$acc enter data copyin(cshiela%g) + +!$acc enter data copyin(acfoo) +!$acc enter data copyin(acfoo%a) +!$acc enter data copyin(acbar) +!$acc enter data copyin(acbar%b) +!$acc enter data copyin(acqux) +!$acc enter data copyin(acqux%c) +!$acc enter data copyin(acquux) +!$acc enter data copyin(acquux%d) +!$acc enter data copyin(acfred) +!$acc enter data copyin(acfred%e) +!$acc enter data copyin(acjim) +!$acc enter data copyin(acjim%f) +!$acc enter data copyin(acshiela) +!$acc enter data copyin(acshiela%g) + +end Index: Fortran/gfortran/regression/goacc/derived-chartypes-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-chartypes-2.f90 @@ -0,0 +1,131 @@ +! { dg-additional-options -Wuninitialized } + +type :: type1 + character(len=35,kind=4) :: a +end type type1 + +type :: type2 + character(len=35,kind=4), pointer :: b +end type type2 + +type :: aux1 + character(len=22,kind=4) :: y +end type aux1 + +type, extends(aux1) :: aux + character(len=33,kind=4) :: x +end type aux + +type :: type3 + class(aux), pointer :: c(:) +end type type3 + +type :: type4 + integer, pointer :: d(:) +end type type4 + +type :: type5 + type(aux1) :: e +end type type5 + +type :: type6 + type(aux1), pointer :: f +end type type6 + +type :: type7 + class(aux), pointer :: g +end type type7 + +type(type1) :: foo +type(type2) :: bar +type(type3) :: qux +type(type4) :: quux +type(type5) :: fred +type(type6) :: jim +type(type7) :: shiela + +type(type1), pointer :: pfoo +type(type2), pointer :: pbar +type(type3), pointer :: pqux +type(type4), pointer :: pquux +type(type5), pointer :: pfred +type(type6), pointer :: pjim +type(type7), pointer :: pshiela + +class(type1), pointer :: cfoo +class(type2), pointer :: cbar +class(type3), pointer :: cqux +class(type4), pointer :: cquux +class(type5), pointer :: cfred +class(type6), pointer :: cjim +class(type7), pointer :: cshiela + +class(type1), allocatable :: acfoo +class(type2), allocatable :: acbar +class(type3), allocatable :: acqux +class(type4), allocatable :: acquux +class(type5), allocatable :: acfred +class(type6), allocatable :: acjim +class(type7), allocatable :: acshiela + +!$acc enter data copyin(foo) +!$acc enter data copyin(foo%a) +!$acc enter data copyin(bar) +!$acc enter data copyin(bar%b) +!$acc enter data copyin(qux) +!$acc enter data copyin(qux%c) +!$acc enter data copyin(quux) +!$acc enter data copyin(quux%d) +!$acc enter data copyin(fred) +!$acc enter data copyin(fred%e) +!$acc enter data copyin(jim) +!$acc enter data copyin(jim%f) +!$acc enter data copyin(shiela) +!$acc enter data copyin(shiela%g) + +!$acc enter data copyin(pfoo) +!$acc enter data copyin(pfoo%a) +!$acc enter data copyin(pbar) +!$acc enter data copyin(pbar%b) +!$acc enter data copyin(pqux) +!$acc enter data copyin(pqux%c) +!$acc enter data copyin(pquux) +!$acc enter data copyin(pquux%d) +!$acc enter data copyin(pfred) +!$acc enter data copyin(pfred%e) +!$acc enter data copyin(pjim) +!$acc enter data copyin(pjim%f) +!$acc enter data copyin(pshiela) +!$acc enter data copyin(pshiela%g) + +!$acc enter data copyin(cfoo) +!$acc enter data copyin(cfoo%a) +!$acc enter data copyin(cbar) +!$acc enter data copyin(cbar%b) +!$acc enter data copyin(cqux) +!$acc enter data copyin(cqux%c) +!$acc enter data copyin(cquux) +!$acc enter data copyin(cquux%d) +!$acc enter data copyin(cfred) +!$acc enter data copyin(cfred%e) +!$acc enter data copyin(cjim) +!$acc enter data copyin(cjim%f) +!$acc enter data copyin(cshiela) +!$acc enter data copyin(cshiela%g) + +!$acc enter data copyin(acfoo) +!$acc enter data copyin(acfoo%a) +!$acc enter data copyin(acbar) +!$acc enter data copyin(acbar%b) +!$acc enter data copyin(acqux) +!$acc enter data copyin(acqux%c) +!$acc enter data copyin(acquux) +!$acc enter data copyin(acquux%d) +!$acc enter data copyin(acfred) +!$acc enter data copyin(acfred%e) +!$acc enter data copyin(acjim) +!$acc enter data copyin(acjim%f) +!$acc enter data copyin(acshiela) +!$acc enter data copyin(acshiela%g) + +end Index: Fortran/gfortran/regression/goacc/derived-chartypes-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-chartypes-3.f90 @@ -0,0 +1,50 @@ +! { dg-additional-options "-fdump-tree-gimple" } + +! { dg-additional-options -Wuninitialized } + +type :: type1 + character(len=35) :: a +end type type1 + +type :: type2 + character(len=46), pointer :: b +end type type2 + +type(type1) :: foo +type(type2) :: bar + +type(type1), pointer :: pfoo +! { dg-note {'pfoo' was declared here} {} { target *-*-* } .-1 } +type(type2), pointer :: pbar +! { dg-note {'pbar' was declared here} {} { target *-*-* } .-1 } + +class(type1), pointer :: cfoo +! { dg-note {'cfoo' declared here} {} { target *-*-* } .-1 } +! { dg-note {'cfoo\._data' was declared here} {} { target *-*-* } .-2 } +class(type2), pointer :: cbar +! { dg-note {'cbar' declared here} {} { target *-*-* } .-1 } +! { dg-note {'cbar\._data' was declared here} {} { target *-*-* } .-2 } + +class(type1), allocatable :: acfoo +class(type2), allocatable :: acbar + +!$acc enter data copyin(foo%a) +!$acc enter data copyin(bar%b) + +!$acc enter data copyin(pfoo%a) +! { dg-warning {'pfoo' is used uninitialized} {} { target *-*-* } .-1 } +!$acc enter data copyin(pbar%b) +! { dg-warning {'pbar' is used uninitialized} {} { target *-*-* } .-1 } + +!$acc enter data copyin(cfoo%a) +! { dg-warning {'cfoo\._data' is used uninitialized} {} { target *-*-* } .-1 } +!$acc enter data copyin(cbar%b) +! { dg-warning {'cbar\._data' is used uninitialized} {} { target *-*-* } .-1 } + +!$acc enter data copyin(acfoo%a) +!$acc enter data copyin(acbar%b) + +! { dg-final { scan-tree-dump-times "to:\[^\\\[\]*\\\[len: 35\\\]" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "to:\[^\\\[\]*\\\[len: 46\\\]" 4 "gimple" } } + +end Index: Fortran/gfortran/regression/goacc/derived-chartypes-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-chartypes-4.f90 @@ -0,0 +1,50 @@ +! { dg-additional-options "-fdump-tree-gimple" } + +! { dg-additional-options -Wuninitialized } + +type :: type1 + character(len=35,kind=4) :: a +end type type1 + +type :: type2 + character(len=46,kind=4), pointer :: b +end type type2 + +type(type1) :: foo +type(type2) :: bar + +type(type1), pointer :: pfoo +! { dg-note {'pfoo' was declared here} {} { target *-*-* } .-1 } +type(type2), pointer :: pbar +! { dg-note {'pbar' was declared here} {} { target *-*-* } .-1 } + +class(type1), pointer :: cfoo +! { dg-note {'cfoo' declared here} {} { target *-*-* } .-1 } +! { dg-note {'cfoo\._data' was declared here} {} { target *-*-* } .-2 } +class(type2), pointer :: cbar +! { dg-note {'cbar' declared here} {} { target *-*-* } .-1 } +! { dg-note {'cbar\._data' was declared here} {} { target *-*-* } .-2 } + +class(type1), allocatable :: acfoo +class(type2), allocatable :: acbar + +!$acc enter data copyin(foo%a) +!$acc enter data copyin(bar%b) + +!$acc enter data copyin(pfoo%a) +! { dg-warning {'pfoo' is used uninitialized} {} { target *-*-* } .-1 } +!$acc enter data copyin(pbar%b) +! { dg-warning {'pbar' is used uninitialized} {} { target *-*-* } .-1 } + +!$acc enter data copyin(cfoo%a) +! { dg-warning {'cfoo\._data' is used uninitialized} {} { target *-*-* } .-1 } +!$acc enter data copyin(cbar%b) +! { dg-warning {'cbar\._data' is used uninitialized} {} { target *-*-* } .-1 } + +!$acc enter data copyin(acfoo%a) +!$acc enter data copyin(acbar%b) + +! { dg-final { scan-tree-dump-times "to:\[^\\\[\]*\\\[len: 140\\\]" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "to:\[^\\\[\]*\\\[len: 184\\\]" 4 "gimple" } } + +end Index: Fortran/gfortran/regression/goacc/derived-classtypes-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-classtypes-1.f95 @@ -0,0 +1,131 @@ +! { dg-additional-options -Wuninitialized } + +type :: type1 + integer :: a +end type type1 + +type :: type2 + integer, pointer :: b +end type type2 + +type :: aux1 + integer :: y +end type aux1 + +type, extends(aux1) :: aux + integer :: x +end type aux + +type :: type3 + class(aux), pointer :: c(:) +end type type3 + +type :: type4 + integer, pointer :: d(:) +end type type4 + +type :: type5 + type(aux) :: e +end type type5 + +type :: type6 + type(aux), pointer :: f +end type type6 + +type :: type7 + class(aux), pointer :: g +end type type7 + +type(type1) :: foo +type(type2) :: bar +type(type3) :: qux +type(type4) :: quux +type(type5) :: fred +type(type6) :: jim +type(type7) :: shiela + +type(type1), pointer :: pfoo +type(type2), pointer :: pbar +type(type3), pointer :: pqux +type(type4), pointer :: pquux +type(type5), pointer :: pfred +type(type6), pointer :: pjim +type(type7), pointer :: pshiela + +class(type1), pointer :: cfoo +class(type2), pointer :: cbar +class(type3), pointer :: cqux +class(type4), pointer :: cquux +class(type5), pointer :: cfred +class(type6), pointer :: cjim +class(type7), pointer :: cshiela + +class(type1), allocatable :: acfoo +class(type2), allocatable :: acbar +class(type3), allocatable :: acqux +class(type4), allocatable :: acquux +class(type5), allocatable :: acfred +class(type6), allocatable :: acjim +class(type7), allocatable :: acshiela + +!$acc enter data copyin(foo) +!$acc enter data copyin(foo%a) +!$acc enter data copyin(bar) +!$acc enter data copyin(bar%b) +!$acc enter data copyin(qux) +!$acc enter data copyin(qux%c) +!$acc enter data copyin(quux) +!$acc enter data copyin(quux%d) +!$acc enter data copyin(fred) +!$acc enter data copyin(fred%e) +!$acc enter data copyin(jim) +!$acc enter data copyin(jim%f) +!$acc enter data copyin(shiela) +!$acc enter data copyin(shiela%g) + +!$acc enter data copyin(pfoo) +!$acc enter data copyin(pfoo%a) +!$acc enter data copyin(pbar) +!$acc enter data copyin(pbar%b) +!$acc enter data copyin(pqux) +!$acc enter data copyin(pqux%c) +!$acc enter data copyin(pquux) +!$acc enter data copyin(pquux%d) +!$acc enter data copyin(pfred) +!$acc enter data copyin(pfred%e) +!$acc enter data copyin(pjim) +!$acc enter data copyin(pjim%f) +!$acc enter data copyin(pshiela) +!$acc enter data copyin(pshiela%g) + +!$acc enter data copyin(cfoo) +!$acc enter data copyin(cfoo%a) +!$acc enter data copyin(cbar) +!$acc enter data copyin(cbar%b) +!$acc enter data copyin(cqux) +!$acc enter data copyin(cqux%c) +!$acc enter data copyin(cquux) +!$acc enter data copyin(cquux%d) +!$acc enter data copyin(cfred) +!$acc enter data copyin(cfred%e) +!$acc enter data copyin(cjim) +!$acc enter data copyin(cjim%f) +!$acc enter data copyin(cshiela) +!$acc enter data copyin(cshiela%g) + +!$acc enter data copyin(acfoo) +!$acc enter data copyin(acfoo%a) +!$acc enter data copyin(acbar) +!$acc enter data copyin(acbar%b) +!$acc enter data copyin(acqux) +!$acc enter data copyin(acqux%c) +!$acc enter data copyin(acquux) +!$acc enter data copyin(acquux%d) +!$acc enter data copyin(acfred) +!$acc enter data copyin(acfred%e) +!$acc enter data copyin(acjim) +!$acc enter data copyin(acjim%f) +!$acc enter data copyin(acshiela) +!$acc enter data copyin(acshiela%g) + +end Index: Fortran/gfortran/regression/goacc/derived-types-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-types-2.f90 @@ -0,0 +1,16 @@ +! { dg-additional-options -Wuninitialized } + +module bar + type :: type1 + real(8), pointer, public :: p(:) => null() + end type + type :: type2 + class(type1), pointer :: p => null() + end type +end module + +subroutine foo (var) + use bar + type(type2), intent(inout) :: var + !$acc enter data create(var%p%p) +end subroutine Index: Fortran/gfortran/regression/goacc/derived-types-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-types-3.f90 @@ -0,0 +1,12 @@ +module bar + type :: type1 + integer :: a(5) + integer :: b(5) + end type +end module + +subroutine foo + use bar + type(type1) :: var + !$acc enter data copyin(var%a) copyin(var%a) ! { dg-error ".var\.a. appears more than once in map clauses" } +end subroutine Index: Fortran/gfortran/regression/goacc/derived-types.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/derived-types.f90 @@ -0,0 +1,77 @@ +! Test ACC UPDATE with derived types. + +module dt + integer, parameter :: n = 10 + type inner + integer :: d(n) + end type inner + type dtype + integer(8) :: a, b, c(n) + type(inner) :: in + end type dtype +end module dt + +program derived_acc + use dt + + implicit none + type(dtype):: var + integer i + !$acc declare create(var) + !$acc declare pcopy(var%a) ! { dg-error "Syntax error in OpenMP" } + + !$acc update host(var) + !$acc update host(var%a) + !$acc update device(var) + !$acc update device(var%a) + !$acc update self(var) + !$acc update self(var%a) + + !$acc enter data copyin(var) + !$acc enter data copyin(var%a) + + !$acc exit data copyout(var) + !$acc exit data copyout(var%a) + + !$acc data copy(var) + !$acc end data + + !$acc data copyout(var%a) + !$acc end data + + !$acc parallel loop pcopyout(var) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel loop copyout(var%a) + do i = 1, 10 + end do + !$acc end parallel loop + + !$acc parallel pcopy(var) + !$acc end parallel + + !$acc parallel pcopy(var%a) + do i = 1, 10 + end do + !$acc end parallel + + !$acc kernels pcopyin(var) + !$acc end kernels + + !$acc kernels pcopy(var%a) + do i = 1, 10 + end do + !$acc end kernels + + !$acc kernels loop pcopyin(var) + do i = 1, 10 + end do + !$acc end kernels loop + + !$acc kernels loop pcopy(var%a) + do i = 1, 10 + end do + !$acc end kernels loop +end program derived_acc Index: Fortran/gfortran/regression/goacc/enter-exit-data.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/enter-exit-data.f95 @@ -0,0 +1,91 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +module test + implicit none +contains + + subroutine foo (vi) + logical :: l + integer, value :: vi + integer :: i, ia(10), a(10), b(2:8) + complex :: c, ca(10) + real, target:: r + real :: ra(10) + real, pointer :: rp + real, dimension(:), allocatable :: aa + type t + integer :: i + end type + type(t) :: ti + type(t), allocatable :: tia + type(t), target :: tit + type(t), pointer :: tip + rp => r + tip => tit + + ! enter data + !$acc enter data + !$acc enter data if (.false.) + !$acc enter data if (l) + !$acc enter data if (.false.) if (l) ! { dg-error "Duplicated 'if' clause" } + !$acc enter data if (i) ! { dg-error "LOGICAL" } + !$acc enter data if (1) ! { dg-error "LOGICAL" } + !$acc enter data if (a) ! { dg-error "LOGICAL" } + !$acc enter data if (b(5:6)) ! { dg-error "LOGICAL" } + !$acc enter data async (l) ! { dg-error "INTEGER" } + !$acc enter data async (.true.) ! { dg-error "INTEGER" } + !$acc enter data async (1) + !$acc enter data async (i) + !$acc enter data async (a) ! { dg-error "INTEGER" } + !$acc enter data async (b(5:6)) ! { dg-error "INTEGER" } + !$acc enter data wait (l) ! { dg-error "INTEGER" } + !$acc enter data wait (.true.) ! { dg-error "INTEGER" } + !$acc enter data wait (i, 1) + !$acc enter data wait (a) ! { dg-error "INTEGER" } + !$acc enter data wait (b(5:6)) ! { dg-error "INTEGER" } + !$acc enter data copyin (tip) + !$acc enter data copyin (tia) + !$acc enter data create (tip) + !$acc enter data create (tia) + !$acc enter data present_or_copyin (tip) + !$acc enter data present_or_copyin (tia) + !$acc enter data present_or_create (tip) + !$acc enter data present_or_create (tia) + !$acc enter data copyin (i) create (i) ! { dg-error "multiple clauses" } + !$acc enter data copyin (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc enter data create (i) present_or_copyin (i) ! { dg-error "multiple clauses" } + !$acc enter data copyin (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc enter data create (i) present_or_create (i) ! { dg-error "multiple clauses" } + !$acc enter data present_or_copyin (i) present_or_create (i) ! { dg-error "multiple clauses" } + + ! exit data + !$acc exit data + !$acc exit data if (.false.) + !$acc exit data if (l) + !$acc exit data if (.false.) if (l) ! { dg-error "Duplicated 'if' clause" } + !$acc exit data if (i) ! { dg-error "LOGICAL" } + !$acc exit data if (1) ! { dg-error "LOGICAL" } + !$acc exit data if (a) ! { dg-error "LOGICAL" } + !$acc exit data if (b(5:6)) ! { dg-error "LOGICAL" } + !$acc exit data async (l) ! { dg-error "INTEGER" } + !$acc exit data async (.true.) ! { dg-error "INTEGER" } + !$acc exit data async (1) + !$acc exit data async (i) + !$acc exit data async (a) ! { dg-error "INTEGER" } + !$acc exit data async (b(5:6)) ! { dg-error "INTEGER" } + !$acc exit data wait (l) ! { dg-error "INTEGER" } + !$acc exit data wait (.true.) ! { dg-error "INTEGER" } + !$acc exit data wait (i, 1) + !$acc exit data wait (a) ! { dg-error "INTEGER" } + !$acc exit data wait (b(5:6)) ! { dg-error "INTEGER" } + !$acc exit data copyout (tip) + !$acc exit data copyout (tia) + !$acc exit data delete (tip) + !$acc exit data delete (tia) + !$acc exit data copyout (i) delete (i) ! { dg-error "multiple clauses" } + !$acc exit data finalize + !$acc exit data finalize copyout (i) + !$acc exit data finalize delete (i) + end subroutine foo +end module test Index: Fortran/gfortran/regression/goacc/finalize-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/finalize-1.f @@ -0,0 +1,37 @@ +! Test valid usage and processing of the finalize clause. + +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + + SUBROUTINE f + IMPLICIT NONE + INTEGER :: del_r + REAL, DIMENSION (3) :: del_f + INTEGER (1), DIMENSION (:), ALLOCATABLE :: del_f_p + DOUBLE PRECISION, DIMENSION (8) :: cpo_r + LOGICAL :: cpo_f + INTEGER (1), DIMENSION (:), ALLOCATABLE :: cpo_f_p + +!$ACC EXIT DATA DELETE (del_r) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(release:del_r\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(release:del_r \\\[len: \[0-9\]+\\\]\\)$" 1 "gimple" } } + +!$ACC EXIT DATA FINALIZE DELETE (del_f) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(release:del_f\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(delete:del_f \\\[len: \[0-9\]+\\\]\\) finalize$" 1 "gimple" } } + +!$ACC EXIT DATA FINALIZE DELETE (del_f_p(2:5)) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(release:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.0\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(to:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) del_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.0\\.data - \\(.*int.*\\) del_f_p\\.data\\\]\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(delete:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(to:del_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:del_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } + +!$ACC EXIT DATA COPYOUT (cpo_r) +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:cpo_r\\);$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(from:cpo_r \\\[len: \[0-9\]+\\\]\\)$" 1 "gimple" } } + +!$ACC EXIT DATA COPYOUT (cpo_f) FINALIZE +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:cpo_f\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_from:cpo_f \\\[len: \[0-9\]+\\\]\\) finalize$" 1 "gimple" } } + +!$ACC EXIT DATA COPYOUT (cpo_f_p(4:10)) FINALIZE +! { dg-final { scan-tree-dump-times "(?n)#pragma acc exit data map\\(from:\\*\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\) parm\\.1\\.data \\\[len: \[^\\\]\]+\\\]\\) map\\(to:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:\\(integer\\(kind=1\\)\\\[0:\\\] \\* restrict\\) cpo_f_p\\.data \\\[pointer assign, bias: \\(.*int.*\\) parm\\.1\\.data - \\(.*int.*\\) cpo_f_p\\.data\\\]\\) finalize;$" 1 "original" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_exit_data map\\(force_from:MEM <\[^>\]+> \\\[\\(integer\\(kind=.\\)\\\[0:\\\] \\*\\)_\[0-9\]+\\\] \\\[len: \[^\\\]\]+\\\]\\) map\\(to:cpo_f_p \\\[pointer set, len: \[0-9\]+\\\]\\) map\\(alloc:cpo_f_p\\.data \\\[pointer assign, bias: \[^\\\]\]+\\\]\\) finalize$" 1 "gimple" } } + END SUBROUTINE f Index: Fortran/gfortran/regression/goacc/firstprivate-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/firstprivate-1.f95 @@ -0,0 +1,11 @@ +! { dg-do compile } + +program test + integer a, b(100) + + !$acc parallel firstprivate (a, b) + !$acc end parallel + + !$acc parallel firstprivate (b(10:20)) ! { dg-error "Syntax error in OpenMP variable list" } + !$acc end parallel ! { dg-error "Unexpected !\\\$ACC END PARALLEL statement" } +end program test Index: Fortran/gfortran/regression/goacc/fixed-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/fixed-1.f @@ -0,0 +1,12 @@ + INTEGER :: ARGC + ARGC = COMMAND_ARGUMENT_COUNT () + +!$OMP PARALLEL +!$ACC PARALLEL COPYIN(ARGC) + IF (ARGC .NE. 0) THEN + STOP 1 + END IF +!$ACC END PARALLEL +!$OMP END PARALLEL + + END Index: Fortran/gfortran/regression/goacc/fixed-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/fixed-2.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + + INTEGER :: ARGC + ARGC = COMMAND_ARGUMENT_COUNT () + +!$OMP xPARALLEL +!$ACC xPARALLEL COPYIN(ARGC) ! { dg-error "Unclassifiable OpenACC directive" } + IF (ARGC .NE. 0) THEN + STOP 1 + END IF +!$ACC END PARALLEL ! { dg-error "Unexpected" } +!$OMP END PARALLEL + + END Index: Fortran/gfortran/regression/goacc/fixed-3.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/fixed-3.f @@ -0,0 +1,13 @@ + IMPLICIT NONE + + INTEGER DEV + +!$ACC PARALLEL + DEV = 0 +!$ACC END PARALLEL + +!$ACC PARALLEL + DEV = 0 +!$ACC END PARALLEL + + END Index: Fortran/gfortran/regression/goacc/fixed-4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/fixed-4.f @@ -0,0 +1,6 @@ + IMPLICIT NONE + +!$ACC PARALLEL +!$ACC END PARALLEL + + END Index: Fortran/gfortran/regression/goacc/fixed-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/fixed-5.f @@ -0,0 +1,30 @@ +! Check that OpenMP conditional compilations sentinels ('!$ ') are ignored + +c$ bogus +!$ bogus +*$ bogus +c$ bogus +!$ bogus +*$ bogus + +c$a23 bogus +!$ a bogus +*$12a bogus + +c$ 1 bogus +!$ 22 bogus +*$34 bogus + +c$bogus +!$bogus +*$bogus + +c$ acc bogus +!$ acc bogus +*$ acc bogus + +c$ acc bogus +!$ acc bogus +*$ acc bogus + + end Index: Fortran/gfortran/regression/goacc/gang-static.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/gang-static.f95 @@ -0,0 +1,82 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-omplower" } + +program main + integer, parameter :: n = 100 + integer i, a(n), b(n) + + do i = 1, n + b(i) = i + end do + + !$acc parallel loop gang (static:*) num_gangs (10) + do i = 1, n + a(i) = b(i) + 0 + end do + !$acc end parallel loop + + call test (a, b, 0, n) + + !$acc parallel loop gang (static:1) num_gangs (10) + do i = 1, n + a(i) = b(i) + 1 + end do + !$acc end parallel loop + + call test (a, b, 1, n) + + !$acc parallel loop gang (static:2) num_gangs (10) + do i = 1, n + a(i) = b(i) + 2 + end do + !$acc end parallel loop + + call test (a, b, 2, n) + + !$acc parallel loop gang (static:5) num_gangs (10) + do i = 1, n + a(i) = b(i) + 5 + end do + !$acc end parallel loop + + call test (a, b, 5, n) + + !$acc parallel loop gang (static:20) num_gangs (10) + do i = 1, n + a(i) = b(i) + 20 + end do + !$acc end parallel loop + + !$acc kernels loop gang (num:5, static:*) + do i = 1, n + a(i) = b(i) + 20 + end do + !$acc end kernels loop + + !$acc kernels loop gang (static:20, num:30) + do i = 1, n + a(i) = b(i) + 20 + end do + !$acc end kernels loop + + call test (a, b, 20, n) + +end program main + +subroutine test (a, b, sarg, n) + integer n + integer a (n), b(n), sarg + integer i + + do i = 1, n + if (a(i) .ne. b(i) + sarg) STOP 1 + end do +end subroutine test + +! { dg-final { scan-tree-dump-times "gang\\(static:\\\*\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(static:1\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(static:2\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(static:5\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(static:20\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(num: 5 static:\\\*\\)" 1 "omplower" } } +! { dg-final { scan-tree-dump-times "gang\\(num: 30 static:20\\)" 1 "omplower" } } Index: Fortran/gfortran/regression/goacc/goacc.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/goacc.exp @@ -0,0 +1,61 @@ +# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +if ![check_effective_target_fopenacc] { + return +} + +# Initialize `dg'. +dg-init + +global gfortran_test_path +global gfortran_aux_module_flags +set gfortran_test_path $srcdir/$subdir +set gfortran_aux_module_flags "-fopenacc" +proc dg-compile-aux-modules { args } { + global gfortran_test_path + global gfortran_aux_module_flags + if { [llength $args] != 2 } { + error "dg-compile-aux-modules: needs one argument" + return + } + + set level [info level] + if { [info procs dg-save-unknown] != [list] } { + rename dg-save-unknown dg-save-unknown-level-$level + } + + dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags + # cleanup-modules is intentionally not invoked here. + + if { [info procs dg-save-unknown-level-$level] != [list] } { + rename dg-save-unknown-level-$level dg-save-unknown + } +} + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-fopenacc" + +# All done. +dg-finish Index: Fortran/gfortran/regression/goacc/host_data-tree.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/host_data-tree.f95 @@ -0,0 +1,27 @@ +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" } + +! { dg-additional-options -Wuninitialized } + +program test + implicit none + integer, pointer :: p + ! { dg-note {'p' was declared here} {} { target *-*-* } .-1 } + + !$acc host_data use_device(p) + ! { dg-warning {'p' is used uninitialized} {} { target *-*-* } .-1 } + ! { dg-final { scan-tree-dump-times "(?n)#pragma acc host_data use_device_ptr\\(p\\)$" 1 "original" } } + ! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_host_data use_device_ptr\\(p\\)$" 1 "gimple" } } + !$acc end host_data + + !$acc host_data use_device(p) if (p == 42) + ! { dg-final { scan-tree-dump-times "(?n)D\\.\[0-9\]+ = \\*p == 42;$" 1 "original" } } + ! { dg-final { scan-tree-dump-times "(?n)#pragma acc host_data use_device_ptr\\(p\\) if\\(D\\.\[0-9\]+\\)$" 1 "original" } } + ! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_host_data use_device_ptr\\(p\\) if\\((?:D\\.|_)\[0-9\]+\\)$" 1 "gimple" } } + !$acc end host_data + + !$acc host_data use_device(p) if_present if (p == 43) + ! { dg-final { scan-tree-dump-times "(?n)D\\.\[0-9\]+ = \\*p == 43;$" 1 "original" } } + ! { dg-final { scan-tree-dump-times "(?n)#pragma acc host_data use_device_ptr\\(p\\) if\\(D\\.\[0-9\]+\\) if_present$" 1 "original" } } + ! { dg-final { scan-tree-dump-times "(?n)#pragma omp target oacc_host_data use_device_ptr\\(if_present:p\\) if\\((?:D\\.|_)\[0-9\]+\\) if_present$" 1 "gimple" } } + !$acc end host_data +end program test Index: Fortran/gfortran/regression/goacc/if.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/if.f95 @@ -0,0 +1,52 @@ +! { dg-do compile } + +program test + implicit none + + logical :: x + integer :: i + + !$acc parallel if ! { dg-error "Expected '\\(' after 'if'" } + !$acc parallel if () ! { dg-error "Invalid character" } + !$acc parallel if (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end parallel + !$acc parallel if (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end parallel + !$acc kernels if (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end kernels + !$acc kernels if ! { dg-error "Expected '\\(' after 'if'" } + !$acc kernels if () ! { dg-error "Invalid character" } + !$acc kernels if (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end kernels + !$acc data if ! { dg-error "Expected '\\(' after 'if'" } + !$acc data if () ! { dg-error "Invalid character" } + !$acc data if (i) ! { dg-error "scalar LOGICAL expression" } + !$acc end data + !$acc data if (1) ! { dg-error "scalar LOGICAL expression" } + !$acc end data + + ! at most one if clause may appear + !$acc parallel if (.false.) if (.false.) { dg-error "Duplicated 'if' clause" } + !$acc kernels if (.false.) if (.false.) { dg-error "Duplicated 'if' clause" } + !$acc data if (.false.) if (.false.) { dg-error "Duplicated 'if' clause" } + + !$acc parallel if (x) + !$acc end parallel + !$acc parallel if (.true.) + !$acc end parallel + !$acc parallel if (i.gt.1) + !$acc end parallel + !$acc kernels if (x) + !$acc end kernels + !$acc kernels if (.true.) + !$acc end kernels + !$acc kernels if (i.gt.1) + !$acc end kernels + !$acc data if (x) + !$acc end data + !$acc data if (.true.) + !$acc end data + !$acc data if (i.gt.1) + !$acc end data + +end program test Index: Fortran/gfortran/regression/goacc/kernels-alias-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-alias-2.f95 @@ -0,0 +1,25 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-ealias-all" } + +program main + implicit none + integer, parameter :: n = 2 + integer :: a, b, c, d + + !$acc kernels copyin (a) create (b) copyout (c) copy (d) + a = 0 + b = 0 + c = 0 + d = 0 + !$acc end kernels + +end program main + +! The xfails occur in light of the new OpenACC data semantics. + +! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } } +! { dg-final { scan-tree-dump-times "clique 1 base 2" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 3" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 4" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 5" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "(?n)clique .* base .*" 8 "ealias" } } Index: Fortran/gfortran/regression/goacc/kernels-alias-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-alias-3.f95 @@ -0,0 +1,19 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-ealias-all" } + +program main + implicit none + integer, target :: a + integer, pointer :: ptr + ptr => a + + !$acc kernels pcopyin (a, ptr) + a = 0 + ptr = 1 + !$acc end kernels + +end program main + +! Only the omp_data_i related loads should be annotated with cliques. +! { dg-final { scan-tree-dump-times "clique 1 base 1" 2 "ealias" } } +! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 3 "ealias" } } Index: Fortran/gfortran/regression/goacc/kernels-alias-4.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-alias-4.f95 @@ -0,0 +1,20 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-ealias-all" } + +program main + implicit none + integer, parameter :: n = 2 + integer, target, dimension (0:n-1) :: a + integer, pointer :: ptr(:) + ptr => a + + !$acc kernels pcopyin (a, ptr(0:2)) + a(0) = 0 + ptr(0) = 1 + !$acc end kernels + +end program main + +! Only the omp_data_i related loads should be annotated with cliques. +! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } } +! { dg-final { scan-tree-dump-times "(?n)clique 1 base 0" 5 "ealias" } } Index: Fortran/gfortran/regression/goacc/kernels-alias.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-alias.f95 @@ -0,0 +1,25 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-ealias-all" } + +program main + implicit none + integer, parameter :: n = 2 + integer, dimension (0:n-1) :: a, b, c, d + + !$acc kernels copyin (a) create (b) copyout (c) copy (d) + a(0) = 0 + b(0) = 0 + c(0) = 0 + d(0) = 0 + !$acc end kernels + +end program main + +! The xfails occur in light of the new OpenACC data semantics. + +! { dg-final { scan-tree-dump-times "clique 1 base 1" 4 "ealias" } } +! { dg-final { scan-tree-dump-times "clique 1 base 2" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 3" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 4" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "clique 1 base 5" 1 "ealias" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "(?n)clique .* base .*" 8 "ealias" } } Index: Fortran/gfortran/regression/goacc/kernels-decompose-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-decompose-1.f95 @@ -0,0 +1,105 @@ +! Test OpenACC 'kernels' construct decomposition. + +! { dg-additional-options "-fopt-info-omp-all" } + +! { dg-additional-options "-fdump-tree-gimple" } + +! { dg-additional-options "--param=openacc-kernels=decompose" } +! { dg-additional-options "-fdump-tree-omp_oacc_kernels_decompose" } + +! { dg-additional-options "--param=openacc-privatization=noisy" } +! Prune a few: uninteresting, and potentially varying depending on GCC configuration (data types): +! { dg-prune-output {note: variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +! See also '../../c-c++-common/goacc/kernels-decompose-1.c'. + +! It's only with Tcl 8.5 (released in 2007) that "the variable 'varName' +! passed to 'incr' may be unset, and in that case, it will be set to [...]", +! so to maintain compatibility with earlier Tcl releases, we manually +! initialize counter variables: +! { dg-line l_dummy[variable c_compute 0 c_loop_i 0] } +! { dg-message "dummy" "" { target iN-VAl-Id } l_dummy } to avoid +! "WARNING: dg-line var l_dummy defined, but not used". + +program main + implicit none + integer, parameter :: N = 1024 + integer, dimension (1:N) :: a + integer :: i, sum + + !$acc kernels copyin(a(1:N)) copy(sum) ! { dg-line l_compute[incr c_compute] } + ! { dg-note {variable 'sum\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-bogus "optimized: assigned OpenACC seq loop parallelism" "TODO" { xfail *-*-* } l_compute$c_compute } + !TODO Is this maybe the report that belongs to the XFAILed report further down? */ + + !$acc loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + sum = sum + a(i) + end do + + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + sum = sum + 1 + a(1) = a(1) + 1 + + !$acc loop independent ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {parallelized loop nest in OpenACC 'kernels' region} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC gang vector loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + sum = sum + a(i) + end do + + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + if (sum .gt. 10) then + !$acc loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-missed "unparallelized loop nest in OpenACC 'kernels' region: it's executed conditionally" "" { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + !TODO { dg-optimized "assigned OpenACC seq loop parallelism" "TODO" { xfail *-*-* } l_loop_i$c_loop_i } + do i = 1, N + sum = sum + a(i) + end do + end if + + !$acc loop auto ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + sum = sum + a(i) + end do + + !$acc end kernels +end program main + +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_kernels map\(to:a\[_[0-9]+\] \[len: _[0-9]+\]\) map\(alloc:a \[pointer assign, bias: _[0-9]+\]\) map\(tofrom:sum \[len: [0-9]+\]\)$} 1 "gimple" } } + +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\)$} 2 "gimple" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\) independent$} 1 "gimple" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\) auto$} 1 "gimple" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop} 4 "gimple" } } + +! Check that the OpenACC 'kernels' got decomposed into 'data' and an enclosed +! sequence of compute constructs. +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_data_kernels map\(to:a\[_[0-9]+\] \[len: _[0-9]+\]\) map\(tofrom:sum \[len: [0-9]+\]\)$} 1 "omp_oacc_kernels_decompose" } } +! As noted above, we get three "old-style" kernel regions, one gang-single region, and one parallelized loop region. +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_kernels async\(-1\) map\(force_present:a\[_[0-9]+\] \[len: _[0-9]+\]\) map\(alloc:a \[pointer assign, bias: _[0-9]+\]\) map\(force_present:sum \[len: [0-9]+\]\)$} 3 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_parallel_kernels_parallelized async\(-1\) map\(force_present:a\[_[0-9]+\] \[len: _[0-9]+\]\) map\(alloc:a \[pointer assign, bias: _[0-9]+\]\) map\(force_present:sum \[len: [0-9]+\]\)$} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_parallel_kernels_gang_single async\(-1\) num_gangs\(1\) map\(force_present:a\[_[0-9]+\] \[len: _[0-9]+\]\) map\(alloc:a \[pointer assign, bias: _[0-9]+\]\) map\(force_present:sum \[len: [0-9]+\]\)$} 1 "omp_oacc_kernels_decompose" } } +! +! 'data' plus five CCs. +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target } 6 "omp_oacc_kernels_decompose" } } + +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\)$} 2 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\) independent$} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop private\(i\) auto} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma acc loop} 4 "omp_oacc_kernels_decompose" } } + +! Each of the parallel regions is async, and there is a final call to +! __builtin_GOACC_wait. +! { dg-final { scan-tree-dump-times "__builtin_GOACC_wait" 1 "omp_oacc_kernels_decompose" } } Index: Fortran/gfortran/regression/goacc/kernels-decompose-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-decompose-2.f95 @@ -0,0 +1,198 @@ +! Test OpenACC 'kernels' construct decomposition. + +! { dg-additional-options "-fopt-info-omp-all" } + +! { dg-additional-options "--param=openacc-kernels=decompose" } +! { dg-additional-options "-O2" } for 'parloops'. + +! { dg-additional-options "--param=openacc-privatization=noisy" } +! Prune a few: uninteresting, and potentially varying depending on GCC configuration (data types): +! { dg-prune-output {note: variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +! See also '../../c-c++-common/goacc/kernels-decompose-2.c'. + +! It's only with Tcl 8.5 (released in 2007) that "the variable 'varName' +! passed to 'incr' may be unset, and in that case, it will be set to [...]", +! so to maintain compatibility with earlier Tcl releases, we manually +! initialize counter variables: +! { dg-line l_dummy[variable c_compute 0 c_loop_i 0 c_loop_j 0 c_loop_k 0 c_part 0] } +! { dg-message "dummy" "" { target iN-VAl-Id } l_dummy } to avoid +! "WARNING: dg-line var l_dummy defined, but not used". + +program main + implicit none + + integer, external :: f_g + !$acc routine (f_g) gang + integer, external :: f_w + !$acc routine (f_w) worker + integer, external :: f_v + !$acc routine (f_v) vector + integer, external :: f_s + !$acc routine (f_s) seq + + integer :: i, j, k + integer :: x, y, z + logical :: y_l + integer, parameter :: N = 10 + integer :: a(N), b(N), c(N) + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'z' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'z' made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'y_l' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'y_l' made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'y' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'y' made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'x' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'x' made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + x = 0 + y = 0 + y_l = x < 10 + z = x + x = x + 1 + ; + !$acc end kernels + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'i' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'i' made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-optimized {assigned OpenACC gang loop parallelism} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + do i = 1, N + a(i) = 0 + end do + !$acc end kernels + + !$acc kernels loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + b(i) = a(N - i + 1) + end do + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'z' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'z' already made addressable} {} { target *-*-* } l_compute$c_compute } + !$acc loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + b(i) = a(N - i + 1) + end do + + !$acc loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + c(i) = a(i) * b(i) + end do + + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + a(z) = 0 + + !$acc loop ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + c(i) = c(i) + a(i) + end do + + !$acc loop seq ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {parallelized loop nest in OpenACC 'kernels' region} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1 + 1, N + c(i) = c(i) + c(i - 1) + end do + !$acc end kernels + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'y' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'y' already made addressable} {} { target *-*-* } l_compute$c_compute } + !TODO What does this mean? + !TODO { dg-optimized "assigned OpenACC worker vector loop parallelism" "" { target *-*-* } l_compute$c_compute } + !$acc loop independent ! { dg-line l_loop_i[incr c_loop_i] } + ! { dg-note {parallelized loop nest in OpenACC 'kernels' region} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-note {variable 'i' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_i$c_loop_i } + ! { dg-optimized "assigned OpenACC gang loop parallelism" "" { target *-*-* } l_loop_i$c_loop_i } + do i = 1, N + !$acc loop independent ! { dg-line l_loop_j[incr c_loop_j] } + ! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_j$c_loop_j } + ! { dg-optimized "assigned OpenACC worker loop parallelism" "" { target *-*-* } l_loop_j$c_loop_j } + do j = 1, N + !$acc loop independent ! { dg-line l_loop_k[incr c_loop_k] } + ! { dg-note {variable 'k' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_k$c_loop_k } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } l_loop_k$c_loop_k } + ! { dg-optimized "assigned OpenACC seq loop parallelism" "" { target *-*-* } l_loop_k$c_loop_k } + do k = 1, N + a(1 + mod(i + j + k, N)) & + = b(j) & + + f_v (c(k)) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + end do + end do + end do + + !TODO Should the following turn into "gang-single" instead of "parloops"? + !TODO The problem is that the first STMT is 'if (y <= 4) goto ; else goto ;', thus "parloops". + ! { dg-note {beginning 'parloops' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + if (y < 5) then + !$acc loop independent ! { dg-line l_loop_j[incr c_loop_j] } + ! { dg-missed "unparallelized loop nest in OpenACC 'kernels' region: it's executed conditionally" "" { target *-*-* } l_loop_j$c_loop_j } + ! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_j$c_loop_j } + do j = 1, N + b(j) = f_w (c(j)) + end do + end if + !$acc end kernels + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'y' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'y' already made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-bogus "\[Ww\]arning: region contains gang partitioned code but is not gang partitioned" "TODO 'kernels'" { xfail *-*-* } l_compute$c_compute } + y = f_g (a(5)) ! { dg-line l_part[incr c_part] } + !TODO If such a construct is placed in its own part (like it is, here), can't this actually use gang paralelism, instead of "gang-single"? + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } l_part$c_part } + ! { dg-optimized "assigned OpenACC gang worker vector loop parallelism" "" { target *-*-* } l_part$c_part } + + !$acc loop independent ! { dg-line l_loop_j[incr c_loop_j] } + ! { dg-note {parallelized loop nest in OpenACC 'kernels' region} {} { target *-*-* } l_loop_j$c_loop_j } + ! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_j$c_loop_j } + ! { dg-optimized "assigned OpenACC gang loop parallelism" "" { target *-*-* } l_loop_j$c_loop_j } + do j = 1, N + b(j) = y + f_w (c(j)) ! { dg-optimized "assigned OpenACC worker vector loop parallelism" } + end do + !$acc end kernels + + !$acc kernels ! { dg-line l_compute[incr c_compute] } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'z' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'z' already made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {OpenACC 'kernels' decomposition: variable 'y' in 'copy' clause requested to be made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {variable 'y' already made addressable} {} { target *-*-* } l_compute$c_compute } + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + y = 3 + + !$acc loop independent ! { dg-line l_loop_j[incr c_loop_j] } + ! { dg-note {parallelized loop nest in OpenACC 'kernels' region} {} { target *-*-* } l_loop_j$c_loop_j } + ! { dg-note {variable 'j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop_j$c_loop_j } + ! { dg-optimized "assigned OpenACC gang worker loop parallelism" "" { target *-*-* } l_loop_j$c_loop_j } + do j = 1, N + b(j) = y + f_v (c(j)) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + end do + + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + z = 2 + !$acc end kernels + + ! { dg-note {beginning 'gang-single' part in OpenACC 'kernels' region} {} { target *-*-* } .+1 } + !$acc kernels + !$acc end kernels +end program main Index: Fortran/gfortran/regression/goacc/kernels-loop-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-2.f95 @@ -0,0 +1,43 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc kernels copyout (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + + !$acc kernels copyout (b(0:n-1)) + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end kernels + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 3 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 3 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-data-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-data-2.f95 @@ -0,0 +1,49 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc data copyout (a(0:n-1)) + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + !$acc end data + + !$acc data copyout (b(0:n-1)) + !$acc kernels present (b(0:n-1)) + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end kernels + !$acc end data + + !$acc data copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + !$acc end data + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 3 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 3 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-data-enter-exit-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-data-enter-exit-2.f95 @@ -0,0 +1,49 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc enter data create (a(0:n-1)) + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + !$acc exit data copyout (a(0:n-1)) + + !$acc enter data create (b(0:n-1)) + !$acc kernels present (b(0:n-1)) + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end kernels + !$acc exit data copyout (b(0:n-1)) + + !$acc enter data copyin (a(0:n-1), b(0:n-1)) create (c(0:n-1)) + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + !$acc exit data copyout (c(0:n-1)) + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 3 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 3 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-data-enter-exit.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-data-enter-exit.f95 @@ -0,0 +1,47 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc enter data create (a(0:n-1), b(0:n-1), c(0:n-1)) + + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + + !$acc kernels present (b(0:n-1)) + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end kernels + + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + !$acc exit data copyout (a(0:n-1), b(0:n-1), c(0:n-1)) + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 3 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 3 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-data-update.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-data-update.f95 @@ -0,0 +1,46 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc enter data create (a(0:n-1), b(0:n-1), c(0:n-1)) + + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + + do i = 0, n -1 + b(i) = i * 4 + end do + + !$acc update device (b(0:n-1)) + + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + !$acc exit data copyout (a(0:n-1), c(0:n-1)) + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 2 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 2 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-data.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-data.f95 @@ -0,0 +1,47 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc data copyout (a(0:n-1), b(0:n-1), c(0:n-1)) + + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + + !$acc kernels present (b(0:n-1)) + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end kernels + + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + !$acc end data + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 3 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 3 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop-inner.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-inner.f95 @@ -0,0 +1,23 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fopt-info-optimized-omp" } + +program main + implicit none + + integer :: a(100,100), b(100,100) + integer :: i, j, d + + !$acc kernels ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i=1,100 + do j=1,100 + a(i,j) = 1 + b(i,j) = 2 + a(i,j) = a(i,j) + b(i,j) + end do + end do + !$acc end kernels + + d = sum(a) + + print *,d +end program main Index: Fortran/gfortran/regression/goacc/kernels-loop-n.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop-n.f95 @@ -0,0 +1,40 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +module test +contains + subroutine foo(n) + implicit none + integer :: n + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + do i = 0, n - 1 + a(i) = i * 2 + end do + + do i = 0, n -1 + b(i) = i * 4 + end do + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + + end subroutine foo +end module test + +! Check that only one loop is analyzed, and that it can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 1 "parloops1" } } +! TODO, PR70545. +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function __test_MOD_foo._omp_fn.0 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loop.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loop.f95 @@ -0,0 +1,37 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + do i = 0, n - 1 + a(i) = i * 2 + end do + + do i = 0, n -1 + b(i) = i * 4 + end do + + !$acc kernels copyin (a(0:n-1), b(0:n-1)) copyout (c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) STOP 1 + end do + +end program main + +! Check that only one loop is analyzed, and that it can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 1 "parloops1" } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 1 "parloops1" } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-loops-adjacent.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-loops-adjacent.f95 @@ -0,0 +1,18 @@ +! { dg-additional-options "-O2" } + +program main + implicit none + + integer :: a(10000), b(10000) + integer :: d + + !$acc kernels + a = 1 + b = 2 + a = a + b + !$acc end kernels + + d = sum(a) + + print *,d +end program main Index: Fortran/gfortran/regression/goacc/kernels-parallel-loop-data-enter-exit.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-parallel-loop-data-enter-exit.f95 @@ -0,0 +1,48 @@ +! { dg-additional-options "-O2" } +! { dg-additional-options "-fdump-tree-parloops1-all" } +! { dg-additional-options "-fdump-tree-optimized" } + +program main + implicit none + integer, parameter :: n = 1024 + integer, dimension (0:n-1) :: a, b, c + integer :: i, ii + + !$acc enter data create (a(0:n-1), b(0:n-1), c(0:n-1)) + + !$acc kernels present (a(0:n-1)) + do i = 0, n - 1 + a(i) = i * 2 + end do + !$acc end kernels + + !$acc parallel present (b(0:n-1)) + !$acc loop + do i = 0, n -1 + b(i) = i * 4 + end do + !$acc end parallel + + !$acc kernels present (a(0:n-1), b(0:n-1), c(0:n-1)) + do ii = 0, n - 1 + c(ii) = a(ii) + b(ii) + end do + !$acc end kernels + + !$acc exit data copyout (a(0:n-1), b(0:n-1), c(0:n-1)) + + do i = 0, n - 1 + if (c(i) .ne. a(i) + b(i)) call abort + end do + +end program main + +! Check that only three loops are analyzed, and that all can be parallelized. +! { dg-final { scan-tree-dump-times "SUCCESS: may be parallelized" 2 "parloops1" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc function \\(, , \\), oacc kernels, omp target entrypoint, noclone\\)\\)" 2 "parloops1" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-not "FAILED:" "parloops1" { xfail *-*-* } } } + +! Check that the loop has been split off into a function. +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.0 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.1 " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "(?n);; Function MAIN__._omp_fn.2 " 1 "optimized" } } Index: Fortran/gfortran/regression/goacc/kernels-tree.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/kernels-tree.f95 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "--param=openacc-kernels=decompose" } +! { dg-additional-options "-fdump-tree-omp_oacc_kernels_decompose" } + +! { dg-additional-options -Wuninitialized } + +program test + implicit none + integer :: q, i, j, k, m, n, o, p, r, s, t, u, v, w + ! { dg-note {'i' was declared here} {} { target *-*-* } .-1 } + logical :: l = .true. + + !$acc kernels if(l) async num_gangs(i) num_workers(i) vector_length(i) & + !$acc copy(i), copyin(j), copyout(k), create(m) & + !$acc no_create(n) & + !$acc present(o), pcopy(p), pcopyin(r), pcopyout(s), pcreate(t) & + !$acc deviceptr(u) + ! { dg-warning {'i' is used uninitialized} {} { target *-*-* } .-1 } + !$acc end kernels + +end program test +! { dg-final { scan-tree-dump-times "pragma acc kernels" 1 "original" } } + +! { dg-final { scan-tree-dump-times "if" 1 "original" } } +! { dg-final { scan-tree-dump-times "async" 1 "original" } } +! { dg-final { scan-tree-dump-times "num_gangs" 1 "original" } } +! { dg-final { scan-tree-dump-times "num_workers" 1 "original" } } +! { dg-final { scan-tree-dump-times "vector_length" 1 "original" } } + +! { dg-final { scan-tree-dump-times "map\\(tofrom:i\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:j\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:k\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:m\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(no_alloc:n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(force_present:o\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:p\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:r\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:s\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:t\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "map\\(force_deviceptr:u\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_data_kernels if\((?:D\.|_)[0-9]+\)$} 1 "omp_oacc_kernels_decompose" } } +! { dg-final { scan-tree-dump-times {(?n)#pragma omp target oacc_parallel_kernels_gang_single num_gangs\(1\) if\((?:D\.|_)[0-9]+\) async\(-1\)$} 1 "omp_oacc_kernels_decompose" } } Index: Fortran/gfortran/regression/goacc/list.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/list.f95 @@ -0,0 +1,115 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +program test + implicit none + + integer :: i, j, k, l, a(10) + common /b/ k + real, pointer :: p1 => NULL() + complex :: c, d(10) + + !$acc parallel private(i) + !$acc end parallel + + !$acc parallel private(a) + !$acc end parallel + + !$acc parallel private(c, d) + !$acc end parallel + + !$acc parallel private(i, j, k, l, a) + !$acc end parallel + + !$acc parallel private (i) private (j) + !$acc end parallel + + !$acc parallel private ! { dg-error "Failed to match clause" } + + !$acc parallel private() ! { dg-error "Syntax error" } + + !$acc parallel private(a(1:3)) ! { dg-error "Syntax error" } + + !$acc parallel private(10) ! { dg-error "Syntax error" } + + !$acc parallel private(/b/, /b/) ! { dg-error "present on multiple clauses" } + !$acc end parallel + + !$acc parallel private(i, j, i) ! { dg-error "present on multiple clauses" } + !$acc end parallel + + !$acc parallel private(p1) + !$acc end parallel + + !$acc parallel firstprivate(i) + !$acc end parallel + + !$acc parallel firstprivate(c, d) + !$acc end parallel + + !$acc parallel firstprivate(a) + !$acc end parallel + + !$acc parallel firstprivate(i, j, k, l, a) + !$acc end parallel + + !$acc parallel firstprivate (i) firstprivate (j) + !$acc end parallel + + !$acc parallel firstprivate ! { dg-error "Failed to match clause" } + + !$acc parallel firstprivate() ! { dg-error "Syntax error" } + + !$acc parallel firstprivate(a(1:3)) ! { dg-error "Syntax error" } + + !$acc parallel firstprivate(10) ! { dg-error "Syntax error" } + + !$acc parallel firstprivate (/b/, /b/) ! { dg-error "present on multiple clauses" } + !$acc end parallel + + !$acc parallel firstprivate (i, j, i) ! { dg-error "present on multiple clauses" } + !$acc end parallel + + !$acc parallel firstprivate(p1) + !$acc end parallel + + !$acc parallel private (i) firstprivate (i) ! { dg-error "present on multiple clauses" } + !$acc end parallel + + !$acc host_data use_device(i) ! { dg-error "neither a POINTER nor an array" } + !$acc end host_data + + !$acc host_data use_device(c, d) ! { dg-error "neither a POINTER nor an array" } + !$acc end host_data + + !$acc host_data use_device(a) + !$acc end host_data + + !$acc host_data use_device(i, j, k, l, a) ! { dg-error "neither a POINTER nor an array" } + !$acc end host_data + + !$acc host_data use_device (i) use_device (j) ! { dg-error "neither a POINTER nor an array" } + !$acc end host_data + + !$acc host_data use_device ! { dg-error "Failed to match clause" } + + !$acc host_data use_device() ! { dg-error "Syntax error" } + + !$acc host_data use_device(a(1:3)) ! { dg-error "Syntax error" } + + !$acc host_data use_device(10) ! { dg-error "Syntax error" } + + !$acc host_data use_device(/b/, /b/) + !$acc end host_data + ! { dg-error "neither a POINTER nor an array" "" { target *-*-* } 102 } + ! { dg-error "present on multiple clauses" "" { target *-*-* } 102 } + + !$acc host_data use_device(i, j, i) + !$acc end host_data + ! { dg-error "neither a POINTER nor an array" "" { target *-*-* } 107 } + ! { dg-error "present on multiple clauses" "" { target *-*-* } 107 } + + !$acc host_data use_device(p1) + !$acc end host_data + +end program test Index: Fortran/gfortran/regression/goacc/literal.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/literal.f95 @@ -0,0 +1,30 @@ +! { dg-do compile } + +module test +contains + subroutine oacc1 + implicit none + integer :: i + !$acc declare device_resident (10) ! { dg-error "Syntax error" } + !$acc data copy (10) ! { dg-error "Syntax error" } + !$acc end data ! { dg-error "Unexpected" } + !$acc data deviceptr (10) ! { dg-error "Syntax error" } + !$acc end data ! { dg-error "Unexpected" } + !$acc data private (10) ! { dg-error "Failed to match clause" } + !$acc end data ! { dg-error "Unexpected" } + !$acc host_data use_device (10) ! { dg-error "Syntax error" } + !$acc end host_data ! { dg-error "Unexpected" } + !$acc parallel loop reduction(+:10) ! { dg-error "Syntax error" } + do i = 1,5 + enddo + !$acc end parallel loop ! { dg-error "Unexpected" } + !$acc parallel loop + do i = 1,5 + !$acc cache (10) ! { dg-error "Syntax error" } + enddo + !$acc end parallel loop + !$acc update device (10) ! { dg-error "Syntax error" } + !$acc update host (10) ! { dg-error "Syntax error" } + !$acc update self (10) ! { dg-error "Syntax error" } + end subroutine oacc1 +end module test Index: Fortran/gfortran/regression/goacc/loop-1-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-1-2.f95 @@ -0,0 +1,173 @@ +! See also loop-1.f95. +! { dg-additional-options "-std=legacy" } + +program test + call test1 +contains + +subroutine test1 + integer :: i, j, k, b(10) + integer, dimension (30) :: a + double precision :: d + real :: r + i = 0 + !$acc loop + do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + 100 i = i + 1 + i = 0 + !$acc loop + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + i = i + 1 + end do + i = 0 + !$acc loop + do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + 200 i = i + 1 + !$acc loop + do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + i = i + 1 + end do + !$acc loop + do 300 d = 1, 30, 6 + i = d + 300 a(i) = 1 + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 33 } + !$acc loop + do d = 1, 30, 5 + i = d + a(i) = 2 + end do + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 38 } + !$acc loop + do i = 1, 30 + if (i .eq. 16) exit ! { dg-error "EXIT statement" } + end do + !$acc loop + outer: do i = 1, 30 + do j = 5, 10 + if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" } + end do + end do outer + last: do i = 1, 30 + end do last + + ! different types of loop are allowed + !$acc loop + do i = 1,10 + end do + !$acc loop + do 400, i = 1,10 +400 a(i) = i + + ! after loop directive must be loop + !$acc loop + a(1) = 1 ! { dg-error "Expected DO loop" } + do i = 1,10 + enddo + + ! combined directives may be used with/without end + !$acc parallel loop + do i = 1,10 + enddo + !$acc parallel loop + do i = 1,10 + enddo + !$acc end parallel loop + !$acc kernels loop + do i = 1,10 + enddo + !$acc kernels loop + do i = 1,10 + enddo + !$acc end kernels loop + + !$acc kernels loop reduction(max:i) + do i = 1,10 + enddo + !$acc kernels + !$acc loop reduction(max:i) + do i = 1,10 + enddo + !$acc end kernels + + !$acc parallel loop collapse(0) ! { dg-error "constant positive integer" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(-1) ! { dg-error "constant positive integer" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(i) ! { dg-error "Constant expression required" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(4) ! { dg-error "not enough DO loops for collapsed" } + do i = 1, 3 + do j = 4, 6 + do k = 5, 7 + a(i+j-k) = i + j + k + end do + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "collapsed loops don.t form rectangular iteration space" } + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(3-1) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(1+1) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do r = 4, 6 + end do + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 150 } + end do + + !$acc loop independent seq + do i = 1,10 + enddo + + + !$acc cache (a(1:10)) ! { dg-error "ACC CACHE directive must be inside of loop" } + + do i = 1,10 + !$acc cache(a(i:i+1)) + enddo + + do i = 1,10 + !$acc cache(a(i:i+1)) + a(i) = i + !$acc cache(a(i+2:i+2+1)) + enddo + +end subroutine test1 +end program test Index: Fortran/gfortran/regression/goacc/loop-1.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-1.f95 @@ -0,0 +1,173 @@ +! See also loop-1-2.f95. +! { dg-additional-options "-std=legacy" } + +module test + implicit none +contains + +subroutine test1 + integer :: i, j, k, b(10) + integer, dimension (30) :: a + double precision :: d + real :: r + i = 0 + !$acc loop + do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + 100 i = i + 1 + i = 0 + !$acc loop + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + i = i + 1 + end do + i = 0 + !$acc loop + do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + 200 i = i + 1 + !$acc loop + do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + i = i + 1 + end do + !$acc loop + do 300 d = 1, 30, 6 + i = d + 300 a(i) = 1 + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 33 } + !$acc loop + do d = 1, 30, 5 + i = d + a(i) = 2 + end do + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 38 } + !$acc loop + do i = 1, 30 + if (i .eq. 16) exit ! { dg-error "EXIT statement" } + end do + !$acc loop + outer: do i = 1, 30 + do j = 5, 10 + if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" } + end do + end do outer + last: do i = 1, 30 + end do last + + ! different types of loop are allowed + !$acc loop + do i = 1,10 + end do + !$acc loop + do 400, i = 1,10 +400 a(i) = i + + ! after loop directive must be loop + !$acc loop + a(1) = 1 ! { dg-error "Expected DO loop" } + do i = 1,10 + enddo + + ! combined directives may be used with/without end + !$acc parallel loop + do i = 1,10 + enddo + !$acc parallel loop + do i = 1,10 + enddo + !$acc end parallel loop + !$acc kernels loop + do i = 1,10 + enddo + !$acc kernels loop + do i = 1,10 + enddo + !$acc end kernels loop + + !$acc kernels loop reduction(max:i) + do i = 1,10 + enddo + !$acc kernels + !$acc loop reduction(max:i) + do i = 1,10 + enddo + !$acc end kernels + + !$acc parallel loop collapse(0) ! { dg-error "constant positive integer" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(-1) ! { dg-error "constant positive integer" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(i) ! { dg-error "Constant expression required" } + do i = 1,10 + enddo + + !$acc parallel loop collapse(4) ! { dg-error "not enough DO loops for collapsed" } + do i = 1, 3 + do j = 4, 6 + do k = 5, 7 + a(i+j-k) = i + j + k + end do + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "collapsed loops don.t form rectangular iteration space" } + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(3-1) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(1+1) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + end do + end do + !$acc parallel loop collapse(2) + do i = 1, 3 + do r = 4, 6 + end do + ! { dg-error "ACC LOOP iteration variable must be of type integer" "" { target *-*-* } 150 } + end do + + !$acc loop independent seq + do i = 1,10 + enddo + + + !$acc cache (a(1:10)) ! { dg-error "ACC CACHE directive must be inside of loop" } + + do i = 1,10 + !$acc cache(a(i:i+1)) + enddo + + do i = 1,10 + !$acc cache(a(i:i+1)) + a(i) = i + !$acc cache(a(i+2:i+2+1)) + enddo + +end subroutine test1 +end module test Index: Fortran/gfortran/regression/goacc/loop-2-kernels-nested.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-kernels-nested.f95 @@ -0,0 +1,34 @@ +program test + implicit none + integer :: i, j + + !$acc kernels loop gang + DO i = 1,10 + !$acc kernels loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + + !$acc kernels loop worker + DO i = 1,10 + !$acc kernels loop worker ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc kernels loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + + !$acc kernels loop vector + DO i = 1,10 + !$acc kernels loop vector ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc kernels loop worker ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc kernels loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-kernels-tile.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-kernels-tile.f95 @@ -0,0 +1,119 @@ +program test + implicit none + integer :: i, j + + !$acc kernels + !$acc loop tile ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop tile() ! { dg-error "Syntax error" } + DO i = 1,10 + ENDDO + !$acc loop tile(1) + DO i = 1,10 + ENDDO + !$acc loop tile(2) + DO i = 1,10 + ENDDO + !$acc loop tile(6-2) + DO i = 1,10 + ENDDO + !$acc loop tile(6+2) + DO i = 1,10 + ENDDO + !$acc loop tile(*) + DO i = 1,10 + ENDDO + !$acc loop tile(*, 1) + DO i = 1,10 + DO j = 1,10 + ENDDO + ENDDO + !$acc loop tile(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop tile(i) ! { dg-error "constant expression" } + do i = 1,10 + enddo + !$acc loop tile(2, 2, 1) ! { dg-error "not enough DO loops for tiled" } + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc loop tile(2, 2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "tiled loops don.t form rectangular iteration space" } + end do + end do + !$acc loop vector tile(*) + DO i = 1,10 + ENDDO + !$acc loop worker tile(*) + DO i = 1,10 + ENDDO + !$acc loop gang tile(*) + DO i = 1,10 + ENDDO + !$acc loop vector gang tile(*) + DO i = 1,10 + ENDDO + !$acc loop vector worker tile(*) + DO i = 1,10 + ENDDO + !$acc loop gang worker tile(*) + DO i = 1,10 + ENDDO + !$acc end kernels + + !$acc kernels loop tile ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc kernels loop tile() ! { dg-error "Syntax error" } + DO i = 1,10 + ENDDO + !$acc kernels loop tile(1) + DO i = 1,10 + ENDDO + !$acc kernels loop tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop tile(*, 1) + DO i = 1,10 + DO j = 1,10 + ENDDO + ENDDO + !$acc kernels loop tile(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc kernels loop tile(i) ! { dg-error "constant expression" } + do i = 1,10 + enddo + !$acc kernels loop tile(2, 2, 1) ! { dg-error "not enough DO loops for tiled" } + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc kernels loop tile(2, 2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "tiled loops don.t form rectangular iteration space" } + end do + end do + !$acc kernels loop vector tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop worker tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop gang tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop vector gang tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop vector worker tile(*) + DO i = 1,10 + ENDDO + !$acc kernels loop gang worker tile(*) + DO i = 1,10 + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-kernels.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-kernels.f95 @@ -0,0 +1,190 @@ +! See also "../../c-c++-common/goacc/loop-2-kernels.c". + +program test + implicit none + integer :: i, j + + !$acc kernels + !$acc loop auto + DO i = 1,10 + ENDDO + !$acc loop gang + DO i = 1,10 + ENDDO + !$acc loop gang(5) + DO i = 1,10 + ENDDO + !$acc loop gang(num:5) + DO i = 1,10 + ENDDO + !$acc loop gang(static:5) + DO i = 1,10 + ENDDO + !$acc loop gang(static:*) + DO i = 1,10 + ENDDO + !$acc loop gang + DO i = 1,10 + !$acc loop vector + DO j = 1,10 + ENDDO + !$acc loop worker + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq gang ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + + !$acc loop worker + DO i = 1,10 + ENDDO + !$acc loop worker(5) + DO i = 1,10 + ENDDO + !$acc loop worker(num:5) + DO i = 1,10 + ENDDO + !$acc loop worker + DO i = 1,10 + !$acc loop vector + DO j = 1,10 + ENDDO + !$acc loop worker ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq worker ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang worker + DO i = 1,10 + ENDDO + + !$acc loop vector + DO i = 1,10 + ENDDO + !$acc loop vector(5) + DO i = 1,10 + ENDDO + !$acc loop vector(length:5) + DO i = 1,10 + ENDDO + !$acc loop vector + DO i = 1,10 + !$acc loop vector ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + !$acc loop worker ! { dg-error "" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq vector ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang vector + DO i = 1,10 + ENDDO + !$acc loop worker vector + DO i = 1,10 + ENDDO + + !$acc loop auto + DO i = 1,10 + ENDDO + !$acc loop seq auto ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop worker auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop vector auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc end kernels + + !$acc kernels loop auto + DO i = 1,10 + ENDDO + !$acc kernels loop gang + DO i = 1,10 + ENDDO + !$acc kernels loop gang(5) + DO i = 1,10 + ENDDO + !$acc kernels loop gang(num:5) + DO i = 1,10 + ENDDO + !$acc kernels loop gang(static:5) + DO i = 1,10 + ENDDO + !$acc kernels loop gang(static:*) + DO i = 1,10 + ENDDO + !$acc kernels loop seq gang ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + + !$acc kernels loop worker + DO i = 1,10 + ENDDO + !$acc kernels loop worker(5) + DO i = 1,10 + ENDDO + !$acc kernels loop worker(num:5) + DO i = 1,10 + ENDDO + !$acc kernels loop seq worker ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc kernels loop gang worker + DO i = 1,10 + ENDDO + + !$acc kernels loop vector + DO i = 1,10 + ENDDO + !$acc kernels loop vector(5) + DO i = 1,10 + ENDDO + !$acc kernels loop vector(length:5) + DO i = 1,10 + ENDDO + !$acc kernels loop seq vector ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc kernels loop gang vector + DO i = 1,10 + ENDDO + !$acc kernels loop worker vector + DO i = 1,10 + ENDDO + + !$acc kernels loop auto + DO i = 1,10 + ENDDO + !$acc kernels loop seq auto ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc kernels loop gang auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc kernels loop worker auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc kernels loop vector auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-parallel-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-parallel-3.f95 @@ -0,0 +1,56 @@ +! See also "../../c-c++-common/goacc/loop-3.c". + +program test + implicit none + integer :: i + + !$acc parallel + !$acc loop gang(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc loop gang(num:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc loop worker(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc loop worker(num:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc loop vector(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc loop vector(length:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + !$acc end parallel + + !$acc parallel loop gang(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc parallel loop gang(num:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc parallel loop worker(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc parallel loop worker(num:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc parallel loop vector(5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO + + !$acc parallel loop vector(length:5) ! { dg-error "argument not permitted" } + DO i = 1,10 + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-parallel-nested.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-parallel-nested.f95 @@ -0,0 +1,34 @@ +program test + implicit none + integer :: i, j + + !$acc parallel loop gang + DO i = 1,10 + !$acc parallel loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + + !$acc parallel loop worker + DO i = 1,10 + !$acc parallel loop worker ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc parallel loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO + + !$acc parallel loop vector + DO i = 1,10 + !$acc parallel loop vector ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc parallel loop worker ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + !$acc parallel loop gang ! { dg-bogus "OpenACC construct inside of non-OpenACC region" "TODO" { xfail *-*-* } } + DO j = 1,10 + ENDDO + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-parallel-tile.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-parallel-tile.f95 @@ -0,0 +1,110 @@ +program test + implicit none + integer :: i, j + + !$acc parallel + !$acc loop tile ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop tile() ! { dg-error "Syntax error" } + DO i = 1,10 + ENDDO + !$acc loop tile(1) + DO i = 1,10 + ENDDO + !$acc loop tile(*) + DO i = 1,10 + ENDDO + !$acc loop tile(2) + DO i = 1,10 + DO j = 1,10 + ENDDO + ENDDO + !$acc loop tile(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop tile(i) ! { dg-error "constant expression" } + do i = 1,10 + enddo + !$acc loop tile(2, 2, 1) ! { dg-error "not enough DO loops for tiled" } + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc loop tile(2, 2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "tiled loops don.t form rectangular iteration space" } + end do + end do + !$acc loop vector tile(*) + DO i = 1,10 + ENDDO + !$acc loop worker tile(*) + DO i = 1,10 + ENDDO + !$acc loop gang tile(*) + DO i = 1,10 + ENDDO + !$acc loop vector gang tile(*) + DO i = 1,10 + ENDDO + !$acc loop vector worker tile(*) + DO i = 1,10 + ENDDO + !$acc loop gang worker tile(*) + DO i = 1,10 + ENDDO + !$acc end parallel + + !$acc parallel loop tile ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc parallel loop tile() ! { dg-error "Syntax error" } + DO i = 1,10 + ENDDO + !$acc parallel loop tile(1) + DO i = 1,10 + ENDDO + !$acc parallel loop tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop tile(*, 1) + DO i = 1,10 + DO j = 1,10 + ENDDO + ENDDO + !$acc parallel loop tile(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc parallel loop tile(i) ! { dg-error "constant expression" } + do i = 1,10 + enddo + !$acc parallel loop tile(2, 2, 1) ! { dg-error "not enough DO loops for tiled" } + do i = 1, 3 + do j = 4, 6 + end do + end do + !$acc parallel loop tile(2, 2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "tiled loops don.t form rectangular iteration space" } + end do + end do + !$acc parallel loop vector tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop worker tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop gang tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop vector gang tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop vector worker tile(*) + DO i = 1,10 + ENDDO + !$acc parallel loop gang worker tile(*) + DO i = 1,10 + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-2-parallel.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-2-parallel.f95 @@ -0,0 +1,154 @@ +! See also "../../c-c++-common/goacc/loop-2-parallel.c". + +program test + implicit none + integer :: i, j + + !$acc parallel + !$acc loop auto + DO i = 1,10 + ENDDO + !$acc loop gang + DO i = 1,10 + ENDDO + !$acc loop gang(static:5) + DO i = 1,10 + ENDDO + !$acc loop gang(static:*) + DO i = 1,10 + ENDDO + !$acc loop gang + DO i = 1,10 + !$acc loop vector + DO j = 1,10 + ENDDO + !$acc loop worker + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq gang ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + + !$acc loop worker + DO i = 1,10 + ENDDO + !$acc loop worker + DO i = 1,10 + !$acc loop vector + DO j = 1,10 + ENDDO + !$acc loop worker ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "incorrectly nested OpenACC loop parallelism" } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq worker ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang worker + DO i = 1,10 + ENDDO + + !$acc loop vector + DO i = 1,10 + ENDDO + !$acc loop vector + DO i = 1,10 + !$acc loop vector ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + DO j = 1,10 + ENDDO + !$acc loop worker ! { dg-error "incorrectly nested OpenACC loop parallelism" } + DO j = 1,10 + ENDDO + !$acc loop gang ! { dg-error "incorrectly nested OpenACC loop parallelism" } + DO j = 1,10 + ENDDO + ENDDO + !$acc loop seq vector ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang vector + DO i = 1,10 + ENDDO + !$acc loop worker vector + DO i = 1,10 + ENDDO + + !$acc loop auto + DO i = 1,10 + ENDDO + !$acc loop seq auto ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop gang auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop worker auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc loop vector auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc end parallel + + !$acc parallel loop auto + DO i = 1,10 + ENDDO + !$acc parallel loop gang + DO i = 1,10 + ENDDO + !$acc parallel loop gang(static:5) + DO i = 1,10 + ENDDO + !$acc parallel loop gang(static:*) + DO i = 1,10 + ENDDO + !$acc parallel loop seq gang ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + + !$acc parallel loop worker + DO i = 1,10 + ENDDO + !$acc parallel loop seq worker ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc parallel loop gang worker + DO i = 1,10 + ENDDO + + !$acc parallel loop vector + DO i = 1,10 + ENDDO + !$acc parallel loop seq vector ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc parallel loop gang vector + DO i = 1,10 + ENDDO + !$acc parallel loop worker vector + DO i = 1,10 + ENDDO + + !$acc parallel loop auto + DO i = 1,10 + ENDDO + !$acc parallel loop seq auto ! { dg-error "'seq' overrides other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc parallel loop gang auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc parallel loop worker auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO + !$acc parallel loop vector auto ! { dg-error "'auto' conflicts with other OpenACC loop specifiers" } + DO i = 1,10 + ENDDO +end Index: Fortran/gfortran/regression/goacc/loop-3-2.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-3-2.f95 @@ -0,0 +1,58 @@ +! { dg-additional-options "-std=f2008" } +! See also loop-3.f95. + +program test + call test1 +contains +subroutine test1 + implicit none + integer :: i, j + + ! !$acc end loop not required by spec + !$acc loop + do i = 1,5 + enddo + !$acc end loop ! { dg-warning "Redundant" } + + !$acc loop + do i = 1,5 + enddo + j = 1 + !$acc end loop ! { dg-error "Unexpected" } + + !$acc parallel + !$acc loop + do i = 1,5 + enddo + !$acc end parallel + !$acc end loop ! { dg-error "Unexpected" } + + ! OpenACC does not support Fortran 2008 do concurrent statement + !$acc loop + do concurrent (i = 1:5) ! { dg-error "ACC LOOP cannot be a DO CONCURRENT loop" } + end do + + !$acc loop + outer_loop: do i = 1, 5 + inner_loop: do j = 1,5 + if (i .eq. j) cycle outer_loop + if (i .ne. j) exit outer_loop ! { dg-error "EXIT statement" } + end do inner_loop + end do outer_loop + + outer_loop1: do i = 1, 5 + !$acc loop + inner_loop1: do j = 1,5 + if (i .eq. j) cycle outer_loop1 ! { dg-error "CYCLE statement" } + end do inner_loop1 + end do outer_loop1 + + !$acc loop collapse(2) + outer_loop2: do i = 1, 5 + inner_loop2: do j = 1,5 + if (i .eq. j) cycle outer_loop2 ! { dg-error "CYCLE statement" } + if (i .ne. j) exit outer_loop2 ! { dg-error "EXIT statement" } + end do inner_loop2 + end do outer_loop2 +end subroutine test1 +end program test Index: Fortran/gfortran/regression/goacc/loop-3.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-3.f95 @@ -0,0 +1,54 @@ +! { dg-additional-options "-std=f2008" } +! See also loop-3-2.f95. + +subroutine test1 + implicit none + integer :: i, j + + ! !$acc end loop not required by spec + !$acc loop + do i = 1,5 + enddo + !$acc end loop ! { dg-warning "Redundant" } + + !$acc loop + do i = 1,5 + enddo + j = 1 + !$acc end loop ! { dg-error "Unexpected" } + + !$acc parallel + !$acc loop + do i = 1,5 + enddo + !$acc end parallel + !$acc end loop ! { dg-error "Unexpected" } + + ! OpenACC does not support Fortran 2008 do concurrent statement + !$acc loop + do concurrent (i = 1:5) ! { dg-error "ACC LOOP cannot be a DO CONCURRENT loop" } + end do + + !$acc loop + outer_loop: do i = 1, 5 + inner_loop: do j = 1,5 + if (i .eq. j) cycle outer_loop + if (i .ne. j) exit outer_loop ! { dg-error "EXIT statement" } + end do inner_loop + end do outer_loop + + outer_loop1: do i = 1, 5 + !$acc loop + inner_loop1: do j = 1,5 + if (i .eq. j) cycle outer_loop1 ! { dg-error "CYCLE statement" } + end do inner_loop1 + end do outer_loop1 + + !$acc loop collapse(2) + outer_loop2: do i = 1, 5 + inner_loop2: do j = 1,5 + if (i .eq. j) cycle outer_loop2 ! { dg-error "CYCLE statement" } + if (i .ne. j) exit outer_loop2 ! { dg-error "EXIT statement" } + end do inner_loop2 + end do outer_loop2 +end subroutine test1 Index: Fortran/gfortran/regression/goacc/loop-4.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-4.f95 @@ -0,0 +1,7 @@ +! Ensure that loops not affiliated with acc compute regions cause an error. + +subroutine test1 + !$acc loop gang ! { dg-error "loop directive must be associated with an OpenACC compute region" } + DO i = 1,10 + ENDDO +end subroutine test1 Index: Fortran/gfortran/regression/goacc/loop-7.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-7.f95 @@ -0,0 +1,122 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +program test + implicit none + integer :: i, j, static, num, length + + !$acc kernels + !$acc loop gang(static:static) + DO i = 1,10 + ENDDO + !$acc loop gang(static:*) + DO i = 1,10 + ENDDO + !$acc loop gang(static:1) + DO i = 1,10 + ENDDO + !$acc loop gang(,static:1) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + !$acc loop gang(static:1,) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + !$acc loop gang(static:*, num:5) + DO i = 1,10 + ENDDO + !$acc loop gang(static:1, 5) + DO i = 1,10 + ENDDO + !$acc loop gang(num:num, static:1) + DO i = 1,10 + ENDDO + !$acc loop gang(static:*, num:5, static:5) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop gang(1, num:2, static:3) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop gang(num:num static:1) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop gang(num) + DO i = 1,10 + ENDDO + !$acc loop gang(num:num+1, static:1+num) + DO i = 1,10 + ENDDO + !$acc loop gang(length:num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + + !$acc loop worker + DO i = 1,10 + ENDDO + !$acc loop worker (5) + DO i = 1,10 + ENDDO + !$acc loop worker (num) + DO i = 1,10 + ENDDO + !$acc loop worker (static:num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop worker (num:,) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + !$acc loop worker (num:num:num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop worker (num:num*num) + DO i = 1,10 + ENDDO + !$acc loop worker (length:num*num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop worker (num:*) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + !$acc loop worker (num:5) + DO i = 1,10 + ENDDO + + !$acc loop vector + DO i = 1,10 + ENDDO + !$acc loop vector (32) + DO i = 1,10 + ENDDO + !$acc loop vector (length) + DO i = 1,10 + ENDDO + !$acc loop vrctor (static:num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop vector (length:,) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + !$acc loop vector (length:num:num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop vector (length:static*num) + DO i = 1,10 + ENDDO + !$acc loop vector (length:length) + DO i = 1,10 + ENDDO + !$acc loop vector (length:32) + DO i = 1,10 + ENDDO + !$acc loop vector (num:num*num) ! { dg-error "Failed to match clause" } + DO i = 1,10 + ENDDO + !$acc loop vector (length:*) ! { dg-error "Invalid character" } + DO i = 1,10 + ENDDO + + + !$acc loop auto + DO i = 1,10 + ENDDO + !$acc end kernels +end Index: Fortran/gfortran/regression/goacc/loop-tree-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/loop-tree-1.f90 @@ -0,0 +1,47 @@ +! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple -std=f2008" } + +! test for tree-dump-original and spaces-commas + +program test + implicit none + integer :: i, j, k, m, sum + REAL :: a(64), b(64), c(64) + + !$acc kernels + !$acc loop collapse(2) + DO i = 1,10 + DO j = 1,10 + ENDDO + ENDDO + + !$acc loop independent gang (3) + DO i = 1,10 + !$acc loop worker(3) + DO j = 1,10 + !$acc loop vector(5) + DO k = 1,10 + ENDDO + ENDDO + ENDDO + !$acc end kernels + + sum = 0 + !$acc parallel + !$acc loop private(m) reduction(+:sum) + DO i = 1,10 + sum = sum + 1 + ENDDO + !$acc end parallel + +end program test +! { dg-final { scan-tree-dump-times "pragma acc loop" 5 "original" } } + +! { dg-final { scan-tree-dump-times "collapse\\(2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "independent" 1 "original" } } +! { dg-final { scan-tree-dump-times "gang\\(num: 3\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "worker\\(3\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "vector\\(5\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "private\\(m\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "reduction\\(\\+:sum\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:sum \\\[len: \[0-9\]+\\\]\\)" 1 "gimple" } } Index: Fortran/gfortran/regression/goacc/mapping-tests-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/mapping-tests-1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +subroutine foo + type t + integer :: i, j + end type t + + type(t) x + + ! We should reject the duplicate reference here. +!$acc enter data copyin(x%i, x%i) +! { dg-error ".x.i. appears more than once in map clauses" "" { target "*-*-*" } 11 } + + +end Index: Fortran/gfortran/regression/goacc/mapping-tests-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/mapping-tests-2.f90 @@ -0,0 +1,32 @@ +subroutine foo + type t + integer :: i, j + end type t + + type t2 + type(t) :: cc(3) + end type t2 + + type(t) x, y(3) + type(t2) :: z(3) + + ! OK - map whole aggregated variable +!$acc enter data copyin(x) + ! map(to:x [len: 8]) + + ! OK - map two components of the aggregated variable +!$acc enter data copyin(x%j, x%i) + + ! Bad - we cannot mix full-object and component accesses +!$acc enter data copyin(x, x%i) +! { dg-error "Symbol .x. has mixed component and non-component accesses" "" { target "*-*-*" } 21 } + + ! Bad - we cannot do a strided access of 'x' + ! No C/C++ equivalent +!$acc enter data copyin(y(:)%i) +! { dg-error "not a proper array section" "" { target "*-*-*" } 26 } + + ! Bad - again, a strided access +!$acc enter data copyin(z(1)%cc(:)%i) +! { dg-error "not a proper array section" "" { target "*-*-*" } 30 } +end Index: Fortran/gfortran/regression/goacc/mapping-tests-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/mapping-tests-3.f90 @@ -0,0 +1,15 @@ +! { dg-additional-options "-fdump-tree-gimple" } + +subroutine foo + type one + integer i, j + end type + type two + type(one) A, B + end type + + type(two) x + + !$acc enter data copyin(x%A) +! { dg-final { scan-tree-dump-times "omp target oacc_enter_data map\\(struct:x \\\[len: 1\\\]\\) map\\(to:x.a \\\[len: \[0-9\]+\\\]\\)" 1 "gimple" } } +end Index: Fortran/gfortran/regression/goacc/mapping-tests-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/mapping-tests-4.f90 @@ -0,0 +1,17 @@ +subroutine foo + type one + integer i, j + end type + type two + type(one) A, B + end type + + type(two) x + +! This is accepted at present, although it represents a probably-unintentional +! overlapping subcopy. + !$acc enter data copyin(x%A, x%A%i) +! But this raises an error. + !$acc enter data copyin(x%A, x%A%i, x%A%i) +! { dg-error ".x.a.i. appears more than once in map clauses" "" { target *-*-* } .-1 } +end Index: Fortran/gfortran/regression/goacc/mapping-tests-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/mapping-tests-5.f90 @@ -0,0 +1,15 @@ +subroutine foo + type one + integer, dimension(10) :: i, j + end type + type two + type(one) A, B + end type + + type(two) x + + !$acc enter data copyin(x%A%i(5), x%A%i(4), x%A) +! { dg-error ".x.a.i. appears more than once in map clauses" "" { target *-*-* } .-1 } + !$acc enter data copyin(x%A, x%A%i(5), x%A%i(4)) +! { dg-error ".x.a.i. appears more than once in map clauses" "" { target *-*-* } .-1 } +end Index: Fortran/gfortran/regression/goacc/modules.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/modules.f95 @@ -0,0 +1,57 @@ +! { dg-additional-options -Wuninitialized } + +MODULE reduction_test + +CONTAINS + +SUBROUTINE reduction_kernel(x_min,x_max,y_min,y_max,arr,sum) + + IMPLICIT NONE + + INTEGER :: x_min,x_max,y_min,y_max + REAL(KIND=8), DIMENSION(x_min-2:x_max+2,y_min-2:y_max+2) :: arr + REAL(KIND=8) :: sum + + INTEGER :: j,k + + sum=0.0 + +!$ACC DATA PRESENT(arr) COPY(sum) +!$ACC PARALLEL LOOP REDUCTION(+ : sum) + ! { dg-bogus {'sum\.[0-9]+' is used uninitialized} TODO { xfail *-*-* } .-1 } + ! { dg-note {'sum\.[0-9]+' was declared here} {} { target *-*-* } .-2 } + DO k=y_min,y_max + DO j=x_min,x_max + sum=sum*arr(j,k) + ENDDO + ENDDO +!$ACC END PARALLEL LOOP +!$ACC END DATA + +END SUBROUTINE reduction_kernel + +END MODULE reduction_test + +program main + use reduction_test + + integer :: x_min,x_max,y_min,y_max + real(kind=8), dimension(1:10,1:10) :: arr + real(kind=8) :: sum + + x_min = 5 + x_max = 6 + y_min = 5 + y_max = 6 + + arr(:,:) = 1.0 + + sum = 1.0 + + !$acc data copy(arr) + + call field_summary_kernel(x_min,x_max,y_min,y_max,arr,sum) + + !$acc end data + +end program Index: Fortran/gfortran/regression/goacc/multi-clause.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/multi-clause.f90 @@ -0,0 +1,13 @@ +! Test if variable appearing in multiple clauses are errors. + +! { dg-do compile } + +program combined + implicit none + integer a(100), i, j + + !$acc parallel loop reduction (+:j) copy (j) copyout(j) ! { dg-error "Symbol 'j' present on multiple clauses" } + do i = 1, 100 + end do + !$acc end parallel loop +end program combined Index: Fortran/gfortran/regression/goacc/nested-function-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-function-1.f90 @@ -0,0 +1,149 @@ +! Exercise nested function decomposition, gcc/tree-nested.c. +! See gcc/testsuite/gcc.dg/goacc/nested-function-1.c for the C version. + +! { dg-additional-options "--param=openacc-kernels=decompose" } + +! { dg-additional-options "-fopt-info-all-omp" } + +! { dg-additional-options "--param=openacc-privatization=noisy" } +! Prune a few: uninteresting, and potentially varying depending on GCC configuration (data types): +! { dg-prune-output {note: variable 'D\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} } + +! It's only with Tcl 8.5 (released in 2007) that "the variable 'varName' +! passed to 'incr' may be unset, and in that case, it will be set to [...]", +! so to maintain compatibility with earlier Tcl releases, we manually +! initialize counter variables: +! { dg-line l_dummy[variable c_compute_loop 0 c_loop 0] } +! { dg-message dummy {} { target iN-VAl-Id } l_dummy } to avoid +! "WARNING: dg-line var l_dummy defined, but not used". + +program main + integer, parameter :: N = 100 + integer :: nonlocal_arg + integer :: nonlocal_a(N) + integer :: nonlocal_i + integer :: nonlocal_j + + nonlocal_a (:) = 5 + nonlocal_arg = 5 + + call local () + call nonlocal () + +contains + + subroutine local () + integer :: local_i + integer :: local_arg + integer :: local_a(N) + integer :: local_j + + local_a (:) = 5 + local_arg = 5 + + !$acc update device(local_a) if_present + + !$acc kernels loop & + !$acc gang(num:local_arg) worker(local_arg) vector(local_arg) & + !$acc wait async(local_arg) ! { dg-line l_compute_loop[incr c_compute_loop] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i' in 'private' clause is candidate for adjusting OpenACC privatization level} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute_loop$c_compute_loop } + do local_i = 1, N + !$acc cache (local_a(local_i:local_i + 5)) + local_a(local_i) = 100 + !$acc loop seq tile(*) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'local_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do local_j = 1, N + enddo + !$acc loop auto independent tile(1) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'local_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do local_j = 1, N + enddo + enddo + !$acc end kernels loop + + !$acc kernels loop & + !$acc gang(static:local_arg) worker(local_arg) vector(local_arg) & + !$acc wait(local_arg, local_arg + 1, local_arg + 2) async ! { dg-line l_compute_loop[incr c_compute_loop] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i' in 'private' clause is candidate for adjusting OpenACC privatization level} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'local_i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute_loop$c_compute_loop } + do local_i = 1, N + !$acc cache (local_a(local_i:local_i + 4)) + local_a(local_i) = 100 + !$acc loop seq tile(1) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'local_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do local_j = 1, N + enddo + !$acc loop auto independent tile(*) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'local_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do local_j = 1, N + enddo + enddo + !$acc end kernels loop + + !$acc exit data copyout(local_a) delete(local_i) finalize + end subroutine local + + subroutine nonlocal () + nonlocal_a (:) = 5 + nonlocal_arg = 5 + + !$acc update device(nonlocal_a) if_present + + !$acc kernels loop & + !$acc gang(num:nonlocal_arg) worker(nonlocal_arg) vector(nonlocal_arg) & + !$acc wait async(nonlocal_arg) ! { dg-line l_compute_loop[incr c_compute_loop] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i' in 'private' clause is candidate for adjusting OpenACC privatization level} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute_loop$c_compute_loop } + do nonlocal_i = 1, N + !$acc cache (nonlocal_a(nonlocal_i:nonlocal_i + 3)) + nonlocal_a(nonlocal_i) = 100 + !$acc loop seq tile(2) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'nonlocal_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do nonlocal_j = 1, N + enddo + !$acc loop auto independent tile(3) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'nonlocal_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do nonlocal_j = 1, N + enddo + enddo + !$acc end kernels loop + + !$acc kernels loop & + !$acc gang(static:nonlocal_arg) worker(nonlocal_arg) vector(nonlocal_arg) & + !$acc wait(nonlocal_arg, nonlocal_arg + 1, nonlocal_arg + 2) async ! { dg-line l_compute_loop[incr c_compute_loop] } + ! { dg-note {forwarded loop nest in OpenACC 'kernels' region to 'parloops' for analysis} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i' in 'private' clause is candidate for adjusting OpenACC privatization level} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'nonlocal_i\.[0-9]+' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_compute_loop$c_compute_loop } + ! { dg-optimized {assigned OpenACC seq loop parallelism} {} { target *-*-* } l_compute_loop$c_compute_loop } + do nonlocal_i = 1, N + !$acc cache (nonlocal_a(nonlocal_i:nonlocal_i + 2)) + nonlocal_a(nonlocal_i) = 100 + !$acc loop seq tile(*) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'nonlocal_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do nonlocal_j = 1, N + enddo + !$acc loop auto independent tile(*) ! { dg-line l_loop[incr c_loop] } + ! { dg-note {variable 'nonlocal_j' in 'private' clause isn't candidate for adjusting OpenACC privatization level: not addressable} {} { target *-*-* } l_loop$c_loop } + do nonlocal_j = 1, N + enddo + enddo + !$acc end kernels loop + + !$acc exit data copyout(nonlocal_a) delete(nonlocal_i) finalize + end subroutine nonlocal +end program main Index: Fortran/gfortran/regression/goacc/nested-parallelism.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-parallelism.f90 @@ -0,0 +1,51 @@ +! Verify the invalid gang, worker, vector parallelism error messages. + +program np + integer, parameter :: n = 100 + integer :: i, j, k + + !$acc parallel loop gang + do i = 1, n + !$acc loop gang ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + do j = 1, n + end do + + !$acc loop worker + do j = 1, n + end do + + !$acc loop vector + do j = 1, n + end do + end do + + !$acc parallel loop worker + do i = 1, n + !$acc loop gang ! { dg-error "incorrectly nested OpenACC loop parallelism" } + do j = 1, n + end do + + !$acc loop worker ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + do j = 1, n + end do + + !$acc loop vector + do j = 1, n + end do + end do + + !$acc parallel loop vector + do i = 1, n + !$acc loop gang ! { dg-error "incorrectly nested OpenACC loop parallelism" } + do j = 1, n + end do + + !$acc loop worker ! { dg-error "incorrectly nested OpenACC loop parallelism" } + do j = 1, n + end do + + !$acc loop vector ! { dg-error "inner loop uses same OpenACC parallelism as containing loop" } + do j = 1, n + end do + end do +end program np Index: Fortran/gfortran/regression/goacc/nested-reductions-1-kernels.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-1-kernels.f90 @@ -0,0 +1,311 @@ +! Test cases of nested 'reduction' clauses expected to compile cleanly. + +! See also 'c-c++-common/goacc/nested-reductions-1-kernels.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_kernels () + implicit none (type, external) + integer :: i, j, k, sum, diff + + !$acc kernels + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop collapse(2) reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end kernels +end subroutine acc_kernels + +! The same tests as above, but using a combined kernels loop construct. + +subroutine acc_kernels_loop () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc kernels loop + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop collapse(2) reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_kernels_loop + +! The same tests as above, but now the outermost reduction clause is on +! the kernels region, not the outermost loop. */ + +subroutine acc_kernels_reduction () + implicit none (type, external) + + ! In contrast to the 'parallel' construct, the 'reduction' clause is not + ! supported on the 'kernels' construct. +end subroutine acc_kernels_reduction + +! The same tests as above, but using a combined kernels loop construct, and +! the outermost reduction clause is on that one, not the outermost loop. */ +subroutine acc_kernels_loop_reduction () + implicit none (type, external) + integer :: h, i, j, k, sum, diff + + !$acc kernels loop reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + !$acc loop + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + do j = 1, 10 + !$acc loop + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_kernels_loop_reduction Index: Fortran/gfortran/regression/goacc/nested-reductions-1-parallel.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-1-parallel.f90 @@ -0,0 +1,418 @@ +! Test cases of nested 'reduction' clauses expected to compile cleanly. + +! See also 'c-c++-common/goacc/nested-reductions-1-parallel.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_parallel () + implicit none (type, external) + integer :: i, j, k, sum, diff + + !$acc parallel + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop collapse(2) reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end parallel +end subroutine acc_parallel + +! The same tests as above, but using a combined parallel loop construct. + +subroutine acc_parallel_loop () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc parallel loop + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop collapse(2) reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_parallel_loop + +! The same tests as above, but now the outermost reduction clause is on +! the parallel region, not the outermost loop. */ + +subroutine acc_parallel_reduction () + implicit none (type, external) + integer :: i, j, k, sum, diff + + !$acc parallel reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + !$acc loop + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + do j = 1, 10 + !$acc loop + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end parallel +end subroutine acc_parallel_reduction + +! The same tests as above, but using a combined parallel loop construct, and +! the outermost reduction clause is on that one, not the outermost loop. */ +subroutine acc_parallel_loop_reduction () + implicit none (type, external) + integer :: h, i, j, k, sum, diff + + !$acc parallel loop reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + !$acc loop + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + do i = 1, 10 + do j = 1, 10 + !$acc loop + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop ! { dg-warning "insufficient partitioning available to parallelize loop" } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_parallel_loop_reduction Index: Fortran/gfortran/regression/goacc/nested-reductions-1-routine.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-1-routine.f90 @@ -0,0 +1,99 @@ +! Test cases of nested 'reduction' clauses expected to compile cleanly. + +! See also 'c-c++-common/goacc/nested-reductions-1-routine.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_routine () + implicit none (type, external) + !$acc routine gang + + integer :: i, j, k, sum, diff + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + ! { dg-warning {'sum' is used uninitialized} {} { target *-*-* } .-1 } + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop collapse(2) reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) reduction(+:sum) + do j = 1, 10 + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) reduction(-:diff) + ! { dg-warning {'diff' is used uninitialized} {} { target *-*-* } .-1 } + do i = 1, 10 + !$acc loop reduction(+:sum) + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(-:diff) + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do +end subroutine acc_routine Index: Fortran/gfortran/regression/goacc/nested-reductions-2-kernels.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-2-kernels.f90 @@ -0,0 +1,400 @@ +! Test erroneous cases of nested 'reduction' clauses. + +! See also 'c-c++-common/goacc/nested-reductions-2-kernels.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_kernels () + implicit none (type, external) + integer :: i, j, k, l, sum, diff + + !$acc kernels + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end kernels +end subroutine acc_kernels + +! The same tests as above, but using a combined kernels loop construct. + +subroutine acc_kernels_loop () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc kernels loop + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_kernels_loop + +! The same tests as above, but now the outermost reduction clause is on +! the kernels region, not the outermost loop. + +subroutine acc_kernels_reduction () + implicit none (type, external) + + ! In contrast to the 'parallel' construct, the 'reduction' clause is not + ! supported on the 'kernels' construct. +end subroutine acc_kernels_reduction + +! The same tests as above, but using a combined kernels loop construct, and +! the outermost reduction clause is on that one, not the outermost loop. */ +subroutine acc_kernels_loop_reduction () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc kernels loop reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "TODO" { xfail *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_kernels_loop_reduction Index: Fortran/gfortran/regression/goacc/nested-reductions-2-parallel.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-2-parallel.f90 @@ -0,0 +1,513 @@ +! Test erroneous cases of nested 'reduction' clauses. + +! See also 'c-c++-common/goacc/nested-reductions-2-parallel.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_parallel () + implicit none (type, external) + integer :: i, j, k, l, sum, diff + + !$acc parallel + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end parallel +end subroutine acc_parallel + +! The same tests as above, but using a combined parallel loop construct. + +subroutine acc_parallel_loop () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc parallel loop + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(+:sum) reduction(-:diff) + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_parallel_loop + +! The same tests as above, but now the outermost reduction clause is on +! the parallel region, not the outermost loop. + +subroutine acc_parallel_reduction () + implicit none (type, external) + integer :: i, j, k, l, sum, diff + + !$acc parallel reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + !$acc end parallel +end subroutine acc_parallel_reduction + +! The same tests as above, but using a combined parallel loop construct, and +! the outermost reduction clause is on that one, not the outermost loop. */ +subroutine acc_parallel_loop_reduction () + implicit none (type, external) + integer :: h, i, j, k, l, sum, diff + + !$acc parallel loop reduction(+:sum) + ! implicit 'copy (sum, diff)' + ! { dg-warning {'sum' is used uninitialized} TODO { xfail *-*-* } .-2 } + ! { dg-warning {'diff' is used uninitialized} TODO { xfail *-*-* } .-3 } + do h = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(max:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do + end do +end subroutine acc_parallel_loop_reduction Index: Fortran/gfortran/regression/goacc/nested-reductions-2-routine.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/nested-reductions-2-routine.f90 @@ -0,0 +1,131 @@ +! Test erroneous cases of nested 'reduction' clauses. + +! See also 'c-c++-common/goacc/nested-reductions-2-routine.c'. + +! { dg-additional-options -Wuninitialized } + +subroutine acc_routine () + implicit none (type, external) + !$acc routine gang + integer :: i, j, k, l, sum, diff + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + ! { dg-warning {'sum' is used uninitialized} {} { target *-*-* } .-1 } + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop collapse(2) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(+:sum) + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(-:sum) + do k = 1, 10 + sum = 1 + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) + do i = 1, 10 + !$acc loop reduction(-:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) ! { dg-warning "conflicting reduction operations for .sum." } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do k = 1, 10 + !$acc loop reduction(*:sum) ! { dg-warning "conflicting reduction operations for .sum." } + do l = 1, 10 + sum = 1 + end do + end do + end do + end do + + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction(+:sum) reduction(-:diff) + ! { dg-warning {'diff' is used uninitialized} {} { target *-*-* } .-1 } + do i = 1, 10 + !$acc loop reduction(-:diff) ! { dg-warning "nested loop in reduction needs reduction clause for .sum." } + do j = 1, 10 + !$acc loop reduction(+:sum) + do k = 1, 10 + sum = 1 + end do + end do + + !$acc loop reduction(+:sum) ! { dg-warning "nested loop in reduction needs reduction clause for .diff." } + do j = 1, 10 + !$acc loop reduction(-:diff) + do k = 1, 10 + diff = 1 + end do + end do + end do +end subroutine acc_routine Index: Fortran/gfortran/regression/goacc/note-parallelism.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/note-parallelism.f90 @@ -0,0 +1,131 @@ +! Test the output of "-fopt-info-optimized-omp". + +! { dg-additional-options "-fopt-info-optimized-omp" } + +! See also "../../c-c++-common/goacc/note-parallelism.c". + +program test + implicit none + + integer x, y, z + + !$acc parallel + do x = 1, 10 + end do + !$acc end parallel + + !$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelis" } + do x = 1, 10 + end do + + !$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop gang vector ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop gang worker ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop worker vector ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop gang worker vector ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do x = 1, 10 + !$acc loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do y = 1, 10 + !$acc loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do z = 1, 10 + end do + end do + end do + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do x = 1, 10 + end do + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do y = 1, 10 + end do + end do + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do y = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do z = 1, 10 + end do + end do + end do + + !$acc parallel + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do y = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do z = 1, 10 + end do + end do + end do + !$acc end parallel + + !$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do y = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do z = 1, 10 + end do + end do + end do + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do x = 1, 10 + !$acc loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do y = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do z = 1, 10 + end do + end do + end do + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do y = 1, 10 + !$acc loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do z = 1, 10 + end do + end do + end do + + !$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do x = 1, 10 + !$acc loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do y = 1, 10 + !$acc loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do z = 1, 10 + end do + end do + end do + +end program test Index: Fortran/gfortran/regression/goacc/omp-fixed.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/omp-fixed.f @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-additional-options "-fopenmp" } + SUBROUTINE ICHI + INTEGER :: ARGC + ARGC = COMMAND_ARGUMENT_COUNT () + +!$OMP PARALLEL +!$ACC PARALLEL & +!$ACC& COPYIN(ARGC) ! { dg-error "The !.ACC PARALLEL directive cannot be specified within a !.OMP PARALLEL region" } + IF (ARGC .NE. 0) THEN + STOP 1 + END IF +!$ACC END PARALLEL +!$OMP END PARALLEL + + END SUBROUTINE ICHI + + + SUBROUTINE NI + IMPLICIT NONE + INTEGER :: I + +!$ACC PARALLEL & +!$OMP& DO ! { dg-error "Wrong OpenACC continuation" } + DO I = 1, 10 + ENDDO +!$ACC END PARALLEL + +!$OMP PARALLEL & +!$ACC& KERNELS LOOP ! { dg-error "Wrong OpenMP continuation" } + DO I = 1, 10 + ENDDO +!$OMP END PARALLEL + +!$OMP PARALLEL & +!$ACC& LOOP ! { dg-error "Wrong OpenMP continuation" } + DO I = 1, 10 + ENDDO +!$OMP END PARALLEL + END SUBROUTINE NI Index: Fortran/gfortran/regression/goacc/omp.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/omp.f95 @@ -0,0 +1,86 @@ +! { dg-do compile } +! { dg-additional-options "-fopenmp" } + +module test +contains + subroutine ichi + implicit none + integer :: i + !$acc parallel + !$omp do ! { dg-error "cannot be specified" } + do i = 1,5 + enddo + !$acc end parallel + end subroutine ichi + + subroutine ni + implicit none + integer :: i + !$omp parallel + !$acc loop ! { dg-error "cannot be specified" } + do i = 1,5 + enddo + !$omp end parallel + end subroutine ni + + subroutine san + implicit none + integer :: i + !$omp do + !$acc loop ! { dg-error "Unexpected" } + do i = 1,5 + enddo + end subroutine san + + subroutine yon + implicit none + integer :: i + !$acc loop + !$omp do ! { dg-error "Expected DO loop" } + do i = 1,5 + enddo + end subroutine yon + + subroutine go + implicit none + integer :: i, j + + !$omp parallel + do i = 1,5 + !$acc kernels ! { dg-error "cannot be specified" } + do j = 1,5 + enddo + !$acc end kernels + enddo + !$omp end parallel + end subroutine go + + subroutine roku + implicit none + + !$acc data + !$omp parallel ! { dg-error "cannot be specified" } + !$omp end parallel + !$acc end data + end subroutine roku + + subroutine nana + !$acc parallel & + !$omp do ! { dg-error "Wrong OpenACC continuation" } + do i = 1, 5 ! { dg-error "The !.OMP DO directive cannot be specified within a !.ACC PARALLEL region" "" { target *-*-* } .-1 } + end do + !$acc end parallel + + !$omp parallel & + !$acc kernels loop ! { dg-error "Wrong OpenMP continuation" } + do i = 1, 5 ! { dg-error "The !.ACC KERNELS LOOP directive cannot be specified within a !.OMP PARALLEL region" "" { target *-*-* } .-1 } + end do + !$omp end parallel + + !$omp parallel & + !$acc loop ! { dg-error "Wrong OpenMP continuation" } + do i = 1, 5 ! { dg-error "The !.ACC LOOP directive cannot be specified within a !.OMP PARALLEL region" "" { target *-*-* } .-1 } + end do + !$omp end parallel + end subroutine nana +end module test Index: Fortran/gfortran/regression/goacc/orphan-reductions-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/orphan-reductions-1.f90 @@ -0,0 +1,210 @@ +! Verify that gang reduction on orphan OpenACC loops reported as errors. + +! { dg-do compile } + +subroutine s1 + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + !$acc parallel loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + + !$acc parallel + !$acc loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel +end subroutine s1 + +subroutine s2 + implicit none + !$acc routine gang + + integer, parameter :: n = 100 + integer :: i, j, sum + sum = 0 + + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + + !$acc loop reduction(+:sum) + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do j = 1, n + sum = sum + 1 + end do + end do +end subroutine s2 + +integer function f1 () + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + !$acc parallel loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + + !$acc parallel + !$acc loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + f1 = sum +end function f1 + +integer function f2 () + implicit none + !$acc routine gang + + integer, parameter :: n = 100 + integer :: i, j, sum + sum = 0 + + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + + !$acc loop reduction(+:sum) + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do j = 1, n + sum = sum + 1 + end do + end do + + f2 = sum +end function f2 + +module m +contains + subroutine s3 + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + !$acc parallel loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + + !$acc parallel + !$acc loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + end subroutine s3 + + subroutine s4 + implicit none + !$acc routine gang + + integer, parameter :: n = 100 + integer :: i, j, sum + sum = 0 + + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + + !$acc loop reduction(+:sum) + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do j = 1, n + sum = sum + 1 + end do + end do + end subroutine s4 + + integer function f3 () + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + !$acc parallel loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + + !$acc parallel + !$acc loop gang reduction(+:sum) + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel + + f3 = sum + end function f3 + + integer function f4 () + implicit none + !$acc routine gang + + integer, parameter :: n = 100 + integer :: i, j, sum + sum = 0 + + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + + !$acc loop reduction(+:sum) + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + !$acc loop gang reduction(+:sum) ! { dg-error "gang reduction on an orphan loop" } + do j = 1, n + sum = sum + 1 + end do + end do + + f4 = sum + end function f4 +end module m Index: Fortran/gfortran/regression/goacc/orphan-reductions-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/orphan-reductions-2.f90 @@ -0,0 +1,93 @@ +! Verify that we diagnose "gang reduction on an orphan loop" for automatically +! assigned gang level of parallelism. + +! { dg-do compile } +! { dg-additional-options "-fopt-info-optimized-omp" } +! { dg-additional-options "-Wopenacc-parallelism" } + +subroutine s1 + implicit none + !$acc routine gang + ! { dg-bogus "\[Ww\]arning: region is worker partitioned but does not contain worker partitioned code" "TODO default 'gang' 'vector'" { xfail *-*-* } .-3 } + !TODO It's the compiler's own decision to not use 'worker' parallelism here, so it doesn't make sense to bother the user about it. + integer i, sum + + sum = 0 + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang vector loop parallelism" } + do i = 1, 10 + sum = sum + 1 + end do +end subroutine s1 + +subroutine s2 + implicit none + !$acc routine gang + integer i, j, sum + + sum = 0 + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang worker loop parallelism" } + do i = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + do j = 1, 10 + sum = sum + 1 + end do + end do +end subroutine s2 + +subroutine s3 + implicit none + !$acc routine gang + integer i, j, k, sum + + sum = 0 + ! { dg-error "gang reduction on an orphan loop" "" { target *-*-* } .+1 } + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang loop parallelism" } + do i = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC worker loop parallelism" } + do j = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + do k = 1, 10 + sum = sum + 1 + end do + end do + end do +end subroutine s3 + +subroutine s4 + implicit none + + integer i, j, k, sum + + sum = 0 + !$acc parallel copy(sum) + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang vector loop parallelism" } + do i = 1, 10 + sum = sum + 1 + end do + !$acc end parallel + + !$acc parallel copy(sum) + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang worker loop parallelism" } + do i = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + do j = 1, 10 + sum = sum + 1 + end do + end do + !$acc end parallel + + !$acc parallel copy(sum) + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC gang loop parallelism" } + do i = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC worker loop parallelism" } + do j = 1, 10 + !$acc loop reduction (+:sum) ! { dg-optimized "assigned OpenACC vector loop parallelism" } + do k = 1, 10 + sum = sum + 1 + end do + end do + end do + !$acc end parallel +end subroutine s4 Index: Fortran/gfortran/regression/goacc/orphan-reductions-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/orphan-reductions-3.f90 @@ -0,0 +1,89 @@ +! Verify that the error message for gang reductions on orphaned OpenACC loops +! is not reported for non-orphaned loops. + +! { dg-additional-options "-Wopenacc-parallelism" } + +subroutine kernels + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc kernels + !$acc loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + !$acc end kernels +end subroutine kernels + +subroutine parallel + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel + !$acc loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + !$acc end parallel +end subroutine parallel + +subroutine serial + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc serial ! { dg-warning "region contains gang partitioned code but is not gang partitioned" } + !$acc loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do + !$acc end serial +end subroutine serial + +subroutine kernels_combined + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc kernels loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do +end subroutine kernels_combined + +subroutine parallel_combined + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc parallel loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + do i = 1, n + sum = sum + 1 + end do +end subroutine parallel_combined + +subroutine serial_combined + implicit none + + integer, parameter :: n = 100 + integer :: i, sum + sum = 0 + + !$acc serial loop gang reduction(+:sum) ! { dg-bogus "gang reduction on an orphan loop" } + ! { dg-warning "region contains gang partitioned code but is not gang partitioned" "" { target *-*-* } .-1 } + do i = 1, n + sum = sum + 1 + end do +end subroutine serial_combined Index: Fortran/gfortran/regression/goacc/parallel-dims-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/parallel-dims-2.f90 @@ -0,0 +1,22 @@ +! Invalid use of OpenACC parallelism dimensions clauses: 'num_gangs', +! 'num_workers', 'vector_length'. + +! See also '../../c-c++-common/goacc/parallel-dims-2.c'. + +subroutine f() + !TODO 'kernels', 'parallel' testing per '../../c-c++-common/goacc/parallel-dims-2.c'. + !TODO This should incorporate some of the testing done in 'sie.f95'. + + + ! The 'serial' construct doesn't allow these at all. + +!$acc serial num_gangs (1) ! { dg-error "Failed to match clause at" } +!$acc end serial ! { dg-error "Unexpected !.ACC END SERIAL statement" } + +!$acc serial num_workers (1) ! { dg-error "Failed to match clause at" } +!$acc end serial ! { dg-error "Unexpected !.ACC END SERIAL statement" } + +!$acc serial vector_length (1) ! { dg-error "Failed to match clause at" } +!$acc end serial ! { dg-error "Unexpected !.ACC END SERIAL statement" } + +end subroutine f Index: Fortran/gfortran/regression/goacc/parallel-kernels-clauses.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/parallel-kernels-clauses.f95 @@ -0,0 +1,96 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +! test clauses added in OpenACC ver 2.0 + +program test + implicit none + integer :: i, a(10), b(5:7) + integer, parameter :: acc_async_noval = -1 + integer, parameter :: acc_async_sync = -2 + logical :: l + + ! async + !$acc kernels async(i) + !$acc end kernels + !$acc parallel async(i) + !$acc end parallel + + !$acc kernels async(0, 1) { dg-error "Failed to match clause" } + !$acc parallel async(0, 1) { dg-error "Failed to match clause" } + + !$acc kernels async + !$acc end kernels + !$acc parallel async + !$acc end parallel + + !$acc kernels async(acc_async_noval) + !$acc end kernels + !$acc parallel async(acc_async_noval) + !$acc end parallel + + !$acc kernels async(acc_async_sync) + !$acc end kernels + !$acc parallel async(acc_async_sync) + !$acc end parallel + + !$acc kernels async() { dg-error "Invalid character" } + !$acc parallel async() { dg-error "Invalid character" } + + !$acc kernels async("a") { dg-error "Failed to match clause" } + !$acc parallel async("a") { dg-error "Failed to match clause" } + + !$acc kernels async(.true.) { dg-error "Failed to match clause" } + !$acc parallel async(.true.) { dg-error "Failed to match clause" } + + ! default(none) + !$acc kernels default(none) + !$acc end kernels + !$acc parallel default(none) + !$acc end parallel + + !$acc kernels default (none) + !$acc end kernels + !$acc parallel default (none) + !$acc end parallel + + !$acc kernels default ( none ) + !$acc end kernels + !$acc parallel default ( none ) + !$acc end parallel + + !$acc kernels default { dg-error "Expected '\\(' after 'default'" } + !$acc parallel default { dg-error "Expected '\\(' after 'default'" } + + !$acc kernels default() { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + !$acc parallel default() { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + + !$acc kernels default(i) { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + !$acc parallel default(i) { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + + !$acc kernels default(1) { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + !$acc parallel default(1) { dg-error "Expected NONE or PRESENT in DEFAULT clause" } + + ! Wait + !$acc kernels wait (l) ! { dg-error "INTEGER" } + !$acc end kernels + !$acc kernels wait (.true.) ! { dg-error "INTEGER" } + !$acc end kernels + !$acc kernels wait (i, 1) + !$acc end kernels + !$acc kernels wait (a) ! { dg-error "INTEGER" } + !$acc end kernels + !$acc kernels wait (b(5:6)) ! { dg-error "INTEGER" } + !$acc end kernels + + !$acc parallel wait (l) ! { dg-error "INTEGER" } + !$acc end parallel + !$acc parallel wait (.true.) ! { dg-error "INTEGER" } + !$acc end parallel + !$acc parallel wait (i, 1) + !$acc end parallel + !$acc parallel wait (a) ! { dg-error "INTEGER" } + !$acc end parallel + !$acc parallel wait (b(5:6)) ! { dg-error "INTEGER" } + !$acc end parallel +end Index: Fortran/gfortran/regression/goacc/parallel-kernels-regions.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/parallel-kernels-regions.f95 @@ -0,0 +1,55 @@ +! { dg-do compile } + +! OpenACC 2.0 allows nested parallel/kernels regions, but this is not yet +! supported. + +program test + implicit none + + integer :: i + + !$acc parallel + !$acc kernels ! { dg-bogus ".kernels. construct inside of .parallel. region" "not implemented" { xfail *-*-* } } + !$acc end kernels + !$acc end parallel + + !$acc parallel + !$acc parallel ! { dg-bogus ".parallel. construct inside of .parallel. region" "not implemented" { xfail *-*-* } } + !$acc end parallel + !$acc end parallel + + !$acc parallel + !$acc parallel ! { dg-bogus ".parallel. construct inside of .parallel. region" "not implemented" { xfail *-*-* } } + !$acc end parallel + !$acc kernels ! { dg-bogus ".kernels. construct inside of .parallel. region" "not implemented" { xfail *-*-* } } + !$acc end kernels + !$acc end parallel + + !$acc kernels + !$acc kernels ! { dg-bogus ".kernels. construct inside of .kernels. region" "not implemented" { xfail *-*-* } } + !$acc end kernels + !$acc end kernels + + !$acc kernels + !$acc parallel ! { dg-bogus ".parallel. construct inside of .kernels. region" "not implemented" { xfail *-*-* } } + !$acc end parallel + !$acc end kernels + + !$acc kernels + !$acc parallel ! { dg-bogus ".parallel. construct inside of .kernels. region" "not implemented" { xfail *-*-* } } + !$acc end parallel + !$acc kernels ! { dg-bogus ".kernels. construct inside of .kernels. region" "not implemented" { xfail *-*-* } } + !$acc end kernels + !$acc end kernels + + !$acc parallel + !$acc data ! { dg-error ".data. construct inside of .parallel. region" } + !$acc end data + !$acc end parallel + + !$acc kernels + !$acc data ! { dg-error ".data. construct inside of .kernels. region" } + !$acc end data + !$acc end kernels + +end program test Index: Fortran/gfortran/regression/goacc/parallel-tree.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/parallel-tree.f95 @@ -0,0 +1,50 @@ +! { dg-additional-options "-fdump-tree-original" } + +! test for tree-dump-original and spaces-commas + +! { dg-additional-options -Wuninitialized } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +program test + implicit none + integer :: q, i, j, k, m, n, o, p, r, s, t, u, v, w + ! { dg-note {'i' was declared here} {} { target *-*-* } .-1 } + logical :: l = .true. + + !$acc parallel if(l) async num_gangs(i) num_workers(i) vector_length(i) & + !$acc reduction(max:q), copy(i), copyin(j), copyout(k), create(m) & + !$acc no_create(n) & + !$acc present(o), pcopy(p), pcopyin(r), pcopyout(s), pcreate(t) & + !$acc deviceptr(u), private(v), firstprivate(w) + ! { dg-warning {'i' is used uninitialized} {} { target *-*-* } .-1 } + ! { dg-warning "region is gang partitioned but does not contain gang partitioned code" "" { target *-*-* } .-2 } + ! { dg-warning "region is worker partitioned but does not contain worker partitioned code" "" { target *-*-* } .-3 } + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-4 } + !$acc end parallel + +end program test + +! { dg-final { scan-tree-dump-times "pragma acc parallel" 1 "original" } } + +! { dg-final { scan-tree-dump-times "if" 1 "original" } } +! { dg-final { scan-tree-dump-times "async" 1 "original" } } +! { dg-final { scan-tree-dump-times "num_gangs" 1 "original" } } +! { dg-final { scan-tree-dump-times "num_workers" 1 "original" } } +! { dg-final { scan-tree-dump-times "vector_length" 1 "original" } } + +! { dg-final { scan-tree-dump-times "reduction\\(max:q\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:i\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:j\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:k\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:m\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(no_alloc:n\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(force_present:o\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:p\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(to:r\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(from:s\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:t\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "map\\(force_deviceptr:u\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "private\\(v\\)" 1 "original" } } Index: Fortran/gfortran/regression/goacc/parameter.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/parameter.f95 @@ -0,0 +1,31 @@ +! { dg-do compile } + +module test +contains + subroutine oacc1 + implicit none + integer :: i + integer, parameter :: a = 1 + !$acc declare device_resident (a) ! { dg-error "is not a variable" } + !$acc data copy (a) ! { dg-error "not a variable" } + !$acc end data + !$acc data deviceptr (a) ! { dg-error "not a variable" } + !$acc end data + !$acc parallel private (a) ! { dg-error "not a variable" } + !$acc end parallel + !$acc host_data use_device (a) ! { dg-error "not a variable" } + !$acc end host_data + !$acc parallel loop reduction(+:a) ! { dg-error "not a variable" } + do i = 1,5 + enddo + !$acc end parallel loop + !$acc parallel loop + do i = 1,5 + !$acc cache (a) ! { dg-error "not a variable" } + enddo + !$acc end parallel loop + !$acc update device (a) ! { dg-error "not a variable" } + !$acc update host (a) ! { dg-error "not a variable" } + !$acc update self (a) ! { dg-error "not a variable" } + end subroutine oacc1 +end module test Index: Fortran/gfortran/regression/goacc/pr104717.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr104717.f90 @@ -0,0 +1,22 @@ +! Extracted from 'libgomp.oacc-fortran/privatized-ref-2.f90'. + +! { dg-additional-options "-O1 -fstack-arrays -fipa-pta" } + +program main + implicit none (type, external) + integer :: j + integer, allocatable :: A(:) + + A = [(3*j, j=1, 10)] + call foo (A, size(A)) + deallocate (A) +contains + subroutine foo (array, nn) + integer :: i, nn + integer :: array(nn) + + !$acc parallel copyout(array) + array = [(-i, i = 1, nn)] + !$acc end parallel + end subroutine foo +end Index: Fortran/gfortran/regression/goacc/pr71704.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr71704.f90 @@ -0,0 +1,60 @@ +! PR fortran/71704 +! { dg-do compile } + +real function f1 () +!$acc routine (f1) + f1 = 1 +end + +real function f2 (a) + integer a + !$acc enter data copyin(a) + f2 = 1 +end + +real function f3 (a) + integer a +!$acc enter data copyin(a) + f3 = 1 +end + +real function f4 () +!$acc wait + f4 = 1 +end + +real function f5 (a) + integer a +!$acc update device(a) + f5 = 1 +end + +real function f6 () +!$acc parallel +!$acc end parallel + f6 = 1 +end + +real function f7 () +!$acc kernels +!$acc end kernels + f7 = 1 +end + +real function f8 () +!$acc data +!$acc end data + f8 = 1 +end + +real function f9 () +!$acc host_data +!$acc end host_data + f8 = 1 +end + +real function f10 (a) + integer a +!$acc declare present (a) + f8 = 1 +end Index: Fortran/gfortran/regression/goacc/pr72715.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr72715.f90 @@ -0,0 +1,6 @@ +program p + integer :: i + !$acc loop + do concurrent (i=1:3) ! { dg-error "ACC LOOP cannot be a DO CONCURRENT loop" } + end do +end program p Index: Fortran/gfortran/regression/goacc/pr72743.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr72743.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-O2" } + +program p + integer, parameter :: n = 8 + integer :: i, z(n) + z = [(i, i=1,n)] + print *, z +end +subroutine s + integer, parameter :: n = 8 + integer :: i, z(n) + z = [(i, i=1,n)] + print *, z +end Index: Fortran/gfortran/regression/goacc/pr77371-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr77371-1.f90 @@ -0,0 +1,9 @@ +! PR fortran/77371 +! { dg-do compile } +program p + character(:), allocatable :: z + !$acc parallel + z = 'abc' + !$acc end parallel + print *, z +end Index: Fortran/gfortran/regression/goacc/pr77371-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr77371-2.f90 @@ -0,0 +1,7 @@ +! PR fortran/77371 +! { dg-do compile } +program p + integer, allocatable :: n +!$acc parallel reduction (+:n) private(n) ! { dg-error "invalid private reduction" } +!$acc end parallel +end Index: Fortran/gfortran/regression/goacc/pr77765.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr77765.f90 @@ -0,0 +1,18 @@ +! Test the presence of an ACC ROUTINE directive inside a function +! containg an error. + +! { dg-do compile } + +module m +contains + recursive function f(x) + end function f + recursive function f(x) + !$acc routine (f) + end function f +end module m + +! { dg-error "Procedure 'f' at .1. is already defined" "" { target *-*-* } 8 } +! { dg-error ".1." "" { target *-*-* } 10 } +! { dg-error "Invalid NAME 'f' in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } 11 } +! { dg-error "Expecting END MODULE statement" "" { target *-*-* } 12 } Index: Fortran/gfortran/regression/goacc/pr78027.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr78027.f90 @@ -0,0 +1,18 @@ +! { dg-additional-options "-fopenmp -O2 -fdump-ipa-icf" } + +real function f() + !$omp declare target(f) + f = 1. + !$acc parallel + !$acc loop + do i = 1, 8 + end do + !$acc end parallel + !$acc parallel + !$acc loop + do i = 1, 8 + end do + !$acc end parallel + end + +! { dg-final { scan-ipa-dump-times "with total: 0 items" 5 "icf" } } Index: Fortran/gfortran/regression/goacc/pr78260-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr78260-2.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fopenacc -fdump-tree-original" } +! { dg-require-effective-target fopenacc } + +! PR fortran/78260 + +! Loosely related to PR fortran/94120 + +module m + implicit none + integer :: n = 0 +contains + integer function f1() + !$acc declare present(f1) + !$acc kernels copyin(f1) + f1 = 5 + !$acc end kernels + end function f1 + integer function g1() result(g1res) + !$acc declare present(g1res) + !$acc kernels copyin(g1res) + g1res = 5 + !$acc end kernels + end function g1 +end module m +! { dg-final { scan-tree-dump-times "#pragma acc data map\\(force_present:__result_f1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma acc kernels map\\(to:__result_f1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma acc data map\\(force_present:g1res\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma acc kernels map\\(to:g1res\\)" 1 "original" } } Index: Fortran/gfortran/regression/goacc/pr78260.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr78260.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fopenacc" } +! { dg-require-effective-target fopenacc } + +! PR fortran/78260 +! Contributed by Gerhard Steinmetz + +module m + implicit none + integer :: n = 0 +contains + subroutine s + !$acc declare present(m) ! { dg-error "Object .m. is not a variable" } + !$acc kernels copyin(m) ! { dg-error "Object .m. is not a variable" } + n = n + 1 + !$acc end kernels + end subroutine s + subroutine s2 + !$acc declare present(s2) ! { dg-error "Object .s2. is not a variable" } + !$acc kernels copyin(s2) ! { dg-error "Object .s2. is not a variable" } + n = n + 1 + !$acc end kernels + end subroutine s2 + integer function f1() + !$acc declare present(f1) ! OK, f1 is also the result variable + !$acc kernels copyin(f1) ! OK, f1 is also the result variable + f1 = 5 + !$acc end kernels + end function f1 + integer function f2() result(res) + !$acc declare present(f2) ! { dg-error "Object .f2. is not a variable" } + !$acc kernels copyin(f2) ! { dg-error "Object .f2. is not a variable" } + res = 5 + !$acc end kernels + end function f2 +end module m Index: Fortran/gfortran/regression/goacc/pr84217.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr84217.f90 @@ -0,0 +1,9 @@ +subroutine foo + integer(2) :: i, j + !$acc parallel loop tile(2,3) + do i = 1, 10 + do j = 1, 10 + end do + end do + !$acc end parallel loop +end Index: Fortran/gfortran/regression/goacc/pr84963.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr84963.f90 @@ -0,0 +1,7 @@ +! PR ipa/84963 +! { dg-additional-options "-O2" } + +program p + print *, sin([1.0, 2.0]) + print *, cos([1.0, 2.0]) +end Index: Fortran/gfortran/regression/goacc/pr85701.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr85701.f90 @@ -0,0 +1,23 @@ +! PR fortran/85701 +! { dg-do compile } + +subroutine s1 + !$acc declare copy(s1) ! { dg-error "is not a variable" } +end + +subroutine s2 + !$acc declare present(s2) ! { dg-error "is not a variable" } +end + +function f1 () result(res) + !$acc declare copy(f1) ! { dg-error "is not a variable" } +end + +function f2 () result(res) + !$acc declare present(f2) ! { dg-error "is not a variable" } +end + +program p + !$acc declare copy(p) ! { dg-error "is not a variable" } +end + Index: Fortran/gfortran/regression/goacc/pr85702.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr85702.f90 @@ -0,0 +1,6 @@ +! PR fortran/85702 +! { dg-do compile } + +subroutine s + !$acc wait(*) ! { dg-error "Invalid argument to ..ACC WAIT" } +end Index: Fortran/gfortran/regression/goacc/pr85703.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr85703.f90 @@ -0,0 +1,9 @@ +! PR fortran/85703 +! { dg-do compile } + +character function f() + !$acc parallel loop reduction(+:a) + do i = 1, 4 + end do + !$acc end parallel loop +end Index: Fortran/gfortran/regression/goacc/pr85879.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr85879.f90 @@ -0,0 +1,12 @@ +! PR middle-end/85879 +! { dg-do compile } + +program p + integer, pointer :: i + integer, target :: j + j = 2 + i => j + !$acc parallel + j = i + !$acc end parallel +end Index: Fortran/gfortran/regression/goacc/pr89773.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/pr89773.f90 @@ -0,0 +1,36 @@ +! Valid usage of 'external' procedures with OpenACC 'routine' directives. + +! { dg-additional-options "-fdump-tree-optimized-raw" } + + subroutine test (x) + implicit none + integer, intent(inout) :: x + !$acc routine (test) + + integer, external :: f_1 + !$acc routine (f_1) + + integer f_2 ! No explicit EXTERNAL attribute. + !$acc routine (f_2) + + external s_1 + !$acc routine (s_1) + + ! 's_2' will be an external subroutine without explicit EXTERNAL + ! attribute, but we don't have a handle for it yet... + !!$acc routine (s_2) ..., so can't specify this, here. + + if (x < 1) then + x = 1 + else + x = x * x - 1 + f_1(f_2(x)) + call s_1(x) + call s_2(x) + end if + end subroutine test + +! { dg-final { scan-tree-dump-times "gimple_call" 4 "optimized" } } +! { dg-final { scan-tree-dump-times "gimple_call NULL() +integer, allocatable :: aa1 (:,:) +save i2 +common /blk/ i1 + +!$acc parallel reduction (+:ia2) +!$acc end parallel +!$acc parallel reduction (+:ra1) +!$acc end parallel +!$acc parallel reduction (+:ca1) +!$acc end parallel +!$acc parallel reduction (+:da1) +!$acc end parallel +!$acc parallel reduction (.and.:la1) +!$acc end parallel +!$acc parallel reduction (+:i3, r1, d1, c1) +!$acc end parallel +!$acc parallel reduction (*:i3, r1, d1, c1) +!$acc end parallel +!$acc parallel reduction (-:i3, r1, d1, c1) +!$acc end parallel +!$acc parallel reduction (.and.:l1) +!$acc end parallel +!$acc parallel reduction (.or.:l1) +!$acc end parallel +!$acc parallel reduction (.eqv.:l1) +!$acc end parallel +!$acc parallel reduction (.neqv.:l1) +!$acc end parallel +!$acc parallel reduction (min:i3, r1, d1) +!$acc end parallel +!$acc parallel reduction (max:i3, r1, d1) +!$acc end parallel +!$acc parallel reduction (iand:i3) +!$acc end parallel +!$acc parallel reduction (ior:i3) +!$acc end parallel +!$acc parallel reduction (ieor:i3) +!$acc end parallel +!$acc parallel reduction (+:/blk/) ! { dg-error "Syntax error" } +!$acc end parallel ! { dg-error "Unexpected" } +!$acc parallel reduction (*:p1) ! { dg-error "POINTER object" } +!$acc end parallel +!$acc parallel reduction (-:aa1) +!$acc end parallel +!$acc parallel reduction (*:ia1) ! { dg-error "Assumed size" } +!$acc end parallel +!$acc parallel reduction (+:l1) ! { dg-error "OMP DECLARE REDUCTION \\+ not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (*:la1) ! { dg-error "OMP DECLARE REDUCTION \\* not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (-:a1) ! { dg-error "OMP DECLARE REDUCTION - not found for type CHARACTER" } +!$acc end parallel +!$acc parallel reduction (+:t1) ! { dg-error "OMP DECLARE REDUCTION \\+ not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (*:ta1) ! { dg-error "OMP DECLARE REDUCTION \\* not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (.and.:i3) ! { dg-error "OMP DECLARE REDUCTION \\.and\\. not found for type INTEGER" } +!$acc end parallel +!$acc parallel reduction (.or.:ia2) ! { dg-error "OMP DECLARE REDUCTION \\.or\\. not found for type INTEGER" } +!$acc end parallel +!$acc parallel reduction (.eqv.:r1) ! { dg-error "OMP DECLARE REDUCTION \\.eqv\\. not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (.neqv.:ra1) ! { dg-error "OMP DECLARE REDUCTION \\.neqv\\. not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (.and.:d1) ! { dg-error "OMP DECLARE REDUCTION \\.and\\. not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (.or.:da1) ! { dg-error "OMP DECLARE REDUCTION \\.or\\. not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (.eqv.:c1) ! { dg-error "OMP DECLARE REDUCTION \\.eqv\\. not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (.neqv.:ca1) ! { dg-error "OMP DECLARE REDUCTION \\.neqv\\. not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (.and.:a1) ! { dg-error "OMP DECLARE REDUCTION \\.and\\. not found for type CHARACTER" } +!$acc end parallel +!$acc parallel reduction (.or.:t1) ! { dg-error "OMP DECLARE REDUCTION \\.or\\. not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (.eqv.:ta1) ! { dg-error "OMP DECLARE REDUCTION \\.eqv\\. not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (min:c1) ! { dg-error "OMP DECLARE REDUCTION min not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (max:ca1) ! { dg-error "OMP DECLARE REDUCTION max not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (max:l1) ! { dg-error "OMP DECLARE REDUCTION max not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (min:la1) ! { dg-error "OMP DECLARE REDUCTION min not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (max:a1) ! { dg-error "OMP DECLARE REDUCTION max not found for type CHARACTER" } +!$acc end parallel +!$acc parallel reduction (min:t1) ! { dg-error "OMP DECLARE REDUCTION min not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (max:ta1) ! { dg-error "OMP DECLARE REDUCTION max not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (iand:r1) ! { dg-error "OMP DECLARE REDUCTION iand not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (ior:ra1) ! { dg-error "OMP DECLARE REDUCTION ior not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (ieor:d1) ! { dg-error "OMP DECLARE REDUCTION ieor not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (ior:da1) ! { dg-error "OMP DECLARE REDUCTION ior not found for type REAL" } +!$acc end parallel +!$acc parallel reduction (iand:c1) ! { dg-error "OMP DECLARE REDUCTION iand not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (ior:ca1) ! { dg-error "OMP DECLARE REDUCTION ior not found for type COMPLEX" } +!$acc end parallel +!$acc parallel reduction (ieor:l1) ! { dg-error "OMP DECLARE REDUCTION ieor not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (iand:la1) ! { dg-error "OMP DECLARE REDUCTION iand not found for type LOGICAL" } +!$acc end parallel +!$acc parallel reduction (ior:a1) ! { dg-error "OMP DECLARE REDUCTION ior not found for type CHARACTER" } +!$acc end parallel +!$acc parallel reduction (ieor:t1) ! { dg-error "OMP DECLARE REDUCTION ieor not found for type TYPE" } +!$acc end parallel +!$acc parallel reduction (iand:ta1) ! { dg-error "OMP DECLARE REDUCTION iand not found for type TYPE" } +!$acc end parallel + +end subroutine + +! { dg-error "Array 'ia2' is not permitted in reduction" "" { target "*-*-*" } 27 } +! { dg-error "Array 'ra1' is not permitted in reduction" "" { target "*-*-*" } 29 } +! { dg-error "Array 'ca1' is not permitted in reduction" "" { target "*-*-*" } 31 } +! { dg-error "Array 'da1' is not permitted in reduction" "" { target "*-*-*" } 33 } +! { dg-error "Array 'la1' is not permitted in reduction" "" { target "*-*-*" } 35 } +! { dg-error "Array 'aa1' is not permitted in reduction" "" { target "*-*-*" } 65 } +! { dg-error "Array 'ia1' is not permitted in reduction" "" { target "*-*-*" } 67 } +! { dg-error "Array 'la1' is not permitted in reduction" "" { target "*-*-*" } 71 } +! { dg-error "Array 'ta1' is not permitted in reduction" "" { target "*-*-*" } 77 } +! { dg-error "Array 'ia2' is not permitted in reduction" "" { target "*-*-*" } 81 } +! { dg-error "Array 'ra1' is not permitted in reduction" "" { target "*-*-*" } 85 } +! { dg-error "Array 'da1' is not permitted in reduction" "" { target "*-*-*" } 89 } +! { dg-error "Array 'ca1' is not permitted in reduction" "" { target "*-*-*" } 93 } +! { dg-error "Array 'ta1' is not permitted in reduction" "" { target "*-*-*" } 99 } +! { dg-error "Array 'ca1' is not permitted in reduction" "" { target "*-*-*" } 103 } +! { dg-error "Array 'la1' is not permitted in reduction" "" { target "*-*-*" } 107 } +! { dg-error "Array 'ta1' is not permitted in reduction" "" { target "*-*-*" } 113 } +! { dg-error "Array 'ra1' is not permitted in reduction" "" { target "*-*-*" } 117 } +! { dg-error "Array 'da1' is not permitted in reduction" "" { target "*-*-*" } 121 } +! { dg-error "Array 'ca1' is not permitted in reduction" "" { target "*-*-*" } 125 } +! { dg-error "Array 'la1' is not permitted in reduction" "" { target "*-*-*" } 129 } +! { dg-error "Array 'ta1' is not permitted in reduction" "" { target "*-*-*" } 135 } Index: Fortran/gfortran/regression/goacc/ref_inquiry.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/ref_inquiry.f90 @@ -0,0 +1,48 @@ +! Check for %re, ...%im, ...%kind, ...%len +! Cf. also OpenMP's ../gomp/ref_inquiry.f90 +! Cf. OpenACC spec issue 346 +! +implicit none +type t + integer :: i + character :: c + complex :: z + complex :: zz(5) +end type t + +integer :: i +character(kind=4, len=5) :: c +complex :: z, zz(5) +type(t) :: x + +print *, is_contiguous(zz(:)%re) + +! inquiry function; expr_type != EXPR_VARIABLE: +!$acc enter data copyin(i%kind, c%len) ! { dg-error "not a proper array section" } +!$acc enter data copyin(x%i%kind) ! { dg-error "not a proper array section" } +!$acc enter data copyin(x%c%len) ! { dg-error "not a proper array section" } +!$acc update self(i%kind, c%len) ! { dg-error "not a proper array section" } +!$acc update self(x%i%kind) ! { dg-error "not a proper array section" } +!$acc update self(x%c%len) ! { dg-error "not a proper array section" } + +! EXPR_VARIABLE +!$acc enter data copyin(z%re) ! { dg-error "Unexpected complex-parts designator" } +!$acc enter data copyin(z%im) ! { dg-error "Unexpected complex-parts designator" } +!$acc enter data copyin(zz%re) ! { dg-error "not a proper array section" } +!$acc enter data copyin(zz%im) ! { dg-error "not a proper array section" } + +!$acc enter data copyin(x%z%re) ! { dg-error "Unexpected complex-parts designator" } +!$acc enter data copyin(x%z%im) ! { dg-error "Unexpected complex-parts designator" } +!$acc enter data copyin(x%zz%re) ! { dg-error "not a proper array section" } +!$acc enter data copyin(x%zz%im) ! { dg-error "not a proper array section" } + +!$acc update self(z%re) ! { dg-error "Unexpected complex-parts designator" } +!$acc update self(z%im) ! { dg-error "Unexpected complex-parts designator" } +!$acc update self(zz%re) ! { dg-error "not a proper array section" } +!$acc update self(zz%im) ! { dg-error "not a proper array section" } + +!$acc update self(x%z%re) ! { dg-error "Unexpected complex-parts designator" } +!$acc update self(x%z%im) ! { dg-error "Unexpected complex-parts designator" } +!$acc update self(x%zz%re) ! { dg-error "is not a proper array section" } +!$acc update self(x%zz%im) ! { dg-error "is not a proper array section" } +end Index: Fortran/gfortran/regression/goacc/routine-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-1.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + + integer, parameter :: n = 10 + integer :: a(n), i + integer, external :: fact + i = 1 + !$acc routine (fact) ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + !$acc routine () ! { dg-error "Syntax error in \\\!\\\$ACC ROUTINE \\\( NAME \\\)" } + !$acc parallel + !$acc loop + do i = 1, n + a(i) = fact (i) + call incr (a(i)) + end do + !$acc end parallel + do i = 1, n + write (*, "(I10)") a(i) + end do +end +recursive function fact (x) result (res) + integer, intent(in) :: x + integer :: res + res = 1 + !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + if (x < 1) then + res = 1 + else + res = x * fact (x - 1) + end if +end function fact +subroutine incr (x) + integer, intent(inout) :: x + integer i + i = 0 + !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + x = x + 1 +end subroutine incr Index: Fortran/gfortran/regression/goacc/routine-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + + module m1 + contains + recursive function mfact (x) result (res) + integer, intent(in) :: x + integer :: res + integer i + i = 0 + !$acc routine ! { dg-error "Unexpected \\\!\\\$ACC ROUTINE" } + if (x < 1) then + res = 1 + else + res = x * mfact (x - 1) + end if + end function mfact + end module m1 Index: Fortran/gfortran/regression/goacc/routine-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-3.f90 @@ -0,0 +1,19 @@ +PROGRAM nested_gwv +CONTAINS + SUBROUTINE gwv + INTEGER :: i + REAL(KIND=8), ALLOCATABLE :: un(:), ua(:) + + !$acc kernels num_gangs(2) num_workers(4) vector_length(32) + DO jj = 1, 100 + un(i) = ua(i) + END DO + !$acc end kernels + + !$acc parallel num_gangs(2) num_workers(4) vector_length(32) + DO jj = 1, 100 + un(i) = ua(i) + END DO + !$acc end parallel + END SUBROUTINE gwv +END PROGRAM nested_gwv Index: Fortran/gfortran/regression/goacc/routine-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-4.f90 @@ -0,0 +1,169 @@ +! Test invalid calls to routines. + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +module param + integer, parameter :: N = 32 +end module param + +program main + use param + integer :: i + integer :: a(N) + + do i = 1, N + a(i) = i + end do + + ! + ! Seq routine tests. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call seq (a) + end do + + !$acc loop gang + do i = 1, N + call seq (a) + end do + + !$acc loop worker + do i = 1, N + call seq (a) + end do + + !$acc loop vector + do i = 1, N + call seq (a) + end do + !$acc end parallel + + ! + ! Gang routines loops. + ! + + !$acc parallel copy (a) + !$acc loop ! { dg-warning "insufficient partitioning" } + do i = 1, N + call gang (a) + end do + + !$acc loop gang ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop worker ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call gang (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel + + ! + ! Worker routines loops. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call worker (a) + end do + + !$acc loop gang + do i = 1, N + call worker (a) + end do + + !$acc loop worker ! { dg-message "containing loop" } + do i = 1, N + call worker (a) ! { dg-error "routine call uses same" } + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call worker (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel + + ! + ! Vector routines loops. + ! + + !$acc parallel copy (a) + !$acc loop + do i = 1, N + call vector (a) + end do + + !$acc loop gang + do i = 1, N + call vector (a) + end do + + !$acc loop worker + do i = 1, N + call vector (a) + end do + + !$acc loop vector ! { dg-message "containing loop" } + do i = 1, N + call vector (a) ! { dg-error "routine call uses same" } + end do + !$acc end parallel +contains + + subroutine gang (a) ! { dg-message "declared here" 3 } + !$acc routine gang + ! { dg-warning "region is gang partitioned but does not contain gang partitioned code" "" { target *-*-* } .-2 } + ! { dg-warning "region is worker partitioned but does not contain worker partitioned code" "" { target *-*-* } .-3 } + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-4 } + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine gang + + subroutine worker (a) ! { dg-message "declared here" 2 } + !$acc routine worker + ! { dg-warning "region is worker partitioned but does not contain worker partitioned code" "" { target *-*-* } .-2 } + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-3 } + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine worker + + subroutine vector (a) ! { dg-message "declared here" } + !$acc routine vector + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-2 } + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine vector + + subroutine seq (a) + !$acc routine seq + integer, intent (inout) :: a(N) + integer :: i + + do i = 1, N + a(i) = a(i) - a(i) + end do + end subroutine seq +end program main Index: Fortran/gfortran/regression/goacc/routine-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-5.f90 @@ -0,0 +1,113 @@ +! Test invalid intra-routine parallellism. + +module param + integer, parameter :: N = 32 +end module param + +subroutine gang (a) + use param + !$acc routine gang + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine gang + +subroutine worker (a) + use param + !$acc routine worker + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine worker + +subroutine vector (a) + use param + !$acc routine vector + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine vector + +subroutine seq (a) + use param + !$acc routine seq + integer, intent (inout) :: a(N) + integer :: i + + !$acc loop ! { dg-warning "insufficient partitioning" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop gang ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop worker ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do + + !$acc loop vector ! { dg-error "disallowed by containing routine" } + do i = 1, N + a(i) = a(i) - a(i) + end do +end subroutine seq Index: Fortran/gfortran/regression/goacc/routine-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-6.f90 @@ -0,0 +1,128 @@ +! Check for invalid syntax with !$ACC ROUTINE. + +module m + integer m1int +contains + subroutine subr5 (x) + implicit none + !$acc routine (m) ! { dg-error "Invalid NAME 'm' in \\!\\\$ACC ROUTINE \\( NAME \\)" } + !$acc routine (subr5) + !$acc routine (m1int) ! { dg-error "Invalid NAME 'm1int' in \\!\\\$ACC ROUTINE \\( NAME \\)" } + integer f_1 ! Referenced. + !$acc routine (f_1) + integer f_2 ! Not referenced. + !$acc routine (f_2) ! { dg-error "NAME 'f_2' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + integer v_1 + !$acc routine (v_1) ! { dg-error "NAME 'v_1' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + integer, intent(inout) :: x + !$acc routine (x) ! { dg-error "NAME 'x' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + v_1 = x + if (x < 1) then + x = 1 + else + x = x * x - 1 + x = f_1(x) + v_1 + end if + end subroutine subr5 +end module m + +program main + implicit none + !$acc routine (main) ! { dg-error "PROGRAM attribute conflicts with SUBROUTINE attribute in 'main'" } + interface + function subr6 (x) + !$acc routine (subr6) ! { dg-error "without list is allowed in interface" } + integer, intent (in) :: x + integer :: subr6 + end function subr6 + end interface + integer, parameter :: n = 10 + integer :: a(n), i + !$acc routine (n) ! { dg-error "NAME 'n' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + !$acc routine (a) ! { dg-error "NAME 'a' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + !$acc routine (i) ! { dg-error "NAME 'i' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + !$acc routine (subr1) ! { dg-error "Invalid NAME 'subr1' in \\!\\\$ACC ROUTINE \\( NAME \\)" } + external :: subr2 + !$acc routine (subr2) + + external :: R1, R2 + !$acc routine (R1 R2 R3) ! { dg-error "Syntax error in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), expecting .\\). after NAME" } + !$acc routine (R1, R2, R3) ! { dg-error "Syntax error in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\), expecting .\\). after NAME" } + !$acc routine (R1) + !$acc routine (R2) + + !$acc parallel + !$acc loop + do i = 1, n + call subr1 (i) + call subr2 (i) + end do + !$acc end parallel +end program main + +! Ensure that we recover from incomplete function definitions. + +integer function f1 ! { dg-error "Expected formal argument list in function definition" } + !$acc routine ! { dg-error "Unclassifiable OpenACC directive" } +end function f1 ! { dg-error "Expecting END PROGRAM statement" } + +subroutine subr1 (x) + !$acc routine + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr1 + +subroutine subr2 (x) + !$acc routine (subr1) ! { dg-error "Invalid NAME 'subr1' in \\!\\\$ACC ROUTINE \\( NAME \\)" } + integer, intent(inout) :: x + !$acc routine (x) ! { dg-error "NAME 'x' does not refer to a subroutine or function in \\!\\\$ACC ROUTINE \\( NAME \\)" } + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr2 + +subroutine subr3 (x) + !$acc routine (subr3) + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + call subr4 (x) + end if +end subroutine subr3 + +subroutine subr4 (x) + !$acc routine (subr4) + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr4 + +subroutine subr10 (x) + !$acc routine (subr10) device ! { dg-error "Failed to match clause" } + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr10 + +subroutine subr20 (x) + !$acc routine (subr20) nohost nohost ! { dg-error "Duplicated 'nohost' clause" } + integer, intent(inout) :: x + if (x < 1) then + x = 1 + else + x = x * x - 1 + end if +end subroutine subr20 Index: Fortran/gfortran/regression/goacc/routine-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-8.f90 @@ -0,0 +1,32 @@ +! Test ACC ROUTINE inside an interface block. + +program main + interface + function s_1 (a) + integer a + !$acc routine + end function s_1 + end interface + + interface + function s_2 (a) + integer a + !$acc routine seq + end function s_2 + end interface + + interface + function s_3 (a) + integer a + !$acc routine (s_3) ! { dg-error "Only the ..ACC ROUTINE form without list is allowed in interface block" } + end function s_3 + end interface + + interface + function s_4 (a) + integer a + !$acc routine (s_4) seq ! { dg-error "Only the ..ACC ROUTINE form without list is allowed in interface block" } + end function s_4 + end interface +end program main + Index: Fortran/gfortran/regression/goacc/routine-external-level-of-parallelism-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-external-level-of-parallelism-1.f @@ -0,0 +1,347 @@ +! Check valid calls to 'external' OpenACC routines. + +! { dg-additional-options "-fopt-info-optimized-omp" } + + subroutine sub + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + external :: gangr, workerr, vectorr, seqr +!$acc routine (gangr) gang +!$acc routine (workerr) worker +!$acc routine (vectorr) vector +!$acc routine (seqr) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n +!$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do + end do +!$acc end parallel loop + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n +!$acc loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do j = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + end subroutine sub + + subroutine func + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + integer, external :: gangf, workerf, vectorf, seqf +!$acc routine (gangf) gang +!$acc routine (workerf) worker +!$acc routine (vectorf) vector +!$acc routine (seqf) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n +!$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do + end do +!$acc end parallel loop + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n +!$acc loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do j = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + end subroutine func Index: Fortran/gfortran/regression/goacc/routine-external-level-of-parallelism-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-external-level-of-parallelism-2.f @@ -0,0 +1,387 @@ +! Check invalid calls to 'external' OpenACC routines. + +! { dg-additional-options "-fopt-info-optimized-omp" } + + subroutine sub + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + external :: gangr, workerr, vectorr, seqr +!$acc routine (gangr) gang +!$acc routine (workerr) worker +!$acc routine (vectorr) vector +!$acc routine (seqr) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n +!$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-bogus "note: routine 'workerr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 } +! { dg-bogus "note: routine 'workerr_' declared here" "TODO2" { xfail offloading_enabled } .-2 } + end do + end do +!$acc end parallel loop + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n +!$acc loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do j = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } +! { dg-bogus "note: routine 'gangr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 } +! { dg-bogus "note: routine 'gangr_' declared here" "TODO2" { xfail offloading_enabled } .-3 } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call seqr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call gangr (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-bogus "note: routine 'vectorr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 } +! { dg-bogus "note: routine 'vectorr_' declared here" "TODO2" { xfail offloading_enabled } .-2 } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + end subroutine sub + + subroutine func + implicit none + integer, parameter :: n = 100 + integer :: a(n), i, j + integer, external :: gangf, workerf, vectorf, seqf +!$acc routine (gangf) gang +!$acc routine (workerf) worker +!$acc routine (vectorf) vector +!$acc routine (seqf) seq + +! +! Test subroutine calls inside nested loops. +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n +!$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do j = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-bogus "note: routine 'workerf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 } +! { dg-bogus "note: routine 'workerf_' declared here" "TODO2" { xfail offloading_enabled } .-2 } + end do + end do +!$acc end parallel loop + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n +!$acc loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do j = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } +! { dg-bogus "note: routine 'gangf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 } +! { dg-bogus "note: routine 'gangf_' declared here" "TODO2" { xfail offloading_enabled } .-3 } + end do + end do +!$acc end parallel loop + +! +! Test calls to seq routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = seqf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to gang routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to worker routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + end do +!$acc end parallel loop + +! +! Test calls to vector routines +! + +!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-bogus "note: routine 'vectorf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 } +! { dg-bogus "note: routine 'vectorf_' declared here" "TODO2" { xfail offloading_enabled } .-2 } + end do +!$acc end parallel loop + +!$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + +!$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } +! { dg-note "containing loop here" "" { target *-*-* } .-1 } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } +! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 } + end do +!$acc end parallel loop + +!$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, n + a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do +!$acc end parallel loop + end subroutine func Index: Fortran/gfortran/regression/goacc/routine-intrinsic-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-intrinsic-1.f @@ -0,0 +1,21 @@ +! Check for valid clauses with intrinsic symbols specified in OpenACC +! 'routine' directives. + + SUBROUTINE sub_1 + IMPLICIT NONE +!$ACC ROUTINE (ABORT) +!$ACC ROUTINE (ABORT) SEQ + + CALL ABORT + END SUBROUTINE sub_1 + + MODULE m_w_1 + IMPLICIT NONE +!$ACC ROUTINE (ABORT) SEQ +!$ACC ROUTINE (ABORT) + + CONTAINS + SUBROUTINE sub_2 + CALL ABORT + END SUBROUTINE sub_2 + END MODULE m_w_1 Index: Fortran/gfortran/regression/goacc/routine-intrinsic-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-intrinsic-2.f @@ -0,0 +1,33 @@ +! Check for invalid clauses with intrinsic symbols specified in OpenACC +! 'routine' directives. + + SUBROUTINE sub_1 + IMPLICIT NONE +!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } + +!$ACC ROUTINE (ABORT) NOHOST ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible NOHOST clause" } + +!$ACC ROUTINE (ABORT) WORKER NOHOST ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) NOHOST GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } + + CALL ABORT + END SUBROUTINE sub_1 + + MODULE m_w_1 + IMPLICIT NONE +!$ACC ROUTINE (ABORT) VECTOR ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) GANG ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } + +!$ACC ROUTINE (ABORT) NOHOST ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible NOHOST clause" } + +!$ACC ROUTINE (ABORT) VECTOR NOHOST ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } +!$ACC ROUTINE (ABORT) NOHOST WORKER ! { dg-error "Intrinsic symbol specified in \\!\\\$ACC ROUTINE \\( NAME \\) at \\(1\\) marked with incompatible GANG, WORKER, or VECTOR clause" } + + CONTAINS + SUBROUTINE sub_2 + CALL ABORT + END SUBROUTINE sub_2 + END MODULE m_w_1 Index: Fortran/gfortran/regression/goacc/routine-level-of-parallelism-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-level-of-parallelism-1.f90 @@ -0,0 +1,78 @@ +! Test various aspects of clauses specifying compatible levels of parallelism +! with the OpenACC routine directive. The C/C++ counterpart is +! '../../c-c++-common/goacc/routine-level-of-parallelism-2.c'. + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +subroutine g_1 + !$acc routine gang + ! { dg-warning "region is gang partitioned but does not contain gang partitioned code" "" { target *-*-* } .-2 } + ! { dg-warning "region is worker partitioned but does not contain worker partitioned code" "" { target *-*-* } .-3 } + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-4 } +end subroutine g_1 + +subroutine s_1_2a + !$acc routine +end subroutine s_1_2a + +subroutine s_1_2b + !$acc routine seq +end subroutine s_1_2b + +subroutine s_1_2c + !$acc routine (s_1_2c) +end subroutine s_1_2c + +subroutine s_1_2d + !$acc routine (s_1_2d) seq +end subroutine s_1_2d + +module s_2 +contains + subroutine s_2_1a + !$acc routine + end subroutine s_2_1a + + subroutine s_2_1b + !$acc routine seq + end subroutine s_2_1b + + subroutine s_2_1c + !$acc routine (s_2_1c) + end subroutine s_2_1c + + subroutine s_2_1d + !$acc routine (s_2_1d) seq + end subroutine s_2_1d +end module s_2 + +subroutine test + external g_1, w_1, v_1 + external s_1_1, s_1_2 + + interface + function s_3_1a (a) + integer a + !$acc routine + end function s_3_1a + end interface + + interface + function s_3_1b (a) + integer a + !$acc routine seq + end function s_3_1b + end interface + + !$acc routine(g_1) gang + + !$acc routine(w_1) worker + + !$acc routine(v_1) worker + + ! Also test the implicit seq clause. + + !$acc routine (s_1_1) seq + +end subroutine test Index: Fortran/gfortran/regression/goacc/routine-module-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-module-1.f90 @@ -0,0 +1,61 @@ +! Valid use of routines defined inside a Fortran module. + +! { dg-compile-aux-modules "routine-module-mod-1.f90" } +! { dg-additional-options "-fopt-info-optimized-omp" } + +program main + use routine_module_mod_1 + implicit none + + integer :: i + + call pl_1 + + !$acc parallel loop seq ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + do i = 1, 10 + call s_1 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_1_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call g_1 ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + call g_1_nh ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + call w_1 ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call w_1_nh ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call v_1 ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + call v_1_nh ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop gang ! { dg-message "optimized: assigned OpenACC gang loop parallelism" } + do i = 1, 10 + call s_1 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_1_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call w_1 ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call w_1_nh ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call v_1 ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + call v_1_nh ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop worker ! { dg-message "optimized: assigned OpenACC worker loop parallelism" } + do i = 1, 10 + call s_1 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_1_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call v_1 ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + call v_1_nh ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + end do + !$acc end parallel loop + + !$acc parallel loop vector ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, 10 + call s_1 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_1_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + end do + !$acc end parallel loop +end program main Index: Fortran/gfortran/regression/goacc/routine-module-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-module-2.f90 @@ -0,0 +1,37 @@ +! Invalid use of routines defined inside a Fortran module. + +! { dg-compile-aux-modules "routine-module-mod-1.f90" } + +program main + use routine_module_mod_1 + implicit none + + integer :: i + + !$acc parallel loop gang + do i = 1, 10 + call g_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call g_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + end do + !$acc end parallel loop + + !$acc parallel loop worker + do i = 1, 10 + call g_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call g_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call w_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call w_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + end do + !$acc end parallel loop + + !$acc parallel loop vector + do i = 1, 10 + call g_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call g_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call w_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call w_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call v_1 ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + call v_1_nh ! { dg-error "routine call uses same OpenACC parallelism as containing loop" } + end do + !$acc end parallel loop +end program main Index: Fortran/gfortran/regression/goacc/routine-module-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-module-3.f90 @@ -0,0 +1,55 @@ +! Invalid use of routines defined inside a Fortran module. + +! { dg-compile-aux-modules "routine-module-mod-1.f90" } + +subroutine sr_1 + use routine_module_mod_1 + implicit none + + !$acc routine (s_1) seq ! { dg-error "Cannot change attributes of USE-associated symbol s_1" } + ! { dg-error "NAME 's_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_1_nh) seq nohost ! { dg-error "Cannot change attributes of USE-associated symbol s_1_nh" } + ! { dg-error "NAME 's_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_2) seq ! { dg-error "Cannot change attributes of USE-associated symbol s_2" } + ! { dg-error "NAME 's_2' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_2_nh) seq nohost ! { dg-error "Cannot change attributes of USE-associated symbol s_2_nh" } + ! { dg-error "NAME 's_2_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (v_1) seq ! { dg-error "Cannot change attributes of USE-associated symbol v_1" } + ! { dg-error "NAME 'v_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (v_1_nh) seq nohost ! { dg-error "Cannot change attributes of USE-associated symbol v_1_nh" } + ! { dg-error "NAME 'v_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (w_1) gang ! { dg-error "Cannot change attributes of USE-associated symbol w_1" } + ! { dg-error "NAME 'w_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (w_1_nh) gang nohost ! { dg-error "Cannot change attributes of USE-associated symbol w_1_nh" } + ! { dg-error "NAME 'w_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (g_1) gang ! { dg-error "Cannot change attributes of USE-associated symbol g_1" } + ! { dg-error "NAME 'g_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (g_1_nh) gang nohost ! { dg-error "Cannot change attributes of USE-associated symbol g_1_nh" } + ! { dg-error "NAME 'g_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } +end subroutine sr_1 + +subroutine sr_2 + use routine_module_mod_1 + implicit none + + !$acc routine (s_1) seq nohost ! { dg-error "Cannot change attributes of USE-associated symbol s_1" } + ! { dg-error "NAME 's_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_1_nh) seq ! { dg-error "Cannot change attributes of USE-associated symbol s_1_nh" } + ! { dg-error "NAME 's_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_2) seq nohost ! { dg-error "Cannot change attributes of USE-associated symbol s_2" } + ! { dg-error "NAME 's_2' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (s_2_nh) seq ! { dg-error "Cannot change attributes of USE-associated symbol s_2_nh" } + ! { dg-error "NAME 's_2_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (v_1) vector nohost ! { dg-error "Cannot change attributes of USE-associated symbol v_1" } + ! { dg-error "NAME 'v_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (v_1_nh) vector ! { dg-error "Cannot change attributes of USE-associated symbol v_1_nh" } + ! { dg-error "NAME 'v_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (w_1) worker nohost ! { dg-error "Cannot change attributes of USE-associated symbol w_1" } + ! { dg-error "NAME 'w_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (w_1_nh) worker ! { dg-error "Cannot change attributes of USE-associated symbol w_1_nh" } + ! { dg-error "NAME 'w_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (g_1) worker nohost ! { dg-error "Cannot change attributes of USE-associated symbol g_1" } + ! { dg-error "NAME 'g_1' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } + !$acc routine (g_1_nh) worker ! { dg-error "Cannot change attributes of USE-associated symbol g_1_nh" } + ! { dg-error "NAME 'g_1_nh' invalid in \\!\\\$ACC ROUTINE \\( NAME \\)" "" { target *-*-* } .-1 } +end subroutine sr_2 Index: Fortran/gfortran/regression/goacc/routine-module-mod-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-module-mod-1.f90 @@ -0,0 +1,143 @@ +! OpenACC 'routine' directives inside a Fortran module. + +! { dg-additional-options "-fopt-info-optimized-omp" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +module routine_module_mod_1 +contains + subroutine s_1 + implicit none + !$acc routine + + integer :: i + + !$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, 3 + end do + end subroutine s_1 + + subroutine s_1_nh + implicit none + !$acc routine nohost + + integer :: i + + !$acc loop ! { dg-bogus "assigned OpenACC .* loop parallelism" } + do i = 1, 3 + end do + end subroutine s_1_nh + + subroutine s_2 + implicit none + !$acc routine (s_2) seq + + integer :: i + + !$acc loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, 3 + end do + end subroutine s_2 + + subroutine s_2_nh + implicit none + !$acc routine (s_2_nh) seq nohost + + integer :: i + + !$acc loop ! { dg-bogus "assigned OpenACC .* loop parallelism" } + do i = 1, 3 + end do + end subroutine s_2_nh + + subroutine v_1 + implicit none + !$acc routine vector + + integer :: i + + !$acc loop ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + do i = 1, 3 + end do + end subroutine v_1 + + subroutine v_1_nh + implicit none + !$acc routine vector nohost + + integer :: i + + !$acc loop ! { dg-bogus "assigned OpenACC .* loop parallelism" } + do i = 1, 3 + end do + end subroutine v_1_nh + + subroutine w_1 + implicit none + !$acc routine (w_1) worker + + integer :: i + + !$acc loop ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + do i = 1, 3 + end do + end subroutine w_1 + + subroutine w_1_nh + implicit none + !$acc routine (w_1_nh) worker nohost + + integer :: i + + !$acc loop ! { dg-bogus "assigned OpenACC .* loop parallelism" } + do i = 1, 3 + end do + end subroutine w_1_nh + + subroutine g_1 + implicit none + !$acc routine gang + ! { dg-bogus "\[Ww\]arning: region is worker partitioned but does not contain worker partitioned code" "TODO default 'gang' 'vector'" { xfail *-*-* } .-3 } + + integer :: i + + !$acc loop ! { dg-message "optimized: assigned OpenACC gang vector loop parallelism" } + do i = 1, 3 + end do + end subroutine g_1 + + subroutine g_1_nh + implicit none + !$acc routine gang nohost + + integer :: i + + !$acc loop ! { dg-bogus "assigned OpenACC .* loop parallelism" } + do i = 1, 3 + end do + end subroutine g_1_nh + + subroutine pl_1 + implicit none + + integer :: i + + !$acc parallel loop ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + ! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 } + do i = 1, 3 + call s_1 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_1_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2 ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call s_2_nh ! { dg-message "optimized: assigned OpenACC seq loop parallelism" } + call v_1 ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + call v_1_nh ! { dg-message "optimized: assigned OpenACC vector loop parallelism" } + call w_1 ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call w_1_nh ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" } + call g_1 ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + call g_1_nh ! { dg-message "optimized: assigned OpenACC gang worker vector loop parallelism" } + end do + end subroutine pl_1 +end module routine_module_mod_1 Index: Fortran/gfortran/regression/goacc/routine-multiple-directives-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-multiple-directives-1.f90 @@ -0,0 +1,127 @@ +! Check for valid cases of multiple OpenACC 'routine' directives. + +! { dg-additional-options "-fdump-tree-oaccloops" } +!TODO See PR101551 for 'offloading_enabled' differences. + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + + SUBROUTINE s_1 +!$ACC ROUTINE(s_1) +!$ACC ROUTINE(s_1) SEQ +!$ACC ROUTINE SEQ + END SUBROUTINE s_1 + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_1' doesn't have 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_1_' doesn't have 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE s_1_nh +!$ACC ROUTINE(s_1_nh) NOHOST +!$ACC ROUTINE(s_1_nh) SEQ NOHOST +!$ACC ROUTINE NOHOST SEQ + END SUBROUTINE s_1_nh + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_1_nh' has 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_1_nh_' has 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE s_2 +!$ACC ROUTINE +!$ACC ROUTINE SEQ +!$ACC ROUTINE(s_2) + END SUBROUTINE s_2 + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_2' doesn't have 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_2_' doesn't have 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE s_2_nh +!$ACC ROUTINE NOHOST +!$ACC ROUTINE NOHOST SEQ +!$ACC ROUTINE(s_2_nh) NOHOST + END SUBROUTINE s_2_nh + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_2_nh' has 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 's_2_nh_' has 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE v_1 +!$ACC ROUTINE VECTOR +!$ACC ROUTINE VECTOR +!$ACC ROUTINE(v_1) VECTOR +!$ACC ROUTINE VECTOR +! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-5 } + END SUBROUTINE v_1 + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_1' doesn't have 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_1_' doesn't have 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE v_1_nh +!$ACC ROUTINE NOHOST VECTOR +!$ACC ROUTINE VECTOR NOHOST +!$ACC ROUTINE(v_1_nh) NOHOST VECTOR +!$ACC ROUTINE VECTOR NOHOST +! { dg-bogus "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-5 } + END SUBROUTINE v_1_nh + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_1_nh' has 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_1_nh_' has 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE v_2 +!$ACC ROUTINE(v_2) VECTOR +!$ACC ROUTINE VECTOR +!$ACC ROUTINE(v_2) VECTOR +! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-4 } + END SUBROUTINE v_2 + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_2' doesn't have 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_2_' doesn't have 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE v_2_nh +!$ACC ROUTINE(v_2_nh) VECTOR NOHOST +!$ACC ROUTINE VECTOR NOHOST +!$ACC ROUTINE(v_2_nh) NOHOST VECTOR +! { dg-bogus "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-4 } + END SUBROUTINE v_2_nh + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_2_nh' has 'nohost' clause" 1 "oaccloops" { target { ! offloading_enabled } } } } + ! { dg-final { scan-tree-dump-times "(?n)OpenACC routine 'v_2_nh_' has 'nohost' clause" 1 "oaccloops" { target offloading_enabled } } } + + SUBROUTINE sub_1 + IMPLICIT NONE + EXTERNAL :: g_1 +!$ACC ROUTINE (g_1) GANG +!$ACC ROUTINE (g_1) GANG +!$ACC ROUTINE (g_1) GANG + EXTERNAL :: g_1_nh +!$ACC ROUTINE (g_1_nh) GANG NOHOST +!$ACC ROUTINE (g_1_nh) NOHOST GANG +!$ACC ROUTINE (g_1_nh) NOHOST GANG +!$ACC ROUTINE (g_1_nh) GANG NOHOST + + CALL s_1 + CALL s_1_nh + CALL s_2 + CALL s_2_nh + CALL v_1 + CALL v_1_nh + CALL v_2 + CALL v_2_nh + CALL g_1 + CALL g_1_nh + CALL ABORT + END SUBROUTINE sub_1 + + MODULE m_w_1 + IMPLICIT NONE + EXTERNAL :: w_1 +!$ACC ROUTINE (w_1) WORKER +!$ACC ROUTINE (w_1) WORKER + EXTERNAL :: w_1_nh +!$ACC ROUTINE (w_1_nh) NOHOST WORKER +!$ACC ROUTINE (w_1_nh) WORKER NOHOST + + CONTAINS + SUBROUTINE sub_2 + CALL s_1 + CALL s_1_nh + CALL s_2 + CALL s_2_nh + CALL v_1 + CALL v_1_nh + CALL v_2 + CALL v_2_nh + CALL w_1 + CALL w_1_nh + CALL ABORT + END SUBROUTINE sub_2 + END MODULE m_w_1 Index: Fortran/gfortran/regression/goacc/routine-multiple-directives-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-multiple-directives-2.f90 @@ -0,0 +1,229 @@ +! Check for invalid (and some valid) cases of multiple OpenACC 'routine' +! directives. + + SUBROUTINE s_1 +!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_1) +!$ACC ROUTINE GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1) SEQ +!$ACC ROUTINE +!$ACC ROUTINE(s_1) WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR NOHOST WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_1) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1) SEQ NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1) NOHOST WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG NOHOST VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE s_1 + + SUBROUTINE s_1_nh +!$ACC ROUTINE NOHOST VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_1_nh) NOHOST +!$ACC ROUTINE NOHOST GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1_nh) NOHOST SEQ +!$ACC ROUTINE NOHOST +!$ACC ROUTINE(s_1_nh) WORKER NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG NOHOST VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_1_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1_nh) SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_1_nh) WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE s_1_nh + + SUBROUTINE s_2 +!$ACC ROUTINE(s_2) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE +!$ACC ROUTINE(s_2) GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ +!$ACC ROUTINE(s_2) +!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_2) VECTOR NOHOST WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2) GANG NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2) NOHOST GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE s_2 + + SUBROUTINE s_2_nh +!$ACC ROUTINE(s_2_nh) NOHOST VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE NOHOST +!$ACC ROUTINE(s_2_nh) GANG NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ NOHOST +!$ACC ROUTINE(s_2_nh) NOHOST +!$ACC ROUTINE NOHOST WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2_nh) NOHOST GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(s_2_nh) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2_nh) GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(s_2_nh) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE s_2_nh + + SUBROUTINE v_1 +!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR +!$ACC ROUTINE GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_1) VECTOR +!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE NOHOST VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE NOHOST VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_1) VECTOR NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE WORKER NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG VECTOR NOHOST ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE v_1 + + SUBROUTINE v_1_nh +!$ACC ROUTINE VECTOR WORKER NOHOST ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR NOHOST +!$ACC ROUTINE GANG NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_1_nh) VECTOR NOHOST +!$ACC ROUTINE WORKER NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG NOHOST VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_1_nh) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE v_1_nh + + SUBROUTINE v_2 +!$ACC ROUTINE(v_2) VECTOR +!$ACC ROUTINE(v_2) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE VECTOR +!$ACC ROUTINE(v_2) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2) VECTOR NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_2) VECTOR NOHOST WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE VECTOR NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_2) NOHOST GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE v_2 + + SUBROUTINE v_2_nh +!$ACC ROUTINE(v_2_nh) VECTOR NOHOST +!$ACC ROUTINE(v_2_nh) VECTOR WORKER NOHOST ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2_nh) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE VECTOR NOHOST +!$ACC ROUTINE(v_2_nh) GANG NOHOST VECTOR ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2_nh) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_2_nh) VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE(v_2_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE(v_2_nh) GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + END SUBROUTINE v_2_nh + + SUBROUTINE sub_1 + IMPLICIT NONE + EXTERNAL :: g_1 +!$ACC ROUTINE (g_1) GANG +!$ACC ROUTINE (g_1) GANG WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (g_1) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) GANG +!$ACC ROUTINE (g_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) NOHOST GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) GANG WORKER NOHOST ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (g_1) NOHOST VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) NOHOST SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) GANG NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } + EXTERNAL :: g_1_nh +!$ACC ROUTINE (g_1_nh) NOHOST GANG +!$ACC ROUTINE (g_1_nh) GANG NOHOST WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (g_1_nh) NOHOST VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) SEQ NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) GANG NOHOST +!$ACC ROUTINE (g_1_nh) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) GANG WORKER ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (g_1_nh) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) GANG ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (g_1_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } + + CALL s_1 + CALL s_1_nh + CALL s_2 + CALL s_2_nh + CALL v_1 + CALL v_1_nh + CALL v_2 + CALL v_2_nh + CALL g_1 + CALL g_1_nh + CALL ABORT + END SUBROUTINE sub_1 + + MODULE m_w_1 + IMPLICIT NONE + EXTERNAL :: w_1 +!$ACC ROUTINE (w_1) WORKER +!$ACC ROUTINE (w_1) WORKER SEQ ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (w_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) WORKER +!$ACC ROUTINE (w_1) SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) WORKER NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) WORKER NOHOST SEQ ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (w_1) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) NOHOST WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) SEQ NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1) VECTOR NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } + EXTERNAL :: w_1_nh +!$ACC ROUTINE (w_1_nh) WORKER NOHOST +!$ACC ROUTINE (w_1_nh) WORKER NOHOST SEQ ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (w_1_nh) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) NOHOST WORKER +!$ACC ROUTINE (w_1_nh) NOHOST SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) VECTOR NOHOST ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) WORKER SEQ ! { dg-error "Multiple loop axes specified for routine" } +!$ACC ROUTINE (w_1_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) WORKER ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) SEQ ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) ! { dg-error "\\!\\\$ACC ROUTINE already applied" } +!$ACC ROUTINE (w_1_nh) VECTOR ! { dg-error "\\!\\\$ACC ROUTINE already applied" } + + CONTAINS + SUBROUTINE sub_2 + CALL s_1 + CALL s_1_nh + CALL s_2 + CALL s_2_nh + CALL v_1 + CALL v_1_nh + CALL v_2 + CALL v_2_nh + CALL w_1 + CALL w_1_nh + CALL ABORT + END SUBROUTINE sub_2 + END MODULE m_w_1 Index: Fortran/gfortran/regression/goacc/routine-multiple-lop-clauses-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/routine-multiple-lop-clauses-1.f90 @@ -0,0 +1,32 @@ +! Check for multiple clauses specifying the level of parallelism. + +SUBROUTINE v_1 + !$ACC ROUTINE VECTOR WORKER ! { dg-error "Multiple loop axes specified for routine" } +END SUBROUTINE v_1 + +SUBROUTINE sub_1 + IMPLICIT NONE + EXTERNAL :: g_1 + !$ACC ROUTINE (g_1) GANG WORKER ! { dg-error "Multiple loop axes specified for routine" } + !$ACC ROUTINE (ABORT) SEQ WORKER GANG VECTOR ! { dg-error "Multiple loop axes specified for routine" } + !$ACC ROUTINE WORKER SEQ ! { dg-error "Multiple loop axes specified for routine" } + + CALL v_1 + CALL g_1 + CALL ABORT +END SUBROUTINE sub_1 + +MODULE m_w_1 + IMPLICIT NONE + EXTERNAL :: w_1 + !$ACC ROUTINE VECTOR GANG SEQ ! { dg-error "Multiple loop axes specified for routine" } + !$ACC ROUTINE (w_1) GANG WORKER SEQ ! { dg-error "Multiple loop axes specified for routine" } + !$ACC ROUTINE (ABORT) VECTOR GANG ! { dg-error "Multiple loop axes specified for routine" } + +CONTAINS + SUBROUTINE sub_2 + CALL v_1 + CALL w_1 + CALL ABORT + END SUBROUTINE sub_2 +END MODULE m_w_1 Index: Fortran/gfortran/regression/goacc/sentinel-free-form.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/sentinel-free-form.f95 @@ -0,0 +1,24 @@ +! { dg-do compile } + +program test + implicit none + + integer :: i + real :: x + + ! sentinel may only be preceeded by white space + x = 0.0 !$acc parallel ! comment + ! sentinel must appear as a single word + ! $acc parallel ! comment + + ! note that '!$ ' is OpenMP's conditional compilation sentinel + !$ acc ignored_due_to_space ! comment + + ! directive lines must have space after sentinel + !$accparallel ! { dg-warning "followed by a space" } + do i = 1,10 + x = x + 0.3 + enddo + !$acc end parallel ! { dg-error "Unexpected" } + print *, x +end Index: Fortran/gfortran/regression/goacc/several-directives.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/several-directives.f95 @@ -0,0 +1,6 @@ +! { dg-do compile } + +program test + ! only one directive-name may appear in directive + !$acc parallel kernels ! { dg-error "Failed to match clause" } +end Index: Fortran/gfortran/regression/goacc/sie.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/sie.f95 @@ -0,0 +1,336 @@ +! { dg-do compile } +! { dg-additional-options "-fmax-errors=100" } + +! tests async, num_gangs, num_workers, vector_length, gang, worker, vector clauses + +program test + implicit none + + integer :: i + + !$acc parallel async + !$acc end parallel + + !$acc parallel async(3) + !$acc end parallel + + !$acc parallel async(i) + !$acc end parallel + + !$acc parallel async(i+1) + !$acc end parallel + + !$acc parallel async(-1) + !$acc end parallel + + !$acc parallel async(0) + !$acc end parallel + + !$acc parallel async() ! { dg-error "Invalid character in name" } + + !$acc parallel async(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel async(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel async("1") ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc kernels async + !$acc end kernels + + !$acc kernels async(3) + !$acc end kernels + + !$acc kernels async(i) + !$acc end kernels + + !$acc kernels async(i+1) + !$acc end kernels + + !$acc kernels async(-1) + !$acc end kernels + + !$acc kernels async(0) + !$acc end kernels + + !$acc kernels async() ! { dg-error "Invalid character in name" } + + !$acc kernels async(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels async(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels async("1") ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + + !$acc parallel num_gangs ! { dg-error "Expected '\\(' after 'num_gangs'" } + + !$acc parallel num_gangs(3) + !$acc end parallel + + !$acc parallel num_gangs(i) + !$acc end parallel + + !$acc parallel num_gangs(i+1) + !$acc end parallel + + !$acc parallel num_gangs(-1) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel num_gangs(0) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel num_gangs() ! { dg-error "Invalid character in name" } + + !$acc parallel num_gangs(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel num_gangs(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel num_gangs("1") ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc kernels num_gangs ! { dg-error "Expected '\\(' after 'num_gangs'" } + + !$acc kernels num_gangs(3) + !$acc end kernels + + !$acc kernels num_gangs(i) + !$acc end kernels + + !$acc kernels num_gangs(i+1) + !$acc end kernels + + !$acc kernels num_gangs(-1) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels num_gangs(0) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels num_gangs() ! { dg-error "Invalid character in name" } + + !$acc kernels num_gangs(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels num_gangs(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels num_gangs("1") ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + + !$acc parallel num_workers ! { dg-error "Expected '\\(' after 'num_workers'" } + + !$acc parallel num_workers(3) + !$acc end parallel + + !$acc parallel num_workers(i) + !$acc end parallel + + !$acc parallel num_workers(i+1) + !$acc end parallel + + !$acc parallel num_workers(-1) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel num_workers(0) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel num_workers() ! { dg-error "Invalid expression after 'num_workers\\('" } + + !$acc parallel num_workers(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel num_workers(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel num_workers("1") ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc kernels num_workers ! { dg-error "Expected '\\(' after 'num_workers'" } + + !$acc kernels num_workers(3) + !$acc end kernels + + !$acc kernels num_workers(i) + !$acc end kernels + + !$acc kernels num_workers(i+1) + !$acc end kernels + + !$acc kernels num_workers(-1) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels num_workers(0) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels num_workers() ! { dg-error "Invalid expression after 'num_workers\\('" } + + !$acc kernels num_workers(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels num_workers(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels num_workers("1") ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + + !$acc parallel vector_length ! { dg-error "Expected '\\(' after 'vector_length'" } + + !$acc parallel vector_length(3) + !$acc end parallel + + !$acc parallel vector_length(i) + !$acc end parallel + + !$acc parallel vector_length(i+1) + !$acc end parallel + + !$acc parallel vector_length(-1) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel vector_length(0) ! { dg-warning "must be positive" } + !$acc end parallel + + !$acc parallel vector_length() ! { dg-error "Invalid expression after 'vector_length\\('" } + + !$acc parallel vector_length(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel vector_length(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc parallel vector_length("1") ! { dg-error "scalar INTEGER expression" } + !$acc end parallel + + !$acc kernels vector_length ! { dg-error "Expected '\\(' after 'vector_length'" } + + !$acc kernels vector_length(3) + !$acc end kernels + + !$acc kernels vector_length(i) + !$acc end kernels + + !$acc kernels vector_length(i+1) + !$acc end kernels + + !$acc kernels vector_length(-1) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels vector_length(0) ! { dg-warning "must be positive" } + !$acc end kernels + + !$acc kernels vector_length() ! { dg-error "Invalid expression after 'vector_length\\('" } + + !$acc kernels vector_length(1.5) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels vector_length(.true.) ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + !$acc kernels vector_length("1") ! { dg-error "scalar INTEGER expression" } + !$acc end kernels + + + !$acc loop gang + do i = 1,10 + enddo + !$acc loop gang(3) + do i = 1,10 + enddo + !$acc loop gang(i) + do i = 1,10 + enddo + !$acc loop gang(i+1) + do i = 1,10 + enddo + !$acc loop gang(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop gang(0) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop gang() ! { dg-error "Invalid character in name" } + do i = 1,10 + enddo + !$acc loop gang(1.5) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop gang(.true.) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop gang("1") ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + + + !$acc loop worker + do i = 1,10 + enddo + !$acc loop worker(3) + do i = 1,10 + enddo + !$acc loop worker(i) + do i = 1,10 + enddo + !$acc loop worker(i+1) + do i = 1,10 + enddo + !$acc loop worker(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop worker(0) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop worker() ! { dg-error "Invalid character in name" } + do i = 1,10 + enddo + !$acc loop worker(1.5) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop worker(.true.) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop worker("1") ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + + + !$acc loop vector + do i = 1,10 + enddo + !$acc loop vector(3) + do i = 1,10 + enddo + !$acc loop vector(i) + do i = 1,10 + enddo + !$acc loop vector(i+1) + do i = 1,10 + enddo + !$acc loop vector(-1) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop vector(0) ! { dg-warning "must be positive" } + do i = 1,10 + enddo + !$acc loop vector() ! { dg-error "Invalid character in name" } + do i = 1,10 + enddo + !$acc loop vector(1.5) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop vector(.true.) ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + !$acc loop vector("1") ! { dg-error "scalar INTEGER expression" } + do i = 1,10 + enddo + +end program test Index: Fortran/gfortran/regression/goacc/specification-part.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/specification-part.f90 @@ -0,0 +1,100 @@ +! { dg-do compile } +! +! PR fortran/90111 +! +! Check that OpenACC directives in everywhere in specification part, +! i.e. it may appear before/after the use, import, implicit, and declaration +! + +module m +end module m + +subroutine foo0(kk) + use m + implicit none + integer :: jj, kk + !$acc routine +end + +subroutine foo1() + use m + implicit none + !$acc routine + integer :: jj +end + +subroutine foo2() + use m + !$acc routine + implicit none +end + +subroutine foo3() + !$acc routine + use m + implicit none +end + +module m2 + interface + subroutine foo0(kk) + use m + import + implicit none + integer :: kk + !$acc routine + end + subroutine foo1() + use m + import + implicit none + !$acc routine + end + subroutine foo2() + use m + import + !$acc routine + implicit none + end + subroutine foo3() + use m + !$acc routine + import + implicit none + end + subroutine foo4() + use m + !$acc routine + import + implicit none + end + end interface +end module m2 + +subroutine bar0() + use m + implicit none + integer :: ii + !$acc declare copyin(ii) +end + +subroutine bar1() + use m + implicit none + !$acc declare copyin(ii) + integer :: ii +end + +subroutine bar2() + use m + !$acc declare copyin(ii) + implicit none + integer :: ii +end + +subroutine bar3() + !$acc declare copyin(ii) + use m + implicit none + integer :: ii +end Index: Fortran/gfortran/regression/goacc/strided-alloc-ptr.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/strided-alloc-ptr.f90 @@ -0,0 +1,34 @@ +implicit none +type t + integer, allocatable :: i, j(:) + integer, pointer :: k, ll(:) +end type t +type(t) :: x(2) + +!$acc enter data copyin(x) + +!$acc enter data copyin(x(:)%i) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the ALLOCATABLE attribute" "" { target "*-*-*" } 10 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 10 } + +!$acc enter data copyin(x(:)%j(3)) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the ALLOCATABLE attribute" "" { target "*-*-*" } 14 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 14 } + +!$acc enter data copyin(x(:)%j) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the ALLOCATABLE attribute" "" { target "*-*-*" } 18 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 18 } + + +!$acc enter data copyin(x(:)%k) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the POINTER attribute" "" { target "*-*-*" } 23 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 23 } + +!$acc enter data copyin(x(:)%ll(3)) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the POINTER attribute" "" { target "*-*-*" } 27 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 27 } + +!$acc enter data copyin(x(:)%ll) +! { dg-error "Component to the right of a part reference with nonzero rank must not have the POINTER attribute" "" { target "*-*-*" } 31 } +! { dg-error ".x. in MAP clause at .1. is not a proper array section" "" { target "*-*-*" } 31 } +end Index: Fortran/gfortran/regression/goacc/subarrays.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/subarrays.f95 @@ -0,0 +1,41 @@ +! { dg-do compile } +program test + implicit none + integer :: a(10), b(10, 10), c(3:7), i + + !$acc parallel copy(a(1:5)) + !$acc end parallel + !$acc parallel copy(a(1 + 0 : 5 + 2)) + !$acc end parallel + !$acc parallel copy(a(:3)) + !$acc end parallel + !$acc parallel copy(a(3:)) + !$acc end parallel + !$acc parallel copy(a(:)) + !$acc end parallel + !$acc parallel copy(a(2:3,2:3)) + ! { dg-error "Rank mismatch" "" { target *-*-* } .-1 } + ! { dg-error "'a' in MAP clause" "" { target *-*-* } .-2 } + !$acc end parallel + !$acc parallel copy (a(:11)) ! { dg-warning "Upper array reference" } + !$acc end parallel + !$acc parallel copy (a(i:)) + !$acc end parallel + + !$acc parallel copy (a(:b)) + ! { dg-error "Array index" "" { target *-*-* } .-1 } + ! { dg-error "'a' in MAP clause" "" { target *-*-* } .-2 } + !$acc end parallel + + !$acc parallel copy (b(1:3,2:4)) ! { dg-error "Array is not contiguous" } + !$acc end parallel + !$acc parallel copy (b(2:3)) + ! { dg-error "Rank mismatch" "" { target *-*-* } .-1 } + ! { dg-error "'b' in MAP clause" "" { target *-*-* } .-2 } + !$acc end parallel + !$acc parallel copy (b(1:, 4:6)) + !$acc end parallel + + !$acc parallel copy (c(2:)) ! { dg-warning "Lower array reference" } + !$acc end parallel +end program test Index: Fortran/gfortran/regression/goacc/substring.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/substring.f90 @@ -0,0 +1,27 @@ +implicit none +character(len=10) :: str1, str2(5,5) + +type t + character(len=10) :: str1, str2(5,5) +end type t +type(t) :: v + +!$acc enter data copyin(v%str1) ! OK +!$acc enter data copyin(v%str2) ! OK +!$acc enter data copyin(v%str2(1,2)) ! OK +!$acc enter data copyin(str1) ! OK +!$acc enter data copyin(str2) ! OK +!$acc enter data copyin(str2(1,2)) ! OK + +!$acc enter data copyin(v%str1(2:5)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc enter data copyin(v%str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc enter data copyin(str1(2:5)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc enter data copyin(str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } + +!$acc parallel +!$acc update host(v%str1(2:5)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc update host(v%str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc update host(str1(2:5)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc update host(str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$acc end parallel +end Index: Fortran/gfortran/regression/goacc/tile-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/tile-1.f90 @@ -0,0 +1,339 @@ +subroutine parloop + integer, parameter :: n = 100 + integer i, j, k, a + + !$acc parallel loop tile(10) + do i = 1, n + end do + + !$acc parallel loop tile(*) + do i = 1, n + end do + + !$acc parallel loop tile(10, *) + do i = 1, n + do j = 1, n + end do + end do + + !$acc parallel loop tile(10, *, i) ! { dg-error "" } + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc parallel loop tile ! { dg-error "Failed to match clause" } + do i = 1, n + end do + + !$acc parallel loop tile() ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc parallel loop tile(,1) ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc parallel loop tile(,,) ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc parallel loop tile(1.1) ! { dg-error "requires a scalar INTEGER" } + do i = 1, n + end do + + !$acc parallel loop tile(-3) ! { dg-warning "must be positive" } + do i = 1, n + end do + + !$acc parallel loop tile(10, -3) ! { dg-warning "must be positive" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc parallel loop tile(-100, 10, 5) ! { dg-warning "must be positive" } + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc parallel loop tile(10, .true.) ! { dg-error "requires a scalar" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc parallel loop tile(1, a) ! { dg-error "constant expression" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc parallel loop tile(a, 1) ! { dg-error "constant expression" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc parallel loop tile(2, 3) collapse (2) ! { dg-error "Incompatible use" } + do i = 1, n + do j = 1, n + end do + end do +end subroutine parloop + +subroutine par + integer, parameter :: n = 100 + integer i, j, k + + !$acc parallel + !$acc loop tile ! { dg-error "Failed to match clause" } + do i = 1, n + end do + + !$acc loop tile() ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc loop tile(1) + do i = 1, n + end do + + !$acc loop tile(*) + do i = 1, n + end do + + !$acc loop tile(2) + do i = 1, n + do j = 1, n + end do + end do + + !$acc loop tile(-2) ! { dg-warning "must be positive" } + do i = 1, n + end do + + !$acc loop tile(i) ! { dg-error "constant expression" } + do i = 1, n + end do + + !$acc loop tile(2, 2, 1) + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc parallel loop tile(2, 2) + do i = 1, n + do j = i+1, n, j ! { dg-error "rectangular iteration space" } + end do + end do + + !$acc loop vector tile(*) + do i = 1, n + end do + + !$acc loop worker tile(*) + do i = 1, n + end do + + !$acc loop gang tile(*) + do i = 1, n + end do + + !$acc loop vector gang tile(*) + do i = 1, n + end do + + !$acc loop vector worker tile(*) + do i = 1, n + end do + + !$acc loop gang worker tile(*) + do i = 1, n + end do + + !$acc loop tile(2, 3) collapse (2) ! { dg-error "Incompatible use" } + do i = 1, n + do j = 1, n + end do + end do + !$acc end parallel +end subroutine par + +subroutine kern + integer, parameter :: n = 100 + integer i, j, k + + !$acc kernels + !$acc loop tile ! { dg-error "Failed to match clause" } + do i = 1, n + end do + + !$acc loop tile() ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc loop tile(1) + do i = 1, n + end do + + !$acc loop tile(*) + do i = 1, n + end do + + !$acc loop tile(2) + do i = 1, n + do j = 1, n + end do + end do + + !$acc loop tile(-2) ! { dg-warning "must be positive" } + do i = 1, n + end do + + !$acc loop tile(i) ! { dg-error "constant expression" } + do i = 1, n + end do + + !$acc loop tile(2, 2, 1) + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc parallel loop tile(2, 2) + do i = 1, n + do j = 1, n + end do + end do + + !$acc loop vector tile(*) + do i = 1, n + end do + + !$acc loop worker tile(*) + do i = 1, n + end do + + !$acc loop gang tile(*) + do i = 1, n + end do + + !$acc loop vector gang tile(*) + do i = 1, n + end do + + !$acc loop vector worker tile(*) + do i = 1, n + end do + + !$acc loop gang worker tile(*) + do i = 1, n + end do + + !$acc loop tile(2, 3) collapse (2) ! { dg-error "Incompatible use" } + do i = 1, n + do j = 1, n + end do + end do + !$acc end kernels +end subroutine kern + +subroutine kernsloop + integer, parameter :: n = 100 + integer i, j, k, a + + !$acc kernels loop tile(10) + do i = 1, n + end do + + !$acc kernels loop tile(*) + do i = 1, n + end do + + !$acc kernels loop tile(10, *) + do i = 1, n + do j = 1, n + end do + end do + + !$acc kernels loop tile(10, *, i) ! { dg-error "" } + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc kernels loop tile ! { dg-error "Failed to match clause" } + do i = 1, n + end do + + !$acc kernels loop tile() ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc kernels loop tile(,1) ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc kernels loop tile(,,) ! { dg-error "Syntax error" } + do i = 1, n + end do + + !$acc kernels loop tile(1.1) ! { dg-error "requires a scalar INTEGER" } + do i = 1, n + end do + + !$acc kernels loop tile(-3) ! { dg-warning "must be positive" } + do i = 1, n + end do + + !$acc kernels loop tile(10, -3) ! { dg-warning "must be positive" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc kernels loop tile(-100, 10, 5) ! { dg-warning "must be positive" } + do i = 1, n + do j = 1, n + do k = 1, n + end do + end do + end do + + !$acc kernels loop tile(10, .true.) ! { dg-error "requires a scalar" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc kernels loop tile(1, a) ! { dg-error "constant expression" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc kernels loop tile(a, 1) ! { dg-error "constant expression" } + do i = 1, n + do j = 1, n + end do + end do + + !$acc kernels loop tile(2, 3) collapse (2) ! { dg-error "Incompatible use" } + do i = 1, n + do j = 1, n + end do + end do +end subroutine kernsloop Index: Fortran/gfortran/regression/goacc/tile-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/tile-2.f90 @@ -0,0 +1,21 @@ +subroutine par + integer ix, jx + + !$acc parallel + !$acc loop tile (*,*) ! { dg-error "not enough DO loops for tiled" } + do ix = 1, 30 + end do + + !$acc loop tile (*,*) + do ix = 1, 30 + do jx = 1, ix ! { dg-error "tiled loops don.t form rectangular" } + end do + end do + + !$acc loop tile (*) + do ix = 1, 30 + do jx = 1, ix + end do + end do + !$acc end parallel +end subroutine par Index: Fortran/gfortran/regression/goacc/tile-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/tile-3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! +! PR fortran/93825 +! +! Check that implicit typing works + +program p + !$acc parallel loop tile(2,2) + do i = 1, 8 + do j = 1, 8 + end do + end do +end Index: Fortran/gfortran/regression/goacc/tile-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/tile-4.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! +! Contributed by G. Steinmetz +! +! PR fortran/93552 +! only collapsed an not tile was checked: +program p + integer :: i, j + !$acc parallel loop tile(2,2) + outer: do i = 1, 8 + do j = 1, 8 + exit ! { dg-error "statement at .1. terminating ..ACC LOOP loop" } + cycle outer ! { dg-error "to non-innermost tiled" } + end do + end do outer +end + +! Kernels loop was missing the check: +subroutine test + !$acc kernels loop collapse(2) + outer: do i = 1, 4 + do j = 1, 4 + exit ! { dg-error "statement at .1. terminating ..ACC LOOP loop" } + cycle outer ! { dg-error "to non-innermost collapsed" } + end do + end do outer +end Index: Fortran/gfortran/regression/goacc/tile-lowering.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/tile-lowering.f95 @@ -0,0 +1,292 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine par + integer i, j, k + + !$acc parallel + !$acc loop tile (1) + do i = 1, 10 + end do + + !$acc loop tile (*) + do i = 1, 10 + end do + + !$acc loop tile (1,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (*,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (1,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (*,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (1,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (*,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (1,*,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (1,2,*) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + !$acc end parallel +end subroutine par + +subroutine kerns + integer i, j, k + + !$acc kernels + !$acc loop tile (1) + do i = 1, 10 + end do + + !$acc loop tile (*) + do i = 1, 10 + end do + + !$acc loop tile (1,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (*,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (1,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (*,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc loop tile (1,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (*,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (1,*,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc loop tile (1,2,*) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + !$acc end kernels +end subroutine kerns + +subroutine parloop + integer i, j, k + + !$acc parallel loop tile (1) + do i = 1, 10 + end do + + !$acc parallel loop tile (*) + do i = 1, 10 + end do + + !$acc parallel loop tile (1,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc parallel loop tile (*,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc parallel loop tile (1,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc parallel loop tile (*,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc parallel loop tile (1,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc parallel loop tile (*,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc parallel loop tile (1,*,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc parallel loop tile (1,2,*) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do +end subroutine parloop + +subroutine kernloop + integer i, j, k + + !$acc kernels loop tile (1) + do i = 1, 10 + end do + + !$acc kernels loop tile (*) + do i = 1, 10 + end do + + !$acc kernels loop tile (1,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc kernels loop tile (*,2) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc kernels loop tile (1,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc kernels loop tile (*,*) + do i = 1, 10 + do j = 1, 10 + end do + end do + + !$acc kernels loop tile (1,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc kernels loop tile (*,2,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc kernels loop tile (1,*,3) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do + + !$acc kernels loop tile (1,2,*) + do i = 1, 10 + do j = 1, 10 + do k = 1, 10 + end do + end do + end do +end subroutine kernloop + + +! { dg-final { scan-tree-dump-times "tile\\(1\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(0\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(1, 2\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(0, 2\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(1, 0\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(0, 0\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(1, 2, 3\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(0, 2, 3\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(1, 0, 3\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "tile\\(1, 2, 0\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "for \\(" 88 "original" } } +! { dg-final { scan-tree-dump-times "while \\(" 0 "original" } } Index: Fortran/gfortran/regression/goacc/unexpected-end.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/unexpected-end.f90 @@ -0,0 +1,25 @@ +! PR fortran/102313 + +!$acc end ATOMIC ! { dg-error "Unexpected !.ACC END ATOMIC" } + +!$acc end DATA ! { dg-error "Unexpected !.ACC END DATA" } + +!$acc end HOST_DATA ! { dg-error "Unexpected !.ACC END HOST_DATA" } + +!$acc end KERNELS ! { dg-error "Unexpected !.ACC END KERNELS" } + +!$acc end KERNELS LOOP ! { dg-error "Unexpected !.ACC END KERNELS LOOP" } + +!$acc end LOOP ! { dg-error "Unexpected !.ACC END LOOP" } + +!$acc end PARALLEL ! { dg-error "Unexpected !.ACC END PARALLEL" } + +!$acc end PARALLEL LOOP ! { dg-error "Unexpected !.ACC END PARALLEL LOOP" } + +!$acc end SERIAL ! { dg-error "Unexpected !.ACC END SERIAL" } + +!$acc end SERIAL LOOP ! { dg-error "Unexpected !.ACC END SERIAL LOOP" } + +!$acc end EUPHORBIA LATHYRIS ! { dg-error "Unclassifiable OpenACC directive" } + +end Index: Fortran/gfortran/regression/goacc/uninit-copy-clause.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/uninit-copy-clause.f95 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } + +subroutine foo + integer :: i + + !$acc kernels + i = 1 + !$acc end kernels + +end subroutine foo + +subroutine foo2 + integer :: i + + !$acc kernels copy (i) + i = 1 + !$acc end kernels + +end subroutine foo2 + +subroutine foo3 + integer :: i + + !$acc kernels copyin (i) + i = 1 + !$acc end kernels + +end subroutine foo3 Index: Fortran/gfortran/regression/goacc/uninit-dim-clause.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/uninit-dim-clause.f95 @@ -0,0 +1,41 @@ +! { dg-additional-options "-Wuninitialized" } + +! { dg-additional-options "-Wopenacc-parallelism" } for testing/documenting +! aspects of that functionality. + +subroutine acc_parallel + implicit none + integer :: i, j, k + ! { dg-note {'i' was declared here} {} { target *-*-* } .-1 } + ! { dg-note {'j' was declared here} {} { target *-*-* } .-2 } + ! { dg-note {'k' was declared here} {} { target *-*-* } .-3 } + + !$acc parallel num_gangs(i) ! { dg-warning "is used uninitialized" } + ! { dg-warning "region is gang partitioned but does not contain gang partitioned code" "" { target *-*-* } .-1 } + !$acc end parallel + + !$acc parallel num_workers(j) ! { dg-warning "is used uninitialized" } + ! { dg-warning "region is worker partitioned but does not contain worker partitioned code" "" { target *-*-* } .-1 } + !$acc end parallel + + !$acc parallel vector_length(k) ! { dg-warning "is used uninitialized" } + ! { dg-warning "region is vector partitioned but does not contain vector partitioned code" "" { target *-*-* } .-1 } + !$acc end parallel +end subroutine acc_parallel + +subroutine acc_kernels + implicit none + integer :: i, j, k + ! { dg-note {'i' was declared here} {} { target *-*-* } .-1 } + ! { dg-note {'j' was declared here} {} { target *-*-* } .-2 } + ! { dg-note {'k' was declared here} {} { target *-*-* } .-3 } + + !$acc kernels num_gangs(i) ! { dg-warning "is used uninitialized" } + !$acc end kernels + + !$acc kernels num_workers(j) ! { dg-warning "is used uninitialized" } + !$acc end kernels + + !$acc kernels vector_length(k) ! { dg-warning "is used uninitialized" } + !$acc end kernels +end subroutine acc_kernels Index: Fortran/gfortran/regression/goacc/uninit-firstprivate-clause.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/uninit-firstprivate-clause.f95 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } + +subroutine test + INTEGER :: i + + !$acc parallel + i = 1 + !$acc end parallel +end subroutine test + +subroutine test2 + INTEGER :: i + ! { dg-note {'i' was declared here} {} { target *-*-* } .-1 } + + !$acc parallel firstprivate (i) ! { dg-warning "is used uninitialized" } + i = 1 + !$acc end parallel +end subroutine test2 Index: Fortran/gfortran/regression/goacc/uninit-if-clause.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/uninit-if-clause.f95 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } + +program test + implicit none + logical :: b, b2, b3, b4 + ! { dg-note {'b' was declared here} {} { target *-*-* } .-1 } + ! { dg-note {'b2' was declared here} {} { target *-*-* } .-2 } + ! { dg-note {'b3' was declared here} {} { target *-*-* } .-3 } + ! { dg-note {'b4' was declared here} {} { target *-*-* } .-4 } + integer :: data, data2 + + !$acc parallel if(b) ! { dg-warning "is used uninitialized" } + !$acc end parallel + + !$acc kernels if(b2) ! { dg-warning "is used uninitialized" } + !$acc end kernels + + !$acc data if(b3) ! { dg-warning "is used uninitialized" } + !$acc end data + + !$acc update if(b4) self(data2) ! { dg-warning "is used uninitialized" } + +end program test Index: Fortran/gfortran/regression/goacc/uninit-use-device-clause.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/uninit-use-device-clause.f95 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } + +subroutine test + integer, pointer :: p + ! { dg-note {'p' was declared here} {} { target *-*-* } .-1 } + + !$acc host_data use_device(p) ! { dg-warning "is used uninitialized" } + !$acc end host_data +end subroutine test + Index: Fortran/gfortran/regression/goacc/update-if_present-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/update-if_present-1.f90 @@ -0,0 +1,27 @@ +! Test valid usages of the if_present clause. + +! { dg-additional-options "-fdump-tree-omplower" } + +subroutine t + implicit none + integer a, b, c(10) + real, allocatable :: x, y, z(:) + + a = 5 + b = 10 + c(:) = -1 + + allocate (x, y, z(100)) + + !$acc update self(a) if_present + !$acc update device(b) if_present async + !$acc update host(c(1:3)) wait(4) if_present + !$acc update self(c) device(a) host(b) if_present async(10) if(a == 10) + + !$acc update self(x) if_present + !$acc update device(y) if_present async + !$acc update host(z(1:3)) wait(3) if_present + !$acc update self(z) device(y) host(x) if_present async(4) if(a == 1) +end subroutine t + +! { dg-final { scan-tree-dump-times " if_present" 8 "omplower" } } Index: Fortran/gfortran/regression/goacc/update-if_present-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/update-if_present-2.f90 @@ -0,0 +1,52 @@ +! Test invalid usages of the if_present clause. + +subroutine t1 + implicit none + !$acc routine gang if_present ! { dg-error "Failed to match clause" } + integer a, b, c(10) + real, allocatable :: x, y, z(:) + + a = 5 + b = 10 + c(:) = -1 + + allocate (x, y, z(100)) + + !$acc enter data copyin(a) if_present ! { dg-error "Expected '\\(' after 'if'" } + !$acc exit data copyout(a) if_present ! { dg-error "Expected '\\(' after 'if'" } + + !$acc data copy(a) if_present ! { dg-error "Expected '\\(' after 'if'" } + !$acc end data ! { dg-error "Unexpected ..ACC END DATA statement" } + + !$acc declare link(a) if_present ! { dg-error "Unexpected junk after" } + + !$acc init if_present ! { dg-error "Unclassifiable OpenACC directive" } + !$acc shutdown if_present ! { dg-error "Unclassifiable OpenACC directive" } + + !$acc update self(a) device_type(nvidia) device(b) if_present ! { dg-error "Failed to match clause" } +end subroutine t1 + +subroutine t2 + implicit none + integer a, b, c(10) + + a = 5 + b = 10 + c(:) = -1 + + !$acc parallel + !$acc loop if_present ! { dg-error "Failed to match clause" } + do b = 1, 10 + end do + !$acc end parallel + + !$acc kernels loop if_present ! { dg-error "Expected '\\(' after 'if'" } + do b = 1, 10 + end do + !$acc end kernels loop ! { dg-error "Unexpected ..ACC END KERNELS LOOP statement" } + + !$acc parallel loop if_present ! { dg-error "Expected '\\(' after 'if'" } + do b = 1, 10 + end do + !$acc end parallel loop ! { dg-error "Unexpected ..ACC END PARALLEL LOOP statement" } +end subroutine t2 Index: Fortran/gfortran/regression/goacc/update.f95 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/update.f95 @@ -0,0 +1,5 @@ +! { dg-do compile } + +program foo + !$acc update ! { dg-error "must contain at least one 'device' or 'host' or 'self' clause" } +end program foo Index: Fortran/gfortran/regression/goacc/vector_length.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/vector_length.f90 @@ -0,0 +1,11 @@ +program t + implicit none + integer, parameter :: n = 100 + integer a(n), i + + !$acc parallel loop num_gangs(100) num_workers(1) vector_length(32) + do i = 1, n + a(i) = i + enddo + !$acc end parallel loop +end program t Index: Fortran/gfortran/regression/goacc/wait.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/wait.f90 @@ -0,0 +1,16 @@ +! Ensure that ACC WAIT accept integer arguments. + +! { dg-additional-options -Wuninitialized } + +subroutine foo (wqueue) + implicit none + integer :: wqueue, waitno + ! { dg-note {'waitno' was declared here} {} { target *-*-* } .-1 } + integer, parameter :: waitp = 100 + + !$acc wait (wqueue) + !$acc wait (waitno) + ! { dg-warning {'waitno' is used uninitialized} {} { target *-*-* } .-1 } + !$acc wait (waitp) + !$acc wait (0) +end subroutine foo Index: Fortran/gfortran/regression/goacc/warn_truncated.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/goacc/warn_truncated.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! PR fortran/97390 +! +integer :: tempRbuffer, array, compactHaloInfo, dimsizes, nHaloLayers, gpu_nList_send, gpu_idx_send, gpu_bufferOffset_send, counter + !$acc data present(tempRbuffer, array, compactHaloInfo, dimsizes, nHaloLayers, gpu_nList_send, gpu_idx_send, gpu_bufferOffset_send) async(counter+1) ! { dg-error "Line truncated" } +! { dg-error "Syntax error in Open.* variable list" "" { target "*-*-*" } .-1 } + + !$acc end data ! { dg-error "Unexpected !.ACC END DATA statement" } +end + +! { dg-message "some warnings being treated as errors" "" {target "*-*-*"} 0 } Index: Fortran/gfortran/regression/gomp/affinity-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-1.f90 @@ -0,0 +1,28 @@ + integer :: i, j + integer, dimension (10, 10) :: a +!$omp parallel do default(none)proc_bind(master)shared(a) + do i = 1, 10 + j = 4 + do j = 1, 10 + a(i, j) = i + j + end do + j = 8 + end do +!$omp end parallel do +!$omp parallel do default(none)proc_bind(primary)shared(a) + do i = 1, 10 + j = 4 + do j = 1, 10 + a(i, j) = i + j + end do + j = 8 + end do +!$omp end parallel do +!$omp parallel proc_bind (close) +!$omp parallel default(none) proc_bind (spread) firstprivate(a) private (i) + do i = 1, 10 + a(i, i) = i + enddo +!$omp end parallel +!$omp endparallel +end Index: Fortran/gfortran/regression/gomp/affinity-clause-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-1.f90 @@ -0,0 +1,33 @@ +! { dg-additional-options "-fdump-tree-original" } +subroutine foo(x) + integer :: x + integer :: a, b(5), cc, d(5,5) + !$omp taskgroup + !$omp task affinity(a) + !$omp end task + !$omp task affinity(iterator(i=int(cos(1.0+a)):5, jj =2:5:2) : b(i), d(i,jj)) + !$omp end task + !$omp task affinity(iterator(i=int(cos(1.0+a)):5) : b(i), d(i,i)) + !$omp end task + !$omp task affinity (iterator(i=1:5): a) + !$omp end task + !$omp task affinity (iterator(i=1:5): a) affinity(iterator(i=1:5) : x) + !$omp end task + !$omp task affinity (iterator(integer(8) :: j=1:5, k=7:4:-1) : b(j+k),a) affinity (cc) + !$omp end task + !$omp end taskgroup +end + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(a\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = .integer.kind=4.. __builtin_cosf ..real.kind=4.. a \\+ 1.0e\\+0\\);" 2 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) jj=2:5:2, integer\\(kind=4\\) i=D\\.\[0-9\]+:5:1\\):b\\\[.* ? \\+ -1\\\]\\) affinity\\(iterator\\(integer\\(kind=4\\) jj=2:5:2, integer\\(kind=4\\) i=D\\.\[0-9\]+:5:1\\):d\\\[\\(.*jj \\* 5 \\+ .* ?\\) \\+ -6\\\]\\)" 1 "original" } } + +! { dg final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) i=D\\.\[0-9\]+:5:1\\):b\\\[\\(.* ? \\+ -1\\\]\\) affinity\\(iterator\\(integer\\(kind=4\\) i=D\\.\[0-9\]+:5:1\\):d\\\[\\(\\(integer\\(kind=8\\)\\) i \\+ -1\\) \\* 6\\\]\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) i=1:5:1\\):a\\)\[^ \]" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) i=1:5:1\\):a\\) affinity\\(iterator\\(integer\\(kind=4\\) i=1:5:1\\):\\*x\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) k=7:4:-1, integer\\(kind=8\\) j=1:5:1\\):b\\\[\\(?\\(integer\\(kind=.\\).* \[jk\] \\+ .*\[kj\]\\) \\+ -1\\\]\\) affinity\\(iterator\\(integer\\(kind=4\\) k=7:4:-1, integer\\(kind=8\\) j=1:5:1\\):a\\) affinity\\(cc\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/affinity-clause-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-2.f90 @@ -0,0 +1,27 @@ +subroutine foo + implicit none + external bar + integer :: i, b(10) + !$omp task affinity(bar(1)) ! { dg-error "not a variable" } + !!$omp end task + !$omp task affinity(b(1.0)) ! { dg-warning "Legacy Extension: REAL array index" } + !$omp end task + !$omp task affinity( iterator( real :: i=1.0:5:1) : b(i)) ! { dg-error "Expected INTEGER type" } + !!$omp end task + !$omp task affinity(iterator(i=1.0:5:1) : b(i)) ! { dg-error "Scalar integer expression for range begin expected" } + !$omp end task + !$omp task affinity(iterator(i=1:5.0:1) : b(i)) ! { dg-error "Scalar integer expression for range end expected" } + !$omp end task + !$omp task affinity(iterator(i=1:5:1.0) : b(i)) ! { dg-error "Scalar integer expression for range step expected" } + !$omp end task + !$omp task affinity(iterator(j=1:3:5, i=1:5:0) : b(i)) ! { dg-error "Nonzero range step expected" } + !$omp end task + !$omp task affinity(iterator(=1:5:0) : b(i)) ! { dg-error "31:Syntax error in OpenMP variable list" } + !!$omp end task + !$omp task affinity(iterator(b(2)=1:5:0) : b(i)) ! { dg-error "31:Syntax error in OpenMP variable list" } + !!$omp end task + !$omp task affinity(iterator(i=1:5:0, i=4:6) : b(i)) ! { dg-error "Same identifier 'i' specified again" } + !!$omp end task + !$omp task affinity(iterator(i=1) : b(i)) ! { dg-error "Expected range-specification" } + !!$omp end task +end Index: Fortran/gfortran/regression/gomp/affinity-clause-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-3.f90 @@ -0,0 +1,14 @@ +! { dg-additional-options "-fdump-tree-gimple" } +subroutine foo + integer :: A(10), B(10), C(10) + interface + integer function ibar(x) + integer :: x + end function ibar + end interface + + !$omp task affinity (iterator(j=ibar(0):ibar(1):ibar(2)) : a(ibar(j)), b(j), c(j)) + !$omp end task +end +! { dg-final { scan-tree-dump-times "= ibar \\(&C\\." 3 "gimple" } } +! { dg-final { scan-tree-dump-times "= ibar \\(&j" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/affinity-clause-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-4.f90 @@ -0,0 +1,16 @@ +subroutine foo + integer :: A(10), B(10), C(10) + interface + integer function ibar(x) + integer :: x + end function ibar + end interface + + !$omp parallel default(none) ! { dg-note "enclosing 'parallel'" } + !$omp task affinity (iterator(j=ibar(0):ibar(1):ibar(2)) : a(ibar(j)), b(j), c(j)) + !$omp end task + !$omp end parallel +! { dg-error "'a' not specified in enclosing 'parallel'" "" { target *-*-* } .-3 } +! { dg-error "'b' not specified in enclosing 'parallel'" "" { target *-*-* } .-4 } +! { dg-error "'c' not specified in enclosing 'parallel'" "" { target *-*-* } .-5 } +end Index: Fortran/gfortran/regression/gomp/affinity-clause-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-5.f90 @@ -0,0 +1,23 @@ +! { dg-additional-options "-fdump-tree-original" } +implicit none +integer :: iterator(10), i + +!$omp taskgroup + !$omp task affinity(iterator) + !$omp end task + + !$omp task affinity(iterator(3)) + !$omp end task + + !$omp task affinity(iterator(i=1:10) : iterator(i)) + !$omp end task + +!$omp end taskgroup + +end + +! { dg-final { scan-tree-dump-times "pragma omp task affinity\\(iterator\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\\[2\\\]\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task affinity\\(iterator\\(integer\\(kind=4\\) i=1:10:1\\):iterator\\\[.* ? \\+ -1\\\]\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/affinity-clause-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-6.f90 @@ -0,0 +1,24 @@ +implicit none +integer :: iterator(10), i + +!$omp taskgroup + !$omp task affinity(iterator) + !$omp end task + + !$omp task affinity(iterator(3)) + !$omp end task + + !$omp task affinity(iterator(i=1:10) : iterator(i)) + !$omp end task + + !$omp task affinity(iterator(integer :: i)) ! { dg-error "Failed to match clause at" } + !!$omp end task + + !$omp task affinity(iterator(integer :: i=1:1)) ! { dg-error "Expected ':' at" } + !!$omp end task + + !$omp task affinity(iterator(i=)) ! { dg-error "Expected range-specification at" } +! !$omp end task +!$omp end taskgroup + +end Index: Fortran/gfortran/regression/gomp/affinity-clause-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/affinity-clause-7.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! PR fortran/101330 - ICE in free_expr0(): Bad expr type +! Contributed by G.Steinmetz + + implicit none + integer :: j, b(10) +!$omp task affinity (iterator(j=1:2:1) : b(j)) +!$omp end task +!$omp task affinity (iterator(j=1:2:) : b(j)) ! { dg-error "Invalid character" } +!!$omp end task +!$omp task affinity (iterator(j=1:2: ! { dg-error "Invalid character" } +!!$omp end task +!$omp task affinity (iterator(j=1:2:) ! { dg-error "Invalid character" } +!!$omp end task +!$omp task affinity (iterator(j=1:2::) ! { dg-error "Invalid character" } +!!$omp end task +!$omp task affinity (iterator(j=1:2:)) ! { dg-error "Invalid character" } +!!$omp end task +end Index: Fortran/gfortran/regression/gomp/all-memory-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/all-memory-1.f90 @@ -0,0 +1,54 @@ +module m + integer :: omp_all_memory ! { dg-error "'omp_all_memory', declared at .1., may only be used in the OpenMP DEPEND clause" } +end module m + +subroutine f1 + integer :: omp_all_memory ! { dg-error "'omp_all_memory', declared at .1., may only be used in the OpenMP DEPEND clause" } + !$omp target depend(out: omp_all_memory) + !$omp end target +end + +subroutine f2 + dimension :: omp_all_memory(5) ! { dg-error "'omp_all_memory', declared at .1., may only be used in the OpenMP DEPEND clause" } + !$omp target depend(out: omp_all_memory) + !$omp end target +end + +subroutine f3 + integer :: A + !$omp target depend(out: omp_all_memory) ! OK + omp_all_memory = 5 ! { dg-error "'omp_all_memory', declared at .1., may only be used in the OpenMP DEPEND clause" } + !$omp end target +end + +subroutine f4 + !$omp target map(to: omp_all_memory) ! { dg-error "'omp_all_memory' at .1. not permitted in this clause" } + ! !$omp end target + + !$omp task private (omp_all_memory) ! { dg-error "'omp_all_memory' at .1. not permitted in this clause" } + ! !$omp end task +end + +subroutine f5 ! OK + !$omp target depend(inout : omp_all_memory ) + !$omp end target + + !$omp target depend ( out : omp_all_memory) + !$omp end target +end + +subroutine f6 + !$omp target depend(in : omp_all_memory ) ! { dg-error "'omp_all_memory' used with DEPEND kind other than OUT or INOUT" } + ! !$omp end target + + !$omp target depend(mutexinoutset : omp_all_memory ) ! { dg-error "'omp_all_memory' used with DEPEND kind other than OUT or INOUT" } + ! !$omp end target + + !$omp target depend(inoutset : omp_all_memory ) ! { dg-error "'omp_all_memory' used with DEPEND kind other than OUT or INOUT" } + ! !$omp end target + + !$omp target depend ( depobj : omp_all_memory) ! { dg-error "'omp_all_memory' used with DEPEND kind other than OUT or INOUT" } + !!$omp end target + + !$omp ordered depend ( sink : omp_all_memory) ! { dg-error "used with dependence-type other than OUT or INOUT" } +end Index: Fortran/gfortran/regression/gomp/all-memory-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/all-memory-2.f90 @@ -0,0 +1,55 @@ +! { dg-additional-options "-fno-openmp" } +module m + integer :: omp_all_memory +end module m + +subroutine f1 + integer :: omp_all_memory + !$omp target depend(out: omp_all_memory) + !$omp end target +end + +subroutine f2 + dimension :: omp_all_memory(5) + !$omp target depend(out: omp_all_memory) + !$omp end target +end + +subroutine f3 + integer :: A + !$omp target depend(out: omp_all_memory) + omp_all_memory = 5 + !$omp end target +end + +subroutine f4 + !$omp target map(to: omp_all_memory) + ! !$omp end target + + !$omp task private (omp_all_memory) + ! !$omp end task +end + +subroutine f5 + !$omp target depend(inout : omp_all_memory ) + !$omp end target + + !$omp target depend ( out : omp_all_memory) + !$omp end target +end + +subroutine f6 + !$omp target depend(in : omp_all_memory ) + ! !$omp end target + + !$omp target depend(mutexinoutset : omp_all_memory ) + ! !$omp end target + + !$omp target depend(inoutset : omp_all_memory ) + ! !$omp end target + + !$omp target depend ( depobj : omp_all_memory) + !$omp end target + + !$omp ordered depend ( sink : omp_all_memory) +end Index: Fortran/gfortran/regression/gomp/all-memory-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/all-memory-3.f90 @@ -0,0 +1,24 @@ +module m + use iso_c_binding + implicit none + integer, parameter :: omp_depend_kind = 2*c_size_t + + integer(omp_depend_kind) :: z +contains + +subroutine foo + integer :: x, y + x = 0; y = 0 + !$omp task depend(out: omp_all_memory) + block; end block + !$omp task depend(inout: omp_all_memory) + block; end block + !$omp task depend(out: x, omp_all_memory, y) + block; end block + !$omp task depend(inout: omp_all_memory, y) + block; end block + !$omp task depend(out: x, omp_all_memory) + block; end block + !$omp depobj (z) depend (inout: omp_all_memory) +end +end Index: Fortran/gfortran/regression/gomp/allocatable_components_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/allocatable_components_1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +! PR fortran/32467 +! Derived types with allocatable components +! + +MODULE test_allocatable_components + type :: t + integer, allocatable :: a(:) + end type + +CONTAINS + SUBROUTINE test_copyin() + TYPE(t), SAVE :: a + + !$omp threadprivate(a) + !$omp parallel copyin(a) + ! do something + !$omp end parallel + END SUBROUTINE + + SUBROUTINE test_copyprivate() + TYPE(t) :: a + + !$omp single + ! do something + !$omp end single copyprivate (a) + END SUBROUTINE + + SUBROUTINE test_firstprivate + TYPE(t) :: a + + !$omp parallel firstprivate(a) + ! do something + !$omp end parallel + END SUBROUTINE + + SUBROUTINE test_lastprivate + TYPE(t) :: a + INTEGER :: i + + !$omp parallel do lastprivate(a) + DO i = 1, 1 + END DO + !$omp end parallel do + END SUBROUTINE + + SUBROUTINE test_reduction + TYPE(t) :: a(10) + INTEGER :: i + + !$omp parallel do reduction(+: a) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } + DO i = 1, SIZE(a) + END DO + !$omp end parallel do + END SUBROUTINE +END MODULE Index: Fortran/gfortran/regression/gomp/allocate-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/allocate-1.f90 @@ -0,0 +1,137 @@ +! { dg-do compile } + +module omp_lib_kinds + use iso_c_binding, only: c_int, c_intptr_t + implicit none + private :: c_int, c_intptr_t + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_null_allocator = 0 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_default_mem_alloc = 1 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_large_cap_mem_alloc = 2 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_const_mem_alloc = 3 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_high_bw_mem_alloc = 4 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_low_lat_mem_alloc = 5 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_cgroup_mem_alloc = 6 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_pteam_mem_alloc = 7 + integer (kind=omp_allocator_handle_kind), & + parameter :: omp_thread_mem_alloc = 8 +end module + +subroutine bar (a, b, c) + implicit none + integer :: a + integer :: b + integer :: c + c = a + b +end + +subroutine bar2 (a, b, c) + implicit none + integer :: a + integer :: b(15) + integer :: c + c = a + b(1) +end + +subroutine foo(x, y) + use omp_lib_kinds + implicit none + integer :: x + integer :: z + + integer, dimension(15) :: y + integer :: r + integer :: i + integer c1, c2, c3, c4 + integer (kind=omp_allocator_handle_kind) :: h + common /B1/ c1, c2 + common /B2/ c3, c4 + + r = 0 + h = omp_default_mem_alloc; + + + !$omp parallel private(/B1/, c3, c4) allocate(/B1/, /B2/) + !$omp end parallel + + !$omp parallel private(/B1/, /B2/) allocate(h:/B1/, /B2/) + !$omp end parallel + + !$omp parallel private(/B1/, /B2/) allocate(omp_large_cap_mem_alloc:/B1/, c3, c4) + !$omp end parallel + + !$omp parallel allocate (x) allocate (h : y) & + !$omp allocate (omp_large_cap_mem_alloc:z) firstprivate (x, y, z) + call bar2 (x, y, z); + !$omp end parallel + + !$omp task private (x) firstprivate (z) allocate (omp_low_lat_mem_alloc:x,z) + call bar (0, x, z); + !$omp end task + + !$omp target teams distribute parallel do private (x) firstprivate (y) & + !$omp allocate ((omp_default_mem_alloc + 0):z) allocate & + !$omp (omp_default_mem_alloc: x, y) allocate (h: r) lastprivate (z) reduction(+:r) + do i = 1, 10 + call bar (0, x, z); + call bar2 (1, y, r); + end do + !$omp end target teams distribute parallel do + + !$omp single private (x) allocate (omp_low_lat_mem_alloc:x) + x=1 + !$omp end single + + !$omp single allocate (omp_low_lat_mem_alloc:x) private (x) + !$omp end single + + !$omp parallel + !$omp do allocate (x) private (x) + do i = 1, 64 + x = 1; + end do + !$omp end parallel + + !$omp sections private (x) allocate (omp_low_lat_mem_alloc: x) + x = 1; + !$omp section + x = 2; + !$omp section + x = 3; + !$omp end sections + + !$omp taskgroup task_reduction(+:r) allocate (omp_default_mem_alloc : r) + call bar (r, r, r); + !$omp end taskgroup + + !$omp teams private (x) firstprivate (y) allocate (h : x, y) + call bar2 (x, y, r); + !$omp end teams + + !$omp taskloop lastprivate (x) reduction (+:r) allocate (h : x, r) + do i = 1, 16 + call bar (0, r, r); + x = i; + end do + !$omp end taskloop + + !$omp taskgroup task_reduction(+:r) allocate (omp_default_mem_alloc : r) + !$omp taskloop firstprivate (x) in_reduction (+:r) & + !$omp allocate (omp_default_mem_alloc : x, r) + do i = 1, 16 + call bar (x, r, r); + end do + !$omp end taskloop + !$omp end taskgroup + !$omp taskwait +end subroutine + Index: Fortran/gfortran/regression/gomp/allocate-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/allocate-2.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } + +module omp_lib_kinds + use iso_c_binding, only: c_int, c_intptr_t + implicit none + private :: c_int, c_intptr_t + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + +end module + +subroutine foo(x) + use omp_lib_kinds + implicit none + integer :: x + + !$omp task allocate (x) ! { dg-error "'x' specified in 'allocate' clause at .1. but not in an explicit privatization clause" } + x=1 + !$omp end task + + !$omp parallel allocate (x) ! { dg-error "'x' specified in 'allocate' clause at .1. but not in an explicit privatization clause" } + x=2 + !$omp end parallel + + !$omp parallel allocate (x) shared (x) ! { dg-error "'x' specified in 'allocate' clause at .1. but not in an explicit privatization clause" } + x=3 + !$omp end parallel + + !$omp parallel private (x) allocate (x) allocate (x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." } + x=4 + !$omp end parallel + + !$omp parallel private (x) allocate (x, x) ! { dg-warning "'x' appears more than once in 'allocate' clauses at .1." } + x=5 + !$omp end parallel + + !$omp parallel allocate (0_1: x) private(x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." } + x=6 + !$omp end parallel + + !$omp parallel private (x) allocate (0.1 : x) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." } + x=7 + !$omp end parallel + +end subroutine + Index: Fortran/gfortran/regression/gomp/allocate-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/allocate-3.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } + +subroutine foo(x) + implicit none + integer :: x + integer :: i + + !$omp parallel do simd private (x) allocate (x) ! { dg-error "'x' specified in 'allocate' clause at .1. but not in an explicit privatization clause" } + do i = 1, 64 + x = i + end do + !$omp end parallel do simd + +end subroutine + +subroutine bar(a) + implicit none + integer :: a +!$omp target + !$omp parallel private (a) allocate(a) ! { dg-error "'allocate' clause must specify an allocator here" } + a = 20 + !$omp end parallel +!$omp end target + +!$omp target private(a) allocate(a) ! { dg-error "'allocate' clause must specify an allocator here" } + a = 30; +!$omp end target +end subroutine Index: Fortran/gfortran/regression/gomp/appendix-a/a.1.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.1.1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + SUBROUTINE A1(N, A, B) + INTEGER I, N + REAL B(N), A(N) +!$OMP PARALLEL DO !I is private by default + DO I=2,N + B(I) = (A(I) + A(I-1)) / 2.0 + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE A1 Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + SUBROUTINE A11_1(AA, BB, CC, DD, EE, FF, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N), EE(N,N), FF(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD + EE = FF +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_1 Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + + SUBROUTINE A11_2(AA, BB, CC, DD, EE, FF, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N) + REAL DD(N,N), EE(N,N), FF(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD +!$OMP END WORKSHARE NOWAIT +!$OMP WORKSHARE + EE = FF +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE A11_3(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + REAL R + R=0 +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB +!$OMP ATOMIC + R = R + SUM(AA) + CC = DD +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_3 Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.4.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + + SUBROUTINE A11_4(AA, BB, CC, DD, EE, FF, GG, HH, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N) + REAL DD(N,N), EE(N,N), FF(N,N) + REAL GG(N,N), HH(N,N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA = BB + CC = DD + WHERE (EE .ne. 0) FF = 1 / EE + GG = HH +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_4 Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.5.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + SUBROUTINE A11_5(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + INTEGER SHR +!$OMP PARALLEL SHARED(SHR) +!$OMP WORKSHARE + AA = BB + SHR = 1 + CC = DD * SHR +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_5 + Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE A11_6_WRONG(AA, BB, CC, DD, N) + INTEGER N + REAL AA(N,N), BB(N,N), CC(N,N), DD(N,N) + INTEGER PRI +!$OMP PARALLEL PRIVATE(PRI) +!$OMP WORKSHARE + AA = BB + PRI = 1 + CC = DD * PRI +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_6_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.11.7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.11.7.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A11_7(AA, BB, CC, N) + INTEGER N + REAL AA(N), BB(N), CC(N) +!$OMP PARALLEL +!$OMP WORKSHARE + AA(1:50) = BB(11:60) + CC(11:20) = AA(1:10) +!$OMP END WORKSHARE +!$OMP END PARALLEL + END SUBROUTINE A11_7 Index: Fortran/gfortran/regression/gomp/appendix-a/a.12.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.12.1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } + SUBROUTINE A12( X, XOLD, N, TOL ) + REAL X(*), XOLD(*), TOL + INTEGER N + INTEGER C, I, TOOBIG + REAL ERROR, Y, AVERAGE + EXTERNAL AVERAGE + C=0 + TOOBIG = 1 +!$OMP PARALLEL + DO WHILE( TOOBIG > 0 ) +!$OMP DO PRIVATE(I) + DO I = 2, N-1 + XOLD(I) = X(I) + ENDDO +!$OMP SINGLE + TOOBIG = 0 +!$OMP END SINGLE +!$OMP DO PRIVATE(I,Y,ERROR), REDUCTION(+:TOOBIG) + DO I = 2, N-1 + Y = X(I) + X(I) = AVERAGE( XOLD(I-1), X(I), XOLD(I+1) ) + ERROR = Y-X(I) + IF( ERROR > TOL .OR. ERROR < -TOL ) TOOBIG = TOOBIG+1 + ENDDO +!$OMP MASTER + C=C+1 + PRINT *, "Iteration ", C, " TOOBIG=", TOOBIG +!$OMP END MASTER + ENDDO +!$OMP END PARALLEL + END SUBROUTINE A12 Index: Fortran/gfortran/regression/gomp/appendix-a/a.13.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.13.1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + SUBROUTINE A13(X, Y) + REAL X(*), Y(*) + INTEGER IX_NEXT, IY_NEXT +!$OMP PARALLEL SHARED(X, Y) PRIVATE(IX_NEXT, IY_NEXT) +!$OMP CRITICAL(XAXIS) + CALL DEQUEUE(IX_NEXT, X) +!$OMP END CRITICAL(XAXIS) + CALL WORK(IX_NEXT, X) +!$OMP CRITICAL(YAXIS) + CALL DEQUEUE(IY_NEXT,Y) +!$OMP END CRITICAL(YAXIS) + CALL WORK(IY_NEXT, Y) +!$OMP END PARALLEL + END SUBROUTINE A13 + Index: Fortran/gfortran/regression/gomp/appendix-a/a.14.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.14.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE A14() + INTEGER I + I=1 +!$OMP PARALLEL SECTIONS +!$OMP SECTION +!$OMP CRITICAL (NAME) +!$OMP PARALLEL +!$OMP SINGLE + I=I+1 +!$OMP END SINGLE +!$OMP END PARALLEL +!$OMP END CRITICAL (NAME) +!$OMP END PARALLEL SECTIONS + END SUBROUTINE A14 Index: Fortran/gfortran/regression/gomp/appendix-a/a.17.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.17.1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + SUBROUTINE A17_1_WRONG() + INTEGER:: I + REAL:: R + EQUIVALENCE(I,R) +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 +!$OMP ATOMIC + R = R + 1.0 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL + END SUBROUTINE A17_1_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.17.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.17.2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + + SUBROUTINE SUB() + COMMON /BLK/ R + REAL R +!$OMP ATOMIC + R = R + 1.0 + END SUBROUTINE SUB + + SUBROUTINE A17_2_WRONG() + COMMON /BLK/ I + INTEGER I +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 + CALL SUB() +!$OMP END PARALLEL + END SUBROUTINE A17_2_WRONG + Index: Fortran/gfortran/regression/gomp/appendix-a/a.17.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.17.3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + SUBROUTINE A17_3_WRONG + INTEGER:: I + REAL:: R + EQUIVALENCE(I,R) +!$OMP PARALLEL +!$OMP ATOMIC + I=I+1 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL +!$OMP PARALLEL +!$OMP ATOMIC + R = R + 1.0 +! incorrect because I and R reference the same location +! but have different types +!$OMP END PARALLEL + END SUBROUTINE A17_3_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.21.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.21.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE WORK(I) + INTEGER I + END SUBROUTINE WORK + SUBROUTINE A21_WRONG(N) + INTEGER N + INTEGER I +!$OMP DO ORDERED + DO I = 1, N +! incorrect because an iteration may not execute more than one +! ordered region +!$OMP ORDERED + CALL WORK(I) +!$OMP END ORDERED +!$OMP ORDERED + CALL WORK(I+1) +!$OMP END ORDERED + END DO + END SUBROUTINE A21_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.21.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.21.3.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + + SUBROUTINE A21_GOOD(N) + INTEGER N +!$OMP DO ORDERED + DO I = 1,N + IF (I <= 10) THEN +!$OMP ORDERED + CALL WORK(I) +!$OMP END ORDERED + ENDIF + IF (I > 10) THEN +!$OMP ORDERED + CALL WORK(I+1) +!$OMP END ORDERED + ENDIF + ENDDO + END SUBROUTINE A21_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.22.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.22.1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + INTEGER FUNCTION INCREMENT_COUNTER() + COMMON/A22_COMMON/COUNTER +!$OMP THREADPRIVATE(/A22_COMMON/) + COUNTER = COUNTER +1 + INCREMENT_COUNTER = COUNTER + RETURN + END FUNCTION INCREMENT_COUNTER Index: Fortran/gfortran/regression/gomp/appendix-a/a.22.4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.22.4.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + MODULE A22_MODULE + COMMON /T/ A + END MODULE A22_MODULE + SUBROUTINE A22_4_WRONG() + USE A22_MODULE +!$OMP THREADPRIVATE(/T/) ! { dg-error "COMMON block" } + !non-conforming because /T/ not declared in A22_4_WRONG + END SUBROUTINE A22_4_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.22.5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.22.5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A22_5_WRONG() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) + CONTAINS + SUBROUTINE A22_5S_WRONG() +!$OMP PARALLEL COPYIN(/T/) ! { dg-error "COMMON block" } + !non-conforming because /T/ not declared in A22_5S_WRONG +!$OMP END PARALLEL ! { dg-error "Unexpected" } + END SUBROUTINE A22_5S_WRONG + END SUBROUTINE A22_5_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.22.6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.22.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A22_6_GOOD() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) + CONTAINS + SUBROUTINE A22_6S_GOOD() + COMMON /T/ A +!$OMP THREADPRIVATE(/T/) +!$OMP PARALLEL COPYIN(/T/) +!$OMP END PARALLEL + END SUBROUTINE A22_6S_GOOD + END SUBROUTINE A22_6_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.23.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.23.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A23_1_GOOD() + COMMON /C/ X,Y + REAL X, Y +!$OMP PARALLEL PRIVATE (/C/) + ! do work here +!$OMP END PARALLEL +!$OMP PARALLEL SHARED (X,Y) + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_1_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.23.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.23.2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE A23_2_GOOD() + COMMON /C/ X,Y + REAL X, Y + INTEGER I +!$OMP PARALLEL +!$OMP DO PRIVATE(/C/) + DO I=1,1000 + ! do work here + ENDDO +!$OMP END DO +! +!$OMP DO PRIVATE(X) + DO I=1,1000 + ! do work here + ENDDO +!$OMP END DO +!$OMP END PARALLEL + END SUBROUTINE A23_2_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.23.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.23.3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + + SUBROUTINE A23_3_GOOD() + COMMON /C/ X,Y +!$OMP PARALLEL PRIVATE (/C/) + ! do work here +!$OMP END PARALLEL +!$OMP PARALLEL SHARED (/C/) + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_3_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.23.4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.23.4.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + + SUBROUTINE A23_4_WRONG() + COMMON /C/ X,Y +! Incorrect because X is a constituent element of C +!$OMP PARALLEL PRIVATE(/C/), SHARED(X) ! { dg-error "Symbol 'x' present" } + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_4_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.23.5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.23.5.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + + SUBROUTINE A23_5_WRONG() + COMMON /C/ X,Y +! Incorrect: common block C cannot be declared both +! shared and private +!$OMP PARALLEL PRIVATE (/C/), SHARED(/C/) + ! { dg-error "Symbol 'y' present" "" { target *-*-* } .-1 } + ! { dg-error "Symbol 'x' present" "" { target *-*-* } .-2 } + ! do work here +!$OMP END PARALLEL + END SUBROUTINE A23_5_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.24.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.24.1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE A24(A) + INTEGER A + INTEGER X, Y, Z(1000) + INTEGER OMP_GET_NUM_THREADS + COMMON/BLOCKX/X + COMMON/BLOCKY/Y + COMMON/BLOCKZ/Z +!$OMP THREADPRIVATE(/BLOCKX/) + INTEGER I, J + i=1 +!$OMP PARALLEL DEFAULT(NONE) PRIVATE(A) SHARED(Z) PRIVATE(J) ! { dg-line omp_parallel } + J = OMP_GET_NUM_THREADS(); + ! O.K. - J is listed in PRIVATE clause + A = Z(J) ! O.K. - A is listed in PRIVATE clause + ! - Z is listed in SHARED clause + X=1 ! O.K. - X is THREADPRIVATE + Z(I) = Y ! Error - cannot reference I or Y here +! { dg-error "'i' not specified" "" { target *-*-* } .-1 } */ +! { dg-message "note: enclosing 'parallel'" "" { target *-*-* } omp_parallel } */ +! { dg-error "'y' not specified" "" { target *-*-* } .-3 } */ +!$OMP DO firstprivate(y) + DO I = 1,10 + Z(I) = Y ! O.K. - I is the loop iteration variable + ! Y is listed in FIRSTPRIVATE clause + END DO + Z(I) = Y ! Error - cannot reference I or Y here +!$OMP END PARALLEL + END SUBROUTINE A24 Index: Fortran/gfortran/regression/gomp/appendix-a/a.25.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.25.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + + SUBROUTINE A25 + INTEGER OMP_GET_THREAD_NUM + REAL A(20) + INTEGER MYTHREAD + !$OMP PARALLEL SHARED(A) PRIVATE(MYTHREAD) + MYTHREAD = OMP_GET_THREAD_NUM() + IF (MYTHREAD .EQ. 0) THEN + CALL SUB(A(1:10)) ! compiler may introduce writes to A(6:10) + ELSE + A(6:10) = 12 + ENDIF + !$OMP END PARALLEL + END SUBROUTINE A25 + SUBROUTINE SUB(X) + REAL X(*) + X(1:5) = 4 + END SUBROUTINE SUB Index: Fortran/gfortran/regression/gomp/appendix-a/a.26.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.26.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + + MODULE A26_2 + REAL A + CONTAINS + SUBROUTINE G(K) + REAL K + A = K ! This is A in module A26_2, not the private + ! A in F + END SUBROUTINE G + SUBROUTINE F(N) + INTEGER N + REAL A + INTEGER I +!$OMP PARALLEL DO PRIVATE(A) + DO I = 1,N + A=I + CALL G(A*2) + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE F + END MODULE A26_2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.27.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.27.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } + + SUBROUTINE A27() + INTEGER I, A +!$OMP PARALLEL PRIVATE(A) +!$OMP PARALLEL DO PRIVATE(A) + DO I = 1, 10 + ! do work here + END DO +!$OMP END PARALLEL DO +!$OMP END PARALLEL + END SUBROUTINE A27 Index: Fortran/gfortran/regression/gomp/appendix-a/a.30.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.30.1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE A30(N, A, B) + INTEGER N + REAL A(*), B(*) + INTEGER I +!$OMP PARALLEL +!$OMP DO LASTPRIVATE(I) + DO I=1,N-1 + A(I) = B(I) + B(I+1) + ENDDO +!$OMP END PARALLEL + A(I) = B(I) ! I has the value of N here + END SUBROUTINE A30 Index: Fortran/gfortran/regression/gomp/appendix-a/a.31.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.31.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE A31_1(A, B, X, Y, N) + INTEGER N + REAL X(*), Y(*), A, B +!$OMP PARALLEL DO PRIVATE(I) SHARED(X, N) REDUCTION(+:A) & +!$OMP& REDUCTION(MIN:B) + DO I=1,N + A = A + X(I) + B = MIN(B, Y(I)) +! Note that some reductions can be expressed in +! other forms. For example, the MIN could be expressed as +! IF (B > Y(I)) B = Y(I) + END DO + END SUBROUTINE A31_1 Index: Fortran/gfortran/regression/gomp/appendix-a/a.31.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.31.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE A31_2 (A, B, X, Y, N) + INTEGER N + REAL X(*), Y(*), A, B, A_P, B_P +!$OMP PARALLEL SHARED(X, Y, N, A, B) PRIVATE(A_P, B_P) + A_P = 0.0 + B_P = HUGE(B_P) +!$OMP DO PRIVATE(I) + DO I=1,N + A_P = A_P + X(I) + B_P = MIN(B_P, Y(I)) + ENDDO +!$OMP END DO +!$OMP CRITICAL + A = A + A_P + B = MIN(B, B_P) +!$OMP END CRITICAL +!$OMP END PARALLEL + END SUBROUTINE A31_2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.31.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.31.3.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +PROGRAM A31_3_WRONG + MAX = HUGE(0) + M=0 + !$OMP PARALLEL DO REDUCTION(MAX: M) ! MAX is no longer the intrinsic so this is non-conforming + ! { dg-error "OMP DECLARE REDUCTION max not found" "" { target *-*-* } .-1 } */ + DO I = 1, 100 + CALL SUB(M,I) + END DO +END PROGRAM A31_3_WRONG +SUBROUTINE SUB(M,I) + M = MAX(M,I) +END SUBROUTINE SUB Index: Fortran/gfortran/regression/gomp/appendix-a/a.32.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.32.1.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + MODULE M + REAL, POINTER, SAVE :: WORK(:) + INTEGER :: SIZE + REAL :: TOL +!$OMP THREADPRIVATE(WORK,SIZE,TOL) + END MODULE M + SUBROUTINE A32( T, N ) + USE M + REAL :: T + INTEGER :: N + TOL = T + SIZE = N +!$OMP PARALLEL COPYIN(TOL,SIZE) + CALL BUILD +!$OMP END PARALLEL + END SUBROUTINE A32 + SUBROUTINE BUILD + USE M + ALLOCATE(WORK(SIZE)) + WORK = TOL + END SUBROUTINE BUILD Index: Fortran/gfortran/regression/gomp/appendix-a/a.33.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.33.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + SUBROUTINE INIT(A,B) + REAL A, B + COMMON /XY/ X,Y +!$OMP THREADPRIVATE (/XY/) +!$OMP SINGLE + READ (11) A,B,X,Y +!$OMP END SINGLE COPYPRIVATE (A,B,/XY/) + END SUBROUTINE INIT Index: Fortran/gfortran/regression/gomp/appendix-a/a.33.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.33.2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + + REAL FUNCTION READ_NEXT() + REAL, POINTER :: TMP +!$OMP SINGLE + ALLOCATE (TMP) +!$OMP END SINGLE COPYPRIVATE (TMP) ! copies the pointer only +!$OMP MASTER + READ (11) TMP +!$OMP END MASTER +!$OMP BARRIER + READ_NEXT = TMP +!$OMP BARRIER +!$OMP SINGLE + DEALLOCATE (TMP) +!$OMP END SINGLE NOWAIT + END FUNCTION READ_NEXT Index: Fortran/gfortran/regression/gomp/appendix-a/a.33.4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.33.4.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE S(N) + INTEGER N + REAL, DIMENSION(:), ALLOCATABLE :: A + REAL, DIMENSION(:), POINTER :: B + ALLOCATE (A(N)) +!$OMP SINGLE + ALLOCATE (B(N)) + READ (11) A,B +!$OMP END SINGLE COPYPRIVATE(A,B) + ! Variable A designates a private object + ! which has the same value in each thread + ! Variable B designates a shared object +!$OMP BARRIER +!$OMP SINGLE + DEALLOCATE (B) +!$OMP END SINGLE NOWAIT + END SUBROUTINE S + Index: Fortran/gfortran/regression/gomp/appendix-a/a.34.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.34.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE GOOD_NESTING(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N +!$OMP PARALLEL SHARED(I,N) +!$OMP DO + DO J = 1, N + CALL WORK(I,J) + END DO +!$OMP END PARALLEL + END DO +!$OMP END PARALLEL + END SUBROUTINE GOOD_NESTING Index: Fortran/gfortran/regression/gomp/appendix-a/a.34.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.34.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE WORK1(I, N) + INTEGER J +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO J = 1, N + CALL WORK(I,J) + END DO +!$OMP END PARALLEL + END SUBROUTINE WORK1 + SUBROUTINE GOOD_NESTING2(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK1(I, N) + END DO +!$OMP END PARALLEL + END SUBROUTINE GOOD_NESTING2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } + + SUBROUTINE WORK(I, J) + INTEGER I, J + END SUBROUTINE WORK + SUBROUTINE WRONG1(N) + INTEGER N + INTEGER I,J +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + ! incorrect nesting of loop regions +!$OMP DO ! { dg-error "may not be closely nested" } + DO J = 1, N + CALL WORK(I,J) + END DO + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG1 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + + SUBROUTINE WORK1(I,N) + INTEGER I, N + INTEGER J +!$OMP DO ! incorrect nesting of loop regions + DO J = 1, N + CALL WORK(I,J) + END DO + END SUBROUTINE WORK1 + SUBROUTINE WRONG2(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK1(I,N) + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.3.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE WRONG3(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + ! incorrect nesting of regions +!$OMP SINGLE ! { dg-error "may not be closely nested" } + CALL WORK(I, 1) +!$OMP END SINGLE + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG3 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.4.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + + SUBROUTINE WRONG4(N) + INTEGER N + INTEGER I +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP DO + DO I = 1, N + CALL WORK(I, 1) +! incorrect nesting of barrier region in a loop region +!$OMP BARRIER ! { dg-error "may not be closely nested" } + CALL WORK(I, 2) + END DO +!$OMP END PARALLEL + END SUBROUTINE WRONG4 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.5.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + + SUBROUTINE WRONG5(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP CRITICAL + CALL WORK(N,1) +! incorrect nesting of barrier region in a critical region +!$OMP BARRIER ! { dg-error "region may not be closely nested inside of" } + CALL WORK(N,2) +!$OMP END CRITICAL +!$OMP END PARALLEL + END SUBROUTINE WRONG5 Index: Fortran/gfortran/regression/gomp/appendix-a/a.35.6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.35.6.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + + SUBROUTINE WRONG6(N) + INTEGER N +!$OMP PARALLEL DEFAULT(SHARED) +!$OMP SINGLE + CALL WORK(N,1) +! incorrect nesting of barrier region in a single region +!$OMP BARRIER ! { dg-error "may not be closely nested" } + CALL WORK(N,2) +!$OMP END SINGLE +!$OMP END PARALLEL + END SUBROUTINE WRONG6 + Index: Fortran/gfortran/regression/gomp/appendix-a/a.36.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.36.1.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } + + SUBROUTINE DO_BY_16(X, IAM, IPOINTS) + REAL X(*) + INTEGER IAM, IPOINTS + END SUBROUTINE DO_BY_16 + SUBROUTINE SUBA36(X, NPOINTS) + INTEGER NPOINTS + REAL X(NPOINTS) + INTEGER IAM, IPOINTS + EXTERNAL OMP_SET_DYNAMIC, OMP_SET_NUM_THREADS + INTEGER OMP_GET_NUM_THREADS, OMP_GET_THREAD_NUM + CALL OMP_SET_DYNAMIC(.FALSE.) + CALL OMP_SET_NUM_THREADS(16) +!$OMP PARALLEL SHARED(X,NPOINTS) PRIVATE(IAM, IPOINTS) + IF (OMP_GET_NUM_THREADS() .NE. 16) THEN + STOP + ENDIF + IAM = OMP_GET_THREAD_NUM() + IPOINTS = NPOINTS/16 + CALL DO_BY_16(X,IAM,IPOINTS) +!$OMP END PARALLEL + END SUBROUTINE SUBA36 Index: Fortran/gfortran/regression/gomp/appendix-a/a.37.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.37.1.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + SUBROUTINE WORK(I) + INTEGER I + I=I+1 + END SUBROUTINE WORK + SUBROUTINE INCORRECT() + INTEGER OMP_GET_NUM_THREADS + INTEGER I, NP + NP = OMP_GET_NUM_THREADS() !misplaced: will return 1 +!$OMP PARALLEL DO SCHEDULE(STATIC) + DO I = 0, NP-1 + CALL WORK(I) + ENDDO +!$OMP END PARALLEL DO + END SUBROUTINE INCORRECT Index: Fortran/gfortran/regression/gomp/appendix-a/a.37.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.37.2.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + SUBROUTINE WORK(I) + INTEGER I + I=I+1 + END SUBROUTINE WORK + SUBROUTINE CORRECT() + INTEGER OMP_GET_THREAD_NUM + INTEGER I +!$OMP PARALLEL PRIVATE(I) + I = OMP_GET_THREAD_NUM() + CALL WORK(I) +!$OMP END PARALLEL + END SUBROUTINE CORRECT Index: Fortran/gfortran/regression/gomp/appendix-a/a.6.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.6.1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } + + SUBROUTINE WORK(I, J) + INTEGER I,J + END SUBROUTINE WORK + SUBROUTINE A6_GOOD() + INTEGER I, J + REAL A(1000) + DO 100 I = 1,10 +!$OMP DO + DO 100 J = 1,10 + CALL WORK(I,J) + 100 CONTINUE ! !$OMP ENDDO implied here +!$OMP DO + DO 200 J = 1,10 +200 A(I) = I + 1 +!$OMP ENDDO +!$OMP DO + DO 300 I = 1,10 + DO 300 J = 1,10 + CALL WORK(I,J) +300 CONTINUE +!$OMP ENDDO + END SUBROUTINE A6_GOOD Index: Fortran/gfortran/regression/gomp/appendix-a/a.6.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.6.2.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } + + SUBROUTINE WORK(I, J) + INTEGER I,J + END SUBROUTINE WORK + + SUBROUTINE A6_WRONG + INTEGER I, J + DO 100 I = 1,10 +!$OMP DO + DO 100 J = 1,10 + CALL WORK(I,J) + 100 CONTINUE +!$OMP ENDDO ! { dg-error "Unexpected ..OMP END DO statement" } + END SUBROUTINE A6_WRONG Index: Fortran/gfortran/regression/gomp/appendix-a/a.7.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.7.1.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +SUBROUTINE A7_1(A,N) +INTEGER OMP_GET_THREAD_NUM +REAL A(*) +INTEGER I, MYOFFSET, N +!$OMP PARALLEL PRIVATE(MYOFFSET) + MYOFFSET = OMP_GET_THREAD_NUM()*N + DO I = 1, N + A(MYOFFSET+I) = FLOAT(I) + ENDDO +!$OMP END PARALLEL +END SUBROUTINE A7_1 Index: Fortran/gfortran/regression/gomp/appendix-a/a.7.2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.7.2.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } + +SUBROUTINE A7_2(A,B,N,I1,I2) +REAL A(*), B(*) +INTEGER I1, I2, N +!$OMP PARALLEL SHARED(A,B,I1,I2) +!$OMP SECTIONS +!$OMP SECTION + DO I1 = I1, N + IF (A(I1).NE.0.0) EXIT + ENDDO +!$OMP SECTION + DO I2 = I2, N + IF (B(I2).NE.0.0) EXIT + ENDDO +!$OMP END SECTIONS +!$OMP SINGLE + IF (I1.LE.N) PRINT *, "ITEMS IN A UP TO ", I1, " ARE ALL ZERO." + IF (I2.LE.N) PRINT *, "ITEMS IN B UP TO ", I2, " ARE ALL ZERO." +!$OMP END SINGLE +!$OMP END PARALLEL +END SUBROUTINE A7_2 Index: Fortran/gfortran/regression/gomp/appendix-a/a.8.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.8.1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + SUBROUTINE A8(N, M, A, B, Y, Z) + INTEGER N, M + REAL A(*), B(*), Y(*), Z(*) + INTEGER I +!$OMP PARALLEL +!$OMP DO + DO I=2,N + B(I) = (A(I) + A(I-1)) / 2.0 + ENDDO +!$OMP END DO NOWAIT +!$OMP DO + DO I=1,M + Y(I) = SQRT(Z(I)) + ENDDO +!$OMP END DO NOWAIT +!$OMP END PARALLEL + END SUBROUTINE A8 Index: Fortran/gfortran/regression/gomp/appendix-a/a.9.1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/appendix-a/a.9.1.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + SUBROUTINE A9() +!$OMP PARALLEL SECTIONS +!$OMP SECTION + CALL XAXIS() +!$OMP SECTION + CALL YAXIS() +!$OMP SECTION + CALL ZAXIS() +!$OMP END PARALLEL SECTIONS + END SUBROUTINE A9 Index: Fortran/gfortran/regression/gomp/associate1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/associate1.f90 @@ -0,0 +1,83 @@ +! { dg-do compile } + +program associate1 + type dl + integer :: i + end type + type dt + integer :: i + real :: a(3, 3) + type(dl) :: c(3, 3) + end type + integer :: v, i, j + real :: a(3, 3) + type(dt) :: b(3) + i = 1 + j = 2 + associate(k => v, l => a(i, j), m => a(i, :)) + associate(n => b(j)%c(:, :)%i, o => a, p => b) +!$omp parallel shared (l) ! { dg-error "Associate name" } +!$omp end parallel +!$omp parallel firstprivate (m) ! { dg-error "Associate name" } +!$omp end parallel +!$omp parallel reduction (+: k) ! { dg-error "Associate name" } +!$omp end parallel +!$omp parallel do firstprivate (k) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp parallel do lastprivate (n) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp parallel do private (o) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp parallel do shared (p) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp task private (k) ! { dg-error "Associate name" } +!$omp end task +!$omp task shared (l) ! { dg-error "Associate name" } +!$omp end task +!$omp task firstprivate (m) ! { dg-error "Associate name" } +!$omp end task +!$omp do private (l) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp do reduction (*: k) ! { dg-error "Associate name" } + do i = 1, 10 + end do +!$omp sections private(o) ! { dg-error "Associate name" } +!$omp section +!$omp section +!$omp end sections +!$omp parallel sections firstprivate(p) ! { dg-error "Associate name" } +!$omp section +!$omp section +!$omp endparallelsections +!$omp parallelsections lastprivate(m) ! { dg-error "Associate name" } +!$omp section +!$omp section +!$omp endparallelsections +!$omp sections reduction(+:k) ! { dg-error "Associate name" } +!$omp section +!$omp section +!$omp end sections +!$omp simd private (l) ! { dg-error "Associate name" } + do i = 1, 10 + end do + k = 1 +!$omp simd lastprivate (m) ! { dg-error "Associate name" } + do i = 1, 10 + end do + k = 1 +!$omp simd reduction (+: k) ! { dg-error "Associate name" } + do i = 1, 10 + end do + k = 1 +!$omp simd linear (k : 2) ! { dg-error "Associate name" } + do i = 1, 10 + k = k + 2 + end do + end associate + end associate +end program Index: Fortran/gfortran/regression/gomp/associate2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/associate2.f90 @@ -0,0 +1,76 @@ +! { dg-do compile } +! +! PR fortran/103039 +! + +subroutine shared_test(cc, ar) +implicit none +class(*) :: cc +integer :: ar(..) + +associate(aa => cc) + !$omp parallel shared(aa) ! { dg-error "Associate name 'aa' in SHARED clause" } + !$omp end parallel +end associate + +select type(tt => cc) + type is (integer) + !$omp parallel shared(tt) ! { dg-error "Associate name 'tt' in SHARED clause" } + !$omp end parallel +end select + +select type(cc) + type is (integer) + !$omp parallel shared(cc) ! { dg-error "Associate name 'cc' in SHARED clause" } + !$omp end parallel +end select + +select rank(rr => ar) + rank(1) + !$omp parallel shared(rr) ! { dg-error "Associate name 'rr' in SHARED clause" } + !$omp end parallel +end select + +select rank(ar) + rank(1) + !$omp parallel shared(ar) ! { dg-error "Associate name 'ar' in SHARED clause" } + !$omp end parallel +end select +end + + + +subroutine firstprivate_test(cc, ar) +implicit none +class(*) :: cc +integer :: ar(..) + +associate(aa => cc) + !$omp parallel firstprivate(aa) ! { dg-error "Associate name 'aa' in FIRSTPRIVATE clause" } + !$omp end parallel +end associate + +select type(tt => cc) + type is (integer) + !$omp parallel firstprivate(tt) ! { dg-error "Associate name 'tt' in FIRSTPRIVATE clause" } + !$omp end parallel +end select + +select type(cc) + type is (integer) + !$omp parallel firstprivate(cc) ! { dg-error "Associate name 'cc' in FIRSTPRIVATE clause" } + !$omp end parallel +end select + +select rank(rr => ar) + rank(1) + !$omp parallel firstprivate(rr) ! { dg-error "Associate name 'rr' in FIRSTPRIVATE clause" } + !$omp end parallel +end select + +select rank(ar) + rank(1) + !$omp parallel firstprivate(ar) ! { dg-error "Associate name 'ar' in FIRSTPRIVATE clause" } + !$omp end parallel +end select +end Index: Fortran/gfortran/regression/gomp/assume-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assume-1.f90 @@ -0,0 +1,24 @@ +subroutine foo (i, a) + implicit none + integer, value :: i + integer :: a(:) + integer :: j + + j = 7 + !$omp assume no_openmp, absent (target, teams) holds (i < 32) holds (i < 32_2) + !$omp end assume + + !$omp assume no_openmp_routines, contains (simd) + block + !$omp simd + do j = 1, i + a(i) = j + end do + end block + + !$omp assume no_parallelism, contains (error) + if (i >= 32) then + !$omp error at (execution) message ("Should not happen") + end if + !$omp end assume +end Index: Fortran/gfortran/regression/gomp/assume-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assume-2.f90 @@ -0,0 +1,27 @@ +subroutine foo (i, a) + implicit none + integer, value :: i + integer :: a(:) + integer :: j + + j = 7 + !$omp assume no_openmp, absent (target, teams,target) holds (i < 32) holds (i < 32_2) ! { dg-error "'TARGET' directive mentioned multiple times in ABSENT clause in !.OMP ASSUME directive" } +! !$omp end assume - silence: 'Unexpected !$OMP END ASSUME statement' + + !$omp assume no_openmp_routines, contains (simd) contains ( simd ) ! { dg-error "'SIMD' directive mentioned multiple times in CONTAINS clause in !.OMP ASSUME directive" } + block + !$omp simd + do j = 1, i + a(i) = j + end do + end block + + !$omp assume no_parallelism, contains (error) absent (error) ! { dg-error "'ERROR' directive mentioned both times in ABSENT and CONTAINS clauses in !.OMP ASSUME directive" } + if (i >= 32) then + !$omp error at (execution) message ("Should not happen") + end if +! !$omp end assume - silence: 'Unexpected !$OMP END ASSUME statement' + + !$omp assume holds (1.0) ! { dg-error "HOLDS expression at .1. must be a scalar logical expression" } + !$omp end assume +end Index: Fortran/gfortran/regression/gomp/assume-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assume-3.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fopenmp -O2 -fdump-tree-optimized -fdump-tree-original" } + +! { dg-final { scan-tree-dump-times ".ASSUME \\(x == 42\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times ".ASSUME \\(x <= 41\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times ".ASSUME \\(y <= 6\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times ".ASSUME \\(y > 5\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "return 42;" 3 "optimized" } } +! { dg-final { scan-tree-dump-not "return -1;" "optimized" } } + +integer function foo (x) + implicit none + integer, value :: x + integer :: y + !$omp assume holds (x == 42) + y = x; + !$omp end assume + foo = y +end + +integer function bar (x) + implicit none + integer, value :: x + !$omp assume holds (x < 42) + block + end block + if (x == 42) then + bar = -1 + return + end if + bar = 42 +end + +integer function foobar (y) + implicit none + integer, value :: y + !$omp assume holds(y > 5) holds (y < 7) + block + if (y == 6) then + foobar = 42 + return + end if + end block + foobar = -1 +end Index: Fortran/gfortran/regression/gomp/assume-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assume-4.f90 @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-options "-fopenmp -O2 -fdump-tree-original -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times ".ASSUME \\(i_lower_bound \\(\\) < i\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times ".ASSUME \\(TARGET_EXPR i_lower_bound ()) + block + if (i > 4) then + f = 42 + else + f = -1 + end if + end block +contains + function i_lower_bound () + integer :: i_lower_bound + i_lower_bound = 5 + end function +end + +integer function g(j) + implicit none + integer, value :: j + + !$omp assume holds(j < j_upper_bound ()) + block + if (j < 10) then + g = 42 + else + g = -1 + end if + end block +contains + function j_upper_bound () + integer, allocatable :: j_upper_bound + j_upper_bound = 10 + end function +end Index: Fortran/gfortran/regression/gomp/assume-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assume-5.f90 @@ -0,0 +1,20 @@ +! PR fortran/107706 +! +! Contributed by G. Steinmetz +! + +integer function f(i) + implicit none + !$omp assumes holds(i < g()) ! { dg-error "HOLDS expression at .1. must be a scalar logical expression" } + integer, value :: i + + !$omp assume holds(i < g()) ! { dg-error "HOLDS expression at .1. must be a scalar logical expression" } + block + end block + f = 3 +contains + function g() + integer :: g(2) + g = 4 + end +end Index: Fortran/gfortran/regression/gomp/assumes-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assumes-1.f90 @@ -0,0 +1,82 @@ +! All of the following (up to PROGRAM) are okay: +! +subroutine sub + interface + subroutine sub_iterface() + !$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram + end + end interface + !$omp assumes no_openmp_routines absent(simd) ! OK external subroutine/subprogram +contains + subroutine inner_sub + !$omp assumes no_parallelism absent(teams) ! OK internal subroutine/subprogram + end +end + +integer function func () + !$omp assumes no_openmp_routines absent(simd) ! OK external function/subprogram + interface + integer function func_iterface() + !$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external function/subprogram + end + end interface + func = 0 +contains + integer function inner_func() + !$omp assumes no_parallelism absent(teams) ! OK internal function/subprogram + inner_sub2 = 0 + end +end + +module m + integer ::x + !$omp assumes contains(target) holds(x > 0.0) + + interface + subroutine mod_mod_sub_iterface() + !$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram + end + integer function mod_mod_func_iterface() + !$omp assumes no_openmp_routines absent(error) ! OK inferface of an external subroutine/subprogram + end + end interface + +contains + subroutine mod_sub + interface + subroutine mod_sub_iterface() + !$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external subroutine/subprogram + end + end interface + !$omp assumes no_openmp_routines absent(simd) ! OK module subroutine/subprogram + contains + subroutine mod_inner_sub + !$omp assumes no_parallelism absent(teams) ! OK internal subroutine/subprogram + end + end + + integer function mod_func () + !$omp assumes no_openmp_routines absent(simd) ! OK module function/subprogram + interface + integer function mod_func_iterface() + !$omp assumes no_openmp_routines absent(simd) ! OK inferface of an external function/subprogram + end + end interface + mod_func = 0 + contains + integer function mod_inner_func() + !$omp assumes no_parallelism absent(teams) ! OK internal function/subprogram + mod_inner_sub2 = 0 + end + end +end module m + + +! PROGRAM - invalid as: +! main program is a program unit that is not a subprogram +!$omp assumes no_openmp absent(simd) ! { dg-error "must be in the specification part of a subprogram or module" } + block + ! invalid: block + !$omp assumes no_openmp absent(target) ! { dg-error "must be in the specification part of a subprogram or module" } + end block +end Index: Fortran/gfortran/regression/gomp/assumes-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/assumes-2.f90 @@ -0,0 +1,19 @@ +module m + integer ::x +! Nonsense but OpenMP-semantically valid: + !$omp assumes contains(target) holds(x > 0.0) + !$omp assumes absent(target) + !$omp assumes holds(0.0) +! { dg-error "HOLDS expression at .1. must be a scalar logical expression" "" { target *-*-* } .-1 } +end module + +module m2 +interface + subroutine foo + !$omp assumes contains(target) contains(teams,target) ! { dg-error "'TARGET' directive mentioned multiple times in CONTAINS clause in !.OMP ASSUMES directive" } + !$omp assumes absent(declare target) ! { dg-error "Invalid 'DECLARE TARGET' directive at .1. in ABSENT clause: declarative, informational and meta directives not permitted" } + !$omp assumes absent(parallel) absent(do,simd,parallel,distribute) ! { dg-error "'PARALLEL' directive mentioned multiple times in ABSENT clause in !.OMP ASSUMES directive" } + !$omp assumes contains(barrier,atomic) absent(cancel,simd,atomic,distribute) ! { dg-error "'SIMD' directive mentioned both times in ABSENT and CONTAINS clauses in !.OMP ASSUMES directive" } + end subroutine foo +end interface +end module m2 Index: Fortran/gfortran/regression/gomp/atomic-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-10.f90 @@ -0,0 +1,32 @@ +! PR middle-end/28046 for the original C tet. +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-ompexp" } +! { dg-require-effective-target cas_int } + +module m + implicit none + integer a(3), b + type t_C + integer :: x, y + end type + type(t_C) :: c + + interface + integer function bar(); end + integer function baz(); end + end interface + pointer :: baz +contains +subroutine foo +!$omp atomic + a(2) = a(2) + bar () +!$omp atomic + b = b + bar () +!$omp atomic + c%y = c%y + bar () +!$omp atomic + b = b + baz () +end +end module + +! { dg-final { scan-tree-dump-times "__atomic_fetch_add" 4 "ompexp" } } Index: Fortran/gfortran/regression/gomp/atomic-12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-12.f90 @@ -0,0 +1,364 @@ +! PR middle-end/45423 - for the original C/C++ testcase +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple -g0 -Wno-deprecated" } +! atomicvar should never be referenced in between the barrier and +! following #pragma omp atomic_load. +! { dg-final { scan-tree-dump-not "barrier\[^#\]*atomicvar" "gimple" } } + +module m + implicit none + logical :: atomicvar, c + integer :: i, atomicvar2, c2 +contains +integer function foo () + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .or. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .and. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .neqv. c + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. .true. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. .false. + !$omp barrier + !$omp atomic + atomicvar = atomicvar .eqv. c + !$omp barrier + !$omp atomic + atomicvar = .true. .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .or. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .and. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .neqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .true. .eqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = .false. .eqv. atomicvar + !$omp barrier + !$omp atomic + atomicvar = c .eqv. atomicvar + !$omp barrier + foo = 0 +end + +integer function bar () + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ieor (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = ior (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = iand (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = min (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = min (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = min (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, -1) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 0) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 1) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, 2) + !$omp barrier + !$omp atomic + atomicvar2 = max (atomicvar2, c2) + !$omp barrier + !$omp atomic + atomicvar2 = max (-1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (0, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (1, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = max (c2, atomicvar2) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 + c2 + !$omp barrier + !$omp atomic + atomicvar2 = -1 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 + atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 - c2 + !$omp barrier + !$omp atomic + atomicvar2 = -1 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 - atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 * c2 + !$omp barrier + !$omp atomic + atomicvar2 = (-1) * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 * atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / (-1) + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 0 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 1 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / 2 + !$omp barrier + !$omp atomic + atomicvar2 = atomicvar2 / c2 + !$omp barrier + !$omp atomic + atomicvar2 = (-1) / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 0 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 1 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = 2 / atomicvar2 + !$omp barrier + !$omp atomic + atomicvar2 = c2 / atomicvar2 + !$omp barrier + bar = 0 +end +end module Index: Fortran/gfortran/regression/gomp/atomic-15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-15.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } +module m + implicit none + integer :: x = 6 +end module m + +program main + use m + implicit none + integer v + !$omp atomic + x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic + x = ieor (x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic update + x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic + x = ior (ieor (x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic + x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic + x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = x * 7 + 6 ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic capture + v = x; x = ieor(x * 7, 6) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + v = x; x = x - 8 + 6 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = ior (ieor(x, 7), 2) ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + v = x; x = x / 7 * 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + v = x; x = x / 7 / 2 ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + x = x * 7 + 6; v = x ! { dg-error "assignment must be var = var op expr or var = expr op var" } + !$omp atomic capture + x = ieor(x * 7, 6); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" } + !$omp atomic capture + x = x - 8 + 6; v = x ! { dg-error "var = var op expr not mathematically equivalent to var = var op \\(expr\\)" } + !$omp atomic capture + x = ior(ieor(x, 7), 2); v = x ! { dg-error "intrinsic arguments except one must not reference 'x'" } +end Index: Fortran/gfortran/regression/gomp/atomic-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-16.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m + implicit none + integer :: x = 6 +contains + +subroutine foo () + integer v + !$omp atomic seq_cst read + v = x + !$omp atomic seq_cst, read + v = x + !$omp atomic seq_cst write + x = v + !$omp atomic seq_cst ,write + x = v + !$omp atomic seq_cst update + x = x + v; + !$omp atomic seq_cst , update + x = v + x; + !$omp atomic seq_cst capture + v = x; x = x + 2; + !$omp atomic seq_cst, capture + v = x; x = 2 + x; + !$omp atomic read , seq_cst + v = x + !$omp atomic write ,seq_cst + x = v + !$omp atomic update, seq_cst + x = x + v + !$omp atomic capture, seq_cst + x = x + 2; v = x +end +end module m Index: Fortran/gfortran/regression/gomp/atomic-17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-17.f90 @@ -0,0 +1,41 @@ +module m +implicit none +integer i, v +real f +contains + +subroutine foo () + !$omp atomic release, hint (0), update + i = i + 1 + !$omp atomic hint(0)seq_cst + i = i + 1 + !$omp atomic relaxed,update,hint (0) + i = i + 1 + !$omp atomic release + i = i + 1 + !$omp atomic relaxed + i = i + 1 + !$omp atomic acq_rel capture + i = i + 1; v = i + !$omp atomic capture,acq_rel , hint (1) + i = i + 1; v = i + !$omp atomic hint(0),acquire capture + i = i + 1; v = i + !$omp atomic read acquire + v = i + !$omp atomic acq_rel read + v = i + !$omp atomic release,write + i = v + !$omp atomic write,acq_rel + i = v + !$omp atomic hint(1),update,release + f = f + 2.0 + !$omp atomic update ,acquire + i = i + 1 + !$omp atomic acq_rel update + i = i + 1 + !$omp atomic acq_rel,hint(0) + i = i + 1 +end +end module Index: Fortran/gfortran/regression/gomp/atomic-18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-18.f90 @@ -0,0 +1,27 @@ +module m +implicit none +integer i, v +real f +contains +subroutine foo (j) +integer, value :: j + !$omp atomic update,update ! { dg-error "Duplicated atomic clause: unexpected update clause" } + i = i + 1 + !$omp atomic seq_cst release ! { dg-error "Duplicated memory-order clause: unexpected release clause" } + i = i + 1 + !$omp atomic read,release ! { dg-error "ATOMIC READ at .1. incompatible with RELEASE clause" } + v = i + !$omp atomic acquire , write ! { dg-error "ATOMIC WRITE at .1. incompatible with ACQUIRE clause" } + i = v + !$omp atomic capture hint (0) capture ! { dg-error "Duplicated 'capture' clause" } + v = i = i + 1 + !$omp atomic hint(j + 2) ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" } + i = i + 1 + !$omp atomic hint(f) + ! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 } + ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 } + i = i + 1 + !$omp atomic foobar ! { dg-error "Failed to match clause" } + i = i + 1 +end +end module Index: Fortran/gfortran/regression/gomp/atomic-19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-19.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic relaxed" 3 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic read relaxed" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic capture relaxed" 1 "original" } } + +module mod + implicit none + integer i, j, k, l, m, n + +contains + +subroutine foo () + !$omp atomic release + i = i + 1; +end +end + +module m2 +use mod +implicit none +!$omp requires atomic_default_mem_order (relaxed) + +contains +subroutine bar () + integer v; + !$omp atomic + j = j + 1 + !$omp atomic update + k = k + 1 + !$omp atomic read + v = l + !$omp atomic write + m = v + !$omp atomic capture + n = n + 1; v = n +end +end module m2 Index: Fortran/gfortran/regression/gomp/atomic-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-2.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } + +subroutine bar + integer :: i, v + real :: f + !$omp atomic update acq_rel hint("abc") + ! { dg-error "HINT clause at .1. requires a scalar INTEGER expression" "" { target *-*-* } .-1 } + ! { dg-error "Value of HINT clause at .1. shall be a valid constant hint expression" "" { target *-*-* } .-2 } + i = i + 1 + !$omp end atomic + + !$omp atomic acq_rel + i = i + 1 + !$omp end atomic + + !$omp atomic capture,acq_rel , hint (1) + i = i + 1 + v = i + !$omp end atomic + + !$omp atomic acq_rel , hint (1), update + i = i + 1 + !$omp end atomic + + !$omp atomic hint(0),acquire capture + i = i + 1 + v = i + !$omp end atomic + + !$omp atomic write capture ! { dg-error "with CAPTURE clause is incompatible with READ or WRITE" } + i = 2 + v = i + !$omp end atomic + + !$omp atomic foobar ! { dg-error "Failed to match clause" } +end Index: Fortran/gfortran/regression/gomp/atomic-20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-20.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! { dg-final { scan-tree-dump-times "omp atomic release" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic seq_cst" 3 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic read seq_cst" 1 "original" } } +! { dg-final { scan-tree-dump-times "omp atomic capture seq_cst" 1 "original" } } + +module mod +implicit none +integer i, j, k, l, m, n + +contains +subroutine foo () + !$omp atomic release + i = i + 1 +end +end module + +module m2 +use mod +implicit none +!$omp requires atomic_default_mem_order (seq_cst) + +contains + +subroutine bar () + integer v + !$omp atomic + j = j + 1 + !$omp atomic update + k = k + 1 + !$omp atomic read + v = l + !$omp atomic write + m = v + !$omp atomic capture + n = n + 1; v = n +end +end module Index: Fortran/gfortran/regression/gomp/atomic-21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-21.f90 @@ -0,0 +1,93 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +module mod +implicit none + +integer i, j, k, l, m, n +contains + +subroutine foo () + !$omp atomic release + i = i + 1 +end +end module + +module m2 +use mod +implicit none +!$omp requires atomic_default_mem_order (acq_rel) + +contains +subroutine bar () + integer v + !$omp atomic + j = j + 1 + !$omp atomic update + k = k + 1 + !$omp atomic read + v = l + !$omp atomic write + m = v + !$omp atomic capture + n = n + 1; v = n +end + +! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 5 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } } + +subroutine foobar() + integer :: aa, bb, cc, dd, ee, ff, gg, hh, ii, jj, kk, nn, oo, pp, qq + + !$omp atomic compare + if (ii == jj) ii = kk + +! #pragma omp atomic release +! TARGET_EXPR = *TARGET_EXPR == jj \\? kk : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == jj \\? kk : \\*TARGET_EXPR ;" 1 "original" } } + + !$omp atomic compare, capture + if (nn == oo) then + nn = pp + else + qq = nn + endif + +! TARGET_EXPR = #pragma omp atomic capture acq_rel +! TARGET_EXPR = NON_LVALUE_EXPR = *TARGET_EXPR == oo> ? pp : *TARGET_EXPR ;, if (TARGET_EXPR ) +! { +! <<< Unknown tree: void_cst >>> +! } +! else +! { +! qq = TARGET_EXPR ; +! }; +! +! { dg-final { scan-tree-dump-times "TARGET_EXPR = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = NON_LVALUE_EXPR = \\*TARGET_EXPR == oo> \\? pp : \\*TARGET_EXPR ;, if \\(TARGET_EXPR \\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "<<< Unknown tree: void_cst >>>" 1 "original" } } +! { dg-final { scan-tree-dump-times "qq = TARGET_EXPR ;" 1 "original" } } + + !$omp atomic capture compare + aa = bb + if (bb == cc) bb = dd + +! aa = #pragma omp atomic capture acq_rel +! TARGET_EXPR = *TARGET_EXPR == cc ? dd : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "aa = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == cc \\? dd : \\*TARGET_EXPR ;" 1 "original" } } + + !$omp atomic capture compare + if (ee == ff) ee = gg + hh = ee + +! hh = #pragma omp atomic capture acq_rel +! TARGET_EXPR = *TARGET_EXPR == ff ? gg : *TARGET_EXPR ; +! +! { dg-final { scan-tree-dump-times "hh = #pragma omp atomic capture acq_rel" 1 "original" } } +! { dg-final { scan-tree-dump-times "TARGET_EXPR = \\*TARGET_EXPR == ff \\? gg : \\*TARGET_EXPR ;" 1 "original" } } +end +end module Index: Fortran/gfortran/regression/gomp/atomic-22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-22.f90 @@ -0,0 +1,24 @@ +module mod +integer i, j + +contains +subroutine foo () + integer v + !$omp atomic release + i = i + 1 + !$omp atomic read + v = j +end +end module + +module m2 +!$omp requires atomic_default_mem_order (acq_rel) ! OK +contains +subroutine bar + !$omp atomic release + i = i + 1 +!$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "must appear in the specification part of a program unit" } + !$omp atomic read + v = j +end subroutine +end module m2 Index: Fortran/gfortran/regression/gomp/atomic-24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-24.f90 @@ -0,0 +1,13 @@ +! PR c/101297 + +module m +implicit none +integer :: i +contains +subroutine foo () + !$omp atomic update, ! { dg-error "Clause expected at .1. after trailing comma" } + i = i + 1 + !$omp atomic update,, ! { dg-error "Failed to match clause" } + i = i + 1 +end +end module Index: Fortran/gfortran/regression/gomp/atomic-25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-25.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } + +module m +use iso_fortran_env +implicit none +integer, parameter :: mrk = maxval(real_kinds) +integer x, r, z +real(kind(4.0d0)) d, v +real(mrk) ld + +contains +subroutine foo (y, e, f) + integer :: y + real(kind(4.0d0)) :: e + real(mrk) :: f + !$omp atomic update seq_cst fail(acquire) + x = min(x, y) + !$omp atomic relaxed fail(relaxed) + d = max (e, d) + !$omp atomic fail(SEQ_CST) + d = min (d, f) + !$omp atomic seq_cst compare fail(relaxed) + if (x == 7) x = 24 + !$omp atomic compare + if (x == 7) x = 24 + !$omp atomic compare + if (x == 123) x = 256 + !$omp atomic compare + if (ld == f) ld = 5.0_mrk + !$omp atomic compare + if (x == 9) then + x = 5 + endif + !$omp atomic compare update capture seq_cst fail(acquire) + if (x == 42) then + x = f + else + v = x + endif + !$omp atomic capture compare weak + if (x == 42) then + x = f + else + v = x + endif + !$omp atomic capture compare fail(seq_cst) + if (d == 8.0) then + d = 16.0 + else + v = d + end if +end +end module Index: Fortran/gfortran/regression/gomp/atomic-26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-26.f90 @@ -0,0 +1,99 @@ +! { dg-do compile } + +module m +implicit none +integer x +real d + +contains + +real function foo (y, e, f) + integer :: y + real v, e + real(8) :: f + !$omp atomic compare compare ! { dg-error "Duplicated 'compare' clause" } + if (x == y) x = d + !$omp atomic compare fail(seq_cst) fail(seq_cst) ! { dg-error "Duplicated 'fail' clause" } + if (x == y) x = d + !$omp atomic compare,fail(seq_cst),fail(relaxed) ! { dg-error "Duplicated 'fail' clause" } + if (x == y) x = d + !$omp atomic compare weak weak ! { dg-error "Duplicated 'weak' clause" } + if (x == y) x = d + !$omp atomic read capture ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" } + v = d + !$omp atomic capture, write ! { dg-error "CAPTURE clause is incompatible with READ or WRITE" } + d = v; v = v + 1 ! { dg-error "Unexpected ..OMP ATOMIC statement" "" { target *-*-* } .-1 } + foo = v +end + +real function bar (y, e, f) + integer :: y + real v, e + real(8) :: f + !$omp atomic read compare ! { dg-error "COMPARE clause is incompatible with READ or WRITE" } + if (x == y) x = d + !$omp atomic compare, write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" } + if (x == y) x = d + !$omp atomic read fail(seq_cst) ! { dg-error "FAIL clause is incompatible with READ or WRITE" } + v = d + !$omp atomic fail(relaxed), write ! { dg-error "FAIL clause is incompatible with READ or WRITE" } + d = v + !$omp atomic fail(relaxed) update ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + d = d + 3.0 + !$omp atomic fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + d = d + 3.0 + !$omp atomic capture fail(relaxed) ! { dg-error "FAIL clause requiries either the COMPARE clause or using the intrinsic MIN/MAX procedure" } + v = d; d = d + 3.0 + !$omp atomic read weak ! { dg-error "WEAK clause requires COMPARE clause" } + v = d + !$omp atomic weak, write ! { dg-error "WEAK clause requires COMPARE clause" } + d = v + !$omp atomic weak update ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0 + !$omp atomic weak ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0 + !$omp atomic capture weak ! { dg-error "WEAK clause requires COMPARE clause" } + d = d + 3.0; v = d + !$omp atomic capture + d = d + 3.0; v = x ! { dg-error "capture statement reads from different variable than update statement writes" } + !$omp atomic compare fail ! { dg-error "Expected '\\\(' after 'fail'" } + if (x == y) x = d + !$omp atomic compare fail( ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail() ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(foobar) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(acq_rel) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(release) ! { dg-error "Expected SEQ_CST, ACQUIRE or RELAXED" } + if (x == y) x = d + !$omp atomic compare fail(seq_cst ! { dg-error "Failed to match clause" } + if (x == y) x = d + bar = v +end + +subroutine foobar + implicit none + integer :: i, j, k + + !$omp atomic compare write ! { dg-error "COMPARE clause is incompatible with READ or WRITE" } + if (i == 1) i = 5 + + !$omp atomic compare + if (k == 5) i = 7 ! { dg-error "For !.OMP ATOMIC COMPARE, the first operand in comparison at .1. must be the variable 'i' that the update statement writes into at .2." } + + !$omp atomic compare + if (j == i) i = 8 ! { dg-error "For !.OMP ATOMIC COMPARE, the first operand in comparison at .1. must be the variable 'i' that the update statement writes into at .2." } + + !$omp atomic compare + if (i == 5) i = 8 + + !$omp atomic compare + if (5 == i) i = 8 ! { dg-error "Expected scalar intrinsic variable at .1. in atomic comparison" } + + !$omp atomic compare + if (i == 5) i = i + 8 ! { dg-error "20: expr in !.OMP ATOMIC COMPARE assignment var = expr must be scalar and cannot reference var" } + +end subroutine +end module Index: Fortran/gfortran/regression/gomp/atomic-27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-27.f90 @@ -0,0 +1,34 @@ +! PR fortran/104328 +! { dg-do compile } + +subroutine foo + integer :: k = 1 + !$omp atomic compare + if ( k == 2 ) then ! { dg-error "unexpected !.OMP ATOMIC expression" } + end if +end +subroutine bar + real :: x = 1 + !$omp atomic compare + if ( x == 2 ) then ! { dg-error "unexpected !.OMP ATOMIC expression" } + end if +end +subroutine baz + integer :: i + !$omp atomic capture + i = 1 + i = i + 1. ! { dg-error "!.OMP ATOMIC capture-statement requires a scalar variable of intrinsic type" } +end +subroutine qux + integer :: i = 0 + !$omp atomic capture + i = i + 1.0 + i = i + 1.0 ! { dg-error "!.OMP ATOMIC capture-statement requires a scalar variable of intrinsic type" } +end +subroutine garply + logical :: k = .true. + !$omp atomic capture compare + if ( k ) then ! { dg-error "unexpected !.OMP ATOMIC expression" } + else + end if +end Index: Fortran/gfortran/regression/gomp/atomic-28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic-28.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR fortran/104329 +! +! Contributed by G. Steinmetz +! +subroutine z1 + character(:), allocatable :: x(:) + x = ['123'] + !$omp atomic update + x = (x) ! { dg-error "OMP ATOMIC statement must set a scalar variable of intrinsic type" } +end + +subroutine z2 + character(:), allocatable :: x(:) + x = ['123'] + !$omp atomic update + x = 'a' // x // 'e' ! { dg-error "OMP ATOMIC statement must set a scalar variable of intrinsic type" } +end + + +subroutine z3 + character(:), allocatable :: x(:) + x = ['123'] + !$omp atomic capture + x = 'a' // x // 'e' ! { dg-error "OMP ATOMIC statement must set a scalar variable of intrinsic type" } + x = x +end Index: Fortran/gfortran/regression/gomp/atomic.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/atomic.f90 @@ -0,0 +1,119 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 4 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic release" 4 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture relaxed" 4 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture release" 2 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read acquire" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst" 7 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic read seq_cst" 3 "original" } } +! { dg-final { scan-tree-dump-times "v = #pragma omp atomic capture seq_cst" 6 "original" } } + +subroutine foo () + integer :: x, v + !$omp atomic + i = i + 2 + + !$omp atomic relaxed + i = i + 2 + + !$omp atomic seq_cst read + v = x + !$omp atomic seq_cst, read + v = x + !$omp atomic seq_cst write + x = v + !$omp atomic seq_cst ,write + x = v + !$omp atomic seq_cst update + x = x + v + !$omp atomic seq_cst , update + x = x + v + !$omp atomic seq_cst capture + x = x + 2 + v = x + !$omp end atomic + !$omp atomic seq_cst, capture + x = x + 2 + v = x + !$omp end atomic + !$omp atomic read , seq_cst + v = x + !$omp atomic write ,seq_cst + x = v + !$omp atomic update, seq_cst + x = x + v + !$omp atomic capture, seq_cst + x = x + 2 + v = x + !$omp end atomic +end + +subroutine bar + integer :: i, v + real :: f + !$omp atomic release, hint (0), update + i = i + 1 + !$omp end atomic + !$omp atomic hint(0)seq_cst + i = i + 1 + !$omp atomic relaxed,update,hint (0) + i = i + 1 + !$omp atomic release + i = i + 1 + !$omp atomic relaxed + i = i + 1 + !$omp atomic relaxed capture + i = i + 1 + v = i + !$omp end atomic + !$omp atomic capture,release , hint (1) + i = i + 1 + v = i + !$omp end atomic + !$omp atomic hint(0),relaxed capture + i = i + 1 + v = i + !$omp end atomic + !$omp atomic read acquire + v = i + !$omp atomic release,write + i = v + !$omp atomic hint(1),update,release + f = f + 2.0 +end + +subroutine openmp51_foo + integer :: x, v + !$omp atomic update seq_cst capture + x = x + 2 + v = x + !$omp end atomic + !$omp atomic seq_cst, capture, update + x = x + 2 + v = x + !$omp end atomic + !$omp atomic capture, seq_cst ,update + x = x + 2 + v = x + !$omp end atomic +end + +subroutine openmp51_bar + integer :: i, v + real :: f + !$omp atomic relaxed capture update + i = i + 1 + v = i + !$omp end atomic + !$omp atomic update capture,release , hint (1) + i = i + 1 + v = i + !$omp end atomic + !$omp atomic hint(0),update relaxed capture + i = i + 1 + v = i + !$omp end atomic +end Index: Fortran/gfortran/regression/gomp/block-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/block-1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } + +!$omp parallel +!$omp critical + goto 10 ! { dg-error "invalid (exit|branch)" } +!$omp end critical + 10 x = 1 +!$omp end parallel + + end Index: Fortran/gfortran/regression/gomp/cancel-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/cancel-1.f90 @@ -0,0 +1,542 @@ +! { dg-additional-options "-cpp" } + +subroutine f1 + !$omp cancel parallel ! { dg-error "orphaned" } + !$omp cancel do ! { dg-error "orphaned" } + !$omp cancel sections ! { dg-error "orphaned" } + !$omp cancel taskgroup ! { dg-error "orphaned" } + !$omp cancellation point parallel ! { dg-error "orphaned" } + !$omp cancellation point do ! { dg-error "orphaned" } + !$omp cancellation point sections ! { dg-error "orphaned" } + !$omp cancellation point taskgroup ! { dg-error "orphaned" } +end + +subroutine f2 + integer :: i, j + j = 0 + !$omp parallel + !$omp cancel parallel + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + + !$omp master + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end master + + !$omp masked + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end masked + + !$omp scope + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end scope + + !$omp single + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end single + + !$omp critical + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end critical + + !$omp taskgroup + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end taskgroup + + !$omp task + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + + !$omp taskgroup + !$omp task + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup + !$omp end task + !$omp end taskgroup + + !$omp taskloop + do i = 0, 9 + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup + !$omp task + !$omp cancellation point taskgroup + !$omp cancel taskgroup + !$omp end task + end do + !$omp taskloop nogroup + do i = 0, 9 + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp task + !$omp cancellation point taskgroup! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + end do + !$omp taskgroup + !$omp task + !$omp task + !$omp cancellation point taskgroup + !$omp cancel taskgroup + !$omp end task + !$omp end task + !$omp taskloop nogroup + do i = 0, 9 + !$omp task + !$omp cancellation point taskgroup + !$omp cancel taskgroup + !$omp end task + !$omp cancellation point taskgroup + !$omp cancel taskgroup + end do + !$omp end taskgroup + + !$omp taskgroup + !$omp parallel + !$omp task + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + !$omp taskloop + do i = 0, 9 + !$omp cancel taskgroup + !$omp cancellation point taskgroup + end do + !$omp taskloop nogroup + do i = 0, 9 + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + end do + !$omp end parallel + !$omp target + !$omp task + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + !$omp end target + !$omp target + !$omp teams + !$omp distribute + do i = 0, 9 + !$omp task + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + end do + !$omp end distribute + !$omp end teams + !$omp end target + !$omp target data map(i) + !$omp task + !$omp cancel taskgroup + !$omp cancellation point taskgroup + !$omp end task + !$omp end target data + !$omp end taskgroup + + !$omp taskloop + do i = 0, 9 + !$omp parallel + !$omp task + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + !$omp end parallel + !$omp target + !$omp task + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + !$omp end target + !$omp target + !$omp teams + !$omp distribute + do j = 0, 9 + !$omp task + !$omp cancel taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp cancellation point taskgroup ! { dg-error "construct not closely nested inside of .taskgroup. region" } + !$omp end task + end do + !$omp end distribute + !$omp end teams + !$omp end target + !$omp target data map(i) + !$omp task + !$omp cancel taskgroup + !$omp cancellation point taskgroup + !$omp end task + !$omp end target data + end do + + !$omp do + do i = 0, 9 + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + end do + + !$omp do ordered + do i = 0, 9 + !$omp ordered + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + !$omp end ordered + end do + !$omp end do + !$omp sections + !$omp section + block + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + end block + !$omp section + block + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + end block + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target data + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target + !$omp end sections + !$omp end parallel + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target data + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target + !$omp target teams + !$omp cancel parallel ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancel do ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancel sections ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancel taskgroup ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancellation point parallel ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancellation point do ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancellation point sections ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp cancellation point taskgroup ! { dg-error "only .distribute., .parallel. or .loop. regions are allowed to be strictly nested" } + !$omp end target teams + !$omp target teams distribute + do i = 0, 9 + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + end do + !$omp end target teams distribute + !$omp do + do i = 0, 9 + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + end do + !$omp do + do i = 0, 9 + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target data + end do + !$omp do + do i = 0, 9 + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target + end do + !$omp do ordered + do i = 0, 9 + !$omp ordered + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + !$omp end target data + !$omp end ordered + end do + do i = 0, 9 + !$omp ordered + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup! { dg-error "not closely nested inside" } + !$omp end target + !$omp end ordered + end do + !$omp sections + !$omp section + block + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + end block + !$omp section + block + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + end block + !$omp end sections + !$omp sections + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target data + !$omp section + !$omp target data map(j) + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target data + !$omp end sections + !$omp sections + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target + !$omp section + !$omp target + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end target + !$omp end sections + !$omp task + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup + !$omp taskgroup + !$omp cancel parallel ! { dg-error "not closely nested inside" } + !$omp cancel do ! { dg-error "not closely nested inside" } + !$omp cancel sections ! { dg-error "not closely nested inside" } + !$omp cancel taskgroup ! { dg-error "not closely nested inside" } + !$omp cancellation point parallel ! { dg-error "not closely nested inside" } + !$omp cancellation point do ! { dg-error "not closely nested inside" } + !$omp cancellation point sections ! { dg-error "not closely nested inside" } + !$omp cancellation point taskgroup ! { dg-error "not closely nested inside" } + !$omp end taskgroup + !$omp end task +end + +subroutine f3 + integer i + !$omp do + do i = 0, 9 + !$omp cancel do ! { dg-warning "nowait" } + end do + !$omp end do nowait + !$omp sections + !$omp section + block + !$omp cancel sections ! { dg-warning "nowait" } + end block + !$omp section + block + !$omp cancel sections ! { dg-warning "nowait" } + end block + !$omp end sections nowait + !$omp do ordered + do i = 0, 9 + !$omp cancel do ! { dg-warning "ordered" } + !$omp ordered + !$omp end ordered + end do +end + + +subroutine f4 +! if (.false.) then +!$omp cancellation point do ! { dg-error "orphaned 'cancellation point' construct" } +! end if +end Index: Fortran/gfortran/regression/gomp/cancel-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/cancel-2.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } + +subroutine foo () + !$omp parallel + !$omp cancel parallel if (.true.) + !$omp cancel parallel if (cancel: .true.) + + !$omp cancel parallel if (.true.) if (.true.) ! { dg-error "Duplicated 'if' clause" } + !$omp cancel parallel if (cancel: .true.) if (cancel: .true.) ! { dg-error "Failed to match clause" } + !$omp cancel parallel if (cancel: .true.) if (.true.) ! { dg-error "IF clause without modifier at .1. used together with IF clauses with modifiers" } + !$omp cancel parallel if (cancel: .true.) if (parallel: .true.) ! { dg-error "IF clause modifier PARALLEL at .1. not appropriate for the current OpenMP construct" } + !$omp cancel parallel if (.true.) if (cancel: .true.) ! { dg-error "Duplicated 'if' clause" } + !$omp cancel parallel if (parallel: .true.) if (cancel: .true.) ! { dg-error "IF clause modifier PARALLEL at .1. not appropriate for the current OpenMP construct" } + !$omp end parallel +end subroutine Index: Fortran/gfortran/regression/gomp/cancel-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/cancel-3.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine foo () + !$omp parallel + !$omp cancel parallel if (.true.) + !$omp cancel parallel if (cancel: .true.) + !$omp cancel parallel if (.false.) + !$omp cancel parallel if (cancel: .false.) + !$omp end parallel + + !$omp sections + !$omp cancel sections if (cancel: .true.) + stop + !$omp end sections + + !$omp do + do i = 1, 10 + !$omp cancel do if (.false.) + end do + + !$omp task + !$omp cancel taskgroup if (cancel: .false.) + !$omp end task + !$omp task + !$omp cancel taskgroup + !$omp end task +end subroutine + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(1, 1\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(1, 0\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(4, 1\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(2, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(8, 0\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel \\(8, 1\\);" 1 "original" } } Index: Fortran/gfortran/regression/gomp/cancel-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/cancel-4.f90 @@ -0,0 +1,9 @@ +subroutine f4 + !$omp cancellation point ! { dg-error "Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP in .OMP CANCELLATION POINT statement at" } + if (.false.) then +!$omp cancellation EKAHI ! { dg-error "Unclassifiable OpenMP directive" } + end if +!$omp cancellation HO OKAHI ! { dg-error "Unclassifiable OpenMP directive" } + +!$omp cancellation point ! { dg-error "Expected construct-type PARALLEL, SECTIONS, DO or TASKGROUP in .OMP CANCELLATION POINT statement at" } +end Index: Fortran/gfortran/regression/gomp/canonical-loop-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/canonical-loop-1.f90 @@ -0,0 +1,224 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +! Test that all specified forms of canonical loop bounds are accepted, +! including non-rectangular loops. + +subroutine s1 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp do collapse(2) + do i = 1, 16 + do j = a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i + a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 + i, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i - a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 - i, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a1 * i, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a1 * i + a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 + a1 * i , 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a1 * i - a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 - a1 * i, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i * a1, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i * a1 + a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 + i * a1, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = i * a1 - a2, 16 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = a2 - i * a1, 16 + end do + end do + +end subroutine + + +subroutine s2 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i + a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 + i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i - a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 - i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a1 * i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a1 * i + a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 + a1 * i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a1 * i - a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 - a1 * i + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i * a1 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i * a1 + a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 + i * a1 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, i * a1 - a2 + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, a2 - i * a1 + end do + end do + +end subroutine + +subroutine s3 (a1, a2) + integer :: a1, a2 + integer :: i, j, k + + !$omp do collapse(3) + do i = 1, 16 + do j = 1, i + do k = j, 16 + end do + end do + end do + +end subroutine Index: Fortran/gfortran/regression/gomp/canonical-loop-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/canonical-loop-2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +! Test that various non-canonical loops are rejected with a diagnostic. + +subroutine s1 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp do collapse(2) + do i = 1, 16 + do j = i * i, 16 ! { dg-error "not in canonical form" } + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = MAX (i, 8), 16 ! { dg-error "not in canonical form" } + end do + end do + + !$omp do collapse(2) + do i = 1, 16 + do j = 1, 16, i ! { dg-error "not in canonical form" } + end do + end do + + !$omp do collapse(3) + do i = 1, 16 + do j = 1, 16 + do k = i, j ! { dg-error "reference different iteration variables" } + end do + end do + end do + + !$omp do collapse(3) + do i = 1, 16 + do j = 1, 16 + do k = 1, i + j ! { dg-error "not in canonical form" } + end do + end do + end do + +end subroutine Index: Fortran/gfortran/regression/gomp/class-firstprivate-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/class-firstprivate-1.f90 @@ -0,0 +1,62 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + integer :: i + integer :: A(4) + type(c_ptr) :: B(4) + + B = [(c_null_ptr, i=1,4)] + A = [1,2,3,4] + call sub(A, B) +contains + subroutine sub(val1, val2) + class(*) :: val1(4) + type(c_ptr) :: val2(2:5) + + !$OMP PARALLEL firstprivate(val2) + do i = 2, 5 + if (c_associated (val2(i))) stop 123 + end do + !$OMP END PARALLEL + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 99 + end select + !$OMP END PARALLEL + + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 454 + class default + stop 99 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp Index: Fortran/gfortran/regression/gomp/class-firstprivate-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/class-firstprivate-2.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + !use omp_lib + implicit none + class(*), allocatable :: B(:) + + allocate(B, source=["abcdef","cdefi2"]) + allocate(B, source=[1,2,3]) + call sub(B) +contains + subroutine sub(val2) + class(*), allocatable :: val2(:) + + !$OMP PARALLEL firstprivate(val2) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + if (.not.allocated(val2)) stop 3 + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 4545 + val2 = ["123456", "789ABC"] + class default + stop 991 + end select + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "123456" .or. val2(2) /= "789ABC") stop 453 + class default + stop 991 + end select + !$OMP END PARALLEL + + if (.not.allocated(val2)) stop 3 + select type (val2) + type is (character(len=*)) + if (len(val2) /= 6) stop 44 + if (val2(1) /= "abcdef" .or. val2(2) /= "cdefi2") stop 456 + class default + stop 991 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp Index: Fortran/gfortran/regression/gomp/class-firstprivate-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/class-firstprivate-3.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + call sub +contains + subroutine sub + integer :: i + class(*), allocatable :: val1(:) + type(c_ptr), allocatable :: val2(:) + + allocate(val1, source=[1, 2, 3, 4]) + allocate(val2(2:5)) + val2 = c_null_ptr + + !$OMP PARALLEL firstprivate(val2) + do i = 2, 5 + if (c_associated (val2(i))) stop 123 + end do + !$OMP END PARALLEL + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 99 + end select + !$OMP END PARALLEL + + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 454 + class default + stop 99 + end select + print *, "PASS!" + end subroutine +end program select_type_openmp Index: Fortran/gfortran/regression/gomp/class-firstprivate-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/class-firstprivate-4.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-prune-output "compilation terminated." } +! +! FIRSTPRIVATE + class array +! +! For now: Expected to give "Sorry" for polymorphic arrays. +! +! Polymorphic arrays are tricky - at least if not allocatable, they become: +! var.0 = var._data.data +! which needs to be handled properly. +! +! +program select_type_openmp + use iso_c_binding + !use omp_lib + implicit none + integer x(4) + x = [1, 2, 3, 4] + call sub(x) + if (any (x /= [1,2,3,4])) stop 3 +contains + subroutine sub(val1) + integer :: i + class(*) :: val1(4) + + !$OMP PARALLEL firstprivate(val1) ! { dg-error "Sorry, polymorphic arrays not yet supported for firstprivate" } + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 33 + if (any (val1 /= [1, 2, 3, 4])) stop 4549 + val1 = [32,6,48,28] + class default + stop 99 + end select + select type (val1) + type is (integer) + if (size(val1) /= 4) stop 34 + if (any (val1 /= [32,6,48,28])) stop 4512 + class default + stop 98 + end select + !$OMP END PARALLEL + end +end Index: Fortran/gfortran/regression/gomp/clauses-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/clauses-1.f90 @@ -0,0 +1,667 @@ +! { dg-do compile } + +module m + use iso_c_binding, only: c_intptr_t + implicit none (external, type) + + integer(c_intptr_t), parameter :: & + omp_null_allocator = 0, & + omp_default_mem_alloc = 1, & + omp_large_cap_mem_alloc = 2, & + omp_const_mem_alloc = 3, & + omp_high_bw_mem_alloc = 4, & + omp_low_lat_mem_alloc = 5, & + omp_cgroup_mem_alloc = 6, & + omp_pteam_mem_alloc = 7, & + omp_thread_mem_alloc = 8 + + integer, parameter :: & + omp_allocator_handle_kind = c_intptr_t + + integer :: t + !$omp threadprivate (t) + + integer :: f, l, ll, r, r2 + !$omp declare target (f, l, ll, r, r2) + +contains + +subroutine foo (d, m, i1, i2, i3, p, idp, s, nte, tl, nth, g, nta, fi, pp, q, dd, ntm) + !$omp declare target (foo) + integer :: d, m, p, idp, s, nte, tl, nth, g, nta, pp, q, dd, ntm + logical :: i1, i2, i3, fi + pointer :: q + integer :: i + + !$omp distribute parallel do & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp distribute parallel do simd & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) if(simd: i1) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) nontemporal(ntm) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) order(concurrent) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp distribute simd & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) reduction(+:r) if(i1) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll +1 + end do +end + +subroutine qux (p) + !$omp declare target (qux) + integer, value :: p + + !$omp loop bind(teams) order(concurrent) & + !$omp& private (p) lastprivate (l) collapse(1) reduction(+:r) + do l = 1, 64 + ll = ll + 1 + end do +end + +subroutine baz (d, m, i1, i2, i3, p, idp, s, nte, tl, nth, g, nta, fi, pp, q, dd, ntm) + integer :: d, m, p, idp, s, nte, tl, nth, g, nta, pp, q, dd, ntm + logical :: i1, i2, i3, fi + pointer :: q + integer :: i + !$omp distribute parallel do & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) copyin(t) & + !$omp& allocate (p) + do i = 1, 64 + ll = ll +1 + end do + + !$omp distribute parallel do & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& allocate (p) + do i = 1, 64 + ll = ll +1 + end do + + !$omp distribute parallel do simd & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) if(simd: i1) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) nontemporal(ntm) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) copyin(t) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp distribute parallel do simd & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) if(simd: i1) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) nontemporal(ntm) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp distribute simd & + !$omp& private (p) firstprivate (f) collapse(1) dist_schedule(static, 16) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) reduction(+:r) if(i1) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp loop bind(parallel) order(concurrent) & + !$omp& private (p) lastprivate (l) collapse(1) reduction(+:r) + do l = 1, 64 + ll = ll + 1 + end do +end + +subroutine bar (d, m, i1, i2, i3, p, idp, s, nte, tl, nth, g, nta, fi, pp, q, dd, ntm) + integer :: d, m, p, idp, s, nte, tl, nth, g, nta, pp, q, dd(0:5), ntm + logical :: i1, i2, i3, fi + pointer :: q + integer :: i + + !$omp do simd & + !$omp& private (p) firstprivate (f) lastprivate (l) linear (ll:1) reduction(+:r) schedule(static, 4) collapse(1) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) nontemporal(ntm) if(i1) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end do simd nowait + + !$omp parallel do & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) linear (ll:1) ordered schedule(static, 4) collapse(1) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp parallel do & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) linear (ll:1) schedule(static, 4) collapse(1) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp parallel do simd & + !$omp& private (p) firstprivate (f) if (i2) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) linear (ll:1) schedule(static, 4) collapse(1) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) nontemporal(ntm) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp parallel sections & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) & + !$omp& allocate (f) + !$omp section + block; end block + !$omp section + block; end block + !$omp end parallel sections + + !$omp target parallel & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& depend(inout: dd(0)) in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + !$omp end target parallel nowait + + !$omp target parallel do & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) linear (ll:1) ordered schedule(static, 4) collapse(1) depend(inout: dd(0)) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target parallel do nowait + + !$omp target parallel do & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) linear (ll:1) schedule(static, 4) collapse(1) depend(inout: dd(0)) order(concurrent) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target parallel do nowait + + !$omp target parallel do simd & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& if (parallel: i2) default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) linear (ll:1) schedule(static, 4) collapse(1) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) depend(inout: dd(0)) nontemporal(ntm) if (simd: i3) order(concurrent) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target parallel do simd nowait + + !$omp target teams & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte - 1:nte) thread_limit(tl) depend(inout: dd(0)) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + !$omp end target teams nowait + + !$omp target teams distribute & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) order(concurrent) & + !$omp& collapse(1) dist_schedule(static, 16) depend(inout: dd(0)) in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + end do + !$omp end target teams distribute nowait + + !$omp target teams distribute parallel do & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) depend(inout: dd(0)) order(concurrent) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target teams distribute parallel do nowait + + !$omp target teams distribute parallel do simd & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) depend(inout: dd(0)) nontemporal(ntm) if (simd: i3) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target teams distribute parallel do simd nowait + + !$omp target teams distribute simd & + !$omp& device(d) map (tofrom: m) if (i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) depend(inout: dd(0)) nontemporal(ntm) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target teams distribute simd nowait + + !$omp target simd & + !$omp& device(d) map (tofrom: m) if (target: i1) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& safelen(8) simdlen(4) lastprivate (l) linear(ll: 1) aligned(q: 32) reduction(+:r) & + !$omp& depend(inout: dd(0)) nontemporal(ntm) if(simd:i3) order(concurrent) & + !$omp& in_reduction(+:r2) & + !$omp& allocate (omp_default_mem_alloc:f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end target simd nowait + + !$omp taskgroup task_reduction(+:r2) & + !$omp& allocate (r2) + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction(+:r) & + !$omp& allocate (r) + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(i1) & + !$omp& final(fi) mergeable nogroup priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) in_reduction(+:r) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskwait + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) if(taskloop: i1) & + !$omp& final(fi) priority (pp) safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(+:r) if (simd: i3) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp target depend(inout: dd(0)) in_reduction(+:r2) + !$omp teams distribute & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) order(concurrent) & + !$omp& allocate (omp_default_mem_alloc: f) + do i = 1, 64 + end do + !$omp end target nowait + + !$omp target + !$omp teams distribute parallel do & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& allocate (omp_default_mem_alloc: f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end target + + !$omp target + !$omp teams distribute parallel do simd & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) if (simd: i3) nontemporal(ntm) & + !$omp& allocate (omp_default_mem_alloc: f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end target + + !$omp target + !$omp teams distribute simd & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) if(i3) nontemporal(ntm) & + !$omp& allocate (omp_default_mem_alloc: f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end target + + !$omp teams distribute parallel do & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) copyin(t) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp teams distribute parallel do & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) order(concurrent) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp teams distribute parallel do simd & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) if (simd: i3) nontemporal(ntm) copyin(t) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp teams distribute parallel do simd & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) & + !$omp& lastprivate (l) schedule(static, 4) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) if (simd: i3) nontemporal(ntm) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp teams distribute simd & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) dist_schedule(static, 16) order(concurrent) & + !$omp& safelen(8) simdlen(4) aligned(q: 32) if(i3) nontemporal(ntm) & + !$omp& allocate(f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel master & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) reduction(+:r) & + !$omp& num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& allocate (f) + !$omp end parallel master + + !$omp parallel masked & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) reduction(+:r) & + !$omp& num_threads (nth) proc_bind(spread) copyin(t) filter (d) & + !$omp& allocate (f) + !$omp end parallel masked + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) in_reduction(+:r2) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) final(fi) mergeable priority (pp) reduction(default, +:r) in_reduction(+:r2) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp parallel master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) nontemporal(ntm) if (parallel: i2) & + !$omp& num_threads (nth) proc_bind(spread) copyin(t) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied & + !$omp& if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) nontemporal(ntm) if (parallel: i2) & + !$omp& num_threads (nth) proc_bind(spread) copyin(t) order(concurrent) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) & + !$omp& untied if(i1) final(fi) mergeable priority (pp) reduction(default, +:r) in_reduction(+:r2) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) & + !$omp& untied if(i1) final(fi) mergeable priority (pp) reduction(default, +:r) in_reduction(+:r2) filter (d) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied if(i1) & + !$omp& final(fi) mergeable priority (pp) safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) & + !$omp& in_reduction(+:r2) nontemporal(ntm) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) & + !$omp& allocate (r2) + !$omp masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied & + !$omp& if(i1) final(fi) mergeable priority (pp) safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) & + !$omp& in_reduction(+:r2) nontemporal(ntm) order(concurrent) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + !$omp end taskgroup + + !$omp parallel master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied & + !$omp& if(i1) final(fi) mergeable priority (pp) reduction(default, +:r) num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied & + !$omp& if(i1) final(fi) mergeable priority (pp) reduction(default, +:r) num_threads (nth) proc_bind(spread) & + !$omp& copyin(t) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied & + !$omp& if(i1) final(fi) mergeable priority (pp) safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) & + !$omp& nontemporal(ntm) num_threads (nth) proc_bind(spread)copyin(t) order(concurrent) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp parallel masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) collapse(1) untied if(i1) & + !$omp& final(fi) mergeable priority (pp) safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) & + !$omp& nontemporal(ntm) num_threads (nth) proc_bind(spread) copyin(t) order(concurrent) filter (d) & + !$omp& allocate (f) + do i = 1, 64 + ll = ll +1 + end do + + !$omp loop bind(thread) order(concurrent) & + !$omp& private (p) lastprivate (l) collapse(1) reduction(+:r) + do l = 1, 64 + ll = ll + 1 + end do + + !$omp parallel loop & + !$omp& private (p) firstprivate (f) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) collapse(1) bind(parallel) order(concurrent) if (parallel: i2) & + !$omp& allocate (f) + do l = 1, 64 + ll = ll + 1 + end do + + !$omp parallel loop & + !$omp& private (p) firstprivate (f) default(shared) shared(s) copyin(t) reduction(+:r) num_threads (nth) & + !$omp& proc_bind(spread) lastprivate (l) collapse(1) if (parallel: i2) & + !$omp& allocate (f) + do l = 1, 64 + ll = ll + 1 + end do + + !$omp teams loop & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) & + !$omp& collapse(1) lastprivate (l) bind(teams) & + !$omp& allocate (f) + do l = 1, 64 + end do + + !$omp teams loop & + !$omp& private(p) firstprivate (f) shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) & + !$omp& collapse(1) lastprivate (l) order(concurrent) & + !$omp& allocate (f) + do l = 1, 64 + end do + + !$omp target parallel loop & + !$omp& device(d) map (tofrom: m) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& default(shared) shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) & + !$omp& depend(inout: dd(0)) lastprivate (l) order(concurrent) collapse(1) in_reduction(+:r2) & + !$omp& if (target: i1) if (parallel: i2) & + !$omp& allocate (omp_default_mem_alloc: f) + do l = 1, 64 + end do + !$omp end target parallel loop nowait + + !$omp target teams loop & + !$omp& device(d) map (tofrom: m) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte-1:nte) thread_limit(tl) depend(inout: dd(0)) & + !$omp& lastprivate (l) bind(teams) collapse(1) in_reduction(+:r2) if (target: i1) & + !$omp& allocate (omp_default_mem_alloc: f) + do l = 1, 64 + end do + !$omp end target teams loop nowait + + !$omp target teams loop & + !$omp& device(d) map (tofrom: m) private (p) firstprivate (f) defaultmap(tofrom: scalar) is_device_ptr (idp) & + !$omp& shared(s) default(shared) reduction(+:r) num_teams(nte) thread_limit(tl) depend(inout: dd(0)) & + !$omp& lastprivate (l) order(concurrent) collapse(1) in_reduction(+:r2) if (target: i1) & + !$omp& allocate (omp_default_mem_alloc: f) + do l = 1, 64 + end do + !$omp end target teams loop nowait + +end +end module Index: Fortran/gfortran/regression/gomp/collapse1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/collapse1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine collapse1 + integer :: i, j, k, a(1:3, 4:6, 5:7) + real :: r + logical :: l + integer, save :: thr + !$omp threadprivate (thr) + l = .false. + a(:, :, :) = 0 + !$omp parallel do collapse(4) schedule(static, 4) ! { dg-error "not enough DO loops for collapsed" } + do i = 1, 3 + do j = 4, 6 + do k = 5, 7 + a(i, j, k) = i + j + k + end do + end do + end do + !$omp parallel do collapse(2) + do i = 1, 5, 2 + do j = i + 1, 7, i ! { dg-error "loop increment not in canonical form" } + end do + end do + !$omp parallel do collapse(2) shared(j) + do i = 1, 3 + do j = 4, 6 ! { dg-error "iteration variable present on clause other than PRIVATE, LASTPRIVATE or ALLOCATE" } + end do + end do + !$omp parallel do collapse(2) + do i = 1, 3 + do j = 4, 6 + end do + k = 4 ! { dg-error "loops not perfectly nested" } + end do + !$omp parallel do collapse(2) + do i = 1, 3 + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + end do + end do + !$omp parallel do collapse(2) + do i = 1, 3 + do r = 4, 6 ! { dg-warning "must be integer" } + end do + end do +end subroutine collapse1 + +subroutine collapse1_2 + integer :: i + !$omp parallel do collapse(2) + do i = -6, 6 ! { dg-error "cannot be redefined inside loop beginning" } + do i = 4, 6 ! { dg-error "iteration variable used in more than one loop|cannot be redefined" } + end do + end do +end subroutine collapse1_2 + +! { dg-error "iteration variable must be of type integer" "integer" { target *-*-* } 43 } Index: Fortran/gfortran/regression/gomp/collapse2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/collapse2.f90 @@ -0,0 +1,32 @@ +program p + integer :: i, j, k + real :: x + !$omp parallel do collapse(3) + do i = 1, 8 + do j = 1, 8 + do k = 1, 8 + end do + x = 5 ! { dg-error "loops not perfectly nested" } + end do + end do + !$omp parallel do ordered(3) + do i = 1, 8 + do j = 1, 8 + do k = 1, 8 + end do + end do + x = 5 ! { dg-error "loops not perfectly nested" } + end do + !$omp parallel do collapse(2) ! { dg-error "not enough DO loops for collapsed" } + do i = 1, 8 + x = 5 + do j = 1, 8 + end do + end do + !$omp parallel do ordered(2) ! { dg-error "not enough DO loops for collapsed" } + do i = 1, 8 + x = 5 + do j = 1, 8 + end do + end do +end Index: Fortran/gfortran/regression/gomp/combined-if.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/combined-if.f90 @@ -0,0 +1,109 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-omplower" } + +module combined_if + implicit none + + integer, parameter :: N = 100 + integer, parameter :: LIMIT = 60 + integer :: i, j + integer, dimension(N) :: a = (/ (i, i = 1,N) /) +contains + subroutine test_parallel_loop_simd + do j = 1, N + !$omp parallel do simd if(j .lt. LIMIT) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_parallel + do j = 1, N + !$omp target parallel if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + !$omp end target parallel + end do + end subroutine + + subroutine test_target_parallel_loop + do j = 1, N + !$omp target parallel do if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_parallel_loop_simd + do j = 1, N + !$omp target parallel do simd if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_simd + do j = 1, N + !$omp target simd if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_teams + do j = 1, N + !$omp target teams if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + !$omp end target teams + end do + end subroutine + + subroutine test_target_teams_distribute + do j = 1, N + !$omp target teams distribute if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_teams_distibute_simd + do j = 1, N + !$omp target teams distribute simd if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_teams_distribute_parallel_loop + do j = 1, N + !$omp target teams distribute parallel do if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + + subroutine test_target_teams_distribute_parallel_loop_simd + do j = 1, N + !$omp target teams distribute parallel do simd if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + end do + end subroutine + +end module + +! { dg-final { scan-tree-dump-times "(?n)#pragma omp target.* if\\(" 9 "omplower" } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp simd.* if\\(" 5 "omplower" { target { ! offload_nvptx } } } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp simd.* if\\(" 9 "omplower" { target { offload_nvptx } } } } +! { dg-final { scan-tree-dump-times "(?n)#pragma omp parallel.* if\\(" 6 "omplower" } } Index: Fortran/gfortran/regression/gomp/copyprivate-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/copyprivate-1.f90 @@ -0,0 +1,21 @@ +! based on pr59467.f90 but COPYPRIVATE on the directive +! { dg-additional-options "-fdump-tree-original" } + + FUNCTION t() + INTEGER :: a, b, t + a = 0 + b = 0 + t = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE COPYPRIVATE (b) + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE + !$OMP END PARALLEL + t = t + b + END FUNCTION + +! { dg-final { scan-tree-dump-times "#pragma omp parallel reduction\\(\\+:b\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp single copyprivate\\(b\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed" 1 "original" } } Index: Fortran/gfortran/regression/gomp/copyprivate-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/copyprivate-2.f90 @@ -0,0 +1,97 @@ + FUNCTION t() + INTEGER :: a, b, t + a = 0 + t = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE COPYPRIVATE (b) NOWAIT ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE + !$OMP END PARALLEL + t = t + b + END FUNCTION + + FUNCTION t2() + INTEGER :: a, b, t2 + a = 0 + t2 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE NOWAIT COPYPRIVATE (b) ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE + !$OMP END PARALLEL + t2 = t2 + b + END FUNCTION + + FUNCTION t3() + INTEGER :: a, b, t3 + a = 0 + t3 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE COPYPRIVATE (b) ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE NOWAIT + !$OMP END PARALLEL + t3 = t3 + b + END FUNCTION + + FUNCTION t4() + INTEGER :: a, b, t4 + a = 0 + t4 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE NOWAIT COPYPRIVATE (b) ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP END PARALLEL + t4 = t4 + b + END FUNCTION + + FUNCTION t5() + INTEGER :: a, b, t5 + a = 0 + t5 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE COPYPRIVATE (b) NOWAIT ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP END PARALLEL + t5 = t5 + b + END FUNCTION + + FUNCTION t6() + INTEGER :: a, b, t6 + a = 0 + t6 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE NOWAIT + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE COPYPRIVATE (b) ! { dg-error "NOWAIT clause must not be used with COPYPRIVATE clause" } + !$OMP END PARALLEL + t6 = t6 + b + END FUNCTION + + FUNCTION t7() + INTEGER :: a, b, t7 + a = 0 + t7 = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE COPYPRIVATE (b) + !$OMP ATOMIC WRITE + b = 7 + !$OMP END SINGLE COPYPRIVATE (b) ! { dg-error "Symbol 'b' present on multiple clauses" } + !$OMP END PARALLEL + t7 = t7 + b + END FUNCTION Index: Fortran/gfortran/regression/gomp/crayptr1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/crayptr1.f90 @@ -0,0 +1,51 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + + integer :: a, b, c, d, i + pointer (ip1, a) + pointer (ip2, b) + pointer (ip3, c) + pointer (ip4, d) + +!$omp parallel shared (a) ! { dg-error "Cray pointee 'a' in SHARED clause" } +!$omp end parallel + +!$omp parallel private (b) ! { dg-error "Cray pointee 'b' in PRIVATE clause" } +!$omp end parallel + +!$omp parallel firstprivate (c) ! { dg-error "Cray pointee 'c' in FIRSTPRIVATE clause" } +!$omp end parallel + +!$omp parallel do lastprivate (d) ! { dg-error "Cray pointee 'd' in LASTPRIVATE clause" } + do i = 1, 10 + if (i .eq. 10) d = 1 + end do +!$omp end parallel do + +!$omp parallel reduction (+: a) ! { dg-error "Cray pointee 'a' in REDUCTION clause" } +!$omp end parallel + + ip1 = loc (i) +!$omp parallel shared (ip1) + a = 2 +!$omp end parallel + +!$omp parallel private (ip2, i) + ip2 = loc (i) + b = 1 +!$omp end parallel + + ip3 = loc (i) +!$omp parallel firstprivate (ip3) +!$omp end parallel + +!$omp parallel do lastprivate (ip4) + do i = 1, 10 + if (i .eq. 10) ip4 = loc (i) + end do +!$omp end parallel do + +!$omp parallel reduction (+: ip1) ! { dg-error "Cray pointer 'ip1' in REDUCTION clause" } +!$omp end parallel + +end Index: Fortran/gfortran/regression/gomp/crayptr2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/crayptr2.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } +! { dg-require-effective-target tls } + +module crayptr2 + integer :: e ! { dg-error "CRAY POINTEE attribute conflicts with THREADPRIVATE" } + pointer (ip5, e) + +! The standard is not very clear about this. +! Certainly, Cray pointees can't be SAVEd, nor they can be +! in COMMON, so the only way to make threadprivate Cray pointees would +! be if they are module variables. But threadprivate pointees don't +! make any sense anyway. + +!$omp threadprivate (e) + +end module crayptr2 Index: Fortran/gfortran/regression/gomp/crayptr3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/crayptr3.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + + integer :: a, b + pointer (ip, a) + + b = 2 + ip = loc (b) +!$omp parallel default (none) shared (ip) + a = 1 +!$omp end parallel + +!$omp parallel default (none) private (ip, b) + b = 3 + ip = loc (b) + a = 1 +!$omp end parallel + +!$omp parallel default (none) ! { dg-message "note: enclosing 'parallel'" } + a = 1 ! { dg-error "'ip' not specified in enclosing 'parallel'" } +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/crayptr4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/crayptr4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } + +subroutine foo (n) + integer :: a, b (38), n + pointer (ip, a (n + 1)) + + b = 2 + n = 36 + ip = loc (b) +!$omp parallel default (none) shared (ip) +!$omp parallel default (none) shared (ip) + a = 1 +!$omp end parallel +!$omp end parallel + +!$omp parallel default (none) +!$omp parallel default (none) private (ip, b) + b = 3 + ip = loc (b) + a = 1 +!$omp end parallel +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/crayptr5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/crayptr5.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fcray-pointer" } +! +! PR fortran/43985 + +subroutine pete(A) + real(8) :: A + print *, 'pete got ',A + if (A /= 3.0) STOP 1 +end subroutine pete + + subroutine bob() + implicit none + real(8) peted + pointer (ipeted, peted(*)) + integer(4) sz + ipeted = malloc(5*8) + peted(1:5) = [ 1.,2.,3.,4.,5.] + sz = 3 +!$omp parallel default(shared) + call pete(peted(sz)) +!$omp end parallel + return + end subroutine bob + +call bob() +end Index: Fortran/gfortran/regression/gomp/declare-simd-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine fn1 (x) + integer :: x +!$omp declare simd (fn1) inbranch notinbranch uniform (x) ! { dg-error "Duplicated 'notinbranch' clause" } +end subroutine fn1 +subroutine fn2 (x) +!$omp declare simd (fn100) ! { dg-error "should refer to containing procedure" } +end subroutine fn2 Index: Fortran/gfortran/regression/gomp/declare-simd-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-2.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } + +function f1 (a, b, c, d, e, f) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } + integer, value :: a, b, c + integer :: d, e, f, f1 +!$omp declare simd (f1) uniform(b) linear(c, d) linear(uval(e)) linear(ref(f)) + a = a + 1 + b = b + 1 + c = c + 1 + d = d + 1 + e = e + 1 + f = f + 1 + f1 = a + b + c + d + e + f +end function f1 +integer function f2 (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } + integer :: a, b +!$omp declare simd uniform(b) linear(ref(a):b) + a = a + 1 + f2 = a + b +end function f2 Index: Fortran/gfortran/regression/gomp/declare-simd-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-3.f90 @@ -0,0 +1,30 @@ +! { dg-do compile } + +module m + implicit none (type, external) +contains + real function add(x, y, j) result(res) + !$omp declare simd(add) uniform(x, y) linear(j : 1) simdlen(4) + integer, value :: j + real, intent(in) :: x(*), y(*) + res = x(j) + y(j) + end function +end module m + +program main + use m + implicit none (type, external) + real, allocatable :: A(:), B(:), C(:) + integer :: i, N + N = 128 + A = [(3*i, i = 1, N)] + B = [(7*i, i = 1, N)] + allocate (C(N)) + + !$omp simd + do i = 1, N + C(i) = add(A, B, i) + end do + + if (any (C /= [(10*i, i = 1, N)])) error stop +end program main Index: Fortran/gfortran/regression/gomp/declare-simd-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-4.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/106566 +! +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare simd \\(linear\\(0:ref,step\\(4\\)\\) simdlen\\(8\\)\\)\\)\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare simd \\(linear\\(0:ref,step\\(8\\)\\) simdlen\\(8\\)\\)\\)\\)" 2 "gimple" } } + +subroutine add_one2(p) + implicit none + !$omp declare simd(add_one2) linear(p: ref) simdlen(8) + integer(kind=4) :: p + + p = p + 1 +end subroutine + +subroutine linear_add_one2(p) + implicit none + !$omp declare simd(linear_add_one2) linear(p: ref, step(2)) simdlen(8) + integer(kind=4) :: p + + p = p + 1 +end subroutine + +module m + integer, parameter :: NN = 1023 + integer(kind=4) :: a(NN) +contains + subroutine module_add_one2(q) + implicit none + !$omp declare simd(module_add_one2) linear(q: ref) simdlen(8) + integer(kind=4) :: q + q = q + 1 + end subroutine + + subroutine linear_add_one2(q) + implicit none + !$omp declare simd(linear_add_one2) linear(q: ref, step(2)) simdlen(8) + integer(kind=4) :: q + q = q + 1 + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-simd-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-5.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } +! +! PR fortran/106566 +! + +subroutine add_one2(p) + implicit none + procedure(add_one2) :: ext1 + !$omp declare simd(ext1) linear(p: ref) simdlen(8) ! { dg-error "OMP DECLARE SIMD should refer to containing procedure 'add_one2'" } + integer :: p + + p = p + 1 +end subroutine + +subroutine linear_add_one2(p) + implicit none + procedure(linear_add_one2) :: ext2 + !$omp declare simd(ext2) linear(p: ref, step(2)) simdlen(8) ! { dg-error "OMP DECLARE SIMD should refer to containing procedure 'linear_add_one2'" } + integer :: p + + p = p + 1 +end subroutine + +module m + integer, parameter :: NN = 1023 + integer :: a(NN) +contains + subroutine some_proc(r) + integer :: r + end subroutine + subroutine module_add_one2(q) + implicit none + !$omp declare simd(some_proc) linear(q: ref) simdlen(8) ! { dg-error "OMP DECLARE SIMD should refer to containing procedure 'module_add_one2'" } + integer :: q + q = q + 1 + end subroutine + + subroutine module_linear_add_one2(q) + implicit none + interface + subroutine other_proc(r) + integer :: r + end subroutine + end interface + !$omp declare simd(other_proc) linear(q: ref, step(2)) simdlen(8) ! { dg-error "OMP DECLARE SIMD should refer to containing procedure 'module_linear_add_one2'" } + integer :: q + q = q + 1 + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-simd-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-6.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/106566 +! +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare simd \\(linear\\(ref\\(0\\):4\\) simdlen\\(8\\)\\)\\)\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare simd \\(linear\\(ref\\(0\\):8\\) simdlen\\(8\\)\\)\\)\\)" 2 "gimple" } } + +subroutine add_one2(p) + implicit none + !$omp declare simd(add_one2) linear(ref(p)) simdlen(8) + integer(kind=4) :: p + + p = p + 1 +end subroutine + +subroutine linear_add_one2(p) + implicit none + !$omp declare simd(linear_add_one2) linear(ref(p) : 2) simdlen(8) + integer(kind=4) :: p + + p = p + 1 +end subroutine + +module m + integer, parameter :: NN = 1023 + integer(kind=4) :: a(NN) +contains + subroutine module_add_one2(q) + implicit none + !$omp declare simd(module_add_one2) linear(ref(q)) simdlen(8) + integer(kind=4) :: q + q = q + 1 + end subroutine + + subroutine linear_add_one2(q) + implicit none + !$omp declare simd(linear_add_one2) linear(ref(q) : 2) simdlen(8) + integer(kind=4) :: q + q = q + 1 + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-simd-coarray-lib.f90 @@ -0,0 +1,12 @@ +! { dg-additional-options "-fcoarray=lib" } +! +! PR fortran/93660 +! +! Failed as TREE_TYPE(fndecl) did not include the +! hidden caf_token/caf_offset arguments. +! +integer function f(x) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } + integer :: x[*] + !$omp declare simd + f = x[1] +end Index: Fortran/gfortran/regression/gomp/declare-target-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-target-1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } + +module declare_target_1 + !$omp declare target to (var_1, var_4) link (var_2, var_3) & + !$omp & link (var_5) to (var_6) + integer :: var_1, var_2, var_3, var_4, var_5, var_6 + interface + subroutine foo + !$omp declare target + end subroutine + end interface +end +subroutine bar + !$omp declare target + integer, save :: var_9 + !$omp declare target link (var_8) to (baz, var_7) link (var_9) to (var_10) + integer, save :: var_7, var_8, var_10 + integer :: var_11, var_12, var_13, var_14 + common /c1/ var_11, var_12 + common /c2/ var_13 + common /c3/ var_14 + !$omp declare target (baz, var_7, var_10, /c1/) + !$omp declare target to (/c2/) + !$omp declare target link (/c3/) + !$omp declare target (bar) + call baz +end subroutine Index: Fortran/gfortran/regression/gomp/declare-target-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-target-2.f90 @@ -0,0 +1,61 @@ +! { dg-do compile } + +module declare_target_2 + !$omp declare target to (a) link (a) ! { dg-error "mentioned multiple times in clauses of the same OMP DECLARE TARGET directive" } + !$omp declare target (b) + !$omp declare target link (b) ! { dg-error "TO or ENTER clause and later in LINK" } + !$omp declare target link (f) + !$omp declare target to (f) ! { dg-error "LINK clause and later in TO" } + !$omp declare target(c, c) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target to (d) to (d) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target link (e, e) ! { dg-error "mentioned multiple times in clauses of the same" } + integer, save :: a, b, c, d, e, f + interface + integer function f1 (a) + !$omp declare target (f1) ! { dg-error "form without clauses is allowed in interface block" } + integer :: a + end function + end interface + interface + integer function f2 (a) + !$omp declare target to (f2) ! { dg-error "form without clauses is allowed in interface block" } + integer :: a + end function + end interface +end +subroutine bar + !$omp declare target link (baz) ! { dg-error "isn.t SAVEd" } + call baz ! { dg-error "attribute conflicts" } +end subroutine +subroutine foo ! { dg-error "attribute conflicts" } + integer :: g, h, i, j, k, l, m, n, o, p, q + common /c1/ g, h + common /c2/ i, j + common /c3/ k, l + common /c4/ m, n + common /c5/ o, p, q + !$omp declare target to (g) ! { dg-error "is an element of a COMMON block" } + !$omp declare target link (foo) + !$omp declare target to (/c2/) + !$omp declare target (/c2/) + !$omp declare target to(/c2/) + !$omp declare target link(/c2/) ! { dg-error "TO or ENTER clause and later in LINK" } + !$omp declare target link(/c3/) + !$omp declare target (/c3/) ! { dg-error "LINK clause and later in ENTER" } + !$omp declare target (/c4/, /c4/) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target to (/c4/) to(/c4/) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target link (/c5/) + !$omp declare target link (/c5/) + !$omp declare target link(/c5/)link(/c5/) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target link(/c5/,/c5/) ! { dg-error "mentioned multiple times in clauses of the same" } +end subroutine + +module declare_target_3 + !$omp declare target enter (a) link (a) ! { dg-error "mentioned multiple times in clauses of the same OMP DECLARE TARGET directive" } + !$omp declare target link(b) enter(b) ! { dg-error "mentioned multiple times in clauses of the same OMP DECLARE TARGET directive" } + !$omp declare target to (c) enter (c) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target enter (d) to (d) ! { dg-error "mentioned multiple times in clauses of the same" } + !$omp declare target enter (e) enter (e) ! { dg-error "mentioned multiple times in clauses of the same" } + integer, save :: a, b, c, d, e +end + Index: Fortran/gfortran/regression/gomp/declare-target-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-target-4.f90 @@ -0,0 +1,86 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +subroutine f1 + !$omp declare target device_type (any) ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE clause is ignored" } +end subroutine + +subroutine f2 + !$omp declare target to (f2) device_type (any) +end subroutine + +subroutine f3 + !$omp declare target device_type (any) to (f3) +end subroutine + +subroutine f4 + !$omp declare target device_type (host) to (f4) +end subroutine + +subroutine f5 + !$omp declare target device_type (nohost) to (f5) +end subroutine + +subroutine f6 + !$omp declare target enter (f6) device_type (any) +end subroutine + +module mymod + ! device_type is ignored for variables in OpenMP 5.0 + ! but TR8 and later apply those rules to variables as well + implicit none + integer :: a, b(4), c, d + integer :: e, f, g + integer :: m, n, o, p, q, r, s, t, u, v, w, x + common /block1/ m, n + common /block2/ o, p + common /block3/ q, r + common /block4/ s, t + common /block5/ u, v + common /block6/ w, x + + !$omp declare target to(a) device_type(nohost) + !$omp declare target to(b) device_type(host) + !$omp declare target to(c) device_type(any) + ! Fails in ME with "Error: wrong number of arguments specified for 'omp declare target link' attribute" + ! !$omp declare target link(e) device_type(nohost) + ! !$omp declare target link(f) device_type(host) + ! !$omp declare target link(g) device_type(any) + + !$omp declare target to(/block1/) device_type(nohost) + !$omp declare target to(/block2/) device_type(host) + !$omp declare target to(/block3/) device_type(any) + !$omp declare target link(/block4/) device_type(nohost) + !$omp declare target link(/block5/) device_type(host) + !$omp declare target link(/block6/) device_type(any) +contains + subroutine s1 + !$omp declare target to (s1) device_type (any) + end + subroutine s2 + !$omp declare target to (s2) device_type (nohost) + end + subroutine s3 + !$omp declare target to (s3) device_type (host) + end +end module + +module m2 + use mymod + implicit none + public + private :: s1, s2, s3, a, b, c, d, e, f, g + public :: m, n, o, p, q, r, s, t, u, v, w, x +end module m2 + +! { dg-final { scan-tree-dump-times "omp declare target" 8 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(" 8 "original" } } +! { dg-final { scan-tree-dump-not "__attribute__\\(\\(omp declare target \[^\n\r\]*\[\n\r\]void f1" "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r]void f2" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void f3" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void f4" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void f5" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r]void f6" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void s1" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void s2" 1 "original" } } +! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]__attribute__\[^\n\r]+\[\n\r\]void s3" 1 "original" } } Index: Fortran/gfortran/regression/gomp/declare-target-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-target-5.f90 @@ -0,0 +1,63 @@ +subroutine foo() + !$omp declare target to(foo) device_type(bar) ! { dg-error "Expected HOST, NOHOST or ANY" } +end + +subroutine bar() + !$omp declare target to(bar) device_type(nohost) + !$omp declare target to(bar) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } +end + +module mymod_one + implicit none + integer :: a, b, c, d, e ,f + integer :: m, n, o, p, q, r + common /block1/ m, n + common /block2/ o, p + common /block3/ q, r + !$omp declare target to(a) device_type(nohost) + !$omp declare target to(b) device_type(any) + !$omp declare target to(c) device_type(host) + !$omp declare target link(d) device_type(nohost) + !$omp declare target link(e) device_type(any) + !$omp declare target link(f) device_type(host) + + !$omp declare target to(c) device_type(host) + !$omp declare target link(d) device_type(nohost) +end module + +module mtest + use mymod_one ! { dg-error "Cannot change attributes of USE-associated symbol" } + implicit none + + !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } +end module + +module mymod + implicit none + integer :: a, b, c, d, e ,f + integer :: m, n, o, p, q, r + common /block1/ m, n + common /block2/ o, p + common /block3/ q, r + !$omp declare target to(a) device_type(nohost) + !$omp declare target to(b) device_type(any) + !$omp declare target to(c) device_type(host) + !$omp declare target link(d) device_type(nohost) + !$omp declare target link(e) device_type(any) + !$omp declare target link(f) device_type(host) + + !$omp declare target to(c) device_type(host) + !$omp declare target link(d) device_type(nohost) + + !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } + !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" } +end Index: Fortran/gfortran/regression/gomp/declare-variant-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-1.f90 @@ -0,0 +1,93 @@ +module main + implicit none + + interface + integer function foo (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + end function + + integer function bar (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + end function + + integer function baz (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + + !$omp declare variant (foo) & + !$omp & match (construct={parallel,do}, & + !$omp & device={isa(avx512f,avx512vl),kind(host,cpu)}, & + !$omp & implementation={vendor(score(0):gnu),unified_shared_memory}, & + !$omp & user={condition(score(0):0)}) + !$omp declare variant (bar) & + !$omp & match (device={arch(x86_64,powerpc64),isa(avx512f,popcntb)}, & + !$omp & implementation={atomic_default_mem_order(seq_cst),made_up_selector("foo", 13, "bar")}, & + !$omp & user={condition(3-3)}) + end function + + subroutine quux + end subroutine quux + + integer function baz3 (x, y, z) + integer, intent(in) :: x, y + integer, intent(inout) :: z + + !$omp declare variant (bar) match & + !$omp & (implementation={atomic_default_mem_order(score(3): acq_rel)}) + end function + end interface +contains + integer function qux () + integer :: i = 3 + + qux = baz (1, 2, i) + end function + + subroutine corge + integer :: i + !$omp declare variant (quux) match (construct={parallel,do}) + + interface + subroutine waldo (x) + integer, intent(in) :: x + end subroutine + end interface + + call waldo (5) + !$omp parallel do + do i = 1, 3 + call waldo (6) + end do + !$omp end parallel do + + !$omp parallel + !$omp taskgroup + !$omp do + do i = 1, 3 + call waldo (7) + end do + !$omp end do + !$omp end taskgroup + !$omp end parallel + + !$omp parallel + !$omp master + call waldo (8) + !$omp end master + !$omp end parallel + end subroutine + + integer function baz2 (x, y, z) + integer, intent(in) :: x, y + integer, intent(inout) :: z + + !$omp declare variant (bar) match & + !$omp & (implementation={atomic_default_mem_order(relaxed), & + !$omp & unified_address, unified_shared_memory, & + !$omp & dynamic_allocators, reverse_offload}) + + baz2 = x + y + z + end function +end module Index: Fortran/gfortran/regression/gomp/declare-variant-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-10.f90 @@ -0,0 +1,97 @@ +! { dg-do compile } +! { dg-additional-options "-cpp -foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw" { target { i?86-*-* x86_64-*-* } } } + +#undef i386 + +program main + !$omp declare target to (test3) +contains + subroutine f01 () + end subroutine + subroutine f02 () + !$omp declare variant (f01) match (device={isa(avx512f,avx512bw)}) + end subroutine + subroutine f03 () + end subroutine + subroutine f04 () + !$omp declare variant (f03) match (device={kind("any"),arch(x86_64),isa(avx512f,avx512bw)}) + end subroutine + subroutine f05 () + end subroutine + subroutine f06 () + !$omp declare variant (f05) match (device={kind(gpu)}) + end subroutine + subroutine f07 () + end subroutine + subroutine f08 () + !$omp declare variant (f07) match (device={kind(cpu)}) + end subroutine + subroutine f09 () + end subroutine + subroutine f10 () + !$omp declare variant (f09) match (device={isa(sm_35)}) + end subroutine + subroutine f11 () + end subroutine + subroutine f12 () + !$omp declare variant (f11) match (device={arch("nvptx")}) + end subroutine + subroutine f13 () + end subroutine + subroutine f14 () + !$omp declare variant (f13) match (device={arch(i386),isa("sse4")}) + end subroutine + subroutine f15 () + end subroutine + subroutine f16 () + !$omp declare variant (f15) match (device={isa(sse4,ssse3),arch(i386)}) + end subroutine + subroutine f17 () + end subroutine + subroutine f18 () + !$omp declare variant (f17) match (device={kind(any,fpga)}) + end subroutine + + subroutine test1 () + !$omp declare target + integer :: i + + call f02 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f14 () ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target ia32 } } } + ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } } + call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } */ + end subroutine + +#if defined(__i386__) || defined(__x86_64__) + __attribute__((target ("avx512f,avx512bw"))) +#endif + subroutine test2 () + !$omp target + call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! ilp32 } } } } } + ! { dg-final { scan-tree-dump-times "f04 \\\(\\\);" 1 "gimple" { target { { ilp32 } || { ! { i?86-*-* x86_64-*-* } } } } } } + !$omp end target + !$omp target + call f16 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" { target ia32 } } } + ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } } + !$omp end target + end subroutine + + subroutine test3 () + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + end subroutine + + subroutine test4 () + !$omp target + call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + !$omp end target + + !$omp target + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } } + !$omp end target + end subroutine +end program + Index: Fortran/gfortran/regression/gomp/declare-variant-11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-11.f90 @@ -0,0 +1,134 @@ +! { dg-do compile } +! { dg-additional-options "-foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + subroutine f01 () + end subroutine + + subroutine f02 () + end subroutine + + subroutine f03 () + !$omp declare variant (f01) match (device={isa(avx512f,"avx512vl")}) + !$omp declare variant (f02) match (device={isa(avx512bw,avx512vl,"avx512f")}) + end subroutine + + subroutine f04 () + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + !$omp declare variant (f04) match (device={isa(avx512f,avx512vl)}) + !$omp declare variant (f05) match (device={isa(avx512bw,avx512vl,avx512f)}) + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + end subroutine + + subroutine f09 () + !$omp declare variant (f07) match (device={isa(sse4,"sse4.1","sse4.2",sse3,"avx")}) + !$omp declare variant (f08) match (device={isa("avx",sse3)}) + end subroutine + + subroutine f10 () + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + end subroutine + + subroutine f13 () + !$omp declare variant (f10) match (device={isa("avx512f")}) + !$omp declare variant (f11) match (user={condition(1)},device={isa(avx512f)},implementation={vendor(gnu)}) + !$omp declare variant (f12) match (user={condition(2 + 1)},device={isa(avx512f)}) + end subroutine + + subroutine f14 () + end subroutine + + subroutine f15 () + end subroutine + + subroutine f16 () + end subroutine + + subroutine f17 () + end subroutine + + subroutine f18 () + !$omp declare variant (f14) match (construct={teams,do}) + !$omp declare variant (f15) match (construct={teams,parallel,do}) + !$omp declare variant (f16) match (construct={do}) + !$omp declare variant (f17) match (construct={parallel,do}) + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + end subroutine + + subroutine f21 () + end subroutine + + subroutine f22 () + end subroutine + + subroutine f23 () + !$omp declare variant (f19) match (construct={teams,do}) + !$omp declare variant (f20) match (construct={teams,parallel,do}) + !$omp declare variant (f21) match (construct={do}) + !$omp declare variant (f22) match (construct={parallel,do}) + end subroutine + + subroutine f24 () + end subroutine + + subroutine f25 () + end subroutine + + subroutine f26 () + end subroutine + + subroutine f27 () + !$omp declare variant (f24) match (device={kind(cpu)}) + !$omp declare variant (f25) match (device={kind(cpu),isa(avx512f),arch(x86_64)}) + !$omp declare variant (f26) match (device={arch(x86_64),kind(cpu)}) + end subroutine + + subroutine test1 + integer :: i + call f03 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f09 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f13 () ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + !$omp teams distribute parallel do + do i = 1, 2 + call f18 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" } } + end do + !$omp end teams distribute parallel do + + !$omp parallel do + do i = 1, 2 + call f23 () ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + + call f27 () ! { dg-final { scan-tree-dump-times "f25 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! ilp32 } } } } } + ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ilp32 } } } } } + ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* i?86-*-* x86_64-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* amdgcn*-*-* } } } } + end subroutine +end program Index: Fortran/gfortran/regression/gomp/declare-variant-12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-12.f90 @@ -0,0 +1,159 @@ +! { dg-do compile } +! { dg-additional-options "-foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } } + +program main + !$omp requires atomic_default_mem_order(seq_cst) +contains + subroutine f01 () + end subroutine + + subroutine f02 () + end subroutine + + subroutine f03 () + end subroutine + + subroutine f04 () + !$omp declare variant (f01) match (device={isa("avx512f","avx512vl")}) ! 16 + !$omp declare variant (f02) match (implementation={vendor(score(15):gnu)}) + !$omp declare variant (f03) match (user={condition(score(11):1)}) + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + !$omp declare variant (f05) match (device={isa(avx512f,avx512vl)}) ! 16 + !$omp declare variant (f06) match (implementation={vendor(score(15):gnu)}) + !$omp declare variant (f07) match (user={condition(score(17):1)}) + end subroutine + + subroutine f09 () + end subroutine + + subroutine f10 () + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + end subroutine + + subroutine f13 () + !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):1)}) ! 64+65 + !$omp declare variant (f10) match (implementation={vendor(score(127):"gnu")}) + !$omp declare variant (f11) match (device={isa(ssse3)}) ! 128 + !$omp declare variant (f12) match (implementation={atomic_default_mem_order(score(126):seq_cst)}) + end subroutine + + subroutine f14 () + end subroutine + + subroutine f15 () + end subroutine + + subroutine f16 () + end subroutine + + subroutine f17 () + !$omp declare variant (f14) match (construct={teams,parallel,do}) ! 16+8+4 + !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):1)}) ! 8+19 + !$omp declare variant (f16) match (implementation={atomic_default_mem_order(score(27):seq_cst)}) + end subroutine + + subroutine f18 () + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + end subroutine + + subroutine f21 () + !$omp declare variant (f18) match (construct={teams,parallel,do}) ! 16+8+4 + !$omp declare variant (f19) match (construct={do},user={condition(score(25):1)}) ! 4+25 + !$omp declare variant (f20) match (implementation={atomic_default_mem_order(score(28):seq_cst)}) + end subroutine + + subroutine f22 () + end subroutine + + subroutine f23 () + end subroutine + + subroutine f24 () + end subroutine + + subroutine f25 () + !$omp declare variant (f22) match (construct={parallel,do}) ! 2+1 + !$omp declare variant (f23) match (construct={do}) ! 0 + !$omp declare variant (f24) match (implementation={atomic_default_mem_order(score(2):seq_cst)}) + end subroutine + + subroutine f26 () + end subroutine + + subroutine f27 () + end subroutine + + subroutine f28 () + end subroutine + + subroutine f29 () + !$omp declare variant (f26) match (construct={parallel,do}) ! 2+1 + !$omp declare variant (f27) match (construct={do},user={condition(1)}) ! 4 + !$omp declare variant (f28) match (implementation={atomic_default_mem_order(score(3):seq_cst)}) + end subroutine + + subroutine test1 () + integer :: i, j + + !$omp parallel do ! 2 constructs in OpenMP context, isa has score 2^4. + do i = 1, 2 + call f04 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + end do + !$omp end parallel do + + !$omp target teams ! 2 constructs in OpenMP context, isa has score 2^4. + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } } + !$omp end target teams + + !$omp teams + !$omp parallel do + do i = 1, 2 + !$omp parallel do ! 5 constructs in OpenMP context, arch is 2^6, isa 2^7. + do j = 1, 2 + call f13 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! ilp32 } } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ilp32 } } } } } + ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f17 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + call f21 () ! { dg-final { scan-tree-dump-times "f19 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + end do + !$omp end parallel do + !$omp end teams + + !$omp do + do i = 1, 2 + !$omp parallel do + do j = 1, 2 + call f25 (); ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } } + call f29 (); ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + end do + !$omp end do + end subroutine +end program + Index: Fortran/gfortran/regression/gomp/declare-variant-13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-13.f90 @@ -0,0 +1,48 @@ +! { dg-do compile { target vect_simd_clones } } +! { dg-additional-options "-fdump-tree-gimple" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + integer function f01 (x) + integer, intent(in) :: x + f01 = x + end function + + integer function f02 (x) + integer, intent(in) :: x + f02 = x + end function + + integer function f03 (x) + integer, intent(in) :: x + f03 = x + end function + + integer function f04 (x) + integer, intent(in) :: x + f04 = x + end function + + integer function f05 (x) + integer, intent(in) :: x + + !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8 + !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3 + !$omp declare variant (f03) match (user={condition(score(9):1)}) + !$omp declare variant (f04) match (implementation={vendor(score(6):gnu)},device={kind(host)}) ! (1 or 2) + 6 + f05 = x + end function + + integer function test1 (x) + !$omp declare simd + integer, intent(in) :: x + + ! 0 or 1 (the latter if in a declare simd clone) constructs in OpenMP context, + ! isa has score 2^2 or 2^3. We can't decide on whether avx512f will match or + ! not, that also depends on whether it is a declare simd clone or not and which + ! one, but the f03 variant has a higher score anyway. */ + test1 = f05 (x) ! { dg-final { scan-tree-dump-times "f03 \\\(x" 1 "gimple" } } + end function +end program Index: Fortran/gfortran/regression/gomp/declare-variant-14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-14.f90 @@ -0,0 +1,49 @@ +! { dg-do compile { target vect_simd_clones } } +! { dg-additional-options "-O0 -fdump-tree-gimple -fdump-tree-optimized" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +module main + implicit none +contains + integer function f01 (x) + integer, intent (in) :: x + f01 = x + end function + + integer function f02 (x) + integer, intent (in) :: x + f02 = x + end function + + integer function f03 (x) + integer, intent (in) :: x + f03 = x + end function + + integer function f04 (x) + integer, intent(in) :: x + + !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8 + !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3 + !$omp declare variant (f03) match (implementation={vendor(score(5):gnu)},device={kind(host)}) ! (1 or 2) + 5 + f04 = x + end function + + integer function test1 (x) + !$omp declare simd + integer, intent (in) :: x + integer :: a, b + + ! At gimplification time, we can't decide yet which function to call. + ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" } } + ! After simd clones are created, the original non-clone test1 shall + ! call f03 (score 6), the sse2/avx/avx2 clones too, but avx512f clones + ! shall call f01 with score 8. + ! { dg-final { scan-tree-dump-not "f04 \\\(x" "optimized" } } + ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" } } + ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" } } + a = f04 (x) + b = f04 (x) + test1 = a + b + end function +end module Index: Fortran/gfortran/regression/gomp/declare-variant-15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-15.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +! Test 'declare variant' directive with an explicit base procedure name. + +module main + implicit none + + !$omp declare variant (base: variant) match (construct={target,parallel}) +contains + subroutine variant () + end subroutine + + subroutine base () + end subroutine + + subroutine variant2 () + end subroutine + + subroutine base2 () + !$omp declare variant (base2: variant2) match (construct={parallel}) + end subroutine + + subroutine test1 () + !$omp target + !$omp parallel + call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } } + !$omp end parallel + !$omp end target + end subroutine + + subroutine test2 () + !$omp parallel + call base2 () ! { dg-final { scan-tree-dump-times "variant2 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-16.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +! Test that 'declare variant' works when applied to an external subroutine + +module main + implicit none + + interface + subroutine base () + !$omp declare variant (variant) match (construct={parallel}) + end subroutine + + subroutine base2 () + !$omp declare variant (base2: variant2) match (construct={target}) + end subroutine + end interface +contains + subroutine variant () + end subroutine + + subroutine variant2 () + end subroutine + + subroutine test () + !$omp parallel + call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine + + subroutine test2 () + !$omp target + call base2 () ! { dg-final { scan-tree-dump-times "variant2 \\\(\\\);" 1 "gimple" } } + !$omp end target + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-17.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + +! Declare variant directives should only appear in the specification parts. + +program main + implicit none + + continue + + !$omp declare variant (base: variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." } +contains + subroutine base () + continue + + !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." } + end subroutine +end program Index: Fortran/gfortran/regression/gomp/declare-variant-18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-18.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } + +! The base procedure must have an accessible explicit interface when the +! directive appears. + +program main + interface + subroutine base_proc () + end subroutine + end interface + + !$omp declare variant (base_proc: variant_proc) match (construct={parallel}) + !$omp declare variant (base_proc2: variant_proc) match (construct={parallel}) ! { dg-error "The base procedure at .1. must have an explicit interface" } +contains + subroutine variant_proc () + end subroutine +end program Index: Fortran/gfortran/regression/gomp/declare-variant-19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-19.f90 @@ -0,0 +1,49 @@ +! { dg-do compile } + +! Test Fortran-specific compilation failures. + +module main + implicit none + + interface base_gen + subroutine base_gen_int (x) + integer :: x + end subroutine + + subroutine base_gen_real (x) + real :: x + end subroutine + end interface + + interface + subroutine base_p () + end subroutine + end interface + + procedure (base_p), pointer :: base_proc_ptr + + !$omp declare variant (base_entry: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be an entry name" } + !$omp declare variant (base_proc_ptr: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a procedure pointer" } + !$omp declare variant (base_gen: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a generic name" } + !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "The base name for 'declare variant' must be specified at .1." } + +contains + subroutine base () + entry base_entry + end subroutine + + subroutine base2 () + !$omp declare variant (variant2) match (construct={parallel}) ! { dg-error "variant .variant2. and base .base2. at .1. have incompatible types: .variant2. has the wrong number of arguments" } + end subroutine + + subroutine base3 () + !$omp declare variant (base: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. does not match the name of the current procedure" } + end subroutine + + subroutine variant () + end subroutine + + subroutine variant2 (x) + integer :: x + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-2.f90 @@ -0,0 +1,197 @@ +module main + implicit none +contains + subroutine f0 () + end subroutine + subroutine f1 () + end subroutine + subroutine f2 () + !$omp declare variant ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f3 () + !$omp declare variant ( ! { dg-error "" } + end subroutine + subroutine f4 () + !$omp declare variant () ! { dg-error "" } + end subroutine + subroutine f5 () + !$omp declare variant match(user={condition(0)}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f6 () + !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." } + end subroutine + subroutine f7 () + !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." } + end subroutine + subroutine f8 () + !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f9 () + !$omp declare variant (f1) match( ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + end subroutine + subroutine f10 () + !$omp declare variant (f1) match() ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + end subroutine + subroutine f11 () + !$omp declare variant (f1) match(foo) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + end subroutine + subroutine f12 () + !$omp declare variant (f1) match(something={something}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + end subroutine + subroutine f13 () + !$omp declare variant (f1) match(user) ! { dg-error "expected '=' at .1." } + end subroutine + subroutine f14 () + !$omp declare variant (f1) match(user=) ! { dg-error "expected '\\\{' at .1." } + end subroutine + subroutine f15 () + !$omp declare variant (f1) match(user= ! { dg-error "expected '\\\{' at .1." } + end subroutine + subroutine f16 () + !$omp declare variant (f1) match(user={) ! { dg-error "expected trait selector name at .1." } + end subroutine + subroutine f17 () + !$omp declare variant (f1) match(user={}) ! { dg-error "expected trait selector name at .1." } + end subroutine + subroutine f18 () + !$omp declare variant (f1) match(user={condition}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f19 () + !$omp declare variant (f1) match(user={condition(}) ! { dg-error "expected expression at .1." } + end subroutine + subroutine f20 () + !$omp declare variant (f1) match(user={condition()}) ! { dg-error "expected expression at .1." } + end subroutine + subroutine f21 () + !$omp declare variant (f1) match(user={condition(f1)}) ! { dg-error "expected expression at .1." } + end subroutine + subroutine f22 () + !$omp declare variant (f1) match(user={condition(1, 2, 3)}) ! { dg-error "expected '\\)' at .1." } + end subroutine + subroutine f23 () + !$omp declare variant (f1) match(construct={master}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f24 () + !$omp declare variant (f1) match(construct={teams,parallel,master,do}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f25 () + !$omp declare variant (f1) match(construct={parallel(1 ! { dg-error "selector 'parallel' does not accept any properties at .1." } + end subroutine + subroutine f26 () + !$omp declare variant (f1) match(construct={parallel(1)}) ! { dg-error "selector 'parallel' does not accept any properties at .1." } + end subroutine + subroutine f27 () + !$omp declare variant (f0) match(construct={simd(12)}) ! { dg-error "expected simd clause at .1." } + end subroutine + subroutine f32 () + !$omp declare variant (f1) match(device={kind}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f33 () + !$omp declare variant (f1) match(device={isa}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f34 () + !$omp declare variant (f1) match(device={arch}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f35 () + !$omp declare variant (f1) match(device={kind,isa,arch}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f36 () + !$omp declare variant (f1) match(device={kind(}) ! { dg-error "expected identifier or string literal at .1." } + end subroutine + subroutine f39 () + !$omp declare variant (f1) match(device={isa(1)}) ! { dg-error "expected identifier or string literal at .1." } + end subroutine + subroutine f40 () + !$omp declare variant (f1) match(device={arch(17)}) ! { dg-error "expected identifier or string literal at .1." } + end subroutine + subroutine f41 () + !$omp declare variant (f1) match(device={foobar(3)}) + end subroutine + subroutine f43 () + !$omp declare variant (f1) match(implementation={foobar(3)}) + end subroutine + subroutine f44 () + !$omp declare variant (f1) match(implementation={vendor}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f45 () + !$omp declare variant (f1) match(implementation={extension}) ! { dg-error "expected '\\(' at .1." } + end subroutine + subroutine f45a () + !$omp declare variant (f1) match(implementation={vendor()}) ! { dg-error "expected identifier or string literal at .1." } + end subroutine + subroutine f46 () + !$omp declare variant (f1) match(implementation={vendor(123-234)}) ! { dg-error "expected identifier or string literal at .1." } + end subroutine + subroutine f48 () + !$omp declare variant (f1) match(implementation={unified_address(yes)}) ! { dg-error "selector 'unified_address' does not accept any properties at .1." } + end subroutine + subroutine f49 () + !$omp declare variant (f1) match(implementation={unified_shared_memory(no)}) ! { dg-error "selector 'unified_shared_memory' does not accept any properties at .1." } + end subroutine + subroutine f50 () + !$omp declare variant (f1) match(implementation={dynamic_allocators(42)}) ! { dg-error "selector 'dynamic_allocators' does not accept any properties at .1." } + end subroutine + subroutine f51 () + !$omp declare variant (f1) match(implementation={reverse_offload()}) ! { dg-error "selector 'reverse_offload' does not accept any properties at .1." } + end subroutine + subroutine f52 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order}) ! { dg-error "expected '\\('" } + end subroutine + subroutine f56 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed,seq_cst)}) ! { dg-error "expected '\\)' at .1." } + end subroutine + subroutine f58 () + !$omp declare variant (f1) match(user={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'user' at .1." } + end subroutine + subroutine f59 () + !$omp declare variant (f1) match(construct={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f60 () + !$omp declare variant (f1) match(construct={parallel},foobar={bar}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." } + end subroutine + subroutine f64 () + !$omp declare variant (f1) match(construct={single}) ! { dg-error "selector 'single' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f65 () + !$omp declare variant (f1) match(construct={taskgroup}) ! { dg-error "selector 'taskgroup' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f66 () + !$omp declare variant (f1) match(construct={for}) ! { dg-error "selector 'for' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f67 () + !$omp declare variant (f1) match(construct={threadprivate}) ! { dg-error "selector 'threadprivate' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f68 () + !$omp declare variant (f1) match(construct={critical}) ! { dg-error "selector 'critical' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f69 () + !$omp declare variant (f1) match(construct={task}) ! { dg-error "selector 'task' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f70 () + !$omp declare variant (f1) match(construct={taskloop}) ! { dg-error "selector 'taskloop' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f71 () + !$omp declare variant (f1) match(construct={sections}) ! { dg-error "selector 'sections' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f72 () + !$omp declare variant (f1) match(construct={section}) ! { dg-error "selector 'section' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f73 () + !$omp declare variant (f1) match(construct={workshare}) ! { dg-error "selector 'workshare' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f74 () + !$omp declare variant (f1) match(construct={requires}) ! { dg-error "selector 'requires' not allowed for context selector set 'construct' at .1." } + end subroutine + subroutine f75 () + !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." } + end subroutine + subroutine f76 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." } + end subroutine + subroutine f77 () + !$omp declare variant (f1) match(user={condition(score(f76):1)}) ! { dg-error "score argument must be constant integer expression at .1." } + end subroutine + subroutine f78 () + !$omp declare variant (f1) match(user={condition(score(-130):1)}) ! { dg-error "score argument must be non-negative" } + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-2a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-2a.f90 @@ -0,0 +1,53 @@ +module main + implicit none +contains + subroutine f1 () + end subroutine + subroutine f28 () + !$omp declare variant (f1) match(construct={parallel},construct={do}) ! { dg-error "selector set 'construct' specified more than once" } + end subroutine + subroutine f29 () + !$omp declare variant (f1) match(construct={parallel},construct={parallel}) ! { dg-error "selector set 'construct' specified more than once" } + end subroutine + subroutine f30 () + !$omp declare variant (f1) match(user={condition(0)},construct={target},user={condition(0)}) ! { dg-error "selector set 'user' specified more than once" } + end subroutine + subroutine f31 () + !$omp declare variant (f1) match(user={condition(0)},user={condition(1)}) ! { dg-error "selector set 'user' specified more than once" } + end subroutine + subroutine f37 () + !$omp declare variant (f1) match(device={kind(unknown)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" } + end subroutine + subroutine f38 () + !$omp declare variant (f1) match(device={kind(unknown,foobar)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" } + ! { dg-warning "unknown property 'foobar' of 'kind' selector" "" { target *-*-* } 22 } + end subroutine + subroutine f42 () + !$omp declare variant (f1) match(device={arch(x86_64)},device={isa(avx512vl)}) ! { dg-error "selector set 'device' specified more than once" } + end subroutine + subroutine f47 () + !$omp declare variant (f1) match(implementation={vendor("foobar")}) ! { dg-warning "unknown property '.foobar.' of 'vendor' selector" } + end subroutine + subroutine f53 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(acquire)}) ! { dg-error "incorrect property 'acquire' of 'atomic_default_mem_order' selector" } + end subroutine + subroutine f54 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(release)}) ! { dg-error "incorrect property 'release' of 'atomic_default_mem_order' selector" } + end subroutine + subroutine f55 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(foobar)}) ! { dg-error "incorrect property 'foobar' of 'atomic_default_mem_order' selector" } + end subroutine + subroutine f57 () + !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed)},& + !$omp & implementation={atomic_default_mem_order(relaxed)}) ! { dg-error "selector set 'implementation' specified more than once" "" { target *-*-* } 41 } + end subroutine + subroutine f61 () + !$omp declare variant (f1) match(construct={parallel,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" } + end subroutine + subroutine f62 () + !$omp declare variant (f1) match(construct={target,parallel,do,simd,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" } + end subroutine + subroutine f63 () + !$omp declare variant (f1) match(construct={target,teams,teams}) ! { dg-error "selector 'teams' specified more than once in set 'construct'" } + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-3.f90 @@ -0,0 +1,237 @@ +module main +contains + subroutine f1 () + end subroutine + subroutine f2 () + !$omp declare variant (f1) match (construct={target}) + end subroutine + subroutine f3 () + end subroutine + subroutine f4 () + !$omp declare variant (f3) match (construct={teams}) + end subroutine + subroutine f5 () + end subroutine + subroutine f6 () + !$omp declare variant (f5) match (construct={parallel}) + end subroutine + subroutine f7 () + end subroutine + subroutine f8 () + !$omp declare variant (f7) match (construct={do}) + end subroutine + subroutine f9 () + end subroutine + subroutine f10 () + !$omp declare variant (f9) match (construct={target,teams,parallel,do}) + end subroutine + subroutine f11 () + end subroutine + subroutine f12 () + !$omp declare variant (f11) match (construct={teams,do,parallel}) + end subroutine + subroutine f13 () + end subroutine + subroutine f14 () + !$omp declare variant (f13) match (device={kind(any)}) + end subroutine + subroutine f15 () + !$omp declare variant (f13) match (device={kind("host")}) + end subroutine + subroutine f16 () + !$omp declare variant (f13) match (device={kind(nohost)}) + end subroutine + subroutine f17 () + !$omp declare variant (f13) match (device={kind(cpu)}) + end subroutine + subroutine f18 () + !$omp declare variant (f13) match (device={kind("gpu")}) + end subroutine + subroutine f19 () + !$omp declare variant (f13) match (device={kind(fpga)}) + end subroutine + subroutine f20 () + !$omp declare variant (f13) match (device={kind(any,any)}) + end subroutine + subroutine f21 () + !$omp declare variant (f13) match (device={kind(host,nohost)}) + end subroutine + subroutine f22 () + !$omp declare variant (f13) match (device={kind("cpu","gpu","fpga")}) + end subroutine + subroutine f23 () + !$omp declare variant (f13) match (device={kind(any,cpu,nohost)}) + end subroutine + subroutine f24 () + !$omp declare variant (f13) match (device={isa(avx)}) + end subroutine + subroutine f25 () + !$omp declare variant (f13) match (device={isa(sse4,"avx512f",avx512vl,avx512bw)}) + end subroutine + subroutine f26 () + !$omp declare variant (f13) match (device={arch("x86_64")}) + end subroutine + subroutine f27 () + !$omp declare variant (f13) match (device={arch(riscv64)}) + end subroutine + subroutine f28 () + !$omp declare variant (f13) match (device={arch(nvptx)}) + end subroutine + subroutine f29 () + !$omp declare variant (f13) match (device={arch(x86_64),isa("avx512f","avx512vl"),kind(cpu)}) + end subroutine + subroutine f30 () + !$omp declare variant (f13) match (implementation={vendor(amd)}) + end subroutine + subroutine f31 () + !$omp declare variant (f13) match (implementation={vendor(arm)}) + end subroutine + subroutine f32 () + !$omp declare variant (f13) match (implementation={vendor("bsc")}) + end subroutine + subroutine f33 () + !$omp declare variant (f13) match (implementation={vendor(cray)}) + end subroutine + subroutine f34 () + !$omp declare variant (f13) match (implementation={vendor(fujitsu)}) + end subroutine + subroutine f35 () + !$omp declare variant (f13) match (implementation={vendor(gnu)}) + end subroutine + subroutine f36 () + !$omp declare variant (f13) match (implementation={vendor(ibm)}) + end subroutine + subroutine f37 () + !$omp declare variant (f13) match (implementation={vendor("intel")}) + end subroutine + subroutine f38 () + !$omp declare variant (f13) match (implementation={vendor(llvm)}) + end subroutine + subroutine f39 () + !$omp declare variant (f13) match (implementation={vendor(pgi)}) + end subroutine + subroutine f40 () + !$omp declare variant (f13) match (implementation={vendor(ti)}) + end subroutine + subroutine f41 () + !$omp declare variant (f13) match (implementation={vendor(unknown)}) + end subroutine + subroutine f42 () + !$omp declare variant (f13) match (implementation={vendor(gnu,llvm,intel,ibm)}) + end subroutine + subroutine f43 () + !$omp declare variant (f13) match (implementation={extension(my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" } + end subroutine + subroutine f44 () + !$omp declare variant (f13) match (implementation={extension(some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" } + ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 } + end subroutine + subroutine f45 () + !$omp declare variant (f13) match (implementation={unified_shared_memory}) + end subroutine + subroutine f46 () + !$omp declare variant (f13) match (implementation={unified_address}) + end subroutine + subroutine f47 () + !$omp declare variant (f13) match (implementation={dynamic_allocators}) + end subroutine + subroutine f48 () + !$omp declare variant (f13) match (implementation={reverse_offload}) + end subroutine + subroutine f49 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(seq_cst)}) + end subroutine + subroutine f50 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(relaxed)}) + end subroutine + subroutine f51 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(acq_rel)}) + end subroutine + subroutine f52 () + !$omp declare variant (f14) match (implementation={atomic_default_mem_order(acq_rel),vendor(gnu),& + !$omp& unified_address,extension(foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 } + end subroutine + subroutine f53 () + !$omp declare variant (f13) match (implementation={vendor(score(3):amd)}) + end subroutine + subroutine f54 () + !$omp declare variant (f13) match (implementation={vendor(score(4):"arm")}) + end subroutine + subroutine f55 () + !$omp declare variant (f13) match (implementation={vendor(score(5):bsc)}) + end subroutine + subroutine f56 () + !$omp declare variant (f13) match (implementation={vendor(score(6):cray)}) + end subroutine + subroutine f57 () + !$omp declare variant (f13) match (implementation={vendor(score(7):fujitsu)}) + end subroutine + subroutine f58 () + !$omp declare variant (f13) match (implementation={vendor(score(8):gnu)}) + end subroutine + subroutine f59 () + !$omp declare variant (f13) match (implementation={vendor(score(9):ibm)}) + end subroutine + subroutine f60 () + !$omp declare variant (f13) match (implementation={vendor(score(10):intel)}) + end subroutine + subroutine f61 () + !$omp declare variant (f13) match (implementation={vendor(score(11):llvm)}) + end subroutine + subroutine f62 () + !$omp declare variant (f13) match (implementation={vendor(score(12):pgi)}) + end subroutine + subroutine f63 () + !$omp declare variant (f13) match (implementation={vendor(score(13):"ti")}) + end subroutine + subroutine f64 () + !$omp declare variant (f13) match (implementation={vendor(score(14):unknown)}) + end subroutine + subroutine f65 () + !$omp declare variant (f13) match (implementation={vendor(score(15):gnu,llvm,intel,ibm)}) + end subroutine + subroutine f66 () + !$omp declare variant (f13) match (implementation={extension(score(16):my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" } + end subroutine + subroutine f67 () + !$omp declare variant (f13) match (implementation={extension(score(17):some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" } + end subroutine ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 } + subroutine f68 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(18):seq_cst)}) + end subroutine + subroutine f69 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(19):relaxed)}) + end subroutine + subroutine f70 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(20):acq_rel)}) + end subroutine + subroutine f71 () + !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(21):acq_rel),& + !$omp& vendor(score(22):gnu),unified_address,extension(score(22):foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 } + end subroutine + subroutine f72 () + !$omp declare variant (f13) match (user={condition(0)}) + end subroutine + subroutine f73 () + !$omp declare variant (f13) match (user={condition(272-272*1)}) + end subroutine + subroutine f74 () + !$omp declare variant (f13) match (user={condition(score(25):1)}) + end subroutine + subroutine f75 () + !$omp declare variant (f13) match (device={kind(any,"any")}) + end subroutine + subroutine f76 () + !$omp declare variant (f13) match (device={kind("any","any")}) + end subroutine + subroutine f77 () + !$omp declare variant (f13) match (device={kind("any",any)}) + end subroutine + subroutine f78 () + !$omp declare variant (f13) match (implementation={vendor(nvidia)}) + end subroutine + subroutine f79 () + !$omp declare variant (f13) match (user={condition(score(0):0)}) + end subroutine + + end module Index: Fortran/gfortran/regression/gomp/declare-variant-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-4.f90 @@ -0,0 +1,62 @@ +program main + implicit none +contains + function f6 (x, y, z) + real (kind = 8) :: f6 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + + interface + function f1 (x, y, z) + real (kind = 8) :: f1 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + end function + + function f2 (x, y, z) + real (kind = 8) :: f2 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + end function + + function f3 (x, y, z) + real (kind = 8) :: f3 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + end function + + function f4 (x, y, z) + real (kind = 8) :: f4 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + end function + + function f5 (x, y, z) + real (kind = 8) :: f5 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real (kind = 4), intent(in) :: z + end function + end interface + + !$omp declare variant (f1) match (user={condition(1)}) + !$omp declare variant (f2) match (user={condition(score(1):1)}) + !$omp declare variant (f3) match (user={condition(score(3):1)}) + !$omp declare variant (f4) match (user={condition(score(2):1)}) + !$omp declare variant (f5) match (implementation={vendor(gnu)}) + + f6 = z + x + y + end function + + function test (x) + real (kind = 8) :: test + integer, intent(in) :: x + + test = f6 (x, int (x, kind = 8), 3.5) + end function +end program Index: Fortran/gfortran/regression/gomp/declare-variant-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-5.f90 @@ -0,0 +1,75 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-mavx2" } + +module main + implicit none +contains + function f1 (x, y, z) + integer, dimension(4) :: f1 + real, dimension(4), intent(in) :: x, y + real, intent(out) :: z + + f1 = x + end function + + function f2 (x, y, z) + integer, dimension(8) :: f2 + real, dimension(8), intent(in) :: x, y + real, intent(out) :: z + + f2 = x + end function + + function f3 (x, y, z) + integer, dimension(4) :: f3 + real, dimension(4), intent(in) :: x, z + integer, intent(in) :: y + + f3 = x + end function + + integer function f4 (x, y, z) + real, intent(in) :: x, y + real, intent(out) :: z + !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))}) + !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)}) + end function + + integer function f5 (x, y) + integer, intent(in) :: x, y + !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))}) + end function + + subroutine test (x, y, z, w) + integer, dimension(8192), intent(inout) :: x + real, dimension(8192), intent(inout) :: y, z + real, pointer, intent(out) :: w + integer :: i + + !$omp parallel + !$omp do simd aligned (w:16) + do i = 1, 1024 + x(i) = f4 (y(i), z(i), w) + end do + !$omp end do simd + !$omp end parallel + + !$omp parallel do simd aligned (w:16) simdlen(4) + do i = 1025, 2048 + x(i) = f4 (y(i), z(i), w) + end do + !$omp end parallel do simd + + !$omp simd aligned (w:16) + do i = 2049, 4096 + x(i) = f4 (y(i), z(i), w) + end do + !$omp end simd + + !$omp simd + do i = 4097, 8192 + if (x(i) .gt. 10) x(i) = f5 (x(i), i) + end do + !$omp end simd + end subroutine +end module Index: Fortran/gfortran/regression/gomp/declare-variant-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-6.f90 @@ -0,0 +1,188 @@ +module main + implicit none +contains + function f1 (x, y, z) + real (kind = 8) :: f1 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + + f1 = 0.0 + end function + + function f2 (x, y, z) + real (kind = 8) :: f2 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + + f2 = 0.0 + end function + + function f3 (x, y, z) + real (kind = 8) :: f3 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f1) match (user={condition(0)},construct={parallel}) + f3 = 0.0 + end function + + function f4 (x, y, z) + real (kind = 8) :: f4 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f1) match (construct={parallel},user={condition(score(1):1)}) + f4 = 0.0 + end function + + function f5 (x, y, z) + real (kind = 8) :: f5 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + f5 = 0.0 + end function + + function f6 (x, y, z) + real (kind = 8) :: f6 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f5) match (user={condition(0)}) ! { dg-error "'f5' used as a variant with incompatible 'construct' selector sets" } + f6 = 0.0 + end function + + function f7 (x, y, z) + real (kind = 8) :: f7 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f5) match (construct={parallel},user={condition(score(1):1)}) + f7 = 0.0 + end function + + function f8 (x, y, z) + real (kind = 8) :: f8 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + f8 = 0.0 + end function + + function f9 (x, y, z) + real (kind = 8) :: f9 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f8) match (user={condition(0)},construct={do}) ! { dg-error "'f8' used as a variant with incompatible 'construct' selector sets" } + f9 = 0.0 + end function + + function f10 (x, y, z) + real (kind = 8) :: f10 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f8) match (user={condition(1)}) + f10 = 0.0 + end function + + function f11 (x, y, z) + real (kind = 8) :: f11 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + f11 = 0.0 + end function + + function f12 (x, y, z) + real (kind = 8) :: f12 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f11) match (construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" } + f12 = 0.0 + end function + + function f13 (x, y, z) + real (kind = 8) :: f13 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f11) match (user={condition(score(1):1)},construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" } + f13 = 0.0 + end function + + function f14 (x, y, z) + real (kind = 8) :: f14 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f11) match (implementation={vendor(gnu)},construct={target,teams,parallel}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" } + f14 = 0.0 + end function + + function f15 (x, y, z) + real (kind = 8) :: f15 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f11) match (device={kind(any)},construct={teams,parallel}) + f15 = 0.0 + end function + + function f16 (x, y, z) + real (kind = 8) :: f16 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + f16 = 0.0 + end function + + function f17 (x, y, z) + real (kind = 8) :: f17 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f16) match (construct={teams,parallel}) ! { dg-error "'f16' used as a variant with incompatible 'construct' selector sets" } + f17 = 0.0 + end function + + function f18 (x, y, z) + real (kind = 8) :: f18 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f16) match(construct={teams,parallel,do}) + f18 = 0.0 + end function + + function f19 (x, y, z) + real (kind = 8) :: f19 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + f19 = 0.0 + end function + + function f20 (x, y, z) + real (kind = 8) :: f20 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f19) match (construct={parallel}) ! { dg-error "'f19' used as a variant with incompatible 'construct' selector sets" } + f20 = 0.0 + end function + + function f21 (x, y, z) + real (kind = 8) :: f21 + integer, intent(in) :: x + integer (kind = 8), intent(in) :: y + real :: z + !$omp declare variant (f19) match (construct={do},implementation={vendor(gnu,llvm)}) + f21 = 0.0 + end function + +end module Index: Fortran/gfortran/regression/gomp/declare-variant-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-7.f90 @@ -0,0 +1,93 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-mavx2" } + +module main + implicit none +contains + function f1 (x, y, z) + integer, dimension(4) :: f1 + real, dimension(4), intent(in) :: x, y + real, intent(out) :: z + + f1 = x + end function + + function f2 (x, y, z) + integer, dimension(8) :: f2 + real, dimension(8), intent(in) :: x, y + real, intent(out) :: z + + f2 = x + end function + + function f3 (x, y, z) + integer, dimension(4) :: f3 + real, dimension(4), intent(in) :: x, z + integer, intent(in) :: y + + f3 = x + end function + + integer function f4 (x, y, z) + real, intent(in) :: x, y + real, pointer, intent(out) :: z + !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f5 (u, v, w) + real, intent(in) :: u, v + real, pointer, intent(out) :: w + !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),simdlen(8*2-12),aligned(w:16),notinbranch)}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f6 (u, v, w) + real, intent(in) :: u, v + real, pointer, intent(out) :: w + !$omp declare variant (f1) match (construct={parallel,do,simd(linear(w),notinbranch,simdlen(4),aligned(w:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f7 (u, v, w) + real, intent(in) :: u, v + real, pointer, intent(out) :: w + !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w:8))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f8 (u, v, w) + real, intent(in) :: u, v + real, pointer, intent(out) :: w + !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w))}) + end function + + integer function f9 (x, y, z) + real, intent(in) :: x, y + real, pointer, intent(out) :: z + !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f10 (x, y, q) + real, intent(in) :: x, y + real, pointer, intent(out) :: q + !$omp declare variant (f2) match (construct={do,simd(notinbranch,simdlen(2+2+4),uniform (q))}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f11 (x, y, z) + real, intent(in) :: x, y + real, pointer, intent(out) :: z + !$omp declare variant (f2) match (construct={do,simd(linear(z:2),simdlen(8),notinbranch)}) + end function + + integer function f12 (x, y) + integer, intent(in) :: x, y + !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f13 (x, q) + integer, intent(in) :: x, q + !$omp declare variant (f3) match (construct={simd(inbranch, simdlen (5-1), linear (q:4-3))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" } + end function + + integer function f14 (x, q) + integer, intent(in) :: x, q + !$omp declare variant (f3) match (construct={simd(inbranch,simdlen(4),linear(q:2))}) + end function +end module Index: Fortran/gfortran/regression/gomp/declare-variant-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-8.f90 @@ -0,0 +1,218 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + !$omp requires atomic_default_mem_order(seq_cst) + !$omp declare target to (test3) +contains + subroutine f01 () + end subroutine + + subroutine f02 () + !$omp declare variant (f01) match (user={condition(6 == 7)},implementation={vendor(gnu)}) + end subroutine + + subroutine f03 () + end subroutine + + subroutine f04 () + !$omp declare variant (f03) match (user={condition(6 == 6)},implementation={atomic_default_mem_order(seq_cst)}) + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + !$omp declare variant (f05) match (user={condition(1)},implementation={atomic_default_mem_order(relaxed)}) + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + !$omp declare variant (f07) match (construct={parallel,do},device={kind("any")}) + end subroutine + + subroutine f09 () + end subroutine + + subroutine f10 () + !$omp declare variant (f09) match (construct={parallel,do},implementation={vendor("gnu")}) + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + !$omp declare variant (f11) match (construct={parallel,do}) + end subroutine + + subroutine f13 () + end subroutine + + subroutine f14 () + !$omp declare variant (f13) match (construct={parallel,do}) + end subroutine + + subroutine f15 () + !$omp declare target to (f13, f14) + end subroutine + + subroutine f16 () + !$omp declare variant (f15) match (implementation={vendor(llvm)}) + end subroutine + + subroutine f17 () + end subroutine + + subroutine f18 () + !$omp declare variant (f17) match (construct={target,parallel}) + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + !$omp declare variant (f19) match (construct={target,parallel}) + end subroutine + + subroutine f22 () + !$omp declare variant (f21) match (construct={teams,parallel}) + end subroutine + + subroutine f23 () + end subroutine + + subroutine f24 () + !$omp declare variant (f23) match (construct={teams,parallel,do}) + end subroutine + + subroutine f25 () + end subroutine + + subroutine f27 () + end subroutine + + subroutine f28 () + !$omp declare variant (f27) match (construct={teams,parallel,do}) + end subroutine + + subroutine f30 () + !$omp declare variant (f29) match (implementation={vendor(gnu)}) + end subroutine + + subroutine f31 () + end subroutine + + subroutine f32 () + !$omp declare variant (f31) match (construct={teams,parallel,do}) + end subroutine + + subroutine f33 () + end subroutine + + subroutine f34 () + !$omp declare variant (f33) match (device={kind("any\0any")}) ! { dg-warning "unknown property '.any..0any.' of 'kind' selector" } + end subroutine + + subroutine f35 () + end subroutine + + subroutine f36 () + !$omp declare variant (f35) match (implementation={vendor("gnu\0")}) ! { dg-warning "unknown property '.gnu..0.' of 'vendor' selector" } + end subroutine + + subroutine test1 () + integer :: i + + call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } } + call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" } } + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" } } + + !$omp parallel + !$omp do + do i = 1, 2 + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + !$omp end parallel + + !$omp parallel do + do i = 1, 2 + call f10 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + + !$omp do + do i = 1, 2 + !$omp parallel + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end do + !$omp end do + + !$omp parallel + !$omp target + !$omp do + do i = 1, 2 + call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + !$omp end target + !$omp end parallel + + call f16 () ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" } } + call f34 () ! { dg-final { scan-tree-dump-times "f34 \\\(\\\);" 1 "gimple" } } + call f36 () ! { dg-final { scan-tree-dump-times "f36 \\\(\\\);" 1 "gimple" } } + end subroutine + + subroutine test2 () + ! OpenMP 5.0 specifies that the 'target' trait should be added for + ! functions within a declare target block, but Fortran does not have + ! the notion of a declare target _block_, so the variant is not used here. + ! This may change in later versions of OpenMP. + + !$omp declare target + !$omp parallel + call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine + + subroutine test3 () + ! In the C version, this test was used to check that the + ! 'declare target to' form of the directive did not result in the variant + ! being used. + !$omp parallel + call f20 () ! { dg-final { scan-tree-dump-times "f20 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine + + subroutine f21 () + integer :: i + !$omp do + do i = 1, 2 + call f24 () ! { dg-final { scan-tree-dump-times "f23 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine + + subroutine f26 () + !$omp declare variant (f25) match (construct={teams,parallel}) + + integer :: i + !$omp do + do i = 1, 2 + call f28 () ! { dg-final { scan-tree-dump-times "f28 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine + + subroutine f29 () + integer :: i + !$omp do + do i = 1, 2 + call f32 () ! { dg-final { scan-tree-dump-times "f32 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine +end program Index: Fortran/gfortran/regression/gomp/declare-variant-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/declare-variant-9.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-additional-options "-cpp -fdump-tree-gimple" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + subroutine f01 () + end subroutine + subroutine f02 () + !$omp declare variant (f01) match (device={isa("avx512f",avx512bw)}) + end subroutine + subroutine f05 () + end subroutine + subroutine f06 () + !$omp declare variant (f05) match (device={kind(gpu)}) + end subroutine + subroutine f07 () + end subroutine + subroutine f08 () + !$omp declare variant (f07) match (device={kind("cpu")}) + end subroutine + subroutine f09 () + end subroutine + subroutine f10 () + !$omp declare variant (f09) match (device={isa(sm_35)}) + end subroutine + subroutine f11 () + end subroutine + subroutine f12 () + !$omp declare variant (f11) match (device={arch(nvptx)}) + end subroutine + subroutine f13 () + end subroutine + subroutine f14 () + !$omp declare variant (f13) match (device={arch("i386"),isa(sse4)}) + end subroutine + subroutine f17 () + end subroutine + subroutine f18 () + !$omp declare variant (f17) match (device={kind("any","fpga")}) + end subroutine + + subroutine test1 () + integer :: i; + call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } } + call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } + end subroutine + + subroutine test3 () + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } } + end subroutine +end program Index: Fortran/gfortran/regression/gomp/defaultmap-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-1.f90 @@ -0,0 +1,19 @@ +! PR fortran/92568 + +implicit none + +!$omp target defaultmap(bar) ! { dg-error "25: Expected ALLOC, TO, FROM, TOFROM, FIRSTPRIVATE, NONE or DEFAULT" } + +!$omp target defaultmap ( alloc: foo) ! { dg-error "34: Expected SCALAR, AGGREGATE, ALLOCATABLE or POINTER" } + +!$omp target defaultmap(alloc:scalar) defaultmap(none:Scalar) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category SCALAR" } + +!$omp target defaultmap(default:aggregate) defaultmap(tofrom) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category AGGREGATE" } + +!$omp target defaultmap(from:pointer) defaultmap(tofrom:pointer) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category POINTER" } + +!$omp target defaultmap(from:scalar) defaultmap(to:allocatable) defaultmap(tofrom:allocatable) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP for category ALLOCATABLE" } + +!$omp target defaultmap(from) defaultmap(to) ! { dg-error "DEFAULTMAP at .1. but prior DEFAULTMAP with unspecified category" } + +end Index: Fortran/gfortran/regression/gomp/defaultmap-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-2.f90 @@ -0,0 +1,108 @@ +! PR fortran/92568 +! +implicit none + type t + end type t + + integer :: ii + integer :: arr(5) + integer, allocatable :: aii, aarr(:) + integer, pointer :: pii, parr(:) + + character :: str1, str1arr(5), str1a, str1aarr(:), str1p, str1parr(:) + character(len=5) :: str5, str5arr(5), str5a, str5aarr(:), str5p, str5parr(:) + character(len=:) :: strXa, strXaarr(:), strXp, strXparr(:) + allocatable :: str1a, str1aarr, str5a, str5aarr, strXa, strXaarr + pointer :: str1p, str1parr, str5p, str5parr, strXp, strXparr + + type(t) :: dt, dtarr(5), dta, dtaarr(:), dtp, dtparr(:) + allocatable :: dta, dtaarr + pointer :: dtp, dtparr + + allocate(aii, aarr(5), str1a, str1aarr(5), dta, dtparr(5)) + allocate(pii, parr(5), str1p, str1parr(5), dtp, dtparr(5)) + allocate(character(len=7) :: strXa, strXaarr(5), strXp, strXparr(5)) + + + !$omp target defaultmap ( none ) ! { dg-note "enclosing 'target'" } + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + ! { dg-error "'ii' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'aii' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'pii' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + ! { dg-error "'str1' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'str1arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'str1a' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'str1aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'str1p' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'str1parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + ! { dg-error "'str5' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'str5arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'str5a' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'str5aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'str5p' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'str5parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + ! { dg-error "'strxa' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'strxaarr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'strxp' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'strxparr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + ! { dg-error "'dt' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'dtarr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'dta' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'dtaarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'dtp' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'dtparr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + !$omp end target + + + !$omp target defaultmap(none : scalar) defaultmap(none : aggregate) & + !$omp& defaultmap(none : allocatable) defaultmap(none : pointer) ! { dg-note "enclosing 'target'" } + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + ! { dg-error "'ii' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'aii' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'pii' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + ! { dg-error "'str1' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'str1arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'str1a' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'str1aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'str1p' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'str1parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + ! { dg-error "'str5' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'str5arr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'str5a' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'str5aarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'str5p' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'str5parr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + ! { dg-error "'strxa' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'strxaarr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'strxp' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'strxparr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + ! { dg-error "'dt' not specified in enclosing 'target'" "" { target *-*-* } .-1 } + ! { dg-error "'dtarr' not specified in enclosing 'target'" "" { target *-*-* } .-2 } + ! { dg-error "'dta' not specified in enclosing 'target'" "" { target *-*-* } .-3 } + ! { dg-error "'dtaarr' not specified in enclosing 'target'" "" { target *-*-* } .-4 } + ! { dg-error "'dtp' not specified in enclosing 'target'" "" { target *-*-* } .-5 } + ! { dg-error "'dtparr' not specified in enclosing 'target'" "" { target *-*-* } .-6 } + !$omp end target +end Index: Fortran/gfortran/regression/gomp/defaultmap-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-3.f90 @@ -0,0 +1,60 @@ +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/92568 +! +implicit none + type t + end type t + + integer :: ii + integer :: arr(5) + integer, allocatable :: aii, aarr(:) + integer, pointer :: pii, parr(:) + + character :: str1, str1arr(5), str1a, str1aarr(:), str1p, str1parr(:) + character(len=5) :: str5, str5arr(5), str5a, str5aarr(:), str5p, str5parr(:) + character(len=:) :: strXa, strXaarr(:), strXp, strXparr(:) + allocatable :: str1a, str1aarr, str5a, str5aarr, strXa, strXaarr + pointer :: str1p, str1parr, str5p, str5parr, strXp, strXparr + + type(t) :: dt, dtarr(5), dta, dtaarr(:), dtp, dtparr(:) + allocatable :: dta, dtaarr + pointer :: dtp, dtparr + + allocate(aii, aarr(5), str1a, str1aarr(5), dta, dtparr(5)) + allocate(pii, parr(5), str1p, str1parr(5), dtp, dtparr(5)) + allocate(character(len=7) :: strXa, strXaarr(5), strXp, strXparr(5)) + + + !$omp target defaultmap ( none ) & + !$omp& map(tofrom: ii, arr, aii, aarr, pii, parr) & + !$omp& map(tofrom: str1, str1arr, str1a, str1aarr, str1p, str1parr) & + !$omp& map(tofrom: str5, str5arr, str5a, str5aarr, str5p, str5parr) & + !$omp& map(tofrom: strXa, strXaarr, strXp, strXparr) & + !$omp& map(tofrom: dt, dtarr, dta, dtaarr, dtp, dtparr) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target + + + !$omp target defaultmap(none : scalar) defaultmap(none : aggregate) & + !$omp& defaultmap(none : allocatable) defaultmap(none : pointer) & + !$omp& map(alloc: ii, arr, aii, aarr, pii, parr) & + !$omp& map(alloc: str1, str1arr, str1a, str1aarr, str1p, str1parr) & + !$omp& map(alloc: str5, str5arr, str5a, str5aarr, str5p, str5parr) & + !$omp& map(alloc: strXa, strXaarr, strXp, strXparr) & + !$omp& map(alloc: dt, dtarr, dta, dtaarr, dtp, dtparr) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target +end + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:.* defaultmap\\(none\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(alloc:.* defaultmap\\(none:scalar\\) defaultmap\\(none:aggregate\\) defaultmap\\(none:allocatable\\) defaultmap\\(none:pointer\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/defaultmap-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-4.f90 @@ -0,0 +1,145 @@ +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/92568 +! +implicit none + type t + end type t + + integer :: ii + integer :: arr(5) + integer, allocatable :: aii, aarr(:) + integer, pointer :: pii, parr(:) + + character :: str1, str1arr(5), str1a, str1aarr(:), str1p, str1parr(:) + character(len=5) :: str5, str5arr(5), str5a, str5aarr(:), str5p, str5parr(:) + character(len=:) :: strXa, strXaarr(:), strXp, strXparr(:) + allocatable :: str1a, str1aarr, str5a, str5aarr, strXa, strXaarr + pointer :: str1p, str1parr, str5p, str5parr, strXp, strXparr + + type(t) :: dt, dtarr(5), dta, dtaarr(:), dtp, dtparr(:) + allocatable :: dta, dtaarr + pointer :: dtp, dtparr + + allocate(aii, aarr(5), str1a, str1aarr(5), dta, dtparr(5)) + allocate(pii, parr(5), str1p, str1parr(5), dtp, dtparr(5)) + allocate(character(len=7) :: strXa, strXaarr(5), strXp, strXparr(5)) + + + !$omp target defaultmap ( alloc ) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target + + !$omp target defaultmap(alloc : scalar) defaultmap(to : aggregate) & + !$omp& defaultmap(tofrom : allocatable) defaultmap(firstprivate : pointer) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target +end + +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(alloc:scalar\\) defaultmap\\(to:aggregate\\) defaultmap\\(tofrom:allocatable\\) defaultmap\\(firstprivate:pointer\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(alloc\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "firstprivate\\(dtp\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(pii\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str1p\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str5p\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(strxp\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*aii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:aii \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:arr \\\[len:" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[len:" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*dta \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dta \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dtarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dt \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*dtp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dtp \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:ii \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*pii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:pii \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*str1a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1a \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*str1p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1p \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*str5a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5a \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*str5p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5p \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxa \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\*strxp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxp \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:aarr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:arr \\\[len:" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[len:" 1 "gimple" } } + +! { dg-final { scan-tree-dump-times "map\\(to:dtaarr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dt \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtparr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*aii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*dta \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str1a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str5a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1aarr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5aarr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxaarr \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxaarr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxa \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxparr \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxparr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxp \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target num_teams\\(-2\\) thread_limit\\(0\\) defaultmap\\(alloc\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target num_teams\\(-2\\) thread_limit\\(0\\) defaultmap\\(alloc:scalar\\) defaultmap\\(to:aggregate\\) defaultmap\\(tofrom:allocatable\\) defaultmap\\(firstprivate:pointer\\)" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/defaultmap-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-5.f90 @@ -0,0 +1,145 @@ +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/92568 +! +implicit none + type t + end type t + + integer :: ii + integer :: arr(5) + integer, allocatable :: aii, aarr(:) + integer, pointer :: pii, parr(:) + + character :: str1, str1arr(5), str1a, str1aarr(:), str1p, str1parr(:) + character(len=5) :: str5, str5arr(5), str5a, str5aarr(:), str5p, str5parr(:) + character(len=:) :: strXa, strXaarr(:), strXp, strXparr(:) + allocatable :: str1a, str1aarr, str5a, str5aarr, strXa, strXaarr + pointer :: str1p, str1parr, str5p, str5parr, strXp, strXparr + + type(t) :: dt, dtarr(5), dta, dtaarr(:), dtp, dtparr(:) + allocatable :: dta, dtaarr + pointer :: dtp, dtparr + + allocate(aii, aarr(5), str1a, str1aarr(5), dta, dtparr(5)) + allocate(pii, parr(5), str1p, str1parr(5), dtp, dtparr(5)) + allocate(character(len=7) :: strXa, strXaarr(5), strXp, strXparr(5)) + + + !$omp target defaultmap ( to ) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target + + + ! FIXME: strXp disabled because of PR fortran/100965 + + !$omp target defaultmap(to : scalar) defaultmap(tofrom : aggregate) & + !$omp& defaultmap(firstprivate : allocatable) defaultmap(default : pointer) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + !strXa = ""; + strXaarr = ""; + ! strXp = "" + strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target +end + +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(to\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(to:scalar\\) defaultmap\\(tofrom:aggregate\\) defaultmap\\(firstprivate:allocatable\\) defaultmap\\(default:pointer\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "firstprivate\\(aarr\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(aii\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(dta\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(dtaarr\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str1a\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str1aarr\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str5a\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(str5aarr\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "firstprivate\\(strxaarr\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:aii \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dta \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dtp \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:pii \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1a \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1p \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5a \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5p \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxa \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxp \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*aii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtaarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*dta \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dt \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtparr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*dtp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:dtarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:dt \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*dtp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*pii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str1arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str1 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str1p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str5arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str5 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str5p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:ii \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*pii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*str1a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*str1p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*str5a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5parr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*str5p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxaarr \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxaarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxparr \\\[len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxparr \\\[pointer set, len:" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\*strxp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target num_teams\\(-2\\) thread_limit\\(0\\) defaultmap\\(to\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target num_teams\\(-2\\) thread_limit\\(0\\) defaultmap\\(to:scalar\\) defaultmap\\(tofrom:aggregate\\) defaultmap\\(firstprivate:allocatable\\) defaultmap\\(default:pointer\\)" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/defaultmap-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-6.f90 @@ -0,0 +1,104 @@ +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +! +! PR fortran/92568 +! +implicit none + type t + end type t + + integer :: ii + integer :: arr(5) + integer, allocatable :: aii, aarr(:) + integer, pointer :: pii, parr(:) + + character :: str1, str1arr(5), str1a, str1aarr(:), str1p, str1parr(:) + character(len=5) :: str5, str5arr(5), str5a, str5aarr(:), str5p, str5parr(:) + character(len=:) :: strXa, strXaarr(:), strXp, strXparr(:) + allocatable :: str1a, str1aarr, str5a, str5aarr, strXa, strXaarr + pointer :: str1p, str1parr, str5p, str5parr, strXp, strXparr + + type(t) :: dt, dtarr(5), dta, dtaarr(:), dtp, dtparr(:) + allocatable :: dta, dtaarr + pointer :: dtp, dtparr + + allocate(aii, aarr(5), str1a, str1aarr(5), dta, dtparr(5)) + allocate(pii, parr(5), str1p, str1parr(5), dtp, dtparr(5)) + allocate(character(len=7) :: strXa, strXaarr(5), strXp, strXparr(5)) + + + !$omp target defaultmap ( default ) + ii = 42; arr = 42; aii = 42; aarr = 42; pii = 42; parr = 42 + str1 = ""; str1arr = ""; str1a = ""; str1aarr = ""; str1p = ""; str1parr = "" + str5 = ""; str5arr = ""; str5a = ""; str5aarr = ""; str5p = ""; str5parr = "" + strXa = ""; strXaarr = ""; strXp = ""; strXparr = "" + dt = t(); dtarr = t(); dta = t(); dtaarr = t(); dtp = t(); dtparr = t() + !$omp end target + +end + +! { dg-final { scan-tree-dump-times "#pragma omp target defaultmap\\(default\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "firstprivate\\(ii\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:aii \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dta \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:dtp \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:pii \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1a \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str1p \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5a \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:str5p \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxa \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(alloc:strxp \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(always_pointer:\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[pointer assign, bias: 0\\\]\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtaarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:dtparr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*aii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxparr\\\] \\*\\) strxparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:\\.strxaarr\\\] \\* restrict\\) strxaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\*\\) str5parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:5\\\] \\* restrict\\) str5aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\*\\) str1parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict\\) str1aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) parr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(struct t\\\[0:\\\] \\*\\) dtparr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(struct t\\\[0:\\\] \\* restrict\\) dtaarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aarr\\.data \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*dta \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:dtarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:dt \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*dtp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*pii \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str1a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str1arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str1 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str1p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str5a \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str5arr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str5 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*str5p \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*strxp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:parr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str1parr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5aarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:str5parr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxaarr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxaarr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxa \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxparr \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:strxparr \\\[pointer set, len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(to:\\.strxp \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp target num_teams\\(-2\\) thread_limit\\(0\\) defaultmap\\(default\\)" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/defaultmap-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/defaultmap-7.f90 @@ -0,0 +1,24 @@ +! PR fortran/92568 +! +! { dg-additional-options "-fdump-tree-original" } +! { dg-additional-options "-fdump-tree-gimple" } +implicit none + integer :: ii, aa, pp + allocatable :: aa + pointer :: pp + character :: str + character(len=2) :: str2 + +!$omp target + ii = 1 + aa = 5 + pp = 7 + str = '1' + str2 = '12' +!$omp end target +end +! { dg-final { scan-tree-dump-times "firstprivate\\(ii\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*aa" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:\\*pp" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str2 \\\[len:" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "map\\(tofrom:str \\\[len:" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/depend-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-1.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + +subroutine foo (x) + integer :: x(5, *) +!$omp parallel +!$omp single +!$omp task depend(in:x(:,5)) +!$omp end task +!$omp task depend(in:x(5,:)) ! { dg-error "Rightmost upper bound of assumed size array section|proper array section" } +!$omp end task +!$omp end single +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/depend-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-4.f90 @@ -0,0 +1,261 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple -fdump-tree-original" } + +! Check that 'omp depobj's depend and 'omp task/... depend' depend on +! the same variable + +! For pointers, it depends on the address of the pointer target +! For allocatable, on the allocated memory address + +subroutine foo(dss, dsp, dsa, daa, daaa, daap, doss, dosp, dosa, doaa, doaaa, doaap, & + dssv, dossv) + !use omp_lib + use iso_c_binding, only: c_intptr_t + implicit none (type, external) + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer :: ss, sp, sa, aa(4), aaa(:), aap(:) + integer :: dss, dsp, dsa, daa(4), daaa(:), daap(:) + integer :: doss, dosp, dosa, doaa(4), doaaa(:), doaap(:) + optional :: doss, dosp, dosa, doaa, doaaa, doaap + allocatable :: sa, aaa, dsa, daaa, dosa, doaaa + pointer :: sp, aap, dsp, daap, dosp, doaap + integer, value :: dssv, dossv + optional :: dossv + + integer(omp_depend_kind) :: object(20) + integer(omp_depend_kind) :: elem(9) + + !$omp depobj(object(1)) depend(in: ss) + !$omp depobj(object(2)) depend(in: sp) + !$omp depobj(object(3)) depend(in: sa) + !$omp depobj(object(4)) depend(in: aa) + !$omp depobj(object(5)) depend(in: aaa) + !$omp depobj(object(6)) depend(in: aap) + !$omp depobj(object(7)) depend(in: dss) + !$omp depobj(object(8)) depend(in: dsp) + !$omp depobj(object(9)) depend(in: dsa) + !$omp depobj(object(10)) depend(in: daa) + !$omp depobj(object(11)) depend(in: daaa) + !$omp depobj(object(12)) depend(in: daap) + !$omp depobj(object(13)) depend(in: doss) + !$omp depobj(object(14)) depend(in: dosp) + !$omp depobj(object(15)) depend(in: dosa) + !$omp depobj(object(16)) depend(in: doaa) + !$omp depobj(object(17)) depend(in: doaaa) + !$omp depobj(object(18)) depend(in: doaap) + !$omp depobj(object(19)) depend(in: dssv) + !$omp depobj(object(20)) depend(in: dossv) + + !$omp depobj(elem(1)) depend(in: aa(2)) + !$omp depobj(elem(2)) depend(in: aaa(2)) + !$omp depobj(elem(3)) depend(in: aap(2)) + !$omp depobj(elem(4)) depend(in: daa(2)) + !$omp depobj(elem(5)) depend(in: daaa(2)) + !$omp depobj(elem(6)) depend(in: daap(2)) + !$omp depobj(elem(7)) depend(in: doaa(2)) + !$omp depobj(elem(8)) depend(in: doaaa(2)) + !$omp depobj(elem(9)) depend(in: doaap(2)) + + !$omp parallel + !$omp single + !$omp task depend(out: ss) + ss = 4 + !$omp end task + !$omp task depend(out: sp) + sp = 4 + !$omp end task + !$omp task depend(out: sa) + sa = 4 + !$omp end task + !$omp task depend(out: aa) + aa = 4 + !$omp end task + !$omp task depend(out: aaa) + aaa = 4 + !$omp end task + !$omp task depend(out: aap) + aap = 4 + !$omp end task + !$omp task depend(out: dss) + dss = 4 + !$omp end task + !$omp task depend(out: dsp) + dsp = 4 + !$omp end task + !$omp task depend(out: dsa) + dsa = 4 + !$omp end task + !$omp task depend(out: daa) + daa = 4 + !$omp end task + !$omp task depend(out: daaa) + daaa = 4 + !$omp end task + !$omp task depend(out: daap) + daap = 4 + !$omp end task + !$omp task depend(out: doss) + doss = 4 + !$omp end task + !$omp task depend(out: dosp) + dosp = 4 + !$omp end task + !$omp task depend(out: dosa) + dosa = 4 + !$omp end task + !$omp task depend(out: doaa) + doaa = 4 + !$omp end task + !$omp task depend(out: doaaa) + doaaa = 4 + !$omp end task + !$omp task depend(out: doaap) + doaap = 4 + !$omp end task + !$omp task depend(out: dossv) + dossv = 4 + !$omp end task + !$omp task depend(out: dssv) + dssv = 4 + !$omp end task + + !$omp task depend(out: aa(2)) + aa(2) = 4 + !$omp end task + !$omp task depend(out: aaa(2)) + aaa(2) = 4 + !$omp end task + !$omp task depend(out: aap(2)) + aap(2) = 4 + !$omp end task + !$omp task depend(out: daa(2)) + daa(2) = 4 + !$omp end task + !$omp task depend(out: daaa(2)) + daaa(2) = 4 + !$omp end task + !$omp task depend(out: daap(2)) + daap(2) = 4 + !$omp end task + !$omp task depend(out: doaa(2)) + doaa(2) = 4 + !$omp end task + !$omp task depend(out: doaaa(2)) + doaaa(2) = 4 + !$omp end task + !$omp task depend(out: doaap(2)) + doaap(2) = 4 + !$omp end task + !$omp end single + !$omp end parallel +end + +subroutine bar + implicit none (type, external) + integer :: depvar, x + + x = 7 + !$omp parallel + !$omp single + !$omp task depend(out: depvar) + x =5 + !$omp end task + !$omp task depend(in: depvar) + if (x /= 5) stop + !$omp end task + !$omp end single + !$omp end parallel +end + +! depvar - only used for dependency, but should still be used in depend: + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:depvar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(in:depvar\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "&object\\\[0\\\] = &ss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[1\\\] = sp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[2\\\] = sa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[3\\\] = &aa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[4\\\] = .integer.kind=4.\\\[0:\\\] \\* restrict\\) aaa.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[5\\\] = .integer.kind=4.\\\[0:\\\] \\*\\) aap.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[6\\\] = dss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[7\\\] = \\*dsp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[8\\\] = \\*dsa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[9\\\] = daa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[10\\\] = .integer.kind=4.\\\[0:\\\] \\* restrict\\) daaa->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[11\\\] = .integer.kind=4.\\\[0:\\\] \\*\\) daap->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[12\\\] = doss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[13\\\] = \\*dosp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[14\\\] = \\*dosa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[15\\\] = doaa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[16\\\] = .integer.kind=4.\\\[0:\\\] \\* restrict\\) doaaa->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[17\\\] = .integer.kind=4.\\\[0:\\\] \\*\\) doaap->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[18\\\] = &dssv;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[19\\\] = &dossv;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "&elem\\\[0\\\] = &aa\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[1\\\] = &\\(\\*\\(integer.kind=4.\\\[0:\\\] \\* restrict\\) aaa.data\\)\\\[aaa.offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[2\\\] = \\(integer.kind=4. \\*\\) \\(aap.data \\+ .sizetype. \\(\\(aap.offset \\+ aap.dim\\\[0\\\].stride \\* 2\\) \\* aap.span\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[3\\\] = &\\(\\*daa\\)\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[4\\\] = &\\(\\*\\(integer.kind=4.\\\[0:\\\] \\* restrict\\) daaa->data\\)\\\[daaa->offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[5\\\] = \\(integer.kind=4. \\*\\) \\(daap->data \\+ .sizetype. \\(\\(daap->offset \\+ daap->dim\\\[0\\\].stride \\* 2\\) \\* daap->span\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[6\\\] = &\\(\\*doaa\\)\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[7\\\] = &\\(\\*\\(integer.kind=4.\\\[0:\\\] \\* restrict\\) doaaa->data\\)\\\[doaaa->offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[8\\\] = \\(integer.kind=4. \\*\\) \\(doaap->data \\+ .sizetype. \\(\\(doaap->offset \\+ doaap->dim\\\[0\\\].stride \\* 2\\) \\* doaap->span\\)\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:ss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*sp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*sa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:aa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aaa.data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) aap.data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*dss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dsp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dsa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*daa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) daaa->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) daap->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*doss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dosp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dosa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*doaa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) doaaa->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) doaap->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:aa\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) aaa.data\\)\\\[aaa.offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\) \\*\\) \\(aap.data \\+ \\(sizetype\\) \\(\\(aap.offset \\+ aap.dim\\\[0\\\].stride \\* 2\\) \\* aap.span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*daa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) daaa->data\\)\\\[daaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\) \\*\\) \\(daap->data \\+ \\(sizetype\\) \\(\\(daap->offset \\+ daap->dim\\\[0\\\].stride \\* 2\\) \\* daap->span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*doaa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) doaaa->data\\)\\\[doaaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(integer\\(kind=4\\) \\*\\) \\(doaap->data \\+ \\(sizetype\\) \\(\\(doaap->offset \\+ doaap->dim\\\[0\\\].stride \\* 2\\) \\* doaap->span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dossv\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dssv\\)" 1 "original" } } + + +! gimple dump - check only those which are simple one-line checkable: + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&ss\\) shared\\(ss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:sp\\) shared\\(sp\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:sa\\) shared\\(sa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&aa\\) shared\\(aa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dss\\) shared\\(dss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:daa\\) shared\\(daa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:doss\\) shared\\(doss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:doaa\\) shared\\(doaa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&aa\\\[1\\\]\\) shared\\(aa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&dossv\\) shared\\(dossv\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&dssv\\) shared\\(dssv\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dsp;" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dsa;" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dosp;" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dosa;" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = doaaa->data;" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = doaap->data;" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = &\\(\\*daa\\)\\\[1\\\];" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = &\\(\\*doaa\\)\\\[1\\\];" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "= &dssv;" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "= &dossv;" 1 "gimple" } } + + Index: Fortran/gfortran/regression/gomp/depend-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-5.f90 @@ -0,0 +1,82 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! Check that depobj is correctly dereferenced in the depend clause. + +subroutine foo(dss, dsp, dsa, daa, daaa, daap, doss, dosp, dosa, doaa, doaaa, doaap) + !use omp_lib + use iso_c_binding, only: c_intptr_t + implicit none (type, external) + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer(omp_depend_kind) :: ss, sp, sa, aa(4), aaa(:), aap(:) + integer(omp_depend_kind) :: dss, dsp, dsa, daa(4), daaa(:), daap(:) + integer(omp_depend_kind) :: doss, dosp, dosa, doaa(4), doaaa(:), doaap(:) + optional :: doss, dosp, dosa, doaa, doaaa, doaap + allocatable :: sa, aaa, dsa, daaa, dosa, doaaa + pointer :: sp, aap, dsp, daap, dosp, doaap + + ! Assume the depend types are initialized ... + + !$omp parallel + !$omp single + !$omp task depend(depobj: ss) + !$omp end task + !$omp task depend(depobj: sp) + !$omp end task + !$omp task depend(depobj: sa) + !$omp end task + !$omp task depend(depobj: dss) + !$omp end task + !$omp task depend(depobj: dsp) + !$omp end task + !$omp task depend(depobj: dsa) + !$omp end task + !$omp task depend(depobj: doss) + !$omp end task + !$omp task depend(depobj: dosp) + !$omp end task + !$omp task depend(depobj: dosa) + !$omp end task + + !$omp task depend(depobj: aa(2)) + !$omp end task + !$omp task depend(depobj: aaa(2)) + !$omp end task + !$omp task depend(depobj: aap(2)) + !$omp end task + !$omp task depend(depobj: daa(2)) + !$omp end task + !$omp task depend(depobj: daaa(2)) + !$omp end task + !$omp task depend(depobj: daap(2)) + !$omp end task + !$omp task depend(depobj: doaa(2)) + !$omp end task + !$omp task depend(depobj: doaaa(2)) + !$omp end task + !$omp task depend(depobj: doaap(2)) + !$omp end task + !$omp end single + !$omp end parallel +end + + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:ss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*sp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*sa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*dss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\*dsp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\*dsa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*doss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\*dosp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\*dosa\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:aa\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\(\\*\\(integer\\(kind=\[0-9\]+\\)\\\[0:\\\] \\* restrict\\) aaa.data\\)\\\[aaa.offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\(integer\\(kind=\[0-9\]+\\) \\*\\) \\(aap.data \\+ \\(sizetype\\) \\(\\(aap.offset \\+ aap.dim\\\[0\\\].stride \\* 2\\) \\* aap.span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\(\\*daa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\(\\*\\(integer\\(kind=\[0-9\]+\\)\\\[0:\\\] \\* restrict\\) daaa->data\\)\\\[daaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\(integer\\(kind=\[0-9\]+\\) \\*\\) \\(daap->data \\+ \\(sizetype\\) \\(\\(daap->offset \\+ daap->dim\\\[0\\\].stride \\* 2\\) \\* daap->span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\(\\*doaa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\(\\*\\(integer\\(kind=\[0-9\]+\\)\\\[0:\\\] \\* restrict\\) doaaa->data\\)\\\[doaaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(depobj:\\*\\(integer\\(kind=\[0-9\]+\\) \\*\\) \\(doaap->data \\+ \\(sizetype\\) \\(\\(doaap->offset \\+ doaap->dim\\\[0\\\].stride \\* 2\\) \\* doaap->span\\)\\)\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/depend-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-6.f90 @@ -0,0 +1,259 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple -fdump-tree-original" } + +! Check that 'omp depobj's depend and 'omp task/... depend' depend on +! the same variable + +! For pointers, it depends on the address of the pointer target +! For allocatable, on the allocated memory address + +subroutine foo(dss, dsp, dsa, daa, daaa, daap, doss, dosp, dosa, doaa, doaaa, doaap, & + dssv, dossv) + !use omp_lib + use iso_c_binding, only: c_intptr_t, c_ptr, c_null_ptr + implicit none (type, external) + integer, parameter :: omp_depend_kind = 2*c_intptr_t + type(c_ptr) :: ss, sp, sa, aa(4), aaa(:), aap(:) + type(c_ptr) :: dss, dsp, dsa, daa(4), daaa(:), daap(:) + type(c_ptr) :: doss, dosp, dosa, doaa(4), doaaa(:), doaap(:) + optional :: doss, dosp, dosa, doaa, doaaa, doaap + allocatable :: sa, aaa, dsa, daaa, dosa, doaaa + pointer :: sp, aap, dsp, daap, dosp, doaap + type(c_ptr), value :: dssv, dossv + optional :: dossv + + integer(omp_depend_kind) :: object(20) + integer(omp_depend_kind) :: elem(9) + + !$omp depobj(object(1)) depend(in: ss) + !$omp depobj(object(2)) depend(in: sp) + !$omp depobj(object(3)) depend(in: sa) + !$omp depobj(object(4)) depend(in: aa) + !$omp depobj(object(5)) depend(in: aaa) + !$omp depobj(object(6)) depend(in: aap) + !$omp depobj(object(7)) depend(in: dss) + !$omp depobj(object(8)) depend(in: dsp) + !$omp depobj(object(9)) depend(in: dsa) + !$omp depobj(object(10)) depend(in: daa) + !$omp depobj(object(11)) depend(in: daaa) + !$omp depobj(object(12)) depend(in: daap) + !$omp depobj(object(13)) depend(in: doss) + !$omp depobj(object(14)) depend(in: dosp) + !$omp depobj(object(15)) depend(in: dosa) + !$omp depobj(object(16)) depend(in: doaa) + !$omp depobj(object(17)) depend(in: doaaa) + !$omp depobj(object(18)) depend(in: doaap) + !$omp depobj(object(19)) depend(in: dssv) + !$omp depobj(object(20)) depend(in: dossv) + + !$omp depobj(elem(1)) depend(in: aa(2)) + !$omp depobj(elem(2)) depend(in: aaa(2)) + !$omp depobj(elem(3)) depend(in: aap(2)) + !$omp depobj(elem(4)) depend(in: daa(2)) + !$omp depobj(elem(5)) depend(in: daaa(2)) + !$omp depobj(elem(6)) depend(in: daap(2)) + !$omp depobj(elem(7)) depend(in: doaa(2)) + !$omp depobj(elem(8)) depend(in: doaaa(2)) + !$omp depobj(elem(9)) depend(in: doaap(2)) + + !$omp parallel + !$omp single + !$omp task depend(out: ss) + ss = c_null_ptr + !$omp end task + !$omp task depend(out: sp) + sp = c_null_ptr + !$omp end task + !$omp task depend(out: sa) + sa = c_null_ptr + !$omp end task + !$omp task depend(out: aa) + aa = c_null_ptr + !$omp end task + !$omp task depend(out: aaa) + aaa = c_null_ptr + !$omp end task + !$omp task depend(out: aap) + aap = c_null_ptr + !$omp end task + !$omp task depend(out: dss) + dss = c_null_ptr + !$omp end task + !$omp task depend(out: dsp) + dsp = c_null_ptr + !$omp end task + !$omp task depend(out: dsa) + dsa = c_null_ptr + !$omp end task + !$omp task depend(out: daa) + daa = c_null_ptr + !$omp end task + !$omp task depend(out: daaa) + daaa = c_null_ptr + !$omp end task + !$omp task depend(out: daap) + daap = c_null_ptr + !$omp end task + !$omp task depend(out: doss) + doss = c_null_ptr + !$omp end task + !$omp task depend(out: dosp) + dosp = c_null_ptr + !$omp end task + !$omp task depend(out: dosa) + dosa = c_null_ptr + !$omp end task + !$omp task depend(out: doaa) + doaa = c_null_ptr + !$omp end task + !$omp task depend(out: doaaa) + doaaa = c_null_ptr + !$omp end task + !$omp task depend(out: doaap) + doaap = c_null_ptr + !$omp end task + !$omp task depend(out: dossv) + dossv = c_null_ptr + !$omp end task + !$omp task depend(out: dssv) + dssv = c_null_ptr + !$omp end task + + !$omp task depend(out: aa(2)) + aa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: aaa(2)) + aaa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: aap(2)) + aap(2) = c_null_ptr + !$omp end task + !$omp task depend(out: daa(2)) + daa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: daaa(2)) + daaa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: daap(2)) + daap(2) = c_null_ptr + !$omp end task + !$omp task depend(out: doaa(2)) + doaa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: doaaa(2)) + doaaa(2) = c_null_ptr + !$omp end task + !$omp task depend(out: doaap(2)) + doaap(2) = c_null_ptr + !$omp end task + !$omp end single + !$omp end parallel +end + +subroutine bar + implicit none (type, external) + integer :: depvar, x + + x = 7 + !$omp parallel + !$omp single + !$omp task depend(out: depvar) + x =5 + !$omp end task + !$omp task depend(in: depvar) + if (x /= 5) stop + !$omp end task + !$omp end single + !$omp end parallel +end + +! depvar - only used for dependency, but should still be used in depend: + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:depvar\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(in:depvar\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "&object\\\[0\\\] = &ss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[1\\\] = sp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[2\\\] = sa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[3\\\] = &aa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[4\\\] = .void \\*\\\[0:\\\] \\* restrict\\) aaa.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[5\\\] = .void \\*\\\[0:\\\] \\*\\) aap.data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[6\\\] = dss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[7\\\] = \\*dsp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[8\\\] = \\*dsa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[9\\\] = daa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[10\\\] = .void \\*\\\[0:\\\] \\* restrict\\) daaa->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[11\\\] = .void \\*\\\[0:\\\] \\*\\) daap->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[12\\\] = doss;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[13\\\] = \\*dosp;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[14\\\] = \\*dosa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[15\\\] = doaa;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[16\\\] = .void \\*\\\[0:\\\] \\* restrict\\) doaaa->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[17\\\] = .void \\*\\\[0:\\\] \\*\\) doaap->data;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[18\\\] = &dssv;" 1 "original" } } +! { dg-final { scan-tree-dump-times "&object\\\[19\\\] = &dossv;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "&elem\\\[0\\\] = &aa\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[1\\\] = &\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) aaa.data\\)\\\[aaa.offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[2\\\] = \\(void \\* \\*\\) \\(aap.data \\+ .sizetype. \\(\\(aap.offset \\+ aap.dim\\\[0\\\].stride \\* 2\\) \\* aap.span\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[3\\\] = &\\(\\*daa\\)\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[4\\\] = &\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) daaa->data\\)\\\[daaa->offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[5\\\] = \\(void \\* \\*\\) \\(daap->data \\+ .sizetype. \\(\\(daap->offset \\+ daap->dim\\\[0\\\].stride \\* 2\\) \\* daap->span\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[6\\\] = &\\(\\*doaa\\)\\\[1\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[7\\\] = &\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) doaaa->data\\)\\\[doaaa->offset \\+ 2\\\];" 1 "original" } } +! { dg-final { scan-tree-dump-times "&elem\\\[8\\\] = \\(void \\* \\*\\) \\(doaap->data \\+ .sizetype. \\(\\(doaap->offset \\+ doaap->dim\\\[0\\\].stride \\* 2\\) \\* doaap->span\\)\\);" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:ss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*sp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*sa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:aa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\* restrict\\) aaa.data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\*\\) aap.data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*dss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dsp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dsa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*daa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\* restrict\\) daaa->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\*\\) daap->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*doss\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dosp\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\*dosa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*doaa\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\* restrict\\) doaaa->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\*\\\[0:\\\] \\*\\) doaap->data\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:aa\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) aaa.data\\)\\\[aaa.offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\* \\*\\) \\(aap.data \\+ \\(sizetype\\) \\(\\(aap.offset \\+ aap.dim\\\[0\\\].stride \\* 2\\) \\* aap.span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*daa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) daaa->data\\)\\\[daaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\* \\*\\) \\(daap->data \\+ \\(sizetype\\) \\(\\(daap->offset \\+ daap->dim\\\[0\\\].stride \\* 2\\) \\* daap->span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*doaa\\)\\\[1\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\(\\*\\(void \\*\\\[0:\\\] \\* restrict\\) doaaa->data\\)\\\[doaaa->offset \\+ 2\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:\\*\\(void \\* \\*\\) \\(doaap->data \\+ \\(sizetype\\) \\(\\(doaap->offset \\+ doaap->dim\\\[0\\\].stride \\* 2\\) \\* doaap->span\\)\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dossv\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dssv\\)" 1 "original" } } + + +! gimple dump - check only those which are simple one-line checkable: + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&ss\\) shared\\(ss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:sp\\) shared\\(sp\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:sa\\) shared\\(sa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&aa\\) shared\\(aa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:dss\\) shared\\(dss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:daa\\) shared\\(daa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:doss\\) shared\\(doss\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:doaa\\) shared\\(doaa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&aa\\\[1\\\]\\) shared\\(aa\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&dossv\\) shared\\(dossv\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(out:&dssv\\) shared\\(dssv\\)" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dsp;" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dsa;" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dosp;" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dosa;" 3 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = doaaa->data;" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = doaap->data;" 4 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = &\\(\\*daa\\)\\\[1\\\];" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = &\\(\\*doaa\\)\\\[1\\\];" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "= &dssv;" 1 "gimple" } } +! { dg-final { scan-tree-dump-times "= &dossv;" 1 "gimple" } } Index: Fortran/gfortran/regression/gomp/depend-iterator-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-iterator-1.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } + +module mymod + implicit none (type, external) + integer, target :: var(0:5) = [0,1,2,3,4,5] +end module mymod + +program main + use mymod + implicit none + + type t + integer :: x(0:64) + integer :: y + end type t + type(t) :: dep2(0:64) + integer :: dep1(0:64) + + integer arr(0:63) + !$omp parallel + !$omp master + block + integer :: i + do i = 0, 63 + !$omp task depend (iterator (j=i:i+1) , out : dep1 (j)) + arr(i) = i + !$omp end task + !$omp task depend (iterator (j=i:i+1) , out : dep2 (j)) + arr(i) = i + !$omp end task + !$omp task depend (iterator (j=i:i+1) , out : dep2 (j)%y) + arr(i) = i + !$omp end task + !$omp task depend (iterator (j=i:i+1) , out : dep2 (j)%x(j)) + arr(i) = i + !$omp end task + !$omp task depend (out : dep2 (:4)) + arr(i) = i + !$omp end task + !$omp taskwait depend(out: dep1(1)) + end do + end block + !$omp end master + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/depend-iterator-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-iterator-2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } + +module mymod + implicit none (type, external) + integer, target :: var(0:5) = [0,1,2,3,4,5] +contains + function foo (i) + integer :: i + integer, pointer :: foo + foo => var(mod(i, 6)) + end +end module mymod + +program main + use mymod + implicit none + + type t + integer :: x(0:64) + integer :: y + end type t + type(t) :: dep2(0:64) + integer :: dep1(0:64) + + integer arr(0:63) + !$omp parallel + !$omp master + block + integer :: i + do i = 0, 63 + ! NB: Revoking foo (pointer returning function) as in 'foo(i)' is a variable in the Fortran sense + !$omp task depend (iterator (j=i:i+1) , out : foo (j)) ! { dg-error "is not a variable" } + arr(i) = i + !!$omp end task + !$omp task depend(iterator(i=1:5), source ) ! { dg-error "ITERATOR may not be combined with SOURCE" } + !!$omp end task + !$omp task affinity (iterator(i=1:5): a) depend(iterator(i=1:5), sink : x) ! { dg-error "SINK at .1. not permitted as dependence-type for this directive" } + !!$omp end task + + end do + end block + !$omp end master + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/depend-iterator-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depend-iterator-3.f90 @@ -0,0 +1,27 @@ +subroutine foo + implicit none + external bar + integer :: i, b(10) + !$omp task depend(in : bar(1)) ! { dg-error "not a variable" } + !!$omp end task + !$omp task depend(out : b(1.0)) ! { dg-warning "Legacy Extension: REAL array index" } + !$omp end task + !$omp task depend( iterator( real :: i=1.0:5:1), in : b(i)) ! { dg-error "Expected INTEGER type" } + !!$omp end task + !$omp task depend(iterator(i=1.0:5:1), out : b(i)) ! { dg-error "Scalar integer expression for range begin expected" } + !$omp end task + !$omp task depend(iterator(i=1:5.0:1), in : b(i)) ! { dg-error "Scalar integer expression for range end expected" } + !$omp end task + !$omp task depend(iterator(i=1:5:1.0), in : b(i)) ! { dg-error "Scalar integer expression for range step expected" } + !$omp end task + !$omp task depend(iterator(j=1:3:5, i=1:5:0), out : b(i)) ! { dg-error "Nonzero range step expected" } + !$omp end task + !$omp task depend(iterator(=1:5:0), in : b(i)) ! { dg-error "Expected identifier" } + !!$omp end task + !$omp task depend(iterator(b(2)=1:5:1), in : b(i)) ! { dg-error "Failed to match clause" } + !!$omp end task + !$omp task depend(iterator(i=1:5:0, i=4:6), out: b(i)) ! { dg-error "Same identifier 'i' specified again" } + !!$omp end task + !$omp task depend(iterator(i=1) ,out: b(i)) ! { dg-error "Expected range-specification" } + !!$omp end task +end Index: Fortran/gfortran/regression/gomp/depobj-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depobj-1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile { target { fortran_integer_16 || ilp32 } } } +! omp_depend_kind = 2*intptr_t --> 16 (128 bit) on 64bit-pointer systems +! --> 8 (128 bit) on 32bit-pointer systems +subroutine f1 + !use omp_lib ! N/A in gcc/testsuite + use iso_c_binding, only: c_intptr_t + implicit none + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer :: a + integer(kind=omp_depend_kind) :: depobj1, depobj2, depobj3, depobj4, depobj5 + !$omp depobj(depobj1) depend (in : a) + !$omp depobj(depobj2) depend (out : a) + !$omp depobj(depobj3) depend( inout : a) + !$omp depobj(depobj4) depend(mutexinoutset: a) + !$omp depobj(depobj1) update(out) + !$omp depobj(depobj2) update(mutexinoutset) + !$omp depobj(depobj3) update(in) + !$omp depobj(depobj4) update(inout) + !$omp task depend (depobj: depobj1, depobj2, depobj3) + !$omp end task + + !$omp task depend(mutexinoutset: a) + !$omp end task + !$omp depobj(depobj2) destroy + !$omp depobj(depobj1) depend(inoutset: a) + !$omp depobj(depobj1) update(mutexinoutset) + !$omp depobj(depobj1) update(inoutset) +end subroutine f1 Index: Fortran/gfortran/regression/gomp/depobj-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/depobj-2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile { target { fortran_integer_16 || ilp32 } } } +! omp_depend_kind = 2*intptr_t --> 16 (128 bit) on 64bit-pointer systems +! --> 8 (128 bit) on 32bit-pointer systems +subroutine f1 + !use omp_lib ! N/A in gcc/testsuite + use iso_c_binding, only: c_intptr_t + implicit none + integer, parameter :: omp_depend_kind = 2*c_intptr_t + integer :: a, b + integer(kind=omp_depend_kind) :: depobj, depobj1(5) + real :: r + integer(1) :: d + + !$omp depobj ! { dg-error "Expected '\\( depobj \\)\'" } + !$omp depobj(depobj) ! { dg-error "Expected DEPEND, UPDATE, or DESTROY clause" } + !$omp depobj destroy ! { dg-error "Expected '\\( depobj \\)\'" } + !$omp depobj ( depobj1 ( 1 ) ) depend( inout : a) ! OK + !$omp depobj(depobj1) depend( inout : a) ! { dg-error "DEPOBJ in DEPOBJ construct at .1. shall be a scalar integer of OMP_DEPEND_KIND kind" } + !$omp depobj(depobj1(:)) depend( inout : a) ! { dg-error "DEPOBJ in DEPOBJ construct at .1. shall be a scalar integer of OMP_DEPEND_KIND kind" } + !$omp depobj(r) depend( inout : a) ! { dg-error "DEPOBJ in DEPOBJ construct at .1. shall be a scalar integer of OMP_DEPEND_KIND kind" } + !$omp depobj(d) depend( inout : a) ! { dg-error "DEPOBJ in DEPOBJ construct at .1. shall be a scalar integer of OMP_DEPEND_KIND kind" } + !$omp depobj(depobj) depend( inout : a, b) ! { dg-error "DEPEND clause at .1. of OMP DEPOBJ construct shall have only a single locator" } + !$omp depobj(depobj) depend(mutexinoutset : a) ! OK + !$omp depobj(depobj) depend(source) ! { dg-error "SOURCE at .1. not permitted as dependence-type for this directive" } + !$omp depobj(depobj) depend(sink : i + 1) ! { dg-error "SINK at .1. not permitted as dependence-type for this directive" } + !$omp depobj(depobj) update(source) ! { dg-error "Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET followed by '\\)'" } + !$omp depobj(depobj) update(sink) ! { dg-error "Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET followed by '\\)'" } + !$omp depobj(depobj) update(depobj) ! { dg-error "Expected IN, OUT, INOUT, INOUTSET or MUTEXINOUTSET followed by '\\)'" } + + ! Valid in OpenMP 5.1: + !$omp depobj(depobj5) depend(depobj: depobj3) ! { dg-error "DEPEND clause at .1. of OMP DEPOBJ construct shall not have dependence-type DEPOBJ" } +end subroutine f1 + Index: Fortran/gfortran/regression/gomp/do-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/do-1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-options "-O -fopenmp -fdump-tree-omplower -std=legacy" } + +subroutine foo (i, j, k, s, a) + integer :: i, j, k, s, a(100), l +!$omp parallel do schedule (dynamic, s * 2) + do 100, l = j, k +100 a(l) = i +!$omp parallel do schedule (dynamic, s * 2) + do 101, l = j, k, 3 +101 a(l) = i + 1 +end subroutine foo + +subroutine bar (i, j, k, s, a) + integer :: i, j, k, s, a(100), l +!$omp parallel do schedule (guided, s * 2) + do 100, l = j, k +100 a(l) = i +!$omp parallel do schedule (guided, s * 2) + do 101, l = j, k, 3 +101 a(l) = i + 1 +end subroutine bar + +! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_dynamic_start" 2 "omplower" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "GOMP_parallel_loop_guided_start" 2 "omplower" { xfail *-*-* } } } Index: Fortran/gfortran/regression/gomp/doacross-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/doacross-5.f90 @@ -0,0 +1,88 @@ +subroutine foo (n) + integer i, n + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(source:) + !$omp ordered doacross(sink: i - 2) + end do +end + +subroutine bar (n) + integer :: i, j, n + + !$omp do collapse(2) ordered(2) + do i = 1, 8, n + do j = 1, 8, n + !$omp ordered doacross(source:omp_cur_iteration) + !$omp ordered doacross(sink: i - 2, j + 2) + end do + end do +end + +subroutine baz () + integer :: i, j + + !$omp do ordered(1) + do i = 1, 64 + !$omp ordered ! { dg-error "'ordered' construct without 'doacross' or 'depend' clauses must not have the same binding region as 'ordered' construct with those clauses" } + !$omp end ordered + + !$omp ordered doacross(source:) + + !$omp ordered doacross(sink: i - 1) + end do + + !$omp do ordered + do i = 1, 64 + !$omp ordered doacross(source: omp_cur_iteration ) + + !$omp ordered doacross(sink: i - 1) + + !$omp ordered threads ! { dg-error "'ordered' construct without 'doacross' or 'depend' clauses must not have the same binding region as 'ordered' construct with those clauses" } + !$omp end ordered + end do + !$omp do ordered(2) + do i = 1, 64 + do j = 1, 64 + !$omp ordered ! { dg-error "'ordered' construct without 'doacross' or 'depend' clauses binds to loop where 'collapse' argument 1 is different from 'ordered' argument 2" } + !$omp end ordered + end do + end do + !$omp do ordered(2) collapse(1) + do i = 1, 8 + do j = 1, 8 + !$omp ordered threads ! { dg-error "'ordered' construct without 'doacross' or 'depend' clauses binds to loop where 'collapse' argument 1 is different from 'ordered' argument 2" } + !$omp end ordered + end do + end do +end + +subroutine qux () + integer :: i, j + j = 0 + !$omp do ordered linear(j) + do i = 1, 64 + j = j + 1 + !$omp ordered + !$omp end ordered + end do + !$omp do ordered linear(j) ! { dg-error "'linear' clause may not be specified together with 'ordered' clause if stand-alone 'ordered' construct is nested in it" } + do i = 1, 64 + j = j + 1 + !$omp ordered doacross(source:) + !$omp ordered doacross(sink:i-1) + end do + !$omp do ordered(1) linear(j) + do i = 1, 64 + j = j + 1 + !$omp ordered + !$omp end ordered + end do + !$omp do ordered(1) linear(j) ! { dg-error "'linear' clause may not be specified together with 'ordered' clause if stand-alone 'ordered' construct is nested in it" } + do i = 1, 64 + j = j + 1 + !$omp ordered doacross(source:) + !$omp ordered doacross(sink:i-1) + end do +end Index: Fortran/gfortran/regression/gomp/doacross-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/doacross-6.f90 @@ -0,0 +1,77 @@ +subroutine foo (n) + integer :: i, n + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(source) ! { dg-error "Expected ':'" } + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(source:omp_current_iteration) ! { dg-error "Expected '\\\)' or 'omp_cur_iteration\\\)'" } + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(source:i - 2) ! { dg-error "Expected '\\\)' or 'omp_cur_iteration\\\)'" } + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink) ! { dg-error "Expected ':'" } + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:) ! { dg-error "Syntax error in OpenMP SINK dependence-type list" } + end do +end + +subroutine bar (n) + implicit none + integer i, n + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_current_iteration - 1) ! { dg-error "Symbol 'omp_current_iteration' at .1. has no IMPLICIT type" } + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_cur_iteration) ! { dg-error "omp_cur_iteration at .1. requires '-1' as logical offset" } + end do +end + +subroutine baz (n) + implicit none + integer i, n + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_cur_iteration + 1) ! { dg-error "omp_cur_iteration at .1. requires '-1' as logical offset" } + end do +end + +subroutine qux (n) + implicit none + integer i, n + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_cur_iteration - (2 - 1)) ! { dg-error "Syntax error in OpenMP SINK dependence-type list" } + end do +end + +subroutine corge (n) + implicit none + integer i, n + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_cur_iteration - 1) + end do + + !$omp do ordered + do i = 1, 8, n + !$omp ordered doacross(sink:omp_cur_iteration - 1_8) + end do +end Index: Fortran/gfortran/regression/gomp/error-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/error-1.f90 @@ -0,0 +1,51 @@ +! { dg-additional-options "-ffree-line-length-none" } +module m +!$omp error ! { dg-error ".OMP ERROR encountered at .1." } +!$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." } +!$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." } +!$omp error message("my msg") ! { dg-error ".OMP ERROR encountered at .1.: my msg" } +!$omp error severity(warning)message("another message")at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: another message" } + +type S + !$omp error ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error message("42") ! { dg-error ".OMP ERROR encountered at .1.: 42" } + !$omp error severity(warning), message("foo"), at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: foo" } + integer s +end type S +end module m + +integer function foo (i, x) + integer :: i + logical :: x + !$omp error ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." } + !$omp error message("42 / 1") ! { dg-error ".OMP ERROR encountered at .1.: 42 / 1" } + !$omp error severity(warning) message("bar") at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: bar" } + if (x) then + !$omp error ! { dg-error ".OMP ERROR encountered at .1." } + i = i + 1 + end if + if (x) then + ; + else + !$omp error at(compilation) ! { dg-error ".OMP ERROR encountered at .1." } + i = i + 1 + end if + select case (.false.) + !$omp error severity(fatal) ! { dg-error ".OMP ERROR encountered at .1." } + case default + ! + end select + do while (.false.) + !$omp error message("42 - 1") ! { dg-error ".OMP ERROR encountered at .1.: 42 - 1" } + i = i + 1 + end do + lab: + !$omp error severity(warning) message("bar") at(compilation) ! { dg-warning ".OMP ERROR encountered at .1.: bar" } + i++; + foo = i + return +end Index: Fortran/gfortran/regression/gomp/error-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/error-2.f90 @@ -0,0 +1,15 @@ +subroutine foo (x, msg1, msg2) + integer x + character(len=*) :: msg1, msg2 + if (x == 0) then + !$omp error at(execution) + else if (x == 1) then + !$omp error severity (warning), at (execution) + else if (x == 2) then + !$omp error at ( execution ) severity (fatal) message ("baz") + else if (x == 3) then + !$omp error severity(warning) message (msg1) at(execution) + else + !$omp error message (msg2), at(execution), severity(fatal) + end if +end Index: Fortran/gfortran/regression/gomp/error-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/error-3.f90 @@ -0,0 +1,88 @@ +module m +!$omp error asdf ! { dg-error "Failed to match clause" } +!$omp error at ! { dg-error "Expected '\\(' after 'at'" } +!$omp error at( ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" } +!$omp error at(runtime) ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" } +!$omp error at(+ ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" } +!$omp error at(compilation ! { dg-error "Expected COMPILATION or EXECUTION in AT clause at" } +!$omp error severity ! { dg-error "Expected '\\(' after 'severity'" } +!$omp error severity( ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" } +!$omp error severity(error) ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" } +!$omp error severity(- ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" } +!$omp error severity(fatal ! { dg-error "Expected FATAL or WARNING in SEVERITY clause at" } +!$omp error message ! { dg-error "Expected '\\(' after 'message'" } +!$omp error message( ! { dg-error "Invalid expression after 'message\\('" } +!$omp error message(0 ! { dg-error "Invalid expression after 'message\\('" } +!$omp error message("foo" ! { dg-error "Invalid expression after 'message\\('" } + +!$omp error at(compilation) at(compilation) ! { dg-error "Duplicated 'at' clause at" } +!$omp error severity(fatal) severity(warning) ! { dg-error "Duplicated 'severity' clause at" } +!$omp error message("foo") message("foo") ! { dg-error "Duplicated 'message' clause at" } +!$omp error message("foo"),at(compilation),severity(fatal),asdf ! { dg-error "Failed to match clause" } + +!$omp error at(execution) ! { dg-error "Unexpected !.OMP ERROR statement in MODULE" } + +end module + +module m2 +character(len=10) :: msg +!$omp error message(1) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error message(1.2) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error message(4_"foo") ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error message(["bar","bar"]) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error message(msg) ! { dg-error "Constant character expression required in MESSAGE clause" } + +type S + !$omp error at(execution) message("foo")! { dg-error "Unexpected !.OMP ERROR statement at" } + integer s +end type +end module + +subroutine bar +character(len=10) :: msg +!$omp error at(execution) message(1) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error at(execution) message(1.2) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error at(execution) message(4_"foo") ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error at(execution) message(["bar","bar"]) ! { dg-error "MESSAGE clause at .1. requires a scalar default-kind CHARACTER expression" } +!$omp error at(execution) message(msg) ! OK + +end + +integer function foo (i, x, msg) + integer :: i + logical :: x + character(len=*) :: msg + !$omp error message(msg) ! { dg-error "Constant character expression required in MESSAGE clause" } + if (x) then + !$omp error at(execution) ! OK + end if + i = i + 1 + if (x) then + ; + else + !$omp error at(execution) severity(warning) ! OK + end if + i = i + 1 + select case (.false.) + !$omp error severity(fatal) at(execution) ! { dg-error "Expected a CASE or END SELECT statement following SELECT CASE" } + end select + do while (.false.) + !$omp error at(execution)message("42 - 1") ! OK + i = i + 1 + end do +99 continue + !$omp error severity(warning) message("bar") at(execution) ! OK + i = i + 1 + foo = i +end + + +subroutine foobar + if (.true.) & ! { dg-error "Syntax error in IF-clause after" } + !$omp error at(execution) + + continue + + if (.true.) & ! { dg-error "Syntax error in IF-clause after" } + !$omp error ! { dg-error ".OMP ERROR encountered at" } +end Index: Fortran/gfortran/regression/gomp/fixed-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/fixed-1.f @@ -0,0 +1,22 @@ +C PR fortran/24493 +C { dg-do compile } +C { dg-require-effective-target tls } + INTEGER I, J, K, L, M +C$OMP THREADPRIVATE(I) +C SOME COMMENT + SAVE I ! ANOTHER COMMENT +C$OMP THREADPRIVATE +C$OMP+(J) ! OMP DIRECTIVE COMMENT +* NORMAL COMMENT +c$OMP THREAD! COMMENT +C$OMP&PRIVATE! COMMENT +*$OMP+ (K) +C$OMP THREADPRIVATE (L ! COMMENT +*$OMP& , M) + SAVE J, K, L, M + I = 1 + J = 2 + K = 3 + L = 4 + M = 5 + END Index: Fortran/gfortran/regression/gomp/flush-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/flush-1.f90 @@ -0,0 +1,49 @@ +! { dg-additional-options "-fdump-tree-gimple" } +! { dg-final { scan-tree-dump "foo \\(6\\);\[\n\r]* __sync_synchronize \\(\\);\[\n\r]* foo \\(6\\);" "gimple" } } +! { dg-final { scan-tree-dump "foo \\(4\\);\[\n\r]* __atomic_thread_fence \\(4\\);\[\n\r]* foo \\(4\\);" "gimple" } } +! { dg-final { scan-tree-dump "foo \\(3\\);\[\n\r]* __atomic_thread_fence \\(3\\);\[\n\r]* foo \\(3\\);" "gimple" } } +! { dg-final { scan-tree-dump "foo \\(2\\);\[\n\r]* __atomic_thread_fence \\(2\\);\[\n\r]* foo \\(2\\);" "gimple" } } +! { dg-final { scan-tree-dump "foo \\(5\\);\[\n\r]* __sync_synchronize \\(\\);\[\n\r]* foo \\(5\\);" "gimple" } } + +module m + interface + subroutine foo(x) + integer, value :: x + end + end interface +end module m + +subroutine f1 + use m + call foo (4) + !$omp flush acq_rel + call foo (4) +end + +subroutine f2 + use m + call foo (3) + !$omp flush release + call foo (3) +end + +subroutine f3 + use m + call foo (2) + !$omp flush acquire + call foo (2) +end + +subroutine f4 + use m + call foo (5) + !$omp flush + call foo (5) +end + +subroutine f5 + use m + call foo (6) + !$omp flush seq_cst + call foo (6) +end Index: Fortran/gfortran/regression/gomp/flush-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/flush-2.f90 @@ -0,0 +1,19 @@ +module m + integer :: a, b +end module m + +subroutine foo (void) + use m + !$omp flush + !$omp flush (a, b) + !$omp flush acquire + !$omp flush release + !$omp flush acq_rel + !$omp flush seq_cst + !$omp flush relaxed ! { dg-error "Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE" } + !$omp flush foobar ! { dg-error "Expected SEQ_CST, AQC_REL, RELEASE, or ACQUIRE" } + !$omp flush acquire (a, b) ! { dg-error "List specified together with memory order clause in FLUSH directive" } + !$omp flush release (a, b) ! { dg-error "List specified together with memory order clause in FLUSH directive" } + !$omp flush acq_rel (a, b) ! { dg-error "List specified together with memory order clause in FLUSH directive" } + !$omp flush seq_cst (a, b) ! { dg-error "List specified together with memory order clause in FLUSH directive" } + end Index: Fortran/gfortran/regression/gomp/free-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/free-1.f90 @@ -0,0 +1,8 @@ +! { dg-require-effective-target tls } + +subroutine foo +integer, save :: i ! Some comment +!$omp threadpri& + !$omp&vate (i) +i = 1 +end subroutine Index: Fortran/gfortran/regression/gomp/free-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/free-2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! +! PR fortran/33445 +! +!$OMP&foo ! { dg-warning "starts a commented line" } +! +!$OMP parallel +!$OMP& default(shared) ! { dg-warning "starts a commented line" } +!$OMP end parallel +! +!$OMP parallel +!$OMP+ default(shared) ! { dg-warning "starts a commented line" } +!$OMP end parallel + end Index: Fortran/gfortran/regression/gomp/gomp.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/gomp.exp @@ -0,0 +1,36 @@ +# Copyright (C) 2005-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +if ![check_effective_target_fopenmp] { + return +} + +# Initialize `dg'. +dg-init + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-fopenmp" + +# All done. +dg-finish Index: Fortran/gfortran/regression/gomp/if-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/if-1.f90 @@ -0,0 +1,122 @@ +! { dg-do compile } + +subroutine foo (a, b, p, q) + logical, value :: a + logical :: b + integer :: p(:) + integer, pointer :: q(:) + integer :: i + !$omp parallel if (a) + !$omp end parallel + !$omp parallel if (parallel:a) + !$omp end parallel + !$omp parallel do simd if (a) + do i = 1, 16 + end do + !$omp end parallel do simd + !$omp parallel do simd if (parallel : a) + do i = 1, 16 + end do + !$omp end parallel do simd + !$omp parallel do simd if (simd : a) + do i = 1, 16 + end do + !$omp end parallel do simd + !$omp parallel do simd if (simd : a) if (parallel:b) + do i = 1, 16 + end do + !$omp end parallel do simd + !$omp task if (a) + !$omp end task + !$omp task if (task: a) + !$omp end task + !$omp taskloop if (a) + do i = 1, 16 + end do + !$omp end taskloop + !$omp taskloop if (taskloop : a) + do i = 1, 16 + end do + !$omp end taskloop + !$omp taskloop simd if (a) + do i = 1, 16 + end do + !$omp end taskloop simd + !$omp taskloop simd if (taskloop : a) + do i = 1, 16 + end do + !$omp end taskloop simd + !$omp taskloop simd if (simd : a) + do i = 1, 16 + end do + !$omp end taskloop simd + !$omp taskloop simd if (taskloop:b) if (simd : a) + do i = 1, 16 + end do + !$omp end taskloop simd + !$omp target if (a) + !$omp end target + !$omp target if (target: a) + !$omp end target + !$omp target simd if (a) + do i = 1, 16 + end do + !$omp end target simd + !$omp target simd if (simd : a) if (target: b) + do i = 1, 16 + end do + !$omp end target simd + !$omp target teams distribute parallel do simd if (a) + do i = 1, 16 + end do + !$omp end target teams distribute parallel do simd + !$omp target teams distribute parallel do simd if (parallel : a) if (target: b) + do i = 1, 16 + end do + !$omp end target teams distribute parallel do simd + !$omp target teams distribute parallel do simd if (simd : a) if (target: b) + do i = 1, 16 + end do + !$omp end target teams distribute parallel do simd + + !$omp target data if (a) map (p(1:2)) + !$omp end target data + !$omp target data if (target data: a) map (p(1:2)) + !$omp end target data + !$omp target enter data if (a) map (to: p(1:2)) + !$omp target enter data if (target enter data: a) map (to: p(1:2)) + !$omp target exit data if (a) map (from: p(1:2)) + !$omp target exit data if (target exit data: a) map (from: p(1:2)) + !$omp target update if (a) to (q(1:3)) + !$omp target update if (target update:a) to (q(1:3)) + !$omp parallel + !$omp cancel parallel if (a) + !$omp end parallel + !$omp parallel + !$omp cancel parallel if (cancel:a) + !$omp end parallel + !$omp do + do i = 1, 16 + !$omp cancel do if (a) + end do + !$omp do + do i = 1, 16 + !$omp cancel do if (cancel: a) + end do + !$omp sections + !$omp section + !$omp cancel sections if (a) + !$omp end sections + !$omp sections + !$omp section + !$omp cancel sections if (cancel: a) + !$omp end sections + !$omp taskgroup + !$omp task + !$omp cancel taskgroup if (a) + !$omp end task + !$omp task + !$omp cancel taskgroup if (cancel: a) + !$omp end task + !$omp end taskgroup +end Index: Fortran/gfortran/regression/gomp/implicit-save.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/implicit-save.f90 @@ -0,0 +1,11 @@ +subroutine foo + integer :: n = 5, m = 7 + !$omp declare target to(n) + !$omp threadprivate (m) +end + +program main + integer :: i, j + !$omp declare target to(i) + !$omp threadprivate (j) +end Index: Fortran/gfortran/regression/gomp/include_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/include_1.f @@ -0,0 +1,49 @@ +c { dg-do compile } +c { dg-options "-fopenmp -fdec" } + subroutine foo + implicit none +c$ 0include 'include_1.inc' + i = 1 + end subroutine foo + subroutine bar + implicit none + i +C$ ;n + +c + +c some comment + +*$ ll +C comment line + uu + DD + ee'include_1.inc' + i = 1 + end subroutine bar + subroutine baz + implicit none + 0include + + 'include_1.inc' + i = 1 + end subroutine baz + subroutine qux + implicit none +!$ i n C lude 'inc +* another comment line + &lude_1.inc' + i = 1 + end subroutine qux + subroutine quux + implicit none +C$ 0inc +*$ 1lud +c$ 2e ' +!$ 3include_1.inc' + i = 1 + end subroutine quux + program include_12 + implicit none + include +! comment +c$ +'include_1.inc' + end program Index: Fortran/gfortran/regression/gomp/include_1.inc =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/include_1.inc @@ -0,0 +1 @@ + integer i Index: Fortran/gfortran/regression/gomp/include_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/include_2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdec-include" } +subroutine foo + implicit none +!$ incl& ! comment1 +!$ &u& +!$ &de & ! comment2 +!$ 'include& + &_1.inc' + i = 1 +end subroutine foo +subroutine bar + implicit none +!$ include & + +! comment3 + +!$ "include_1.inc" + i = 1 +end subroutine bar +subroutine baz + implicit none +!$ include& +!$ &'include_1.& +!$ &inc' + i = 1 +end subroutine baz +subroutine qux + implicit none +!$ include '& +include_1.inc' +end subroutine qux Index: Fortran/gfortran/regression/gomp/intentin1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/intentin1.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } + +subroutine foo (x) + integer, pointer, intent (in) :: x + integer :: i +!$omp parallel private (x) ! { dg-error "INTENT.IN. POINTER" } +!$omp end parallel +!$omp parallel do lastprivate (x) ! { dg-error "INTENT.IN. POINTER" } + do i = 1, 10 + end do +!$omp simd linear (x) ! { dg-error "INTENT.IN. POINTER" } + do i = 1, 10 + end do +!$omp single +!$omp end single copyprivate (x) ! { dg-error "INTENT.IN. POINTER" } +end Index: Fortran/gfortran/regression/gomp/is_device_ptr-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/is_device_ptr-1.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +subroutine test(b,c,d) + implicit none + integer, value, target :: b + integer, pointer :: c + integer, allocatable, target :: d + + integer, target :: a(5) + + !$omp target is_device_ptr(a) ! Valid since OpenMP 5.1 + !$omp end target + + !$omp target is_device_ptr(b) ! Valid since OpenMP 5.1 + !$omp end target + + !$omp target is_device_ptr(c) ! Valid since OpenMP 5.1 + !$omp end target + + !$omp target is_device_ptr(d) ! Valid since OpenMP 5.1 + !$omp end target + + !$omp target data map(a) use_device_addr(a) ! Should be okay + !$omp end target data + + !$omp target data map(c) use_device_ptr(c) ! Should be okay + !$omp end target data +end subroutine test Index: Fortran/gfortran/regression/gomp/is_device_ptr-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/is_device_ptr-2.f90 @@ -0,0 +1,21 @@ +! PR fortran/98476 + +subroutine abc(cc) + integer, target :: cc, dd + cc = 131 + dd = 484 + + !$omp target enter data map(to: cc, dd) + + !$omp target data use_device_addr(cc) use_device_ptr(dd) + !$omp target is_device_ptr(cc, dd) ! Valid since OpenMP 5.1 + if (cc /= 131 .or. dd /= 484) stop 1 + cc = 44 + dd = 45 + !$omp end target + !$omp end target data + + !$omp target exit data map(from:cc, dd) + + if (cc /= 44 .or. dd /= 45) stop 5 +end Index: Fortran/gfortran/regression/gomp/is_device_ptr-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/is_device_ptr-3.f90 @@ -0,0 +1,28 @@ +! Test to ensure that IS_DEVICE_PTR is removed for non-used variables. + +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + use iso_c_binding + implicit none + + integer :: x, y + call foo (x, y) + +contains + subroutine foo (a, b) + integer, target :: a, b + + !$omp target data map(a, b) use_device_ptr(a, b) + !$omp target is_device_ptr(a, b) + a = 42 + !$omp end target + !$omp end target data + end subroutine foo + +end program main + +! { dg-final { scan-tree-dump "has_device_addr\\(a\\)" "gimple" } } +! { dg-final { scan-tree-dump-not "has_device_addr\\(b\\)" "gimple" } } +! { dg-final { scan-tree-dump-not "is_device_ptr\\(b\\)" "gimple" } } Index: Fortran/gfortran/regression/gomp/lastprivate-conditional-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/lastprivate-conditional-1.f90 @@ -0,0 +1,82 @@ +subroutine foo (p) + implicit none + logical :: p(:) + integer a, b, c, d, e, f, g, h; + integer :: i + a = -1; b = -1; c = -1; d = -1; e = -1; f = -1; g = -1; h = -1 + !$omp teams + !$omp distribute lastprivate (conditional: a) ! { dg-error "conditional 'lastprivate' clause on 'distribute' construct" } + do i = 1, 32 + if (p(i)) & + a = i + end do + !$omp distribute simd lastprivate (conditional: b) ! { dg-error "conditional 'lastprivate' clause on 'distribute' construct" } + do i = 1, 32 + if (p(i)) & + b = i + end do + !$omp distribute parallel do lastprivate (conditional: c) ! { dg-error "conditional 'lastprivate' clause on 'distribute' construct" } + do i = 1, 32 + if (p(i)) & + c = i + end do + !$omp distribute parallel do simd lastprivate (conditional: d) ! { dg-error "conditional 'lastprivate' clause on 'distribute' construct" } + do i = 1, 32 + if (p(i)) & + d = i + end do + !$omp end teams + + !$omp teams distribute parallel do lastprivate (conditional: e) ! { dg-error "conditional 'lastprivate' clause on 'distribute' construct" } + do i = 1, 32 + if (p(i)) & + e = i + end do + + !$omp parallel + !$omp master + !$omp taskloop lastprivate (conditional: f) ! { dg-error "conditional 'lastprivate' clause on 'taskloop' construct" } + do i = 1, 32 + if (p(i)) & + f = i + end do +! !$omp master taskloop simd lastprivate (conditional: g) ! { dg!error "conditional 'lastprivate' clause on 'taskloop' construct" } +! do i = 1, 32 +! if (p(i)) & +! g = i +! end do + !$omp end master + !$omp end parallel + +! !$omp parallel master taskloop simd lastprivate (conditional: h) ! { dg!error "conditional 'lastprivate' clause on 'taskloop' construct" } +! do i = 1, 32 +! if (p(i)) & +! h = i +! end do +! !$omp end parallel master taskloop simd +end subroutine + +!struct S { int a, b; }; + +subroutine bar (p) + implicit none + logical :: p(:) + type s_t + integer :: a, b + end type s_t + type(s_t) s, t + integer i + s = s_t(-1, -1) + t = s_t( 1, 2) + !$omp parallel do lastprivate (conditional: s) ! { dg-error "non-scalar variable 's' in conditional 'lastprivate' clause" } + do i = 1, 32 + if (p(i)) then + block + type(s_t) u + u = t + u%b = i + s = u + end block + end if + end do +end subroutine Index: Fortran/gfortran/regression/gomp/lastprivate-conditional-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/lastprivate-conditional-2.f90 @@ -0,0 +1,46 @@ +! { dg-additional-options "-fdump-tree-original" } +subroutine foo (p) + logical :: p(:) + integer i + integer a, b, c, d, e, f, g, h + a = -1; b = -1; c = -1; d = -1; e = -1; f = -1; g = -1; h = -1 + !$omp parallel + !$omp do lastprivate (conditional: a) + do i = 1, 32 + if (p(i)) & + a = i + end do + !$omp end parallel + !$omp simd lastprivate (conditional: b) + do i = 1, 32 + if (p(i)) & + b = i + end do + !$omp parallel + !$omp do simd lastprivate (conditional: c) + do i = 1, 32 + if (p(i)) & + c = i + end do + !$omp end parallel + !$omp parallel do lastprivate (conditional: d) + do i = 1, 32 + if (p(i)) & + d = i + end do + !$omp end parallel do + !$omp parallel do simd lastprivate (conditional: e) + do i = 1, 32 + if (p(i)) & + e = i + end do + !$omp end parallel do simd +end subroutine + +! { dg-final { scan-tree-dump-times "#pragma omp for lastprivate\\(conditional:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) lastprivate\\(conditional:b\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for lastprivate\\(conditional:c\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) lastprivate\\(conditional:c\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel lastprivate\\(conditional:d\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel lastprivate\\(conditional:e\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) lastprivate\\(conditional:e\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/lastprivate-conditional-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/lastprivate-conditional-3.f90 @@ -0,0 +1,61 @@ +subroutine foo + integer i, j, k + !$omp parallel + !$omp do lastprivate (conditional: i) ! { dg-warning "conditional 'lastprivate' on loop iterator 'i' ignored" } + do i = 1, 32 + end do + !$omp do collapse (3) lastprivate (conditional: i) ! { dg-warning "conditional 'lastprivate' on loop iterator 'i' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp do collapse (3) lastprivate (conditional: j) ! { dg-warning "conditional 'lastprivate' on loop iterator 'j' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp do collapse (3) lastprivate (conditional: k) ! { dg-warning "conditional 'lastprivate' on loop iterator 'k' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp end parallel + + !$omp parallel do lastprivate (conditional: i) ! { dg-warning "conditional 'lastprivate' on loop iterator 'i' ignored" } + do i = 1, 32 + end do + !$omp end parallel do + + !$omp parallel do collapse (3) lastprivate (conditional: i) ! { dg-warning "conditional 'lastprivate' on loop iterator 'i' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp end parallel do + + !$omp parallel do collapse (3) lastprivate (conditional: j) ! { dg-warning "conditional 'lastprivate' on loop iterator 'j' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp end parallel do + + !$omp parallel do collapse (3) lastprivate (conditional: k) ! { dg-warning "conditional 'lastprivate' on loop iterator 'k' ignored" } + do i = 1, 32 + do j = 1, 32 + do k = 1, 32 + end do + end do + end do + !$omp end parallel do +end subroutine Index: Fortran/gfortran/regression/gomp/lastprivate-conditional-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/lastprivate-conditional-4.f90 @@ -0,0 +1,28 @@ +module m +integer x, w +end module m + +subroutine foo + use m + interface + logical function bar(i) + integer i + end function + end interface + integer y, i, z + logical tmp + y = 5 + !$omp teams num_teams(1) firstprivate (x) shared (y) shared (w) + !$omp parallel do firstprivate (x, y, z, w) lastprivate (conditional: x, y, z, w) + do i = 1, 64 + if (bar (i)) then + x = i; + y = i + 1; + z = i + 2; + w = i + 3; + end if + tmp = bar (y); + tmp = bar (z); + end do + !$omp end teams +end Index: Fortran/gfortran/regression/gomp/lastprivate-conditional-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/lastprivate-conditional-5.f90 @@ -0,0 +1,47 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-ompexp" } +! { dg-final { scan-tree-dump-times "GOMP_loop_start " 3 "ompexp" } } +! { dg-final { scan-tree-dump-times "GOMP_loop_end_nowait " 3 "ompexp" } } + +module m + logical r +end module m + +subroutine foo (a) + use m + implicit none + logical a(:) + integer :: i + !$omp do lastprivate(conditional: r) + do i = 1, 64 + if (a(i)) & + r = a(i) + end do + !$omp end do nowait +end + +subroutine bar (a) + use m + implicit none + logical a(:) + integer :: i + !$omp do lastprivate(conditional: r) schedule (static, 4) + do i = 1, 64 + if (a(i)) & + r = a(i) + end do + !$omp end do nowait +end + +subroutine baz (a) + use m + implicit none + logical a(:) + integer :: i + !$omp do lastprivate(conditional: r) schedule (runtime) + do i = 1, 64 + if (a(i)) & + r = a(i) + end do + !$omp end do nowait +end Index: Fortran/gfortran/regression/gomp/linear-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-1.f90 @@ -0,0 +1,58 @@ +subroutine foo (x, y) + integer :: i, x, y + common /i/ i + interface + function bar (x, y) + integer :: x, y, bar + !$omp declare simd (bar) linear (ref (x) : 1) linear (uval (y)) + end function bar + end interface + !$omp simd linear (x : y + 1) + do i = 1, 10 + x = x + y + 1 + end do + !$omp simd linear (val (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp simd linear (ref (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp simd linear (uval (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do linear (x : y + 1) + do i = 1, 10 + x = x + y + 1 + end do + !$omp do linear (val (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do linear (ref (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do linear (uval (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do simd linear (x : y + 1) + do i = 1, 10 + x = x + y + 1 + end do + !$omp do simd linear (val (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do simd linear (ref (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do + !$omp do simd linear (uval (x) : y + 1) ! { dg-error "LINEAR clause modifier used on DO or SIMD construct" } + do i = 1, 10 + x = x + y + 1 + end do +end Index: Fortran/gfortran/regression/gomp/linear-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-2.f90 @@ -0,0 +1,112 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-original" } + +module m + implicit none (type, external) + + integer i + + interface + integer function bar (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (x : val, step (1)) linear (y : step (2)) + end + + integer function baz (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (x : step (1), val) + end + + integer function qux (x, val) + integer, value :: x, val + !$omp declare simd linear (val (x) : val) uniform (val) + end + + integer function corge (x, val) + integer, value :: x, val + !$omp declare simd linear (x : val, step (val)) uniform (val) + end + + integer function grault (x) + integer, value :: x + !$omp declare simd linear (x : val) + end + + integer function step (x) + integer, value :: x + end + end interface + +contains + +subroutine foo (x,y) + integer :: x, y + integer :: val + + val = 1 + + !$omp simd linear (i: step (3)) + do i = 0, 32, 3 + end do + + !$omp simd linear (i: val, step (3)) + do i = 0, 32, 3 + end do + + !$omp simd linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp simd linear (x: step (y + 1), val) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do linear (x: val, step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (i: step (3)) + do i = 0, 32, 3 + end do + + !$omp parallel do simd linear (i: step (3), val) + do i = 0, 32, 3 + end do + + !$omp parallel do simd linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: val, step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (i: val + 0) + do i = 0, 9 + end do + + !$omp parallel do simd linear (i: step (1) * 1) + do i = 0, 9 + end do +end +end module + +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 8 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for linear\\(x:D\\.\[0-9\]+\\) nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for linear\\(x:val,step\\(D\\.\[0-9\]+\\)\\) nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(count\\.\[0-9\]:1\\) linear\\(i:3\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(count\\.\[0-9\]:1\\) linear\\(i:val,step\\(3\\)\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) linear\\(x:D\\.\[0-9\]+\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) linear\\(x:val,step\\(D\\.\[0-9\]+\\)\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:D\\.\[0-9\]+\\)" 2 "original" } } Index: Fortran/gfortran/regression/gomp/linear-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-3.f90 @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m2 + implicit none (type, external) + + integer :: val + +contains +integer function step (x) + integer, value :: x +end +subroutine foo(x) + integer, value :: x + !$omp declare simd linear (val (x) : step (1)) ! { dg-error "requires a constant integer linear-step expression or dummy argument" } +end +end module m2 + + +module m + implicit none (type, external) + + integer :: val + +contains +integer function step (x) + integer, value :: x + !$omp declare simd linear (val (x) : step (1)) ! { dg-error "Failed to match clause" } +end + +integer function bar (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (val (x) : val) ! { dg-error "requires a constant integer linear-step expression or dummy argument" } +end + +integer function baz (x, y, z) + integer, value :: x, y, z +end +end module m Index: Fortran/gfortran/regression/gomp/linear-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-4.f90 @@ -0,0 +1,102 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m +implicit none + +integer :: i + +interface + integer function bar (x, y, z) + integer :: x, y + integer, value :: z + !$omp declare simd linear (x : ref, step (1)) linear (y : step (2), uval) + end + + integer function baz (x, y, z) + integer :: x + integer, value :: y, z + !$omp declare simd linear (x : step (1), uval) + end + + integer function qux (x, ref) + integer :: x + integer, value :: ref + !$omp declare simd linear (ref (x) : ref) uniform (ref) + end + + integer function corge (x, ref) + integer :: x + integer, value :: ref + !$omp declare simd linear (x : ref, step (ref)) uniform (ref) + end + + integer function grault (x) + integer :: x + !$omp declare simd linear (x : ref) + end + + integer function waldo (x) + integer :: x + !$omp declare simd linear (x : uval) + end +end interface + +contains + +integer function step (x) + integer, value :: x + step = x +end + +subroutine foo (x, y) + integer :: x, y + !$omp simd linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp simd linear (x: val, step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do linear (x: step (y + 1), val) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: val, step (y + 1)) + do i = 0, 9 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: step (1) + 0) + do i = 0, 9 + x = x + step (1) + 0 + end do + + block + integer, parameter :: ref = 1, uval = 2 + !$omp parallel do simd linear (x: ref + 0) + do i = 0, 9 + x = x + ref + 0 + end do + + !$omp parallel do simd linear (x: uval * 1) + do i = 0, 9 + x = x + uval + end do + end block +end +end Index: Fortran/gfortran/regression/gomp/linear-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-5.f90 @@ -0,0 +1,43 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m +implicit none +integer :: i + +contains + +subroutine foo (x, y) + integer :: x, y + + !$omp simd linear (x: step (y + 1), ref) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do + + !$omp simd linear (x: uval, step (y + 1)) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do + + !$omp parallel do linear (x: ref, step (y + 1)) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do + + !$omp parallel do linear (x: step (y + 1), uval) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: step (y + 1), ref) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do + + !$omp parallel do simd linear (x: uval, step (y + 1)) ! { dg-error "LINEAR clause modifier other than VAL used on DO or SIMD construct" } + do i = 0, 10 + x = x + y + 1 + end do +end +end Index: Fortran/gfortran/regression/gomp/linear-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-6.f90 @@ -0,0 +1,54 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m +implicit none +integer, parameter :: val = 1 +integer, parameter :: ref = 2 +integer, parameter :: uval = 3 + +interface + integer function foo (x, y, z) + import + implicit none + integer, value :: x + integer :: y, z + !$omp declare simd linear (val (x) : step (1)) linear (ref (y) : step (2)) linear (uval (z) : step (3)) + +! STEP is a function - thus: +! { dg-error "'x' in LINEAR clause at .1. requires a constant integer linear-step expression or dummy argument specified in UNIFORM clause" "" { target *-*-* } .-3 } +! { dg-error "'y' in LINEAR clause at .1. requires a constant integer linear-step expression or dummy argument specified in UNIFORM clause" "" { target *-*-* } .-4 } +! { dg-error "'z' in LINEAR clause at .1. requires a constant integer linear-step expression or dummy argument specified in UNIFORM clause" "" { target *-*-* } .-5 } + + end + + integer function bar (x, y, z) + import + implicit none + integer, value :: x + integer :: y, z + !$omp declare simd linear (val (x) : val) linear (ref (y) : ref) linear (uval (z) : uval) + end + + integer function baz (x, y, z) + import + implicit none + integer, value :: x + integer :: y, z + !$omp declare simd linear (val (x) : ref) linear (ref (y) : uval) linear (uval (z) : val) + end + + integer function qux (x, y, z) + import + implicit none + integer, value :: x + integer :: y, z + !$omp declare simd linear (val (x) : uval) linear (ref (y) : val) linear (uval (z) : ref) + end +end interface +contains + integer function step (x) + integer, value :: x + step = x + end +end module Index: Fortran/gfortran/regression/gomp/linear-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-7.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m + implicit none (type, external) + + integer i + + interface + integer function s1 (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (x : val, step (1), val) ! { dg-error "Multiple 'linear' modifiers specified" } + end + + integer function s2 (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (x : val, step (1), step(2)) ! { dg-error "Multiple 'step' modifiers specified" } + end + + integer function s3 (x, y, z) + integer, value :: x, y, z + !$omp declare simd linear (x : val, ref, step(2)) ! { dg-error "Multiple 'linear' modifiers specified" } + end + + end interface + +end module Index: Fortran/gfortran/regression/gomp/linear-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/linear-8.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +module m + implicit none (type, external) + + interface + integer function step (x, y, z) + integer :: x, y, z + end function step + end interface + +contains + +integer function foo (x) + integer, value :: x + integer :: i + !$omp parallel do linear (x : step (step (1, 2, 3))) + do i = 0, 63 + x = x + 6 + end do + foo = x +end + +integer function bar (x) + integer, value :: x + integer :: i + !$omp parallel do linear (x : step (1, 2, 3)) ! { dg-error "40: Invalid character in name" } + do i = 0, 63 + x = x + 6 + end do + bar = x +end + +integer function bar2 (x) + integer, value :: x + integer :: i + !$omp parallel do linear (x : step (1, 2, 3) * 1) + do i = 0, 63 + x = x + 6 + end do + bar2 = x +end +end module Index: Fortran/gfortran/regression/gomp/loop-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-1.f90 @@ -0,0 +1,55 @@ +! { dg-additional-options "-fdump-tree-original" } + +implicit none +integer :: q, i, j +integer :: r +r = 0 +!$omp loop bind(thread) reduction(default,+: r) collapse(2) order(concurrent), private(q) lastprivate(i) +do i = 1,4 +do j = 1,4 + r = r + 1 + q = 5 +end do +end do + +!$omp teams loop bind(teams) collapse(2) order(concurrent), private(q) lastprivate(i) reduction(default,+: r) +do i = 1,4 +do j = 1,4 + r = r + 1 + q = 5 +end do +end do + +!$omp target teams loop bind(thread) reduction(+: r) collapse(2) order(concurrent), private(q) lastprivate(i) +do i = 1,4 +do j = 1,4 + r = r + 1 + q = 5 +end do +end do + +!$omp parallel loop bind(thread) collapse(2) order(concurrent), private(q) lastprivate(i) reduction(default,+: r) +do i = 1,4 +do j = 1,4 + r = r + 1 + q = 5 +end do +end do + +!$omp target parallel loop bind(parallel) collapse(2) order(concurrent), private(q) lastprivate(i) reduction(default,+: r) +do i = 1,4 +do j = 1,4 + r = r + 1 + q = 5 +end do +end do + +end + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:i\\) map\\(tofrom:r\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel shared\\(i\\) shared\\(r\\)\[\r\n\]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams shared\\(i\\) shared\\(r\\)\[\r\n\]" 2 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp loop private\\(q\\) lastprivate\\(i\\) reduction\\(\\+:r\\) order\\(concurrent\\) collapse\\(2\\) bind\\(parallel\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop private\\(q\\) lastprivate\\(i\\) reduction\\(\\+:r\\) order\\(concurrent\\) collapse\\(2\\) bind\\(teams\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop private\\(q\\) lastprivate\\(i\\) reduction\\(\\+:r\\) order\\(concurrent\\) collapse\\(2\\) bind\\(thread\\)" 3 "original" } } Index: Fortran/gfortran/regression/gomp/loop-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-2.f90 @@ -0,0 +1,49 @@ +subroutine foo() +implicit none +integer :: i, r +!$omp loop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp teams loop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp parallel loop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp target teams loop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp target parallel loop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do + +!$omp loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp teams loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp parallel loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp target teams loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp target parallel loop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do + +!$omp loop bind(target) ! { dg-error "17: Expected TEAMS, PARALLEL or THREAD as binding in BIND" } +do i = 1, 64 +end do + +!$omp loop bind(teams) bind(teams) ! { dg-error "Duplicated 'bind' clause" } +do i = 1, 64 +end do + +end Index: Fortran/gfortran/regression/gomp/loop-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-3.f90 @@ -0,0 +1,55 @@ +! PR middle-end/100905 +! +PROGRAM test_loop_order_concurrent + implicit none + integer :: a, cc(64), dd(64) + + dd = 54 + cc = 99 + + call test_loop() + call test_affinity(a) + if (a /= 5) stop 3 + call test_scan(cc, dd) + if (any (cc /= 99)) stop 4 + if (dd(1) /= 5 .or. dd(2) /= 104) stop 5 + +CONTAINS + + SUBROUTINE test_loop() + INTEGER,DIMENSION(1024):: a, b, c + INTEGER:: i + + DO i = 1, 1024 + a(i) = 1 + b(i) = i + 1 + c(i) = 2*(i + 1) + END DO + + !$omp loop order(concurrent) bind(thread) + DO i = 1, 1024 + a(i) = a(i) + b(i)*c(i) + END DO + + DO i = 1, 1024 + if (a(i) /= 1 + (b(i)*c(i))) stop 1 + END DO + END SUBROUTINE test_loop + + SUBROUTINE test_affinity(aa) + integer :: aa + !$omp task affinity(aa) + a = 5 + !$omp end task + end + + subroutine test_scan(c, d) + integer i, c(*), d(*) + !$omp simd reduction (inscan, +: a) + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do + end +END PROGRAM test_loop_order_concurrent Index: Fortran/gfortran/regression/gomp/loop-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-4.f90 @@ -0,0 +1,279 @@ +module m + use iso_c_binding, only: c_loc + implicit none (type, external) + integer :: v + interface + subroutine foo (); end + integer function omp_get_thread_num (); end + integer function omp_get_num_threads (); end + integer function omp_get_cancellation (); end + integer(c_int) function omp_target_is_present(ptr, device_num) bind(c) + use, intrinsic :: iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: ptr + integer(c_int), value :: device_num + end + end interface + +contains +subroutine f1(a) + integer :: a(0:) + integer :: i, j + !$omp simd order(concurrent) + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do +end + +subroutine f2 (a) + integer :: a(0:) + integer :: i, j + !$omp do simd order(concurrent) + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do +end + +subroutine f3 (a) + integer :: a(0:) + integer :: i, j + !$omp do order(concurrent) + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do +end + +subroutine f4 (a) + integer, target :: a(0:) + integer :: i, j + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp simd + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end critical + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end ordered + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = v + 1 + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + a(i) = v + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = a(i) + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop order(concurrent) bind(parallel) + do i = 0, 63 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f5 (a) + integer, target :: a(0:) + integer :: i, j + !$omp parallel + !$omp loop + do i = 0, 63 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp loop + do i = 0, 63 + !$omp simd + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop + do i = 0, 63 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end critical + end do + !$omp loop + do i = 0, 63 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end ordered + end do + !$omp loop + do i = 0, 63 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = v + 1 + end do + !$omp loop + do i = 0, 63 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + a(i) = v + end do + !$omp loop + do i = 0, 63 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = a(i) + end do + !$omp loop + do i = 0, 63 + !$omp master ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end master + end do + !$omp loop + do i = 0, 63 + !$omp masked ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end masked + end do + !$omp loop + do i = 0, 63 + !$omp scope ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end scope + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp end parallel +end + +subroutine f6 (a) + integer, target :: a(0:) + integer :: i, j + !$omp master + !$omp loop + do i = 0, 63 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp loop + do i = 0, 63 + !$omp simd + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop + do i = 0, 63 + !$omp loop + do j = 0, 63 + a(64 * i + j) = i + j + end do + end do + !$omp loop + do i = 0, 63 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end critical + end do + !$omp loop + do i = 0, 63 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + call foo () + !$omp end ordered + end do + !$omp loop + do i = 0, 63 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = v + 1 + end do + !$omp loop + do i = 0, 63 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + a(i) = v + end do + !$omp loop + do i = 0, 63 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a 'loop' region" } + v = a(i) + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp loop + do i = 0, 63 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp end master +end +end module Index: Fortran/gfortran/regression/gomp/loop-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-5.f90 @@ -0,0 +1,84 @@ +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/108512 + +! The problem was that the context wasn't reset for the 'LOOP' +! such that the clauses of the loops weren't seen when adding +! PRIVATE clauses. +! +! In the following, only the loop variable of the non-OpenMP loop +! in 'subroutine four' should get a front-end addded PRIVATE clause + +implicit none +integer :: x, a(10), b(10), n + n = 10 + a = -42 + b = [(2*x, x=1,10)] + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:a\\) map\\(tofrom:b\\) map\\(tofrom:x\\)\[\r\n\]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel\[\r\n\]" 2 "original" } } +! ^- shows up twice; checked only here. +! { dg-final { scan-tree-dump-times "#pragma omp loop lastprivate\\(x\\)\[\r\n\]" 1 "original" } } + + !$omp target parallel map(tofrom: a, b, x) + !$omp loop lastprivate(x) + DO x = 1, n + a(x) = a(x) + b(x) + END DO + !$omp end loop + !$omp end target parallel + if (x /= 11) error stop + if (any (a /= [(2*x - 42, x=1,10)])) error stop + call two() + call three() + call four() +end + +subroutine two + implicit none + integer :: ii, mm, arr(10) + mm = 10 + arr = 0 + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:arr\\) map\\(tofrom:ii\\)\[\r\n\]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel shared\\(ii\\)\[\r\n\]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop lastprivate\\(ii\\)\[\r\n\]" 1 "original" } } + + !$omp target parallel loop map(tofrom: arr) lastprivate(ii) + DO ii = 1, mm + arr(ii) = arr(ii) + ii + END DO +end + +subroutine three + implicit none + integer :: kk, zz, var(10) + zz = 10 + var = 0 + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:var\\)\[\r\n\]" 1 "original" } } +! "#pragma omp parallel\[\r\n\]" - shows up twice, dump checked above +! { dg-final { scan-tree-dump-times "#pragma omp loop\[\r\n\]" 1 "original" } } + + !$omp target parallel loop map(tofrom: var) + DO kk = 1, zz + var(kk) = var(kk) + kk + END DO +end + +subroutine four + implicit none + integer :: jj, qq, dist(10) + qq = 10 + dist = 0 + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(tofrom:dist\\)\[\r\n\]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel private\\(jj\\)\[\r\n\]" 1 "original" } } + + !$omp target parallel map(tofrom: dist) + ! *no* '!$omp do/loop/simd' + DO jj = 1, qq + dist(qq) = dist(qq) + qq + END DO + !$omp end target parallel +end Index: Fortran/gfortran/regression/gomp/loop-exit.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/loop-exit.f90 @@ -0,0 +1,674 @@ +subroutine sub1 +!$omp do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub2 +!$omp parallel do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub3 +!$omp simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub4 +!$omp do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub5 +!$omp parallel do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub6 +!$omp distribute simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub7 +!$omp distribute parallel do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub8 +!$omp distribute parallel do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub9 +!$omp teams distribute simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub10 +!$omp target teams distribute simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub11 +!$omp teams distribute parallel do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub12 +!$omp target teams distribute parallel do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub13 +!$omp teams distribute parallel do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub14 +!$omp target teams distribute parallel do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub15 +!$omp target parallel do +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub16 +!$omp target parallel do simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub17 +!$omp target simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub18 +!$omp taskloop simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub19 +!$omp parallel master taskloop simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub20 +!$omp master taskloop simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub21 +!$omp parallel masked taskloop simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub22 +!$omp masked taskloop simd +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub23 +!$omp loop +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub24 +!$omp parallel loop +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub25 +!$omp teams loop +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub26 +!$omp target parallel loop +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub27 +!$omp target teams loop +outer: do i = 1, 5 + inner: do j = 1, 5 + if (k == 5) exit ! ok + if (k == 7) exit inner ! ok + if (k == 9) exit outer ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do inner +end do outer +end + +subroutine sub28 +!$omp do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub29 +!$omp parallel do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub30 +!$omp simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub31 +!$omp do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub32 +!$omp parallel do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub33 +!$omp distribute simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub34 +!$omp distribute parallel do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub35 +!$omp distribute parallel do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub36 +!$omp teams distribute simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub37 +!$omp target teams distribute simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub38 +!$omp teams distribute parallel do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub39 +!$omp target teams distribute parallel do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub40 +!$omp teams distribute parallel do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub41 +!$omp target teams distribute parallel do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub42 +!$omp target parallel do collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub43 +!$omp target parallel do simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub44 +!$omp target simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub45 +!$omp taskloop simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub46 +!$omp parallel master taskloop simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub47 +!$omp master taskloop simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub48 +!$omp parallel masked taskloop simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub49 +!$omp masked taskloop simd collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub50 +!$omp loop collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub51 +!$omp parallel loop collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub52 +!$omp teams loop collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub53 +!$omp target parallel loop collapse(3) +do ii = i1, i2 +do jj = j1, j2 +do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end + +subroutine sub54 +!$omp target teams loop collapse(3) +do ii = i1, i2 + do jj = j1, j2 + do kk = k1, k2 + if (kk > 5) then + k = 0 + end if + if (kk == 7) exit ! { dg-error "EXIT statement at .1. terminating !.OMP DO loop" } + end do + end do +end do +end Index: Fortran/gfortran/regression/gomp/map-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-1.f90 @@ -0,0 +1,111 @@ +subroutine test(aas) + implicit none + + integer :: i, j(10), k(10, 10), aas(*) + integer, save :: tp + !$omp threadprivate(tp) + integer, parameter :: p = 1 + + type t + integer :: i, j(10) + end type t + + type(t) :: tt + + !$omp target map(i) + !$omp end target + + !$omp target map(j) + !$omp end target + + !$omp target map(p) ! { dg-error "Object 'p' is not a variable" } + !$omp end target + + !$omp target map(j(1)) + !$omp end target + + !$omp target map(j(i)) + !$omp end target + + !$omp target map(j(i:)) + !$omp end target + + !$omp target map(j(:i)) + !$omp end target + + !$omp target map(j(i:i+1)) + !$omp end target + + !$omp target map(j(11)) ! { dg-warning "out of bounds" } + !$omp end target + + !$omp target map(j(:11)) ! { dg-warning "out of bounds" } + !$omp end target + + !$omp target map(j(0:)) ! { dg-warning "out of bounds" } + !$omp end target + + !$omp target map(j(5:4)) + !$omp end target + + !$omp target map(j(5:)) + !$omp end target + + !$omp target map(j(:5)) + !$omp end target + + !$omp target map(j(:)) + !$omp end target + + !$omp target map(j(1:9:2)) + ! { dg-error "Array is not contiguous" "" { target *-*-* } 60 } + ! { dg-error "Stride should not be specified for array section in MAP clause" "" { target *-*-* } 60 } + !$omp end target + + !$omp target map(aas(5:)) + !$omp end target + ! { dg-error "Rightmost upper bound of assumed size array section not specified" "" { target *-*-* } 65 } + ! { dg-error "'aas' in MAP clause at \\\(1\\\) is not a proper array section" "" { target *-*-* } 65 } + + !$omp target map(aas(:)) + !$omp end target + ! { dg-error "Rightmost upper bound of assumed size array section not specified" "" { target *-*-* } 70 } + ! { dg-error "'aas' in MAP clause at \\\(1\\\) is not a proper array section" "" { target *-*-* } 70 } + + !$omp target map(aas) ! { dg-error "Assumed size array" } + !$omp end target + + !$omp target map(aas(5:7)) + !$omp end target + + !$omp target map(aas(:7)) + !$omp end target + + !$omp target map(k(5:)) + !$omp end target + ! { dg-error "Rank mismatch in array reference" "" { target *-*-* } 84 } + ! { dg-error "'k' in MAP clause at \\\(1\\\) is not a proper array section" "" { target *-*-* } 84 } + + !$omp target map(k(5:,:,3)) + !$omp end target + ! { dg-error "Rank mismatch in array reference" "" { target *-*-* } 89 } + ! { dg-error "'k' in MAP clause at \\\(1\\\) is not a proper array section" "" { target *-*-* } 89 } + + !$omp target map(tt) + !$omp end target + + !$omp target map(tt%k) ! { dg-error "not a member of" } + !$omp end target ! { dg-error "Unexpected !\\\$OMP END TARGET statement" } + + !$omp target map(tt%j) + !$omp end target + + !$omp target map(tt%j(1)) + !$omp end target + + !$omp target map(tt%j(1:)) + !$omp end target + + !$omp target map(tp) ! { dg-error "THREADPRIVATE object 'tp' in MAP clause" } + !$omp end target +end subroutine test Index: Fortran/gfortran/regression/gomp/map-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-2.f90 @@ -0,0 +1,6 @@ +type t + integer :: i +end type t +type(t) v +!$omp target enter data map(to:v%i, v%i) +end Index: Fortran/gfortran/regression/gomp/map-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-3.f90 @@ -0,0 +1,38 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine bar +integer, target :: x, x2 +integer, allocatable, target :: y(:,:), z(:,:) +x = 7 +!$omp target enter data map(to:x, x2) + +x = 8 +!$omp target data map(always, to: x) +call foo(x) +!$omp end target data + +!$omp target data use_device_ptr(x) +call foo2(x) +!$omp end target data + +!$omp target data use_device_addr(x2) +call foo2(x) +!$omp end target data +!$omp target exit data map(release:x) + +!$omp target data map(y) use_device_addr(y) +call foo3(y) +!$omp end target data + +!$omp target data map(z) use_device_ptr(z) +call foo3(z) +!$omp end target data +end + +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(to:x\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(always,to:x\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data use_device_addr\\(x\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data use_device_addr\\(x2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(release:x\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) y.data \\\[len: .*\\) map\\(to:y \\\[pointer set, len: .*\\) map\\(alloc:.*y.data \\\[pointer assign, bias: 0\\\]\\) use_device_addr\\(y\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\) z.data \\\[len: .*\\) map\\(to:z \\\[pointer set, len: .*\\) map\\(alloc:.*z.data \\\[pointer assign, bias: 0\\\]\\) use_device_addr\\(z\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/map-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-4.f90 @@ -0,0 +1,7 @@ +!$omp target enter data device(1) if (.true.) nowait ! { dg-error "TARGET ENTER DATA must contain at least one MAP clause" } + +!$omp target data device(1) ! { dg-error "TARGET DATA must contain at least one MAP, USE_DEVICE_PTR, or USE_DEVICE_ADDR clause" } +!$omp endtarget data + +!$omp target exit data device(1) if (.true.) nowait ! { dg-error "TARGET EXIT DATA must contain at least one MAP clause" } +end Index: Fortran/gfortran/regression/gomp/map-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-5.f90 @@ -0,0 +1,13 @@ +implicit none +type t + integer :: b(5) +end type t +integer :: a(5), x, y(5) +type(t) :: b +!$omp target enter data map( to: a (:) ) +!$omp target enter data map( to: b % b ) +!$omp target enter data map( to: a(:) ) +!$omp target depend(out: y (2)) nowait +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/map-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-6.f90 @@ -0,0 +1,50 @@ +! { dg-additional-options "-fdump-tree-original" } + +implicit none + +integer :: a, b, b1, b2, b3, b4, b5, b6 + +!$omp target map(a) +!$omp end target + +!$omp target map(to : a) +!$omp end target + +!$omp target map(always to: a) +!$omp end target +!$omp target map(always, to: a) +!$omp end target +!$omp target map(close to: a) +!$omp end target +!$omp target map(close, to: a) +!$omp end target + +!$omp target map(close always to:b1) +!$omp end target +!$omp target map(close, always to:b2) +!$omp end target +!$omp target map(close, always, to:b3) +!$omp end target +!$omp target map(always close to:b4) +!$omp end target +!$omp target map(always, close to:b5) +!$omp end target +!$omp target map(always, close, to:b6) +!$omp end target + + +!$omp target map (always to : a) map (close to : b) +!$omp end target + +end + +! { dg-final { scan-tree-dump-not "map\\(\[^\n\r)]*close\[^\n\r)]*to:" "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(always,to:" 9 "original" } } + +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b1\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b2\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b3\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b4\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b5\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:b6\\)" "original" } } Index: Fortran/gfortran/regression/gomp/map-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-7.f90 @@ -0,0 +1,26 @@ +! { dg-additional-options "-fdump-tree-original" } + +implicit none + +integer :: a, b, close, always, to + +!$omp target map(close) +!$omp end target + +!$omp target map(always) +!$omp end target + +!$omp target map(always, close) +!$omp end target + +!$omp target map(always, close, to : always, close, a) +!$omp end target + +!$omp target map(to, always, close) +!$omp end target + +end + +! { dg-final { scan-tree-dump-not "map\\(\[^\n\r)]*close\[^\n\r)]*to:" "original" } } +! { dg-final { scan-tree-dump "#pragma omp target map\\(always,to:always\\) map\\(always,to:close\\) map\\(always,to:a\\)" "original" } } +! { dg-final { scan-tree-dump-not "map\\(\[^\n\r)]*close\[^\n\r)]*to:" "original" } } Index: Fortran/gfortran/regression/gomp/map-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-8.f90 @@ -0,0 +1,34 @@ +implicit none + +integer :: a + +!$omp target map(close, delete: a) ! { dg-error "TARGET with map-type other than TO, FROM, TOFROM, or ALLOC on MAP clause at \\(1\\)" } +!$omp end target + +!$omp target map(close) ! { dg-error "Symbol 'close' at \\(1\\) has no IMPLICIT type" } +!$omp end target + +!$omp target map(always) ! { dg-error "Symbol 'always' at \\(1\\) has no IMPLICIT type" } +!$omp end target + +!$omp target map(always, always, to : a) ! { dg-error "too many 'always' modifiers" } +! !$omp end target +!$omp target map(always always, to : a) ! { dg-error "too many 'always' modifiers" } +! !$omp end target +!$omp target map(always, always to : a) ! { dg-error "too many 'always' modifiers" } +! !$omp end target +!$omp target map(always always to : a) ! { dg-error "too many 'always' modifiers" } +! !$omp end target +!$omp target map(close, close, to : a) ! { dg-error "too many 'close' modifiers" } +! !$omp end target +!$omp target map(close close, to : a) ! { dg-error "too many 'close' modifiers" } +! !$omp end target +!$omp target map(close, close to : a) ! { dg-error "too many 'close' modifiers" } +! !$omp end target +!$omp target map(close close to : a) ! { dg-error "too many 'close' modifiers" } +! !$omp end target + +!$omp target map(close close always always to : a) ! { dg-error "too many 'always' modifiers" } +! !$omp end target + +end Index: Fortran/gfortran/regression/gomp/map-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-9.f90 @@ -0,0 +1,13 @@ +! { dg-additional-options "-fdump-tree-omplower" } + +! PR fortran/108545 + +! { dg-final { scan-tree-dump "#pragma omp target enter data map\\(struct:x \\\[len: 1\\\]\\) map\\(to:x.a \\\[len: \[0-9\]+\\\]\\) map\\(to:MEM \\\[\\(integer\\(kind=4\\)\\\[0:\\\] \\*\\)_\[0-9\]+] \\\[len: _\[0-9\]+\\\]\\) map\\(always_pointer:x.a.data \\\[pointer assign, bias: 0\\\]\\)" "omplower" } } + +program p + type t + integer, pointer :: a(:) + end type + type(t), volatile :: x + !$omp target enter data map(to: x%a) +end Index: Fortran/gfortran/regression/gomp/map-alloc-comp-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/map-alloc-comp-1.f90 @@ -0,0 +1,14 @@ +! +! ALLOCATABLE COMPONENTS: +! - OpenMP 5: Permitted (and automatically recursively mapped) +! -> Not yet supported. +! - OpenMP 4.5: Not permitted. +! +implicit none (type, external) +type sct + integer, allocatable :: c +end type +type(sct) var + +!$omp target enter data map(to:var) ! { dg-error "allocatable components is not permitted in map clause" } +end Index: Fortran/gfortran/regression/gomp/masked-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-1.f90 @@ -0,0 +1,94 @@ +! { dg-additional-options "-ffree-line-length-none" } +subroutine foo (x, a) + implicit none + integer, value :: x + integer, contiguous :: a(0:) + external :: bar + integer :: i + + !$omp masked + call bar () + !$omp end masked + + !$omp masked filter (0) + call bar () + !$omp end masked + + !$omp masked filter (7) + call bar () + !$omp end masked + + !$omp masked filter (x) + call bar () + !$omp end masked + + !$omp masked taskloop simd filter (x) grainsize (12) simdlen (4) + do i = 0, 127 + a(i) = i + end do + !$omp end masked taskloop simd + + !$omp parallel masked filter (x) firstprivate (x) + call bar () + !$omp end parallel masked + + !$omp masked + !$omp masked filter (0) + !$omp masked filter (x) + !$omp end masked + !$omp end masked + !$omp end masked +end + +subroutine foobar (d, f, fi, p, s, g, i1, i2, l, ll, nth, ntm, pp, q, r, r2) + implicit none (type, external) + logical :: i1, i2, fi + integer :: i, d, f, p, s, g, l, ll, nth, ntm, pp, q, r, r2 + allocatable :: q + integer, save :: t + !$omp threadprivate (t) + + !$omp parallel masked & + !$omp& private (p) firstprivate (f) if (parallel: i2) default(shared) shared(s) reduction(+:r) & + !$omp& num_threads (nth) proc_bind(spread) copyin(t) filter (d) ! allocate (f) + ! + !$omp end parallel masked + + !$omp taskgroup task_reduction (+:r2) ! allocate (r2) + !$omp masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) in_reduction(+:r2) filter (d) ! allocate (f) + do i = 0, 63 + ll = ll + 1 + end do + !$omp end masked taskloop + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) ! allocate (r2) + !$omp masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) filter (d) ! allocate (f) + do i = 0, 63 + ll = ll + 1 + end do + !$omp end masked taskloop simd + !$omp end taskgroup + + !$omp parallel masked taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) filter (d) ! allocate (f) + do i = 0, 63 + ll = ll + 1 + end do + !$omp end parallel masked taskloop + + !$omp parallel masked taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) nontemporal(ntm) if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& order(concurrent) filter (d) ! allocate (f) + do i = 0, 63 + ll = ll + 1 + end do + !$omp end parallel masked taskloop simd +end subroutine Index: Fortran/gfortran/regression/gomp/masked-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-2.f90 @@ -0,0 +1,46 @@ +module m + implicit none (external, type) + type t + end type t +contains +subroutine foo (x, y, z, a) + external :: bar + type(t) :: x + integer :: y + real :: z + integer :: a(4) + + !$omp masked filter (x) ! { dg-error "FILTER clause at .1. requires a scalar INTEGER expression" } + call bar () + !$omp end masked + + !$omp masked filter (y) ! OK + call bar () + !$omp end masked + + !$omp masked filter (z) ! { dg-error "FILTER clause at .1. requires a scalar INTEGER expression" } + call bar () + !$omp end masked + + !$omp masked filter (a) ! { dg-error "FILTER clause at .1. requires a scalar INTEGER expression" } + call bar () + !$omp end masked + + !$omp masked filter (0.0) ! { dg-error "FILTER clause at .1. requires a scalar INTEGER expression" } + call bar () + !$omp end masked + + !$omp masked filter ([1]) ! { dg-error "FILTER clause at .1. requires a scalar INTEGER expression" } + call bar () + !$omp end masked + + !$omp masked filter (-1) ! { dg-warning "INTEGER expression of FILTER clause at .1. must be non-negative" } + call bar () + !$omp end masked +end +end module + +subroutine bar + !$omp masked filter (0) filter (0) ! { dg-error "Duplicated 'filter' clause" } + call foobar +end Index: Fortran/gfortran/regression/gomp/masked-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-3.f90 @@ -0,0 +1,12 @@ +subroutine foo + + !$omp masked + goto 55 ! { dg-error "invalid branch to/from OpenMP structured block" } + ! { dg-warning "Legacy Extension: Label at .1. is not in the same block as the GOTO statement" "" { target *-*-* } .-1 } + !$omp end masked + + !$omp masked +55 continue ! { dg-warning "Legacy Extension: Label at .1. is not in the same block as the GOTO statement" } + return ! { dg-error "invalid branch to/from OpenMP structured block" } + !$omp end masked +end subroutine foo Index: Fortran/gfortran/regression/gomp/masked-combined-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-combined-1.f90 @@ -0,0 +1,65 @@ +subroutine foo (a, f) + implicit none (type, external) + interface + subroutine bar (x) + integer :: x + end subroutine + end interface + + integer, value :: f + integer, contiguous :: a(0:) + integer :: i, j, k, u, v, w, x, y, z + + !$omp parallel masked default(none) private (k) filter (f) firstprivate (f) + call bar (k) + !$omp end parallel masked + + !$omp parallel masked default(none) private (k) + call bar (k) + !$omp end parallel masked + + !$omp parallel default(none) firstprivate(a, f) shared(x, y, z) + !$omp masked taskloop reduction (+:x) default(none) firstprivate(a) filter (f) + do i = 0, 63 + x = x + a(i) + end do + !$omp end masked taskloop + !$omp masked taskloop simd reduction (+:y) default(none) firstprivate(a) private (i) filter (f) + do i = 0, 63 + y = y + a(i) + end do + !$omp end masked taskloop simd + !$omp masked taskloop simd reduction (+:y) default(none) firstprivate(a) private (i) + do i = 0, 63 + y = y + a(i) + end do + !$omp end masked taskloop simd + !$omp masked taskloop simd collapse(2) reduction (+:z) default(none) firstprivate(a) private (i, j) filter (f) + do j = 0, 0 + do i = 0, 63 + z = z + a(i) + end do + end do + !$omp end masked taskloop simd + !$omp end parallel + + !$omp parallel masked taskloop reduction (+:u) default(none) firstprivate(a, f) filter (f) + do i = 0, 63 + u = u + a(i) + end do + !$omp end parallel masked taskloop + + !$omp parallel masked taskloop simd reduction (+:v) default(none) firstprivate(a, f) filter (f) + do i = 0, 63 + v = v + a(i) + end do + !$omp end parallel masked taskloop simd + + !$omp parallel masked taskloop simd collapse(2) reduction (+:w) default(none) firstprivate(a, f) filter (f) + do j = 0, 0 + do i = 0, 63 + w = w + a(i) + end do + end do + !$omp end parallel masked taskloop simd +end Index: Fortran/gfortran/regression/gomp/masked-combined-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-combined-2.f90 @@ -0,0 +1,24 @@ +subroutine foo (a) + implicit none (external, type) + integer, contiguous :: a(0:) + integer :: i, r, s + r = 0; s = 0 + + ! In 'parallel masked taskloop', in_reduction is not permitted. + + !$omp taskgroup task_reduction(+:r) + !$omp parallel masked taskloop in_reduction(+:r) ! { dg-error "36: Failed to match clause" } + do i = 0, 63 + r = r + a(i) + end do + !!$omp end parallel masked taskloop + !$omp end taskgroup + + !$omp taskgroup task_reduction(+:s) + !$omp parallel masked taskloop simd in_reduction(+:s) ! { dg-error "41: Failed to match clause" } + do i = 0, 63 + s = s + a(i) + end do + !!$omp end parallel masked taskloop simd + !$omp end taskgroup +end Index: Fortran/gfortran/regression/gomp/masked-taskloop.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/masked-taskloop.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-additional-options "-fopenmp -fdump-tree-original" } + +! There was a bug in the clause splitting for the "masked taskloop" +! combined directive that caused it to lose all the clauses. + +subroutine s1 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp masked taskloop collapse(2) grainsize(4) + do i = 1, a1 + do j = 1, a2 + end do + end do + +end subroutine + +! { dg-final { scan-tree-dump "omp taskloop \[^\n\r]*grainsize\\(4\\)" "original" } } +! { dg-final { scan-tree-dump "omp taskloop \[^\n\r]*collapse\\(2\\)" "original" } } Index: Fortran/gfortran/regression/gomp/minmaxloc_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/minmaxloc_1.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! +! PR fortran/108450 +! This program used to cause an ICE because of the double resolution +! of the maxloc expression and the addition of a hidden unnamed argument +! during the first resolution. +! +! Original testcase from G. Steinmetz + +subroutine s1 + integer :: a(8) = 0 + integer :: l + integer :: n + !$omp atomic + n = maxloc(a, mask=l) ! { dg-error ".mask. argument of .maxloc. intrinsic at .1. must be LOGICAL" } +end + +subroutine s2 + integer :: a(8) = 0 + integer :: l + integer :: n + !$omp atomic + n = minloc(a, mask=l) ! { dg-error ".mask. argument of .minloc. intrinsic at .1. must be LOGICAL" } +end + +subroutine s3 + integer :: a(8) = 0 + integer :: l + integer :: n + !$omp atomic + n = findloc(a, 3, mask=l) ! { dg-error ".mask. argument of .findloc. intrinsic at .1. must be LOGICAL" } +end Index: Fortran/gfortran/regression/gomp/nesting-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nesting-1.f90 @@ -0,0 +1,68 @@ +module m + implicit none + integer i +contains + +subroutine f_omp_parallel + !$omp parallel + !$omp parallel + !$omp end parallel + + !$omp target + !$omp end target + + !$omp target data map(i) + !$omp end target data + + !$omp target update to(i) + + !$omp target data map(i) + !$omp parallel + !$omp end parallel + + !$omp target + !$omp end target + + !$omp target data map(i) + !$omp end target data + + !$omp target update to(i) + !$omp end target data + !$omp end parallel +end + +subroutine f_omp_target + !$omp target + !$omp parallel + !$omp end parallel + !$omp end target +end + +subroutine f_omp_target_data + !$omp target data map(i) + !$omp parallel + !$omp end parallel + + !$omp target + !$omp end target + + !$omp target data map(i) + !$omp end target data + + !$omp target update to(i) + + !$omp target data map(i) + !$omp parallel + !$omp end parallel + + !$omp target + !$omp end target + + !$omp target data map(i) + !$omp end target data + + !$omp target update to(i) + !$omp end target data + !$omp end target data +end +end module m Index: Fortran/gfortran/regression/gomp/nesting-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nesting-2.f90 @@ -0,0 +1,165 @@ +subroutine foo + integer :: i, j + !$omp taskloop + do i = 0, 63 + !$omp do ! { dg-error "region may not be closely nested inside of" } + do j = 0, 9 + end do + !$omp single ! { dg-error "region may not be closely nested inside of" } + !$omp end single + !$omp sections ! { dg-error "region may not be closely nested inside of" } + !$omp section + block + end block + !$omp end sections + !$omp barrier ! { dg-error "region may not be closely nested inside of" } + !$omp master ! { dg-error "region may not be closely nested inside of" } -- ? + block; end block ! otherwise not generated + !$omp end master + !$omp masked ! { dg-error "region may not be closely nested inside of" } -- ? + block; end block ! otherwise not generated + !$omp end masked + !$omp scope ! { dg-error "region may not be closely nested inside of" } -- ? + block; end block ! otherwise not generated + !$omp end scope + !$omp ordered ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp ordered threads ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp ordered simd threads ! { dg-error ".ordered. .simd. must be closely nested inside .simd. region" } + !$omp end ordered + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp critical + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp end critical + end do + !$omp taskloop + do i = 0, 63 + !$omp parallel + !$omp do + do j = 0, 9 + end do + !$omp single + !$omp end single + !$omp sections + !$omp section + block; end block + !$omp end sections + !$omp barrier + !$omp master + block; end block ! otherwise not generated + !$omp end master + !$omp masked + block; end block ! otherwise not generated + !$omp end masked + !$omp scope + block; end block ! otherwise not generated + !$omp end scope + !$omp ordered ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp ordered threads ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp critical + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp end critical + !$omp end parallel + end do + !$omp taskloop + do i = 0, 63 + !$omp target + !$omp do + do j = 0, 9 + end do + !$omp single + !$omp end single + !$omp sections + !$omp section + block; end block + !$omp end sections + !$omp barrier + !$omp master + block; end block ! otherwise not generated + !$omp end master + !$omp masked + block; end block ! otherwise not generated + !$omp end masked + !$omp scope + block; end block ! otherwise not generated + !$omp end scope + !$omp ordered ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp ordered threads ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp critical + !$omp simd + do j = 0, 9 + !$omp ordered simd + !$omp end ordered + end do + !$omp end critical + !$omp end target + end do + !$omp ordered + !$omp ordered ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp end ordered + !$omp ordered threads + !$omp ordered ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp end ordered + !$omp ordered + !$omp ordered threads ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp end ordered + !$omp ordered threads + !$omp ordered threads ! { dg-error "region may not be closely nested inside of" } + !$omp end ordered + !$omp end ordered + !$omp critical + !$omp ordered simd ! { dg-error ".ordered. .simd. must be closely nested inside .simd. region" } + !$omp end ordered + !$omp end critical + !$omp do ordered + do i = 0, 63 + !$omp parallel + !$omp ordered threads ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp end parallel + end do + !$omp do ordered + do i = 0, 63 + !$omp parallel + !$omp ordered ! { dg-error ".ordered. region must be closely nested inside a loop region with an .ordered. clause" } + !$omp end ordered + !$omp end parallel + end do + !$omp do ordered(1) + do i = 0, 63 + !$omp parallel + !$omp ordered depend(source) ! { dg-error ".ordered. construct with .depend. clause must be closely nested inside a loop with .ordered. clause" } + !$omp ordered depend(sink: i - 1) ! { dg-error ".ordered. construct with .depend. clause must be closely nested inside a loop with .ordered. clause" } + !$omp end parallel + end do +end Index: Fortran/gfortran/regression/gomp/nesting-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nesting-3.f90 @@ -0,0 +1,347 @@ +subroutine f1 + integer i, j + !$omp do + do i = 0, 2 + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master ! { dg-error "may not be closely nested" } + block; end block + !$omp end master + !$omp masked ! { dg-error "may not be closely nested" } + block; end block + !$omp end masked + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + end do + !$omp sections + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp end sections + !$omp sections + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp end sections + !$omp sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp end sections + !$omp sections + !$omp master ! { dg-error "may not be closely nested" } + block; end block + !$omp end master + !$omp end sections + !$omp sections + !$omp masked ! { dg-error "may not be closely nested" } + block; end block + !$omp end masked + !$omp end sections + !$omp sections + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end sections + !$omp sections + !$omp section + block; end block + !$omp end sections + !$omp sections + !$omp section + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp end sections + !$omp sections + !$omp section + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp end sections + !$omp sections + !$omp section + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp end sections + !$omp sections + !$omp section + !$omp master ! { dg-error "may not be closely nested" } + block; end block + !$omp end master + !$omp section + !$omp masked ! { dg-error "may not be closely nested" } + block; end block + !$omp end masked + !$omp end sections + !$omp sections + !$omp section + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end sections + !$omp single + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master ! { dg-error "may not be closely nested" } + block; end block + !$omp end master + !$omp masked ! { dg-error "may not be closely nested" } + block; end block + !$omp end masked + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end single + !$omp master + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master + block; end block + !$omp end master + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end master + !$omp masked filter (1) + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master + block; end block + !$omp end master + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end masked + !$omp task + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master ! { dg-error "may not be closely nested" } + block; end block + !$omp end master + !$omp masked ! { dg-error "may not be closely nested" } + block; end block + !$omp end masked + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end task + !$omp parallel + !$omp do + do j = 0, 2 + block; end block + end do + !$omp sections + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single + block; end block + !$omp end single + !$omp master + block; end block + !$omp end master + !$omp masked + block; end block + !$omp end masked + !$omp barrier + !$omp scope + block; end block + !$omp end scope + !$omp scope + !$omp scope + block; end block + !$omp end scope + !$omp end scope + !$omp end parallel + !$omp scope + !$omp do + do j = 0, 2 + block; end block + end do + !$omp sections + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single + block; end block + !$omp end single + !$omp master + block; end block + !$omp end master + !$omp masked + block; end block + !$omp end masked + !$omp barrier + !$omp scope + block; end block + !$omp end scope + !$omp scope + !$omp scope + block; end block + !$omp end scope + !$omp end scope + !$omp end scope +end + +subroutine f2 + integer i, j + !$omp ordered + !$omp do ! { dg-error "may not be closely nested" } + do j = 0, 2 + block; end block + end do + !$omp sections ! { dg-error "may not be closely nested" } + call do_work + !$omp section + block; end block + !$omp end sections + !$omp single ! { dg-error "may not be closely nested" } + block; end block + !$omp end single + !$omp master + block; end block + !$omp end master + !$omp masked + block; end block + !$omp end masked + !$omp barrier ! { dg-error "may not be closely nested" } + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end ordered +end + +subroutine f3 (void) + !$omp critical + !$omp ordered ! { dg-error "may not be closely nested" } + block; end block + !$omp end ordered + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end critical +end + +subroutine f4 (void) + !$omp task + !$omp ordered ! { dg-error "may not be closely nested" } + block; end block + !$omp end ordered + !$omp scope ! { dg-error "may not be closely nested" } + block; end block + !$omp end scope + !$omp end task +end + +subroutine f5 (void) + integer i + !$omp do + do i = 0, 9 + !$omp ordered ! { dg-error "must be closely nested" } + block; end block + !$omp end ordered + end do + !$omp do ordered + do i = 0, 9 + !$omp ordered + block; end block + !$omp end ordered + end do +end + +subroutine f6 (void) + !$omp critical (foo) + !$omp critical (bar) + block; end block + !$omp end critical (bar) + !$omp end critical (foo) + !$omp critical + !$omp critical (baz) + block; end block + !$omp end critical (baz) + !$omp end critical +end + +subroutine f7 (void) + !$omp critical (foo2) + !$omp critical + block; end block + !$omp end critical + !$omp end critical (foo2) + !$omp critical (bar) + !$omp critical (bar) ! { dg-error "may not be nested" } + block; end block + !$omp end critical (bar) + !$omp end critical (bar) + !$omp critical + !$omp critical ! { dg-error "may not be nested" } + block; end block + !$omp end critical + !$omp end critical +end Index: Fortran/gfortran/regression/gomp/non-rectangular-loop.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/non-rectangular-loop.f90 @@ -0,0 +1,227 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +! Test that errors are given for cases where there are constraints +! disallowing nonrectangular loops. + +! Work-sharing loop disallows "schedule" and "ordered" clauses. + +subroutine s1 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp do collapse(2) ordered ! { dg-error "'ordered' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp do collapse(2) ordered ! { dg-error "'ordered' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + ! Derived constructs + + !$omp do simd collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp parallel do simd collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp target parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp target parallel do collapse(2) schedule(static) ! { dg-error "'schedule' clause may not appear on non-rectangular 'do'" } + do i = 1, 16 + do j = 1, i + end do + end do + +end subroutine + + +! Distribute construct disallows "dist_schedule" clause. + +subroutine s2 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + ! Derived constructs + + !$omp distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp teams distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp teams distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp teams distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp teams distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp target teams distribute collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp target teams distribute simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp target teams distribute parallel do collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp target teams distribute parallel do simd collapse(2) dist_schedule(static) ! { dg-error "'dist_schedule' clause may not appear on non-rectangular 'distribute'" } + do i = 1, 16 + do j = i, 16 + end do + end do + +end subroutine + +! Taskloop construct disallows "grainsize" and "num_tasks" clauses. + +subroutine s3 (a1, a2) + integer :: a1, a2 + integer :: i, j + + !$omp taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + !$omp taskloop collapse(2) num_tasks(4) ! { dg-error "'num_tasks' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp taskloop collapse(2) num_tasks(4) ! { dg-error "'num_tasks' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = i, 16 + end do + end do + + ! Derived constructs + + !$omp taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp masked taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp masked taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp parallel masked taskloop collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + + !$omp parallel masked taskloop simd collapse(2) grainsize(4) ! { dg-error "'grainsize' clause may not appear on non-rectangular 'taskloop'" } + do i = 1, 16 + do j = 1, i + end do + end do + +end subroutine + +! TODO: not yet implemented +! The tile construct disallows all non-rectangular loops. + + Index: Fortran/gfortran/regression/gomp/nontemporal-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nontemporal-1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-O2 -fdump-tree-original" } + +module m + integer :: a(:), b(1024), c(1024), d(1024) + allocatable :: a +end module m + +subroutine foo + use m + implicit none + integer :: i + !$omp simd nontemporal (a, b) + do i = 1, 1024 + a(i) = b(i) + c(i) + end do + + !$omp simd nontemporal (d) + do i = 1, 1024 + d(i) = 2 * c(i) + end do +end subroutine foo + +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) nontemporal\\(a\\) nontemporal\\(b\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) nontemporal\\(d\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/nontemporal-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nontemporal-2.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } + +module m + integer, allocatable :: a(:), b(:), c(:), d(:) +end module m + +subroutine foo + use m + implicit none + integer :: i + + !$omp simd nontemporal (a, b) aligned (a, b, c) + do i = 1, ubound(a, dim=1) + a(i) = b(i) + c(i) + end do + + !$omp simd nontemporal (d) nontemporal (d) ! { dg-error "'d' present on multiple clauses" } + do i = 1, ubound(d, dim=1) + d(i) = 2 * c(i) + end do + + !$omp simd nontemporal (a, b, b) ! { dg-error "'b' present on multiple clauses" } + do i = 1, ubound(a, dim=1) + a(i) = a(i) + b(i) + c(i) + end do +end subroutine foo Index: Fortran/gfortran/regression/gomp/nothing-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nothing-1.f90 @@ -0,0 +1,28 @@ +module m + implicit none (type, external) + !$omp nothing + + type t + !$omp nothing + integer s + end type + +contains + +integer function foo (i) + integer :: i + + !$omp nothing + if (.false.) & +& & !$omp nothing + i = i + 1 + +! In the following, '& & !$' is not a valid OpenMP sentinel and, +! hence, the line is regarded as comment + if (.false.) & +& & !$omp nothing + then + end if + foo = i +end +end module Index: Fortran/gfortran/regression/gomp/nothing-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nothing-2.f90 @@ -0,0 +1,7 @@ +pure subroutine foo + !$omp nothing ! { dg-error "OpenMP directives other than SIMD or DECLARE TARGET at .1. may not appear in PURE procedures" } +end subroutine + +subroutine bar + !$omp nothing foo ! { dg-error "Unexpected junk after .OMP NOTHING statement" } +end Index: Fortran/gfortran/regression/gomp/nowait-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-1.f90 @@ -0,0 +1,19 @@ +subroutine foo + +!$omp do +do i = 1, 2 +end do +!$omp end do nowait foo ! { dg-error "Unexpected junk after NOWAIT clause" } +!$omp end do ! as previous line is ignored + +!$omp scope + block; end block +!$omp end scope bar ! { dg-error "Unexpected junk at" } +!$omp end scope + +!$omp scope + block; end block +!$omp end scope nowait nowait ! { dg-error "Unexpected junk after NOWAIT clause" } +!$omp end scope + +end Index: Fortran/gfortran/regression/gomp/nowait-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-2.f90 @@ -0,0 +1,156 @@ +! Cross check that it is accepted without nowait +subroutine bar() +implicit none +integer :: i, a(5) +!$omp atomic write +i = 5 +!$omp end atomic + +!$omp critical +!$omp end critical + +!$omp distribute +do i = 1, 5 +end do +!$omp end distribute + +!$omp distribute parallel do +do i = 1, 5 +end do +!$omp end distribute parallel do + +!$omp distribute parallel do simd +do i = 1, 5 +end do +!$omp end distribute parallel do simd + +!$omp distribute simd +do i = 1, 5 +end do +!$omp end distribute simd + +!$omp masked +!$omp end masked + +!$omp masked taskloop +do i = 1, 5 +end do +!$omp end masked taskloop + +!$omp masked taskloop simd +do i = 1, 5 +end do +!$omp end masked taskloop simd + +!$omp master +!$omp end master + +!$omp master taskloop +do i = 1, 5 +end do +!$omp end master taskloop + +!$omp master taskloop simd +do i = 1, 5 +end do +!$omp end master taskloop simd + +!$omp ordered +!$omp end ordered + +!$omp parallel +!$omp end parallel + +!$omp parallel workshare +a(:) = 5 +!$omp end parallel workshare + +!$omp parallel do +do i = 1, 5 +end do +!$omp end parallel do + +!$omp parallel do simd +do i = 1, 5 +end do +!$omp end parallel do simd + +!$omp parallel sections + !$omp section + block; end block +!$omp end parallel sections + +!$omp parallel masked +!$omp end parallel masked + +!$omp parallel masked taskloop +do i = 1, 5 +end do +!$omp end parallel masked taskloop + +!$omp parallel masked taskloop simd +do i = 1, 5 +end do +!$omp end parallel masked taskloop simd + +!$omp parallel master +!$omp end parallel master + +!$omp parallel master taskloop +do i = 1, 5 +end do +!$omp end parallel master taskloop + +!$omp parallel master taskloop simd +do i = 1, 5 +end do +!$omp end parallel master taskloop simd + +!$omp simd +do i = 1, 5 +end do +!$omp end simd + +!$omp task +!$omp end task + +!$omp taskgroup +!$omp end taskgroup + +!$omp taskloop +do i = 1, 5 +end do +!$omp end taskloop + +!$omp taskloop simd +do i = 1, 5 +end do +!$omp end taskloop simd + +!$omp teams +!$omp end teams + +!$omp teams distribute +do i = 1, 5 +end do +!$omp end teams distribute + +!$omp teams distribute parallel do +do i = 1, 5 +end do +!$omp end teams distribute parallel do + +!$omp teams distribute parallel do simd +do i = 1, 5 +end do +!$omp end teams distribute parallel do simd + +!$omp teams distribute simd +do i = 1, 5 +end do +!$omp end teams distribute simd + +!$omp target data map(tofrom:i) +!$omp end target data + +end Index: Fortran/gfortran/regression/gomp/nowait-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-3.f90 @@ -0,0 +1,118 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine foo +implicit none +integer :: i, a(5) + +!$omp do +do i = 1, 5 +end do +!$omp end do nowait + +!$omp do simd +do i = 1, 5 +end do +!$omp end do simd nowait + +!$omp scope +!$omp end scope nowait + +!$omp sections + !$omp section + block; end block +!$omp end sections nowait + +!$omp single +!$omp end single nowait + +!$omp target +!$omp end target nowait + +!$omp target parallel +!$omp end target parallel nowait + +!$omp target parallel do +do i = 1, 5 +end do +!$omp end target parallel do nowait + +!$omp target parallel do simd +do i = 1, 5 +end do +!$omp end target parallel do simd nowait + +!$omp target parallel loop +do i = 1, 5 +end do +!$omp end target parallel loop nowait + +!$omp target teams distribute parallel do +do i = 1, 5 +end do +!$omp end target teams distribute parallel do nowait + +!$omp target teams distribute parallel do simd +do i = 1, 5 +end do +!$omp end target teams distribute parallel do simd nowait + +!$omp target simd +do i = 1, 5 +end do +!$omp end target simd nowait + +!$omp target teams +!$omp end target teams nowait + +!$omp target teams distribute +do i = 1, 5 +end do +!$omp end target teams distribute nowait + +!$omp target teams distribute simd +do i = 1, 5 +end do +!$omp end target teams distribute simd nowait + +!$omp target teams loop +do i = 1, 5 +end do +!$omp end target teams loop nowait + +!$omp workshare +A(:) = 5 +!$omp end workshare nowait +end + +! Note: internally, for '... parallel do ...', 'nowait' is always added +! such that for 'omp end target parallel do nowait', 'nowait' is on both +! 'target' as specified in the OpenMP spec and and on 'do' due to internal usage. + +! Expected with 'nowait' + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for schedule\\(static\\) nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp sections nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp single nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target nowait" 12 "original" } } + +! Never: + +! { dg-final { scan-tree-dump-not "#pragma omp distribute\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp loop\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp parallel\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp section\[^s\]\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp simd\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp teams\[^\n\r]*nowait" "original" } } + +! Sometimes or never with nowait: + +! { dg-final { scan-tree-dump-times "#pragma omp distribute\[\n\r]" 4 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop\[\n\r]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel\[\n\r]" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp section\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\)\[\n\r]" 5 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams\[\n\r]" 6 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target\[\n\r]" 0 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for\[\n\r]" 0 "original" } } Index: Fortran/gfortran/regression/gomp/nowait-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-4.f90 @@ -0,0 +1,158 @@ +! invalid nowait + +subroutine foo +implicit none +integer :: i, a(5) +!$omp atomic write +i = 5 +!$omp end atomic nowait ! { dg-error "Unexpected junk" } + +!$omp critical +!$omp end critical nowait ! { dg-error "Unexpected junk" } + +!$omp distribute +do i = 1, 5 +end do +!$omp end distribute nowait ! { dg-error "Unexpected junk" } + +!$omp distribute parallel do +do i = 1, 5 +end do +!$omp end distribute parallel do nowait ! { dg-error "Unexpected junk" } + +!$omp distribute parallel do simd +do i = 1, 5 +end do +!$omp end distribute parallel do simd nowait ! { dg-error "Unexpected junk" } + +!$omp parallel sections + !$omp section + block; end block +!$omp end parallel sections nowait ! { dg-error "Unexpected junk" } + +!$omp distribute simd +do i = 1, 5 +end do +!$omp end distribute simd nowait ! { dg-error "Unexpected junk" } + +!$omp masked +!$omp end masked nowait ! { dg-error "Unexpected junk" } + +!$omp masked taskloop +do i = 1, 5 +end do +!$omp end masked taskloop nowait ! { dg-error "Unexpected junk" } + +!$omp masked taskloop simd +do i = 1, 5 +end do +!$omp end masked taskloop simd nowait ! { dg-error "Unexpected junk" } + +!$omp master +!$omp end master nowait ! { dg-error "Unexpected junk" } + +!$omp master taskloop +do i = 1, 5 +end do +!$omp end master taskloop nowait ! { dg-error "Unexpected junk" } + +!$omp master taskloop simd +do i = 1, 5 +end do +!$omp end master taskloop simd nowait ! { dg-error "Unexpected junk" } + +!$omp ordered +!$omp end ordered nowait ! { dg-error "Unexpected junk" } + +!$omp parallel +!$omp end parallel nowait ! { dg-error "Unexpected junk" } + +!$omp parallel workshare +a(:) = 5 +!$omp end parallel workshare nowait ! { dg-error "Unexpected junk" } + +!$omp parallel do +do i = 1, 5 +end do +!$omp end parallel do nowait ! { dg-error "Unexpected junk" } + +!$omp parallel do simd +do i = 1, 5 +end do +!$omp end parallel do simd nowait ! { dg-error "Unexpected junk" } + +!$omp parallel masked +!$omp end parallel masked nowait ! { dg-error "Unexpected junk" } + +!$omp parallel masked taskloop +do i = 1, 5 +end do +!$omp end parallel masked taskloop nowait ! { dg-error "Unexpected junk" } + +!$omp parallel masked taskloop simd +do i = 1, 5 +end do +!$omp end parallel masked taskloop simd nowait ! { dg-error "Unexpected junk" } + +!$omp parallel master +!$omp end parallel master nowait ! { dg-error "Unexpected junk" } + +!$omp parallel master taskloop +do i = 1, 5 +end do +!$omp end parallel master taskloop nowait ! { dg-error "Unexpected junk" } + +!$omp parallel master taskloop simd +do i = 1, 5 +end do +!$omp end parallel master taskloop simd nowait ! { dg-error "Unexpected junk" } + +!$omp simd +do i = 1, 5 +end do +!$omp end simd nowait ! { dg-error "Unexpected junk" } + +!$omp task +!$omp end task nowait ! { dg-error "Unexpected junk" } + +!$omp taskgroup +!$omp end taskgroup nowait ! { dg-error "Unexpected junk" } + +!$omp taskloop +do i = 1, 5 +end do +!$omp end taskloop nowait ! { dg-error "Unexpected junk" } + +!$omp taskloop simd +do i = 1, 5 +end do +!$omp end taskloop simd nowait ! { dg-error "Unexpected junk" } + +!$omp teams +!$omp end teams nowait ! { dg-error "Unexpected junk" } + +!$omp teams distribute +do i = 1, 5 +end do +!$omp end teams distribute nowait ! { dg-error "Unexpected junk" } + +!$omp teams distribute parallel do +do i = 1, 5 +end do +!$omp end teams distribute parallel do nowait ! { dg-error "Unexpected junk" } + +!$omp teams distribute parallel do simd +do i = 1, 5 +end do +!$omp end teams distribute parallel do simd nowait ! { dg-error "Unexpected junk" } + +!$omp teams distribute simd +do i = 1, 5 +end do +!$omp end teams distribute simd nowait ! { dg-error "Unexpected junk" } + +!$omp target data map(tofrom:i) +!$omp end target data nowait ! { dg-error "Unexpected junk" } + +end ! { dg-error "Unexpected END statement" } +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/gomp/nowait-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-5.f90 @@ -0,0 +1,156 @@ +! Cross check that it is accepted without nowait +subroutine bar() +implicit none +integer :: i, a(5) +!$omp atomic write +i = 5 +!$omp end atomic + +!$omp critical +!$omp end critical + +!$omp distribute +do i = 1, 5 +end do +!$omp end distribute + +!$omp distribute parallel do +do i = 1, 5 +end do +!$omp end distribute parallel do + +!$omp distribute parallel do simd +do i = 1, 5 +end do +!$omp end distribute parallel do simd + +!$omp distribute simd +do i = 1, 5 +end do +!$omp end distribute simd + +!$omp masked +!$omp end masked + +!$omp masked taskloop +do i = 1, 5 +end do +!$omp end masked taskloop + +!$omp masked taskloop simd +do i = 1, 5 +end do +!$omp end masked taskloop simd + +!$omp master +!$omp end master + +!$omp master taskloop +do i = 1, 5 +end do +!$omp end master taskloop + +!$omp master taskloop simd +do i = 1, 5 +end do +!$omp end master taskloop simd + +!$omp ordered +!$omp end ordered + +!$omp parallel +!$omp end parallel + +!$omp parallel workshare +a(:) = 5 +!$omp end parallel workshare + +!$omp parallel do +do i = 1, 5 +end do +!$omp end parallel do + +!$omp parallel do simd +do i = 1, 5 +end do +!$omp end parallel do simd + +!$omp parallel sections + !$omp section + block; end block +!$omp end parallel sections + +!$omp parallel masked +!$omp end parallel masked + +!$omp parallel masked taskloop +do i = 1, 5 +end do +!$omp end parallel masked taskloop + +!$omp parallel masked taskloop simd +do i = 1, 5 +end do +!$omp end parallel masked taskloop simd + +!$omp parallel master +!$omp end parallel master + +!$omp parallel master taskloop +do i = 1, 5 +end do +!$omp end parallel master taskloop + +!$omp parallel master taskloop simd +do i = 1, 5 +end do +!$omp end parallel master taskloop simd + +!$omp simd +do i = 1, 5 +end do +!$omp end simd + +!$omp task +!$omp end task + +!$omp taskgroup +!$omp end taskgroup + +!$omp taskloop +do i = 1, 5 +end do +!$omp end taskloop + +!$omp taskloop simd +do i = 1, 5 +end do +!$omp end taskloop simd + +!$omp teams +!$omp end teams + +!$omp teams distribute +do i = 1, 5 +end do +!$omp end teams distribute + +!$omp teams distribute parallel do +do i = 1, 5 +end do +!$omp end teams distribute parallel do + +!$omp teams distribute parallel do simd +do i = 1, 5 +end do +!$omp end teams distribute parallel do simd + +!$omp teams distribute simd +do i = 1, 5 +end do +!$omp end teams distribute simd + +!$omp target data map(tofrom:i) +!$omp end target data + +end Index: Fortran/gfortran/regression/gomp/nowait-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-6.f90 @@ -0,0 +1,158 @@ +! invalid nowait + +subroutine foo +implicit none +integer :: i, a(5) +!$omp atomic write nowait ! { dg-error "Failed to match clause" } +i = 5 +!$omp end atomic ! { dg-error "Unexpected ..OMP END " } + +!$omp critical nowait ! { dg-error "Failed to match clause" } +!$omp end critical ! { dg-error "Unexpected ..OMP END " } + +!$omp distribute nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end distribute ! { dg-error "Unexpected ..OMP END " } + +!$omp distribute parallel do nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end distribute parallel do ! { dg-error "Unexpected ..OMP END " } + +!$omp distribute parallel do simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end distribute parallel do simd ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel sections nowait ! { dg-error "Failed to match clause" } + !$omp section ! { dg-error "Unexpected ..OMP SECTION statement" } + block; end block +!$omp end parallel sections ! { dg-error "Unexpected ..OMP END " } + +!$omp distribute simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end distribute simd ! { dg-error "Unexpected ..OMP END " } + +!$omp masked nowait ! { dg-error "Failed to match clause" } +!$omp end masked ! { dg-error "Unexpected ..OMP END " } + +!$omp masked taskloop nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end masked taskloop ! { dg-error "Unexpected ..OMP END " } + +!$omp masked taskloop simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end masked taskloop simd ! { dg-error "Unexpected ..OMP END " } + +!$omp master nowait ! { dg-error "Unexpected junk" } +!$omp end master ! { dg-error "Unexpected ..OMP END " } + +!$omp master taskloop nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end master taskloop ! { dg-error "Unexpected ..OMP END " } + +!$omp master taskloop simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end master taskloop simd ! { dg-error "Unexpected ..OMP END " } + +!$omp ordered nowait ! { dg-error "Failed to match clause" } +!$omp end ordered ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel nowait ! { dg-error "Failed to match clause" } +!$omp end parallel ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel workshare nowait ! { dg-error "Failed to match clause" } +a(:) = 5 +!$omp end parallel workshare ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel do nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel do ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel do simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel do simd ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel masked nowait ! { dg-error "Failed to match clause" } +!$omp end parallel masked ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel masked taskloop nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel masked taskloop ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel masked taskloop simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel masked taskloop simd ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel master nowait ! { dg-error "Failed to match clause" } +!$omp end parallel master ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel master taskloop nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel master taskloop ! { dg-error "Unexpected ..OMP END " } + +!$omp parallel master taskloop simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end parallel master taskloop simd ! { dg-error "Unexpected ..OMP END " } + +!$omp simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end simd ! { dg-error "Unexpected ..OMP END " } + +!$omp task nowait ! { dg-error "Failed to match clause" } +!$omp end task ! { dg-error "Unexpected ..OMP END " } + +!$omp taskgroup nowait ! { dg-error "Failed to match clause" } +!$omp end taskgroup ! { dg-error "Unexpected ..OMP END " } + +!$omp taskloop nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end taskloop ! { dg-error "Unexpected ..OMP END " } + +!$omp taskloop simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end taskloop simd ! { dg-error "Unexpected ..OMP END " } + +!$omp teams nowait ! { dg-error "Failed to match clause" } +!$omp end teams ! { dg-error "Unexpected ..OMP END " } + +!$omp teams distribute nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end teams distribute ! { dg-error "Unexpected ..OMP END " } + +!$omp teams distribute parallel do nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end teams distribute parallel do ! { dg-error "Unexpected ..OMP END " } + +!$omp teams distribute parallel do simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end teams distribute parallel do simd ! { dg-error "Unexpected ..OMP END " } + +!$omp teams distribute simd nowait ! { dg-error "Failed to match clause" } +do i = 1, 5 +end do +!$omp end teams distribute simd ! { dg-error "Unexpected ..OMP END " } + +!$omp target data map(tofrom:i) nowait ! { dg-error "Failed to match clause" } +!$omp end target data ! { dg-error "Unexpected ..OMP END " } + +end +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/gomp/nowait-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-7.f90 @@ -0,0 +1,118 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine foo +implicit none +integer :: i, a(5) + +!$omp do nowait +do i = 1, 5 +end do +!$omp end do + +!$omp do simd nowait +do i = 1, 5 +end do +!$omp end do simd + +!$omp scope nowait +!$omp end scope + +!$omp sections nowait + !$omp section + block; end block +!$omp end sections + +!$omp single nowait +!$omp end single + +!$omp target nowait +!$omp end target + +!$omp target parallel nowait +!$omp end target parallel + +!$omp target parallel do nowait +do i = 1, 5 +end do +!$omp end target parallel do + +!$omp target parallel do simd nowait +do i = 1, 5 +end do +!$omp end target parallel do simd + +!$omp target parallel loop nowait +do i = 1, 5 +end do +!$omp end target parallel loop + +!$omp target teams distribute parallel do nowait +do i = 1, 5 +end do +!$omp end target teams distribute parallel do + +!$omp target teams distribute parallel do simd nowait +do i = 1, 5 +end do +!$omp end target teams distribute parallel do simd + +!$omp target simd nowait +do i = 1, 5 +end do +!$omp end target simd + +!$omp target teams nowait +!$omp end target teams + +!$omp target teams distribute nowait +do i = 1, 5 +end do +!$omp end target teams distribute + +!$omp target teams distribute simd nowait +do i = 1, 5 +end do +!$omp end target teams distribute simd + +!$omp target teams loop nowait +do i = 1, 5 +end do +!$omp end target teams loop + +!$omp workshare nowait +A(:) = 5 +!$omp end workshare +end + +! Note: internally, for '... parallel do ...', 'nowait' is always added +! such that for 'omp end target parallel do nowait', 'nowait' is on both +! 'target' as specified in the OpenMP spec and and on 'do' due to internal usage. + +! Expected with 'nowait' + +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for schedule\\(static\\) nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp sections nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp single nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target nowait" 12 "original" } } + +! Never: + +! { dg-final { scan-tree-dump-not "#pragma omp distribute\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp loop\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp parallel\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp section\[^s\]\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp simd\[^\n\r]*nowait" "original" } } +! { dg-final { scan-tree-dump-not "#pragma omp teams\[^\n\r]*nowait" "original" } } + +! Sometimes or never with nowait: + +! { dg-final { scan-tree-dump-times "#pragma omp distribute\[\n\r]" 4 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp loop\[\n\r]" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel\[\n\r]" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp section\[\n\r]" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\)\[\n\r]" 5 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams\[\n\r]" 6 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp target\[\n\r]" 0 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for\[\n\r]" 0 "original" } } Index: Fortran/gfortran/regression/gomp/nowait-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/nowait-8.f90 @@ -0,0 +1,92 @@ +subroutine foo +implicit none +integer :: i, a(5) + +!$omp do nowait nowait ! { dg-error "Duplicated 'nowait' clause" } +do i = 1, 5 +end do + +!$omp do +do i = 1, 5 +end do +!$omp do nowait nowait ! { dg-error "Duplicated 'nowait' clause" } + +!$omp do nowait +do i = 1, 5 +end do +!$omp end do nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp do simd nowait +do i = 1, 5 +end do +!$omp end do simd nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp scope nowait +!$omp end scope nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp sections nowait + !$omp section + block; end block +!$omp end sections nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp single nowait +!$omp end single nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target nowait +!$omp end target nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target parallel nowait +!$omp end target parallel nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target parallel do nowait +do i = 1, 5 +end do +!$omp end target parallel do nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target parallel do simd nowait +do i = 1, 5 +end do +!$omp end target parallel do simd nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target parallel loop nowait +do i = 1, 5 +end do +!$omp end target parallel loop nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams distribute parallel do nowait +do i = 1, 5 +end do +!$omp end target teams distribute parallel do nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams distribute parallel do simd nowait +do i = 1, 5 +end do +!$omp end target teams distribute parallel do simd nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target simd nowait +do i = 1, 5 +end do +!$omp end target simd nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams nowait +!$omp end target teams nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams distribute nowait +do i = 1, 5 +end do +!$omp end target teams distribute nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams distribute simd nowait +do i = 1, 5 +end do +!$omp end target teams distribute simd nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp target teams loop nowait +do i = 1, 5 +end do +!$omp end target teams loop nowait ! { dg-error "Duplicated NOWAIT clause" } + +!$omp workshare nowait +A(:) = 5 +!$omp end workshare nowait ! { dg-error "Duplicated NOWAIT clause" } +end Index: Fortran/gfortran/regression/gomp/num-teams-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/num-teams-1.f90 @@ -0,0 +1,53 @@ +module m + implicit none (type, external) + + interface + integer function fn(i); integer :: i; end + end interface + +contains + +subroutine foo + !$omp teams num_teams (4 : 6) + !$omp end teams + + !$omp teams num_teams (7) + !$omp end teams +end + +subroutine bar + !$omp target teams num_teams (5 : 19) + !$omp end target teams + + !$omp target teams num_teams (21) + !$omp end target teams +end + +subroutine baz + !$omp teams num_teams (fn (1) : fn (2)) + !$omp end teams + + !$omp teams num_teams (fn (3)) + !$omp end teams +end + +subroutine qux + !$omp target teams num_teams (fn (4) : fn (5)) + !$omp end target teams + + !$omp target teams num_teams (fn (6)) + !$omp end target teams +end + +subroutine corge + !$omp target + !$omp teams num_teams (fn (7) : fn (8)) + !$omp end teams + !$omp end target + + !$omp target + !$omp teams num_teams (fn (9)) + !$omp end teams + !$omp end target +end +end module m Index: Fortran/gfortran/regression/gomp/num-teams-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/num-teams-2.f90 @@ -0,0 +1,37 @@ +module m + implicit none (type, external) + +contains + +subroutine foo (i) + integer :: i + + !$omp teams num_teams (6 : 4) ! { dg-warning "NUM_TEAMS lower bound at .1. larger than upper bound at .2." } + !$omp end teams + + !$omp teams num_teams (-7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end teams + + !$omp teams num_teams (i : -7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end teams + + !$omp teams num_teams (-7 : 8) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end teams +end + +subroutine bar (i) + integer :: i + + !$omp target teams num_teams (6 : 4) ! { dg-warning "NUM_TEAMS lower bound at .1. larger than upper bound at .2." } + !$omp end target teams + + !$omp target teams num_teams (-7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end target teams + + !$omp target teams num_teams (i : -7) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end target teams + + !$omp target teams num_teams (-7 : 8) ! { dg-warning "INTEGER expression of NUM_TEAMS clause at .1. must be positive" } + !$omp end target teams +end +end module Index: Fortran/gfortran/regression/gomp/omp_atomic1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_atomic1.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +subroutine test_atomic + integer (kind = 4) :: a + integer :: b + real :: c, f + double precision :: d + integer, dimension (10) :: e + a = 1 + b = 2 + c = 3 + d = 4 + e = 5 + f = 6 +!$omp atomic + a = a + 4 +!$omp atomic + b = 4 - b +!$omp atomic + c = c * 2 +!$omp atomic + d = 2 / d +!$omp atomic + e = 1 ! { dg-error "must set a scalar variable" } +!$omp atomic + a = a ** 8 ! { dg-error "assignment operator must be" } +!$omp atomic + b = b + 3 + b ! { dg-error "cannot reference" } +!$omp atomic + c = c - f + 1 ! { dg-error "not mathematically equivalent to" } +!$omp atomic + a = ishft (a, 1) ! { dg-error "assignment intrinsic must be" } +!$omp atomic + c = min (c, 2.1, c) ! { dg-error "intrinsic arguments except one" } +!$omp atomic + a = max (b, e(1)) ! { dg-error "intrinsic argument must be 'a'" } +!$omp atomic + d = 12 ! { dg-error "assignment must have an operator" } +end subroutine test_atomic Index: Fortran/gfortran/regression/gomp/omp_atomic2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_atomic2.f90 @@ -0,0 +1,54 @@ + real :: r1, r2 + complex :: c1, c2 + integer :: i1, i2 +!$omp atomic write + c1 = 0 +!$omp atomic write + r2 = 0 +!$omp atomic write + i2 = 0 +!$omp atomic read + r1 = c1 +!$omp atomic read + c2 = r2 +!$omp atomic read + i1 = r2 +!$omp atomic read + c2 = i2 +!$omp atomic write + c1 = r1 +!$omp atomic write + r2 = c2 +!$omp atomic write + r2 = i1 +!$omp atomic write + i2 = c2 +!$omp end atomic +!$omp atomic write + c1 = 1 + 2 + r1 +!$omp atomic write + r2 = c2 + 2 + 3 +!$omp atomic write + r2 = 3 + 4 + i1 +!$omp atomic write + i2 = c2 + 4 + 5 +!$omp atomic + c1 = c1 * 2. +!$omp atomic update + r2 = r2 / 4 +!$omp end atomic +!$omp atomic update + i2 = i2 + 8 +!$omp atomic capture + c1 = c1 * 2. + r1 = c1 +!$omp end atomic +!$omp atomic capture + c2 = r2 + r2 = r2 / 4 +!$omp end atomic +!$omp atomic capture + i2 = i2 + 8 + c2 = i2 +!$omp end atomic +end Index: Fortran/gfortran/regression/gomp/omp_clauses1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_clauses1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } + subroutine test1 + integer :: i, j, k, l + common /b/ j, k +!$omp parallel shared (i) private (/b/) +!$omp end parallel +!$omp parallel do shared (/b/), firstprivate (i), lastprivate (i) + do l = 1, 10 + end do +!$omp end parallel do +!$omp parallel shared (j) private (/b/) ! { dg-error "'j' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (j, j) private (i) ! { dg-error "'j' present on multiple clauses" } +!$omp end parallel +!$omp parallel firstprivate (i, j, i) ! { dg-error "'i' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (i) private (/b/, /b/) ! { dg-error "'\[jk\]' present on multiple clauses" } +!$omp end parallel +!$omp parallel shared (i) reduction (+ : i, j) ! { dg-error "'i' present on multiple clauses" } +!$omp end parallel +!$omp parallel do shared (/b/), firstprivate (/b/), lastprivate (i) ! { dg-error "'\[jk\]' present on multiple clauses" } + do l = 1, 10 + end do +!$omp end parallel do + end subroutine test1 Index: Fortran/gfortran/regression/gomp/omp_do1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_do1.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! { dg-options "-fopenmp -std=legacy" } +subroutine foo + integer :: i, j + integer, dimension (30) :: a + double precision :: d + i = 0 +!$omp do private (i) + do 100 ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } +100 i = i + 1 + i = 0 +!$omp do private (i) + do ! { dg-error "cannot be a DO WHILE or DO without loop control" } + if (i .gt. 0) exit ! { dg-error "EXIT statement" } + i = i + 1 + end do + i = 0 +!$omp do private (i) + do 200 while (i .lt. 4) ! { dg-error "cannot be a DO WHILE or DO without loop control" } +200 i = i + 1 +!$omp do private (i) + do while (i .lt. 8) ! { dg-error "cannot be a DO WHILE or DO without loop control" } + i = i + 1 + end do +!$omp do + do 300 d = 1, 30, 6 + i = d +300 a(i) = 1 +!$omp do + do d = 1, 30, 5 + i = d + a(i) = 2 + end do +!$omp do + do i = 1, 30 + if (i .eq. 16) exit ! { dg-error "EXIT statement" } + end do +!$omp do +outer: do i = 1, 30 + do j = 5, 10 + if (i .eq. 6 .and. j .eq. 7) exit outer ! { dg-error "EXIT statement" } + end do + end do outer +last: do i = 1, 30 +!$omp parallel + if (i .eq. 21) exit last ! { dg-error "leaving OpenMP structured block" } +!$omp end parallel + end do last +!$omp parallel do shared (i) + do i = 1, 30, 2 ! { dg-error "iteration variable present on clause" } + a(i) = 5 + end do +!$omp end parallel do +end subroutine +! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 27 } +! { dg-error "iteration variable must be of type integer" "" { target *-*-* } 31 } Index: Fortran/gfortran/regression/gomp/omp_do_concurrent.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_do_concurrent.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } +! +! PR fortran/60127 +! +! OpenMP 4.0 doesn't permit DO CONCURRENT (yet) +! + +!$omp do +do concurrent(i=1:5) ! { dg-error "OMP DO cannot be a DO CONCURRENT loop" } +print *, 'Hello' +end do +end Index: Fortran/gfortran/regression/gomp/omp_parallel_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_parallel_1.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/66549 +! The resolution of CVN in the middle CLWF's OpenMP construct was +! making the DO loop (wrongly) interpreted as an OpenMP-managed loop, leading +! to an ICE. +! +! Contributed by Andrew Benson . + +module smfa + type :: sgc + contains + procedure :: sla => sa + end type sgc + class(sgc), pointer :: sg_ + double precision, allocatable, dimension(:) :: vni +contains + double precision function sa(self,i) + class(sgc), intent(in ) :: self + end function sa + subroutine cvn(sg_,vn) + class(sgc), intent(inout) :: sg_ + double precision, intent( out), dimension(:) :: vn + integer :: i + do i=1,2 + vn(i)= sg_%sla(i) + end do + end subroutine cvn + subroutine clwf() + !$omp parallel + call cvn(sg_,vni) + !$omp end parallel + end subroutine clwf +end module smfa + +! { dg-final { scan-tree-dump-times "#pragma\\s+omp\\s+parallel\\n" 1 "original" } } Index: Fortran/gfortran/regression/gomp/omp_parse1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_parse1.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-omplower" } + !$omp parallel +call bar + !$omp end parallel + !$omp p& +!$omp&arallel +call bar +!$omp e& +!$omp&ndparallel +!$omp & +!$omp & & +!$omp pa& +!$omp rallel +call bar +!$omp end parallel +end + +! { dg-final { scan-tree-dump-times "pragma omp parallel" 3 "omplower" } } Index: Fortran/gfortran/regression/gomp/omp_parse2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_parse2.f @@ -0,0 +1,13 @@ +c { dg-do compile } +c { dg-options "-fopenmp -fdump-tree-omplower" } +!$omp parallel + call bar +c$omp end parallel +C$omp p +*$omp+arallel + call bar +!$omp e +!$omp+ndparallel + end + +! { dg-final { scan-tree-dump-times "pragma omp parallel" 2 "omplower" } } Index: Fortran/gfortran/regression/gomp/omp_threadprivate1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_threadprivate1.f90 @@ -0,0 +1,17 @@ +! { dg-require-effective-target tls } + module omp_threadprivate1 + common /T/ a + end module omp_threadprivate1 + subroutine bad1 + use omp_threadprivate1 +!$omp threadprivate (/T/) ! { dg-error "not found" } + end subroutine bad1 + subroutine bad2 + common /S/ b +!$omp threadprivate (/S/) + contains + subroutine bad3 +!$omp parallel copyin (/T/) ! { dg-error "not found" } +!$omp end parallel ! { dg-error "" } + end subroutine bad3 + end subroutine bad2 Index: Fortran/gfortran/regression/gomp/omp_threadprivate2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omp_threadprivate2.f90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + subroutine bad1 + double precision :: d ! { dg-error "isn't SAVEd" } +!$omp threadprivate (d) + end subroutine bad1 Index: Fortran/gfortran/regression/gomp/ompx-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/ompx-1.f90 @@ -0,0 +1,2 @@ +!$ompx foo ! { dg-warning "!.OMP at .1. starts a commented line as it neither is followed by a space nor is a continuation line" } +end Index: Fortran/gfortran/regression/gomp/omx-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omx-1.f @@ -0,0 +1,7 @@ +!$omx foo +!$OMX foo +c$oMx foo +c$OMx foo +*$oMx foo +*$OMx foo + end Index: Fortran/gfortran/regression/gomp/omx-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/omx-2.f @@ -0,0 +1,9 @@ +! { dg-additional-options "-Wsurprising" } + +!$omx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +!$OMX foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +c$oMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +c$OMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +*$oMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } +*$OMx foo ! { dg-warning "Ignoring '!.omx' vendor-extension sentinel" } + end Index: Fortran/gfortran/regression/gomp/openmp-simd-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-1.f90 @@ -0,0 +1,136 @@ +! { dg-do compile } +! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original -O2" } + +!$omp declare reduction (foo:integer:omp_out = omp_out + omp_in) + interface + integer function foo (x, y) + integer, value :: x, y +!$omp declare simd (foo) linear (y : 2) + end function foo + end interface + integer :: i, a(64), b, c + integer, save :: d +!$omp threadprivate (d) + d = 5 + a = 6 +!$omp simd + do i = 1, 64 + a(i) = foo (a(i), 2 * i) + end do + b = 0 + c = 0 +!$omp simd reduction (+:b) reduction (foo:c) + do i = 1, 64 + b = b + a(i) + c = c + a(i) * 2 + end do + print *, b + b = 0 +!$omp parallel +!$omp do simd schedule(static, 4) safelen (8) reduction (+:b) + do i = 1, 64 + a(i) = a(i) + 1 + b = b + 1 + end do +!$omp end parallel + print *, b + b = 0 +!$omp parallel do simd schedule(static, 4) safelen (8) & +!$omp num_threads (4) if (.true.) reduction (+:b) + do i = 1, 64 + a(i) = a(i) + 1 + b = b + 1 + end do + print *, b + b = 0 +!$omp parallel +!$omp do simd schedule(static, 4) safelen (8) reduction (+:b) + do i = 1, 64 + a(i) = a(i) + 1 + b = b + 1 + end do +!$omp enddosimd +!$omp end parallel + print *, b + b = 0 +!$omp parallel do simd schedule(static, 4) safelen (8) & +!$omp num_threads (4) if (.true.) reduction (+:b) + do i = 1, 64 + a(i) = a(i) + 1 + b = b + 1 + end do +!$omp end parallel do simd +!$omp atomic seq_cst + b = b + 1 +!$omp end atomic +!$omp barrier +!$omp parallel private (i) +!$omp cancellation point parallel +!$omp critical (bar) + b = b + 1 +!$omp end critical (bar) +!$omp flush(b) +!$omp single + b = b + 1 +!$omp end single +!$omp do ordered + do i = 1, 10 + !$omp atomic + b = b + 1 + !$omp end atomic + !$omp ordered + print *, b + !$omp end ordered + end do +!$omp end do +!$omp master + b = b + 1 +!$omp end master +!$omp cancel parallel +!$omp end parallel +!$omp parallel do schedule(runtime) num_threads(8) + do i = 1, 10 + print *, b + end do +!$omp end parallel do +!$omp sections +!$omp section + b = b + 1 +!$omp section + c = c + 1 +!$omp end sections + print *, b +!$omp parallel sections firstprivate (b) if (.true.) +!$omp section + b = b + 1 +!$omp section + c = c + 1 +!$omp endparallelsections +!$omp workshare + b = 24 +!$omp end workshare +!$omp parallel workshare num_threads (2) + b = b + 1 + c = c + 1 +!$omp end parallel workshare + print *, b +!$omp parallel +!$omp single +!$omp taskgroup +!$omp task firstprivate (b) + b = b + 1 +!$omp taskyield +!$omp end task +!$omp task firstprivate (b) + b = b + 1 +!$omp end task +!$omp taskwait +!$omp end taskgroup +!$omp end single +!$omp end parallel + print *, a, c +end + +! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp" 6 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP" 0 "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-2.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fopenmp-simd -fdump-tree-original -O2" } + +include 'openmp-simd-1.f90' + +! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } } +! Includes the above taskgroup +! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } } +! Includes the above sections +! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } } +! Includes the above cancellation point +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-3.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fno-openmp-simd -fdump-tree-original -O2" } + +include 'openmp-simd-1.f90' + +! { dg-final { scan-tree-dump-times "pragma omp simd" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp" 39 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp for" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp parallel" 9 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp taskgroup" 1 "original" } } +! Includes the above taskgroup +! { dg-final { scan-tree-dump-times "pragma omp task" 3 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp critical" 1 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp atomic" 2 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp sections" 2 "original" } } +! Includes the above sections +! { dg-final { scan-tree-dump-times "pragma omp section" 6 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp single" 4 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp ordered" 1 "original" } } +! { dg-final { scan-tree-dump-times "pragma omp master" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP" 5 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_barrier" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancellation_point" 1 "original" } } +! Includes the above cancellation point +! { dg-final { scan-tree-dump-times "__builtin_GOMP_cancel" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskyield" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait" 1 "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-4.f90 @@ -0,0 +1,65 @@ +! { dg-do compile } + +integer :: i, j, k +integer :: x(5), y(2,5) + +!$omp parallel do private(i) +do i = 1, 5 + x(i) = 42 +end do + +!$omp parallel do lastprivate(i) +do i = 1, 5 + x(i) = 42 +end do + + +!$omp simd private(i) +do i = 1, 5 + x(i) = 42 +end do + +!$omp simd linear(i) +do i = 1, 5 + x(i) = 42 +end do + +!$omp simd lastprivate(i) +do i = 1, 5 + x(i) = 42 +end do + + +!$omp simd private(i) lastprivate(j) collapse(2) +do i = 1, 5 + do j = 1, 2 + y(j, i) = 52 + end do +end do + +!$omp simd lastprivate(i) private(j) collapse(2) +do i = 1, 5 + do j = 1, 2 + y(j, i) = 52 + end do +end do + +!$omp parallel do firstprivate(i) +do i = 1, 5 ! { dg-error "PARALLEL DO iteration variable present on clause other than PRIVATE, LASTPRIVATE or ALLOCATE" } + x(i) = 42 +end do + +!$omp parallel do simd firstprivate(i) +do i = 1, 5 ! { dg-error "PARALLEL DO SIMD iteration variable present on clause other than PRIVATE, LASTPRIVATE, ALLOCATE or LINEAR" } + x(i) = 42 +end do + +!$omp simd linear(i) collapse(2) +do i = 1, 5 ! { dg-error "SIMD iteration variable present on clause other than PRIVATE, LASTPRIVATE or ALLOCATE" } + do j = 1, 2 + y(j, i) = 52 + end do +end do + + +end Index: Fortran/gfortran/regression/gomp/openmp-simd-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-5.f90 @@ -0,0 +1,24 @@ +! { dg-additional-options "-fdump-tree-original" } +! +! Related: +! PR fortran/95109 +! PR fortran/94690 +! +implicit none +integer :: i, j, k, ll +integer :: a +!$omp target parallel do simd collapse(1) + do i = 1, 5 + do j = 1, 5 + do k = 1, 5 + a = a + 1 + end do + do ll = 1, 5 + a = a + 1 + end do + end do + end do +!$omp end target parallel do simd +end + +! { dg-final { scan-tree-dump-times "omp simd linear\\(i:1\\) private\\(j\\) private\\(ll\\) private\\(k\\) collapse\\(1\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-6.f90 @@ -0,0 +1,62 @@ +! { dg-additional-options "-fdump-tree-original" } +! +! PR fortran/97061 + +integer function f3 (a1, b1, u) + implicit none + integer :: a1, b1, d1 + integer u(0:1023) + !$omp teams distribute parallel do simd default(none) firstprivate (a1, b1) shared(u) lastprivate(d1) + do d1 = a1, b1-1 + u(d1) = 5 + end do +end + +subroutine foo(n, m, u) + implicit none + integer :: hh, ii, jj, n, m + integer u(0:1023) + !$omp simd private(ii) + do ii = n, m + u(ii) = 5 + end do + !$omp simd linear(jj:1) + do jj = 2, m+n + u(jj) = 6 + end do + !$omp simd + do hh = 2, m+n + u(hh) = 6 + end do +end + +subroutine bar(n, m, u) + implicit none + integer :: kkk, lll, ooo, ppp, n, m + integer u(:,:) + !$omp simd lastprivate(kkk) lastprivate(lll) collapse(2) + do kkk = n, m + do lll = n, m + u(kkk, lll) = 5 + end do + end do + !$omp simd private(kkk) private(lll) collapse(2) + do ooo = n, m + do ppp = n, m + u(ooo, ppp) = 5 + end do + end do +end + + +! { dg-final { scan-tree-dump-times "#pragma omp teams firstprivate\\(a1\\) firstprivate\\(b1\\) shared\\(u\\) shared\\(d1\\) default\\(none\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp distribute lastprivate\\(d1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel firstprivate\\(a1\\) firstprivate\\(b1\\) lastprivate\\(d1\\) shared\\(u\\) default\\(none\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd lastprivate\\(d1\\)" 1 "original" } } + +! { dg-final { scan-tree-dump-times "#pragma omp simd private\\(ii\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(jj:1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(hh:1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd lastprivate\\(kkk\\) lastprivate\\(lll\\) collapse\\(2\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd private\\(kkk\\) private\\(lll\\) collapse\\(2\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-7.f90 @@ -0,0 +1,23 @@ +! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original" } + +subroutine foo (a, b) + integer, contiguous :: a(:), b(:) + integer :: i + !$omp simd reduction (inscan, +:r) + do i = 1, 1024 + r = r + a(i) + !$omp scan inclusive(r) + b(i) = r + end do + !$omp end simd + + !$omp loop + do i = 1, 1024 + a(i) = a(i) + i + end do + !$omp end loop +end + +! { dg-final { scan-tree-dump "#pragma omp simd linear\\(i:1\\) reduction\\(inscan,\\+:r\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp scan inclusive\\(r\\)" "original" } } +! { dg-final { scan-tree-dump "#pragma omp loop" "original" } } Index: Fortran/gfortran/regression/gomp/openmp-simd-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/openmp-simd-8.f90 @@ -0,0 +1,25 @@ +! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-original" } + +! While 'omp assumes' is ignored with -fopenmp-simd, +! 'omp assume' is processed - check that this works. + +module m + !$omp assumes no_openmp invalid_clause ! Should get ignored +contains + integer function foo() + foo = 5 + end function +end + +program main + use m + implicit none + !$omp assumes no_openmp ! likewise ignored + integer :: n + !$omp assume holds (foo() > 0) ! should be honoured + n = foo() + if (n == 0) stop + !$omp end assume +end + +! { dg-final { scan-tree-dump "\\.ASSUME \\(foo \\(\\) > 0\\);" "original" } } Index: Fortran/gfortran/regression/gomp/order-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-1.f90 @@ -0,0 +1,92 @@ +! { dg-do compile } + +module m + integer :: i +end module m +subroutine f1 + type t + integer :: i + end type t + interface + integer function f3 (a, b) + !$omp declare simd (f3) uniform (a) + use m + import :: t + implicit none + type (t) :: a + integer :: b + end function f3 + end interface + interface + integer function f4 (a, b) + use m + !$omp declare simd (f4) uniform (a) + import :: t + implicit none + type (t) :: a + integer :: b + end function f4 + end interface + interface + integer function f5 (a, b) + use m + import :: t + !$omp declare simd (f5) uniform (a) + implicit none + type (t) :: a + integer :: b + end function f5 + end interface + interface + integer function f6 (a, b) + use m + import :: t + implicit none + !$omp declare simd (f6) uniform (a) + type (t) :: a + integer :: b + end function f6 + end interface + interface + integer function f7 (a, b) + use m + import :: t + implicit none + type (t) :: a + !$omp declare simd (f7) uniform (a) + integer :: b + end function f7 + end interface + call f2 +contains + subroutine f2 + !$omp threadprivate (t1) + use m + !$omp threadprivate (t2) + implicit none + !$omp threadprivate (t3) + integer, save :: t1, t2, t3, t4 + !$omp threadprivate (t4) + t1 = 1; t2 = 2; t3 = 3; t4 = 4 + end subroutine f2 + subroutine f8 + !$omp declare reduction (f8_1:real:omp_out = omp_out + omp_in) + use m + !$omp declare reduction (f8_2:real:omp_out = omp_out + omp_in) + implicit none + !$omp declare reduction (f8_3:real:omp_out = omp_out + omp_in) + integer :: j + !$omp declare reduction (f8_4:real:omp_out = omp_out + omp_in) + end subroutine f8 + subroutine f9 + !$omp declare target (f9_1) + use m + !$omp declare target (f9_2) + implicit none + !$omp declare target (f9_3) + !$omp declare target + integer, save :: f9_1, f9_2, f9_3, f9_4 + !$omp declare target (f9_4) + f9_1 = 1; f9_2 = 2; f9_3 = 3; f9_4 = 4 + end subroutine f9 +end subroutine f1 Index: Fortran/gfortran/regression/gomp/order-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-2.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + +module m + integer :: i +end module m +subroutine f1 + call f2 +contains + subroutine f2 + use m + implicit none + integer, save :: t + t = 1 + !$omp threadprivate (t1) ! { dg-error "Unexpected" } + end subroutine f2 + subroutine f3 + use m + implicit none + integer :: j + j = 1 + !$omp declare reduction (foo:real:omp_out = omp_out + omp_in) ! { dg-error "Unexpected" } + end subroutine f3 + subroutine f4 + use m + implicit none + !$omp declare target + integer, save :: f4_1 + f4_1 = 1 + !$omp declare target (f4_1) ! { dg-error "Unexpected" } + !$omp declare target ! { dg-error "Unexpected" } + end subroutine f4 + integer function f5 (a, b) + integer :: a, b + a = 1; b = 2 + !$omp declare simd (f5) notinbranch ! { dg-error "Unexpected" } + end function f5 +end subroutine f1 Index: Fortran/gfortran/regression/gomp/order-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-3.f90 @@ -0,0 +1,227 @@ +module my_omp_mod + use iso_c_binding, only: c_loc + implicit none + integer :: v + interface + integer function omp_get_thread_num () bind(C) + end + integer function omp_get_num_threads () bind(C) + end + integer function omp_get_cancellation () bind(C) + end + integer function omp_target_is_present (ptr, device_num) bind(C) + use iso_c_binding, only: c_ptr + type(c_ptr), value :: ptr + integer :: device_num + end + end interface +contains + subroutine foo () + end +end + +subroutine f1 (a, b) + use my_omp_mod + implicit none + integer :: a(:), b(:,:) + target :: a + integer i, j + !$omp simd order(concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp end simd + !$omp simd order(concurrent) + do i = 1, 64 + !$omp simd + do j = 1, 64 + b(j, i) = i + j + end do + end do + !$omp simd order(concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp simd order(concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp simd order(concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp simd order(concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp simd order(concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f2 (a, b) + use my_omp_mod + implicit none + integer a(:), b(:,:) + target :: a + integer i, j + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp simd + do j = 1, 64 + b (j, i) = i + j + end do + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do simd order(concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f3 (a, b) + use my_omp_mod + implicit none + integer :: a(:), b(:,:) + target :: a + integer i, j + !$omp do order(concurrent) + do i = 1, 64 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp simd + do j = 1, 64 + b(j, i) = i + j + end do + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end critical + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp task ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = a(i) + 1 + !$omp end task + end do + !$omp do order(concurrent) + do i = 1, 64 + !$omp taskloop ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + do j = 1, 64 + b(j, i) = i + j + end do + end do + !$omp do order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end Index: Fortran/gfortran/regression/gomp/order-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-4.f90 @@ -0,0 +1,34 @@ +module m + integer t; + !$omp threadprivate(t) +end + +subroutine f1 + use m + implicit none + integer :: i + !$omp simd order(concurrent) ! { dg-message "note: enclosing region" } */ + do i = 1, 64 + t = t + 1 ! { dg-error "threadprivate variable 't' used in a region with 'order\\(concurrent\\)' clause" } */ + end do +end + +subroutine f2 + use m + implicit none + integer :: i + !$omp do simd order(concurrent) ! { dg-message "note: enclosing region" } */ + do i = 1, 64 + t = t + 1 ! { dg-error "threadprivate variable 't' used in a region with 'order\\(concurrent\\)' clause" } */ + end do +end + +subroutine f3 + use m + implicit none + integer :: i + !$omp do order(concurrent) ! { dg-message "note: enclosing region" } */ + do i = 1, 64 + t = t + 1 ! { dg-error "threadprivate variable 't' used in a region with 'order\\(concurrent\\)' clause" } */ + end do +end Index: Fortran/gfortran/regression/gomp/order-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-5.f90 @@ -0,0 +1,129 @@ +! { dg-additional-options "-fdump-tree-original" } + +subroutine f1 (a) + integer :: a(*), i + !$omp do order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp simd order ( reproducible : concurrent ) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order(reproducible :concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +subroutine f2 (a) + integer :: a(*), i + !$omp parallel do order(reproducible: concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp parallel do simd order (reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do simd order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams + !$omp distribute parallel do order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute parallel do simd order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute order(reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp end teams + !$omp taskloop simd order (reproducible:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +subroutine f3 (a) + integer :: a(*), i + !$omp do order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp simd order ( unconstrained : concurrent ) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order(unconstrained :concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +subroutine f4 (a) + integer :: a(*), i + !$omp parallel do order(unconstrained: concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp parallel do simd order (unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do simd order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams + !$omp distribute parallel do order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute parallel do simd order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute order(unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp end teams + !$omp taskloop simd order (unconstrained:concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +! { dg-final { scan-tree-dump-times "#pragma omp distribute order\\(reproducible:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp distribute order\\(unconstrained:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait order\\(reproducible:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp for nowait order\\(unconstrained:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp for order\\(reproducible:concurrent\\)" 2 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp for order\\(unconstrained:concurrent\\)" 2 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp parallel" 12 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) order\\(reproducible:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) order\\(unconstrained:concurrent\\)" 6 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp taskloop" 2 "original"} } +! { dg-final { scan-tree-dump-times "#pragma omp teams" 8 "original"} } Index: Fortran/gfortran/regression/gomp/order-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-6.f90 @@ -0,0 +1,436 @@ +module m + use iso_c_binding + implicit none (type, external) + interface + subroutine foo() + end subroutine foo + integer function omp_get_thread_num () + end + integer function omp_get_num_threads () + end + integer function omp_target_is_present (x, i) bind(c) + import :: c_ptr + type(c_ptr) :: x + integer, value :: i + end + integer function omp_get_cancellation () + end + end interface + integer :: v +contains +subroutine f1 (a) + integer, target :: a(*) + integer :: i + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f2 (a) + integer, target :: a(*) + integer :: i + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc(a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f3 (a) + integer, target :: a(*) + integer :: i + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end critical + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + !$omp task ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = a(i) + 1 + !$omp end task + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + block + integer j + !$omp taskloop ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(reproducible:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f4 (a) + integer, target :: a(*) + integer :: i + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f5 (a) + integer, target :: a(*) + integer :: i + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp parallel ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end parallel + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'ordered simd', 'simd', 'loop' or 'atomic' may not be nested inside 'simd' region" } + call foo () + !$omp end critical + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do simd order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end + +subroutine f6 (a) + integer, target :: a(*) + integer :: i + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp parallel + call foo () + !$omp end parallel + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + block + integer j + !$omp simd + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp critical ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end critical + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp ordered simd ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + call foo () + !$omp end ordered + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = v + 1 + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic read ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = v + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp atomic write ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + v = a(i) + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + !$omp task ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + a(i) = a(i) + 1 + !$omp end task + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + block + integer j + !$omp taskloop ! { dg-error "OpenMP constructs other than 'parallel', 'loop' or 'simd' may not be nested inside a region with the 'order\\(concurrent\\)' clause" } + do j = 1, 64 + a(64 * i + j) = i + j + end do + end block + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_thread_num () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_thread_num\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_num_threads () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_num_threads\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_target_is_present (c_loc (a(i)), 0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_target_is_present\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do + !$omp do order(unconstrained:concurrent) + do i = 1, 64 + a(i) = a(i) + omp_get_cancellation () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_cancellation\[^\n\r]*' in a region with 'order\\(concurrent\\)' clause" } + end do +end +end module m Index: Fortran/gfortran/regression/gomp/order-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-7.f90 @@ -0,0 +1,59 @@ +subroutine f1 (a) + integer :: a(*) + integer i + !$omp do order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp simd order ( concurrent ) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +subroutine f2 (a) + integer :: a(*) + integer i + !$omp parallel do order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp parallel do simd order (concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute parallel do simd order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams distribute order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp teams + !$omp distribute parallel do order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute parallel do simd order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp distribute order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp end teams + !$omp taskloop simd order (concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do +end Index: Fortran/gfortran/regression/gomp/order-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-8.f90 @@ -0,0 +1,61 @@ +subroutine f1 (a) + integer :: a(*) + integer i + !$omp do order ! { dg-error "Failed to match clause" } + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order : ! { dg-error "Failed to match clause" } + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp simd order ( foobar ) ! { dg-error "Expected ORDER\\(CONCURRENT\\) at .1. with optional 'reproducible' or 'unconstrained' modifier" } + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order( concurrent ! { dg-error "Expected ORDER\\(CONCURRENT\\) at .1. with optional 'reproducible' or 'unconstrained' modifier" } + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do simd order( concurrent : foo )! { dg-error "Expected ORDER\\(CONCURRENT\\) at .1. with optional 'reproducible' or 'unconstrained' modifier" } + do i = 1, 128 + a(i) = a(i) + 1 + end do +end + +subroutine f2 (a) + integer :: a(*) + integer i + !$omp teams + !$omp distribute order(concurrent) + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp end teams + !$omp taskloop order (concurrent) ! { dg-error "Failed to match clause" } + do i = 1, 128 + a(i) = a(i) + 1 + end do + !$omp do order(concurrent) ordered ! { dg-error "ORDER clause must not be used together ORDERED" } + do i = 1, 128 + !$omp ordered + a(i) = a(i) + 1 + !$omp end ordered + end do + !$omp do ordered order(concurrent) ! { dg-error "ORDER clause must not be used together ORDERED" } + do i = 1, 128 + !$omp ordered + a(i) = a(i) + 1 + !$omp end ordered + end do + !$omp do ordered (1) order(concurrent) ! { dg-error "ORDER clause must not be used together ORDERED" } + do i = 1, 128 + !$omp ordered depend (sink: i - 1) + !$omp ordered depend (source) + end do + !$omp do order(concurrent)ordered (1) ! { dg-error "ORDER clause must not be used together ORDERED" } + do i = 1, 128 + !$omp ordered depend (sink: i - 1) + !$omp ordered depend (source) + end do +end Index: Fortran/gfortran/regression/gomp/order-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/order-9.f90 @@ -0,0 +1,35 @@ +subroutine foo + !$omp do schedule(static) order(concurrent) order(concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp do schedule(static) order(reproducible:concurrent) order(unconstrained:concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + + !$omp loop bind(thread) order(concurrent) order(concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp loop bind(thread) order(reproducible:concurrent) order(unconstrained:concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp simd order(concurrent) order(concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp simd order(reproducible:concurrent) order(unconstrained:concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp distribute dist_schedule(static) order(concurrent) order(concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do + !$omp loop bind(thread) order(reproducible:concurrent) order(unconstrained:concurrent) ! { dg-error "Duplicated 'order \\(' clause" } + do i = 1, 8 + call f0 () + end do +end Index: Fortran/gfortran/regression/gomp/parallel-master-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/parallel-master-1.f90 @@ -0,0 +1,23 @@ +! { dg-additional-options "-fdump-tree-original" } + implicit none + integer :: k, p, s, r, nth, t, f + logical(kind=2) l2 + !$omp threadprivate (t) + + external bar + !$omp parallel master default(none) private (k) + call bar (k) + !$omp end parallel master + + !$omp parallel master private (p) firstprivate (f) if (parallel: l2) default(shared) & + !$omp& shared(s) reduction(+:r) num_threads (nth) proc_bind(spread) copyin(t) + ! + !$omp end parallel master +end + +! { dg-final { scan-tree-dump "omp parallel private\\(k\\) default\\(none\\)" "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp master" 1 "original" } } +! { dg-final { scan-tree-dump "D.\[0-9\]+ = l2;" "original" } } +! { dg-final { scan-tree-dump "D.\[0-9\]+ = nth;" "original" } } +! { dg-final { scan-tree-dump "#pragma omp parallel private\\(p\\) firstprivate\\(f\\) shared\\(s\\) copyin\\(t\\) reduction\\(\\+:r\\) if\\(parallel:D.\[0-9\]+\\) num_threads\\(D.\[0-9\]+\\) default\\(shared\\) proc_bind\\(spread\\)" "original" } } + Index: Fortran/gfortran/regression/gomp/parallel-master-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/parallel-master-2.f90 @@ -0,0 +1,9 @@ + use iso_c_binding, only: c_intptr_t + implicit none (external, type) + integer, parameter :: omp_event_handle_kind = c_intptr_t + integer (kind=omp_event_handle_kind) :: x + !$omp parallel master default (none) ! { dg-message "enclosing 'parallel'" } + !$omp task detach (x) ! { dg-error "'x' not specified in enclosing 'parallel'" } + !$omp end task + !$omp end parallel master +end Index: Fortran/gfortran/regression/gomp/pr100965.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr100965.f90 @@ -0,0 +1,16 @@ +! PR fortran/100965 +! { dg-do compile } + +implicit none + character(len=:), allocatable :: s + logical :: l + !$omp target map(from: l) + l = allocated (s) + !$omp end target + if (l) stop 1 + + !$omp target map(from: l) + l = allocated (s) + !$omp end target + if (l) stop 2 +end Index: Fortran/gfortran/regression/gomp/pr102431.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr102431.f90 @@ -0,0 +1,10 @@ +! PR middle-end/102431 + +program pr102431 + integer :: a(2) + a(:) = 0 + !$omp parallel loop reduction(+:a) + do i = 1, 8 + a = a + 1 + end do +end Index: Fortran/gfortran/regression/gomp/pr102621.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr102621.f90 @@ -0,0 +1,12 @@ +! This program used to ICE in convert_nonlocal_reference_op due to +! incorrect scoping of AFFINITY clause iterator variables. + +program p + integer :: a(8) + !$omp task affinity (iterator(j=1:8) : a(j)) + !$omp end task +contains + integer function f(x) + class(*) :: x + end +end Index: Fortran/gfortran/regression/gomp/pr103643.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr103643.f90 @@ -0,0 +1,19 @@ +! PR middle-end/103643 +! { dg-do compile } + +program test_task_affinity + implicit none + integer i + integer, allocatable :: A(:) + + allocate (A(10)) + + !$omp target + !$omp task affinity(A) + do i = 1, 10 + A(i) = 0 + end do + !$omp end task + !$omp end target + +end program test_task_affinity Index: Fortran/gfortran/regression/gomp/pr103695.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr103695.f90 @@ -0,0 +1,18 @@ +! This test case used to ICE in verify_ssa due to the iterator variable j +! incorrectly being inserted into program scope. + +program p + integer :: i + do i = 1, 3 + call sub (s(i)) + end do +contains + function s(n) result(z) + integer, target, intent(in) :: n + integer, pointer :: z + integer :: a(8), b(8), c(8) + !$omp task affinity (iterator(j=1:8) : a(j), b(j), c(j)) + !$omp end task + z => n + end +end Index: Fortran/gfortran/regression/gomp/pr104131.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr104131.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +program p + use iso_c_binding, only: c_intptr_t + implicit none + integer, parameter :: omp_event_handle_kind = c_intptr_t + + type dt + integer(omp_event_handle_kind) :: f + end type + integer(omp_event_handle_kind) :: x(1) + type(dt) :: y + + !$omp task detach(x) ! { dg-error "'x' at \\\(1\\\) should be a scalar of type integer\\\(kind=omp_event_handle_kind\\\)" } + !$omp end task + + !$omp task detach(x(1)) ! { dg-error "The event handle at \\\(1\\\) must not be an array element" } + !$omp end task + + !$omp task detach(y) ! { dg-error "'y' at \\\(1\\\) should be a scalar of type integer\\\(kind=omp_event_handle_kind\\\)" } + !$omp end task + + !$omp task detach(y%f) ! { dg-error "The event handle at \\\(1\\\) must not be part of a derived type or class" } + !$omp end task +end program Index: Fortran/gfortran/regression/gomp/pr104757.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr104757.f90 @@ -0,0 +1,19 @@ +! PR middle-end/104757 +! { dg-do compile } +! { dg-options "-O -fopenmp" } + +module pr104757 + implicit none (external, type) + integer :: ll + !$omp declare target (ll) +contains + subroutine foo (i1) + !$omp declare target (foo) + logical :: i1 + integer :: i + !$omp distribute simd if(i1) + do i = 1, 64 + ll = ll + 1 + end do + end +end module Index: Fortran/gfortran/regression/gomp/pr107214-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-2.f90 @@ -0,0 +1,6 @@ +integer :: y + +!$omp target has_device_addr(y) firstprivate(y) ! { dg-error "Symbol 'y' present on multiple clauses" } +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/pr107214-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-3.f90 @@ -0,0 +1,14 @@ +program p +integer :: y + +!$omp target map(y) firstprivate(y) ! { dg-error "Symbol 'y' present on both data and map clauses" } +y = y + 1 +!$omp end target + +!$omp target simd map(y) firstprivate(y) ! { dg-error "Symbol 'y' present on both data and map clauses" } +do i=1,1 + y = y + 1 +end do +!$omp end target simd + +end program p Index: Fortran/gfortran/regression/gomp/pr107214-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-4.f90 @@ -0,0 +1,147 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +integer :: x, y + +! EXEC_OMP_TARGET_TEAMS + +!$omp target teams map(x) firstprivate(x) +x = x + 1 +!$omp end target teams + +!$omp target teams map(x) firstprivate(y) +x = y + 1 +!$omp end target teams + +! EXEC_OMP_TARGET_TEAMS_DISTRIBUTE + +!$omp target teams distribute map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute + +!$omp target teams distribute map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target teams distribute + +! EXEC_OMP_TARGET_TEAMS_LOOP + +!$omp target teams loop map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams loop + +!$omp target teams loop map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target teams loop + +! EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD + +!$omp target teams distribute simd map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute simd + +!$omp target teams distribute simd map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target teams distribute simd + +! EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO + +!$omp target teams distribute parallel do map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute parallel do + +!$omp target teams distribute parallel do map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target teams distribute parallel do + +! EXEC_OMP_TARGET_PARALLEL + +!$omp target parallel map(x) firstprivate(x) +x = x + 1 +!$omp end target parallel + +!$omp target parallel map(x) firstprivate(y) +x = y + 1 +!$omp end target parallel + +! EXEC_OMP_TARGET_PARALLEL_DO + +!$omp target parallel do map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target parallel do + +!$omp target parallel do map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target parallel do + +! EXEC_OMP_TARGET_PARALLEL_LOOP + +!$omp target parallel loop map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target parallel loop + +!$omp target parallel loop map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target parallel loop + +! EXEC_OMP_TARGET_PARALLEL_DO_SIMD + +!$omp target parallel do simd map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target parallel do simd + +!$omp target parallel do simd map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target parallel do simd + +! EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD + +!$omp target teams distribute parallel do simd map(x) firstprivate(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute parallel do simd + +!$omp target teams distribute parallel do simd map(x) firstprivate(y) +do i=1,1 + x = y + 1 +end do +!$omp end target teams distribute parallel do simd + +! { dg-final { scan-tree-dump-times {omp target map\(tofrom:x\)} 10 "original" } } +! { dg-final { scan-tree-dump-times {omp target firstprivate\(y\) map\(tofrom:x\)} 10 "original" } } + +! { dg-final { scan-tree-dump-times {omp teams firstprivate\(x\)} 6 "original" } } +! { dg-final { scan-tree-dump-times {omp teams firstprivate\(y\)} 6 "original" } } + +! { dg-final { scan-tree-dump-times {omp parallel firstprivate\(x\)} 6 "original" } } +! { dg-final { scan-tree-dump-times {omp parallel firstprivate\(y\)} 6 "original" } } + +end Index: Fortran/gfortran/regression/gomp/pr107214-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-5.f90 @@ -0,0 +1,11 @@ +integer :: x, y + +!$omp target in_reduction(+: x) private(x) ! { dg-error "Symbol 'x' present on multiple clauses" } +x = x + 1 +!$omp end target + +!$omp target in_reduction(+: y) firstprivate(y) ! { dg-error "Symbol 'y' present on both data and map clauses" } +y = y + 1 +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/pr107214-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-6.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +integer :: x + +!$omp target map(x) private(x) ! { dg-error "Symbol 'x' present on multiple clauses" } +x = x + 1 +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/pr107214-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-7.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +integer :: x + +!$omp target simd map(x) private(x) +do i=1,1 + x = x + 1 +end do +!$omp end target simd + +!$omp target teams distribute simd map(x) private(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute simd + +!$omp target parallel do simd map(x) private(x) +do i=1,1 + x = x + 1 +end do +!$omp end target parallel do simd + +!$omp target teams distribute parallel do simd map(x) private(x) +do i=1,1 + x = x + 1 +end do +!$omp end target teams distribute parallel do simd + +! { dg-final { scan-tree-dump-times {omp target map\(tofrom:x\)} 4 "original" } } +! { dg-final { scan-tree-dump-times {(?n)omp simd.* private\(x\)} 4 "original" } } + +end Index: Fortran/gfortran/regression/gomp/pr107214-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214-8.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +integer, allocatable :: x +integer, pointer :: y + +!$omp target map(x) has_device_addr(x) ! { dg-error "Symbol 'x' present on multiple clauses" } +!$omp end target + +!$omp target map(y) is_device_ptr(y) ! { dg-error "Symbol 'y' present on multiple clauses" } +!$omp end target + +!$omp target firstprivate(x) has_device_addr(x) ! { dg-error "Symbol 'x' present on multiple clauses" } +!$omp end target + +!$omp target firstprivate(y) is_device_ptr(y) ! { dg-error "Symbol 'y' present on multiple clauses" } +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/pr107214.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr107214.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } + +program p + integer, allocatable :: a + !$omp target map(tofrom: a, a) ! { dg-error "Symbol 'a' present on multiple clauses" } + !$omp end target +end Index: Fortran/gfortran/regression/gomp/pr26224.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr26224.f @@ -0,0 +1,8 @@ +C PR fortran/26224 +C { dg-do compile } + + PROGRAM PR26224 + INTEGER FOO +C$OMP SINGLE +C$OMP END SINGLE COPYPRIVATE (FOO, BAR) + END Index: Fortran/gfortran/regression/gomp/pr27573.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr27573.f90 @@ -0,0 +1,14 @@ +! PR middle-end/27573 +! { dg-do compile } +! { dg-require-profiling "-fprofile-generate" } +! { dg-options "-O2 -fopenmp -fprofile-generate" } + +program pr27573 + integer i,j + j = 8 + !$omp parallel + print *, "foo" + do i = 1, j - 1 + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr29759.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr29759.f90 @@ -0,0 +1,42 @@ +! PR fortran/29759 +! { dg-do compile } + +PROGRAM test_omp +!$OMP PARALLEL & +!$OMP NUM_THREADS(2) +!$OMP END PARALLEL + +!$OMP PARALLEL & +!$OMP & NUM_THREADS(2) +!$OMP END PARALLEL + +!$OMP PARALLEL & +! +!$OMP NUM_THREADS(2) +!$OMP END PARALLEL + +!$OMP PARALLEL & +! +!$OMP & NUM_THREADS(2) +!$OMP END PARALLEL + + +!$OMP PARALLEL & ! { dg-error "Failed to match clause" } +!$ NUM_THREADS(2) +!$OMP END PARALLEL ! { dg-error "Unexpected" } + +!$OMP PARALLEL & ! { dg-error "Failed to match clause" } +!$ & NUM_THREADS(2) ! { dg-error "Invalid character" } +!$OMP END PARALLEL ! { dg-error "Unexpected" } + +!$OMP PARALLEL & ! { dg-error "Failed to match clause" } +! +!$ NUM_THREADS(2) +!$OMP END PARALLEL ! { dg-error "Unexpected" } + +!$OMP PARALLEL & ! { dg-error "Failed to match clause" } +! +!$ & NUM_THREADS(2) ! { dg-error "Invalid character" } +!$OMP END PARALLEL ! { dg-error "Unexpected" } + +END PROGRAM Index: Fortran/gfortran/regression/gomp/pr33439.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr33439.f90 @@ -0,0 +1,39 @@ +! PR fortran/33439 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine pr33439_1 + integer :: s, i + s = 4 +!$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } + call somethingelse +!$omp do schedule(static, s) ! { dg-error "not specified in enclosing 'parallel'" } + do i = 1, 8 + call something + end do +!$omp end do +!$omp end parallel +end subroutine pr33439_1 + +subroutine pr33439_2 + integer :: s, i + s = 4 +!$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } +!$omp do schedule(static, s) ! { dg-error "not specified in enclosing 'parallel'" } + do i = 1, 8 + call something + end do +!$omp end do +!$omp end parallel +end subroutine pr33439_2 + +subroutine pr33439_3 + integer :: s, i + s = 4 +!$omp parallel do default(none) schedule(static, s) ! { dg-message "note: enclosing 'parallel'" } +! ! { dg-error "'s' not specified in enclosing 'parallel'" "" { target *-*-* } .-1 } + do i = 1, 8 + call something + end do +!$omp end parallel do +end subroutine pr33439_3 Index: Fortran/gfortran/regression/gomp/pr35786-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr35786-1.f90 @@ -0,0 +1,72 @@ +! PR fortran/35786 +! { dg-do compile } +! { dg-options "-fopenmp" } + +module pr35768 + real, parameter :: one = 1.0 +contains + subroutine fn1 + !$omp parallel firstprivate (one) ! { dg-error "is not a variable" } + !$omp end parallel + end subroutine fn1 + subroutine fn2 (doit) + external doit + !$omp parallel firstprivate (doit) ! { dg-error "is not a variable" } + call doit () + !$omp end parallel + end subroutine fn2 + subroutine fn3 + interface fn4 + subroutine fn4 () + end subroutine fn4 + end interface + !$omp parallel private (fn4) ! { dg-error "is not a variable" } + call fn4 () + !$omp end parallel + end subroutine fn3 + subroutine fn5 + interface fn6 + function fn6 () + integer :: fn6 + end function fn6 + end interface + integer :: x + !$omp parallel private (fn6, x) ! { dg-error "is not a variable" } + x = fn6 () + !$omp end parallel + end subroutine fn5 + function fn7 () result (re7) + integer :: re7 + !$omp parallel private (fn7) ! { dg-error "is not a variable" } + !$omp end parallel + end function fn7 + function fn8 () result (re8) + integer :: re8 + call fn9 + contains + subroutine fn9 + !$omp parallel private (fn8) ! { dg-error "is not a variable" } + !$omp end parallel + end subroutine fn9 + end function fn8 + function fn10 () result (re10) + integer :: re10, re11 + entry fn11 () result (re11) + !$omp parallel private (fn10) ! { dg-error "is not a variable" } + !$omp end parallel + !$omp parallel private (fn11) ! { dg-error "is not a variable" } + !$omp end parallel + end function fn10 + function fn12 () result (re12) + integer :: re12, re13 + entry fn13 () result (re13) + call fn14 + contains + subroutine fn14 + !$omp parallel private (fn12) ! { dg-error "is not a variable" } + !$omp end parallel + !$omp parallel private (fn13) ! { dg-error "is not a variable" } + !$omp end parallel + end subroutine fn14 + end function fn12 +end module Index: Fortran/gfortran/regression/gomp/pr35786-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr35786-2.f90 @@ -0,0 +1,48 @@ +! PR fortran/35786 +! { dg-do compile } +! { dg-options "-fopenmp" } + +function fn7 () + integer :: fn7 + !$omp parallel private (fn7) + fn7 = 6 + !$omp end parallel + fn7 = 7 +end function fn7 +function fn8 () + integer :: fn8 + call fn9 +contains + subroutine fn9 + !$omp parallel private (fn8) + fn8 = 6 + !$omp end parallel + fn8 = 7 + end subroutine fn9 +end function fn8 +function fn10 () + integer :: fn10, fn11 + entry fn11 () + !$omp parallel private (fn10) + fn10 = 6 + !$omp end parallel + !$omp parallel private (fn11) + fn11 = 6 + !$omp end parallel + fn10 = 7 +end function fn10 +function fn12 () + integer :: fn12, fn13 + entry fn13 () + call fn14 +contains + subroutine fn14 + !$omp parallel private (fn12) + fn12 = 6 + !$omp end parallel + !$omp parallel private (fn13) + fn13 = 6 + !$omp end parallel + fn12 = 7 + end subroutine fn14 +end function fn12 Index: Fortran/gfortran/regression/gomp/pr36726.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr36726.f90 @@ -0,0 +1,20 @@ +! PR middle-end/36726 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo + integer, allocatable :: vs(:) + !$omp parallel private (vs) + allocate (vs(10)) + vs = 2 + deallocate (vs) + !$omp end parallel +end subroutine foo +subroutine bar + integer, allocatable :: vs(:) + !$omp parallel private (vs) + allocate (vs(10)) + vs = 2 + deallocate (vs) + !$omp end parallel +end subroutine bar Index: Fortran/gfortran/regression/gomp/pr39152.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr39152.f90 @@ -0,0 +1,32 @@ +! { dg-do compile { target { { i?86-*-* x86_64-*-* } && ia32 } } } +! { dg-options "-march=i486 -fopenmp -mavx -O3 -funroll-all-loops" } + + call test_workshare + +contains + subroutine test_workshare + integer :: i, j, k, l, m + double precision, dimension (64) :: d, e + integer, dimension (10) :: f, g + integer, dimension (16, 16) :: a, b, c + integer, dimension (16) :: n +!$omp parallel num_threads (4) private (j, k) +!$omp barrier +!$omp workshare + where (g .lt. 0) + f = 100 + elsewhere + where (g .gt. 6) f = f + sum (g) + f = 300 + f + end where +!$omp end workshare nowait +!$omp workshare + forall (j = 1:16, k = 1:16) b (k, j) = a (j, k) + forall (j = 2:16, n (17 - j) / 4 * 4 .ne. n (17 - j)) + n (j) = n (j - 1) * n (j) + end forall +!$omp endworkshare +!$omp end parallel + + end subroutine test_workshare +end Index: Fortran/gfortran/regression/gomp/pr39354.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr39354.f90 @@ -0,0 +1,37 @@ +! PR fortran/39354 +! { dg-do compile } +! { dg-options "-fopenmp" } + SUBROUTINE ltest(l1, l2, l3, l4, r1, r2, r3, r4) + LOGICAL l1, l2, l3, l4, r1, r2, r3, r4 +!$OMP ATOMIC + l1 = l1 .and. r1 +!$OMP ATOMIC + l2 = l2 .or. r2 +!$OMP ATOMIC + l3 = l3 .eqv. r3 +!$OMP ATOMIC + l4 = l4 .neqv. r4 + END + SUBROUTINE itest(l1, l2, l3, l4, l5, l6, l7, l8, l9, & +& r1, r2, r3, r4, r5, r6, r7, r8, r9) + INTEGER l1, l2, l3, l4, l5, l6, l7, l8, l9, & +& r1, r2, r3, r4, r5, r6, r7, r8, r9 +!$OMP ATOMIC + l1 = l1 + r1 +!$OMP ATOMIC + l2 = l2 - r2 +!$OMP ATOMIC + l3 = l3 * r3 +!$OMP ATOMIC + l4 = l4 / r4 +!$OMP ATOMIC + l5 = max (l5, r1, r5) +!$OMP ATOMIC + l6 = min (r1, r6, l6) +!$OMP ATOMIC + l7 = iand (l7, r7) +!$OMP ATOMIC + l8 = ior (r8, l8) +!$OMP ATOMIC + l9 = ieor (l9, r9) + END Index: Fortran/gfortran/regression/gomp/pr40878-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr40878-1.f90 @@ -0,0 +1,63 @@ +! PR fortran/40878 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine test1 + integer :: j, k + integer :: m = 2 +!$omp parallel do collapse(m) schedule (static,1) ! { dg-error "Constant expression required" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test2 + integer :: j, k + integer :: m + m = 2 +!$omp parallel do collapse(m) schedule (static,1) ! { dg-error "Constant expression required" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test3 + integer :: j, k + integer, parameter :: m = 0 +!$omp parallel do collapse(m) schedule (static,1) ! { dg-error "not constant positive integer" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test4 + integer :: j, k + integer, parameter :: m = -2 +!$omp parallel do collapse(m) schedule (static,1) ! { dg-error "not constant positive integer" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test5 + integer :: j, k +!$omp parallel do collapse(0) schedule (static,1) ! { dg-error "not constant positive integer" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test6 + integer :: j, k +!$omp parallel do collapse(-1) schedule (static,1) ! { dg-error "not constant positive integer" } + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end Index: Fortran/gfortran/regression/gomp/pr40878-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr40878-2.f90 @@ -0,0 +1,23 @@ +! PR fortran/40878 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine test1 + integer :: j, k + integer, parameter :: m = 2 +!$omp parallel do collapse(m) schedule (static,1) + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end +subroutine test2 + integer :: j, k +!$omp parallel do collapse(2) schedule (static,1) + do k = 1, 2 + do j = 1, 6 + enddo + enddo +!$omp end parallel do +end Index: Fortran/gfortran/regression/gomp/pr41344.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr41344.f @@ -0,0 +1,16 @@ + subroutine xrotate(nerr) + + common /dfm/ndfl + +*$omp parallel private(ix) + ix = 0 +*$omp do + do i=1,ndfl + ix = ix + 1 + if (ix.gt.5) go to 9000 ! { dg-error "invalid (exit|branch)" } + enddo +*$omp end do +*$omp end parallel + +9000 continue + end Index: Fortran/gfortran/regression/gomp/pr43337.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr43337.f90 @@ -0,0 +1,30 @@ +! PR middle-end/43337 +! { dg-do compile } +! { dg-options "-fopenmp -O2 -g" } + +subroutine pr43337 + integer :: a, b(10) + call foo (b) + call bar (b) +contains + subroutine foo (b) + integer :: b(10) +!$omp parallel if (.false.) +!$omp task if (.false.) shared(b) + do a = 1, 10 + b(a) = 1 + end do +!$omp end task +!$omp end parallel + end subroutine foo + subroutine bar (b) + integer :: b(10) +!$omp parallel if (.false.) +!$omp parallel if (.false.) + do a = 1, 10 + b(a) = 1 + end do +!$omp end parallel +!$omp end parallel + end subroutine bar +end subroutine pr43337 Index: Fortran/gfortran/regression/gomp/pr43711.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr43711.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } +! +! PR fortran/43711 uninformative error message for two 'nowait' in omp statement +! Contributed by Bill Long + +program NF03_2_5_2_1a + !$omp parallel + !$omp sections + !$omp section + print *, 'FAIL' + !$omp section + print *, 'FAIL' + !$omp end sections nowait nowait ! { dg-error "Unexpected junk after NOWAIT clause" } + !$omp end parallel ! { dg-error "Unexpected !.OMP END PARALLEL statement" } +end program NF03_2_5_2_1a ! { dg-error "Unexpected END statement" } + +! { dg-prune-output "Unexpected end of file" } Index: Fortran/gfortran/regression/gomp/pr43836.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr43836.f90 @@ -0,0 +1,10 @@ +! PR fortran/43836 +! { dg-do compile } +! { dg-options "-fopenmp -fexceptions -O2" } +subroutine foo +!$omp single +!$omp parallel + call bar +!$omp end parallel +!$omp end single +end subroutine foo Index: Fortran/gfortran/regression/gomp/pr44036-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44036-1.f90 @@ -0,0 +1,24 @@ +! PR fortran/44036 +! { dg-do compile } +! { dg-options "-fopenmp" } +subroutine foo(a, b) + integer, external :: a + integer, external, pointer :: b + integer, external :: c + integer, external, pointer :: d + integer :: x + x = 6 +!$omp parallel default(none) private (x) + x = a(4) +!$omp end parallel +!$omp parallel default(none) private (x) ! { dg-message "note: enclosing 'parallel'" } + x = b(5) ! { dg-error "not specified in" } +!$omp end parallel +!$omp parallel default(none) private (x) + x = c(6) +!$omp end parallel + d => a +!$omp parallel default(none) private (x) ! { dg-message "note: enclosing 'parallel'" } + x = d(7) ! { dg-error "not specified in" } +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr44036-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44036-2.f90 @@ -0,0 +1,17 @@ +! PR fortran/44036 +! { dg-do compile } +! { dg-options "-fopenmp" } +subroutine foo(a, b) + integer, external :: a + integer, external, pointer :: b + integer, external :: c + integer, external, pointer :: d + integer :: x + d => a +!$omp parallel default(none) private (x) firstprivate (b, d) + x = a(4) + x = b(5) + x = c(6) + x = d(7) +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr44036-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44036-3.f90 @@ -0,0 +1,13 @@ +! PR fortran/44036 +! { dg-do compile } +! { dg-options "-fopenmp" } +subroutine foo(a) + integer, external :: a, c + integer :: x +!$omp parallel default(none) private (x) shared (a) ! { dg-error "is not a variable" } + x = a(6) +!$omp end parallel +!$omp parallel default(none) private (x) shared (c) ! { dg-error "is not a variable" } + x = c(6) +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr44085.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44085.f90 @@ -0,0 +1,25 @@ +! PR middle-end/44085 +! { dg-do compile } +! { dg-require-effective-target tls_native } +! { dg-options "-fopenmp" } + + integer, save :: thr1, thr2 + integer :: thr3, thr4 + common /thrs/ thr3, thr4 +!$omp threadprivate (thr1, thr2, /thrs/) + +!$omp task untied ! { dg-message "note: enclosing task" } + thr1 = thr1 + 1 ! { dg-error "used in untied task" } + thr2 = thr2 + 2 ! { dg-error "used in untied task" } + thr3 = thr3 + 3 ! { dg-error "used in untied task" } + thr4 = thr4 + 4 ! { dg-error "used in untied task" } +!$omp end task + +!$omp task + thr1 = thr1 + 1 + thr2 = thr2 + 2 + thr3 = thr3 + 3 + thr4 = thr4 + 4 +!$omp end task + + end Index: Fortran/gfortran/regression/gomp/pr44536.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44536.f90 @@ -0,0 +1,10 @@ +! PR fortran/44536 +! { dg-do compile } +! { dg-options "-fopenmp" } + subroutine foo (a, i, j) + integer, dimension(:) :: a + integer :: i, j +!$omp parallel default(none) shared(i, j) ! { dg-message "note: enclosing 'parallel'" } + j=a(i) ! { dg-error "not specified in" } +!$omp end parallel + end subroutine Index: Fortran/gfortran/regression/gomp/pr44847.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr44847.f90 @@ -0,0 +1,86 @@ +! PR fortran/44847 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine pr44847_1 + integer :: i, j +!$omp parallel do collapse(2) +l:do i = 1, 2 + do j = 1, 2 + cycle l ! { dg-error "CYCLE statement" } + end do + end do l +end subroutine +subroutine pr44847_2 + integer :: i, j, k +!$omp parallel do collapse(3) + do i = 1, 2 + l:do j = 1, 2 + do k = 1, 2 + cycle l ! { dg-error "CYCLE statement" } + end do + end do l + end do +end subroutine +subroutine pr44847_3 + integer :: i, j +!$omp parallel do +l:do i = 1, 2 + do j = 1, 2 + cycle l + end do + end do l +end subroutine +subroutine pr44847_4 + integer :: i, j, k +!$omp parallel do collapse(2) + do i = 1, 2 + l:do j = 1, 2 + do k = 1, 2 + cycle l + end do + end do l + end do +end subroutine +subroutine pr44847_5 + integer :: i, j +!$omp parallel do collapse(2) +l:do i = 1, 2 + do j = 1, 2 + exit l ! { dg-error "EXIT statement" } + end do + end do l +end subroutine +subroutine pr44847_6 + integer :: i, j, k +!$omp parallel do collapse(3) + do i = 1, 2 + l:do j = 1, 2 + do k = 1, 2 + exit l ! { dg-error "EXIT statement" } + end do + end do l + end do +end subroutine +subroutine pr44847_7 + integer :: i, j, k +!$omp parallel do collapse(2) + do i = 1, 2 + l:do j = 1, 2 + do k = 1, 2 + exit l ! { dg-error "EXIT statement" } + end do + end do l + end do +end subroutine +subroutine pr44847_8 + integer :: i, j, k +!$omp parallel do + do i = 1, 2 + l:do j = 1, 2 + do k = 1, 2 + exit l + end do + end do l + end do +end subroutine Index: Fortran/gfortran/regression/gomp/pr45172.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr45172.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-options "-O -fopenmp -fexceptions" } + + SUBROUTINE dbcsr_mult_m_e_e ( ) + LOGICAL, PARAMETER :: use_combined_types = .FALSE. + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: right_index_sr + INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: my_sizes + INTEGER, ALLOCATABLE, DIMENSION(:, :, :, :) :: all_sizes + ALLOCATE (all_sizes(4, LBOUND(my_sizes,2):UBOUND(my_sizes,2), & + LBOUND(my_sizes,3):UBOUND(my_sizes,3), 0:numnodes-1)) + IF (use_combined_types) THEN + CALL mp_waitall (right_index_sr) + ENDIF + DO ki = 0, min_nimages-1 +!$omp parallel default (none) & +!$omp reduction (+: flop_single, t_all, t_dgemm) +!$omp end parallel + ENDDO + checksum = dbcsr_checksum (product_matrix, error) + END SUBROUTINE dbcsr_mult_m_e_e + Index: Fortran/gfortran/regression/gomp/pr45595.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr45595.f90 @@ -0,0 +1,10 @@ +! PR fortran/45595 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo(l,u) + integer :: k,l,u + !$omp parallel do shared(l,u) collapse(3) ! { dg-error "not enough DO loops" } + do k = l,u + end do +end subroutine Index: Fortran/gfortran/regression/gomp/pr45597.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr45597.f90 @@ -0,0 +1,22 @@ +! PR fortran/45597 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo(n) + integer :: i, n(6) + !$omp parallel do default(none) shared(n) + do i = 1, 6 + if (n(i).gt.0) cycle + end do +end subroutine +subroutine bar(n) + integer :: i, j, k, n(6, 6, 6) + !$omp parallel do default(none) shared(n) collapse(3) + do i = 1, 6 + do j = 1, 6 + do k = 1, 6 + if (n(i, j, k).gt.0) cycle + end do + end do + end do +end subroutine Index: Fortran/gfortran/regression/gomp/pr47331.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr47331.f90 @@ -0,0 +1,24 @@ +! PR fortran/47331 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo + !$omp parallel + call bar () + !$omp end parallel +end subroutine foo + +subroutine bar + integer :: k + do k=1,5 + call baz (k) + end do +end subroutine bar + +subroutine baz (k) + integer :: k +end subroutine + +program pr47331 + call foo +end program pr47331 Index: Fortran/gfortran/regression/gomp/pr48117.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr48117.f90 @@ -0,0 +1,11 @@ +! PR fortran/48117 +! { dg-do compile } +! { dg-options "-O2 -fopenmp" } + +subroutine foo(x) + character(len=*), optional :: x + character(len=80) :: v + !$omp master + if (present(x)) v = adjustl(x) + !$omp end master +end subroutine foo Index: Fortran/gfortran/regression/gomp/pr48611.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr48611.f90 @@ -0,0 +1,12 @@ +! PR tree-optimization/48611 +! { dg-do compile } +! { dg-options "-Os -fopenmp -fexceptions -fno-tree-ccp -fno-tree-copy-prop" } + + integer, allocatable :: a(:) + logical :: l +!$omp parallel private (a) reduction (.or.:l) + do i = 1, 7 + a(:) = i + end do +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr48794-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr48794-2.f90 @@ -0,0 +1,16 @@ +! PR tree-optimization/48794 +! { dg-do compile } +! { dg-options "-Os -fopenmp -fexceptions -fno-tree-ccp -fno-tree-copy-prop" } + + integer, allocatable :: a(:) + integer :: b(48) + logical :: l + if (allocated (a)) then + STOP 1 + call bla(b) + end if +!$omp parallel private (a) reduction (.or.:l) + do i = 1, 7 + end do +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr48794.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr48794.f90 @@ -0,0 +1,12 @@ +! PR tree-optimization/48794 +! { dg-do compile } +! { dg-options "-Os -fopenmp -fexceptions -fno-tree-ccp -fno-tree-copy-prop" } + + integer, allocatable :: a(:) + logical :: l + if (allocated (a)) STOP 1 +!$omp parallel private (a) reduction (.or.:l) + do i = 1, 7 + end do +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr51089.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr51089.f90 @@ -0,0 +1,16 @@ +! PR middle-end/51089 +! { dg-do compile } +! { dg-options "-O -fexceptions -fopenmp" } + +subroutine foo + real, allocatable, dimension(:) :: s + real, dimension(:, :, :), pointer :: t + call fn1 (t, s) + call fn2 () +end subroutine foo +subroutine bar + integer :: i +!$omp parallel do + do i = 1, 10 + end do +end subroutine bar Index: Fortran/gfortran/regression/gomp/pr52531.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr52531.f90 @@ -0,0 +1,16 @@ +! { dg-do compile } +! PR fortran/52531 +module test_mod + type, public :: test_type + end type +contains + subroutine foo(bar) + type(test_type) :: bar +!$omp parallel default(none) shared(bar) ! Compiles if one removes default(none) + call question(bar) +!$omp end parallel + end subroutine + subroutine question(var) + class(test_type), intent(in) :: var ! Compiles if one replaces class by type + end subroutine +end module Index: Fortran/gfortran/regression/gomp/pr56052.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr56052.f90 @@ -0,0 +1,16 @@ +! PR fortran/56052 +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine middle(args) + type args_t + end type + type, extends(args_t) :: scan_args_t + end type + class(args_t),intent(inout) :: args + !$omp single + select type (args) + type is (scan_args_t) + end select + !$omp end single +end subroutine middle Index: Fortran/gfortran/regression/gomp/pr57089.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr57089.f90 @@ -0,0 +1,12 @@ +! PR middle-end/57089 +! { dg-do compile } +! { dg-options "-O -fopenmp" } + SUBROUTINE T() + INTEGER :: npoints, grad_deriv + SELECT CASE(grad_deriv) + CASE (0) + !$omp do + DO ii=1,npoints + END DO + END SELECT + END SUBROUTINE Index: Fortran/gfortran/regression/gomp/pr59467.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr59467.f90 @@ -0,0 +1,24 @@ +! PR libgomp/59467 +! { dg-do compile } +! { dg-options "-fopenmp" } + FUNCTION t() + INTEGER :: a, b, t + a = 0 + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE ! { dg-error "is not threadprivate or private in outer context" } + !$OMP ATOMIC WRITE + a = 6 + !$OMP END SINGLE COPYPRIVATE (a) + b = a + !$OMP END PARALLEL + t = b + b = 0 + !$OMP PARALLEL REDUCTION(+:b) + !$OMP SINGLE + !$OMP ATOMIC WRITE + b = 6 + !$OMP END SINGLE COPYPRIVATE (b) + !$OMP END PARALLEL + t = t + b + END FUNCTION Index: Fortran/gfortran/regression/gomp/pr59488-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr59488-1.f90 @@ -0,0 +1,13 @@ +! PR fortran/59488 +! { dg-do compile } +! { dg-options "-fopenmp" } + + implicit none + integer, parameter :: p(2) = (/ 11, 12 /) + integer :: r + + !$omp parallel do default(none) + do r = 1, 2 + print *, p(r) + end do +end Index: Fortran/gfortran/regression/gomp/pr59488-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr59488-2.f90 @@ -0,0 +1,16 @@ +! PR fortran/59488 +! { dg-do compile } +! { dg-options "-fopenmp" } + + implicit none + type t + integer :: s1, s2, s3 + end type + integer :: r + type(t), parameter :: u = t(1, 2, 3) + + !$omp parallel do default(none) + do r = 1, 2 + print *, u + end do +end Index: Fortran/gfortran/regression/gomp/pr62131.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr62131.f90 @@ -0,0 +1,19 @@ +! PR fortran/62131 +! { dg-do compile } +! { dg-options "-fopenmp" } + +program pr62131 + integer,allocatable :: nerrs(:,:) + allocate(nerrs(10,10)) + nerrs(:,:) = 0 +!$omp parallel do + do k=1,10 + call uperrs(k,1) + end do +contains + subroutine uperrs(i,io) + integer,intent(in) :: i,io +!$omp atomic + nerrs(i,io)=nerrs(i,io)+1 + end subroutine +end Index: Fortran/gfortran/regression/gomp/pr66633.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr66633.f90 @@ -0,0 +1,17 @@ +! PR middle-end/66633 +! Testcase by Andrew Benson + +! { dg-do compile } +! { dg-options "-O0 -fopenmp" } + +module spls +contains + function spl() + !$omp parallel + write (0,*) igrt(fli) + !$omp end parallel + contains + double precision function fli() + end function fli + end function spl +end module spls Index: Fortran/gfortran/regression/gomp/pr67500.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr67500.f90 @@ -0,0 +1,57 @@ +! Fortran version of PR c/67500 +! { dg-do compile } + +subroutine f1 + !$omp declare simd simdlen(d) ! { dg-error "requires a scalar INTEGER expression" } +end subroutine + +subroutine f2 + !$omp declare simd simdlen(0.5) ! { dg-error "requires a scalar INTEGER expression" } +end + +subroutine f3 (i) + !$omp declare simd simdlen(-2) ! { dg-warning "INTEGER expression of SIMDLEN clause at .1. must be positive" } +end subroutine + +subroutine f4 + !$omp declare simd simdlen(0) ! { dg-warning "INTEGER expression of SIMDLEN clause at .1. must be positive" } +end + +subroutine foo(p, d, n) + integer, allocatable :: p(:) + real, value :: d + integer, value :: n + integer :: i + + !$omp simd safelen(d) ! { dg-error "requires a scalar INTEGER expression" } + do i = 1, 16 + end do + + !$omp simd safelen(0.5) ! { dg-error "requires a scalar INTEGER expression" } + do i = 1, 16 + end do + + !$omp simd safelen(-2) ! { dg-warning "INTEGER expression of SAFELEN clause at .1. must be positive" } + do i = 1, 16 + end do + + !$omp simd safelen(0) ! { dg-warning "INTEGER expression of SAFELEN clause at .1. must be positive" } + do i = 1, 16 + end do + + !$omp simd aligned(p:n) ! { dg-error "requires a scalar positive constant integer alignment expression" } + do i = 1, 16 + end do + + !$omp simd aligned(p:0.5) ! { dg-error "requires a scalar positive constant integer alignment expression" } + do i = 1, 16 + end do + + !$omp simd aligned(p:-2) ! { dg-error "requires a scalar positive constant integer alignment expression" } + do i = 1, 16 + end do + + !$omp simd aligned(p:0) ! { dg-error "requires a scalar positive constant integer alignment expression" } + do i = 1, 16 + end do +end Index: Fortran/gfortran/regression/gomp/pr69128.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr69128.f90 @@ -0,0 +1,23 @@ +! PR fortran/69128 +! { dg-do compile } + +program test + implicit none + interface + subroutine use(b, c) + real, allocatable :: b(:), c(:) + end subroutine + end interface + real, allocatable :: a(:,:), b(:), c(:) + integer :: dim1, dim2, i,j + dim1=10000 + dim2=500 + allocate(a(dim1,dim2),b(dim1),c(dim1)) + call random_number(a) + +!$omp parallel workshare + b(:) = maxval(a(:,:), dim=2) + c(:) = sum(a(:,:), dim=2) +!$omp end parallel workshare + call use(b, c) +end program Index: Fortran/gfortran/regression/gomp/pr69183.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr69183.f90 @@ -0,0 +1,11 @@ +! PR middle-end/69183 +! { dg-do compile } + +program pr69183 + integer, allocatable :: z + integer :: i + !$omp do private(z) + do i = 1, 2 + z = i + end do +end Index: Fortran/gfortran/regression/gomp/pr69281.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr69281.f90 @@ -0,0 +1,63 @@ +! PR fortran/69281 +! { dg-do compile } +! { dg-additional-options "-fstack-arrays -O2" } + +program pr69281 + implicit none + call foo1((/ 1, 3, 3, 7 /)) + call foo2((/ 1, 3, 3, 7 /)) + call foo3((/ 1, 3, 3, 7 /)) + call foo4((/ 1, 3, 3, 7 /)) + call foo5((/ 1, 3, 3, 7 /)) + call foo6((/ 1, 3, 3, 7 /)) +contains + subroutine foo1(x) + integer, intent(in) :: x(:) + !$omp parallel + call baz(bar(x)) + !$omp end parallel + end subroutine + subroutine foo2(x) + integer, intent(in) :: x(:) + !$omp task + call baz(bar(x)) + !$omp end task + end subroutine + subroutine foo3(x) + integer, intent(in) :: x(:) + !$omp target + call baz(bar(x)) + !$omp end target + end subroutine + subroutine foo4(x) + integer, intent(in) :: x(:) + !$omp target teams + call baz(bar(x)) + !$omp end target teams + end subroutine + subroutine foo5(x) + integer, intent(in) :: x(:) + integer :: i + !$omp parallel do + do i = 1, 1 + call baz(bar(x)) + end do + end subroutine + subroutine foo6(x) + integer, intent(in) :: x(:) + integer :: i + !$omp target teams distribute parallel do + do i = 1, 1 + call baz(bar(x)) + end do + end subroutine + function bar(x) result(a) + integer, dimension(:), intent(in) :: x + integer, dimension(2,size(x)) :: a + a(1,:) = 1 + a(2,:) = x + end function + subroutine baz(a) + integer, dimension(:,:), intent(in) :: a + end subroutine +end program Index: Fortran/gfortran/regression/gomp/pr70855.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr70855.f90 @@ -0,0 +1,18 @@ +! PR fortran/70855 +! { dg-do compile } +! { dg-additional-options "-O2" } + +program pr70855 + integer, parameter :: m = 4 + integer, parameter :: n = 2 + real :: a(m,n) + real :: x(n) + real :: y(m) + a = 1.0 + x = 1.0 +!$omp parallel +!$omp workshare + y(1:m) = matmul ( a(1:m,1:n), x(1:n) ) +!$omp end workshare +!$omp end parallel +end program pr70855 Index: Fortran/gfortran/regression/gomp/pr71687.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr71687.f90 @@ -0,0 +1,11 @@ +! PR fortran/71687 +! { dg-do compile } +! { dg-additional-options "-fstack-arrays -O2" } + +subroutine s (n, x) + integer :: n + real :: x(n) +!$omp parallel + x(1:n) = x(n:1:-1) +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr71704.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr71704.f90 @@ -0,0 +1,58 @@ +! PR fortran/71704 +! { dg-do compile } + +real function f0 () +!$omp declare simd (f0) + f0 = 1 +end + +real function f1 () +!$omp declare target (f1) + f1 = 1 +end + +real function f2 () +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) & +!$omp & initializer (omp_priv = 0) + f2 = 1 +end + +real function f3 () + real, save :: t +!$omp threadprivate (t) + f3 = 1 +end + +real function f4 () +!$omp taskwait + f4 = 1 +end + +real function f5 () +!$omp barrier + f5 = 1 +end + +real function f6 () +!$omp parallel +!$omp end parallel + f6 = 1 +end + +real function f7 () +!$omp single +!$omp end single + f7 = 1 +end + +real function f8 () +!$omp critical +!$omp end critical + f8 = 1 +end + +real function f9 () +!$omp critical +!$omp end critical + f9 = 1 +end Index: Fortran/gfortran/regression/gomp/pr71705.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr71705.f90 @@ -0,0 +1,7 @@ +! PR fortran/71705 +! { dg-do compile } + + real :: x + x = 0.0 + !$omp target update to(x) +end Index: Fortran/gfortran/regression/gomp/pr71758.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr71758.f90 @@ -0,0 +1,10 @@ +! PR middle-end/71758 + +subroutine pr71758 (p) + integer(8) :: i + integer :: p(20) + i = 0 + !$omp target device(i) + !$omp end target + !$omp target update to(p(1:1)) device(i) +end subroutine Index: Fortran/gfortran/regression/gomp/pr72716.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr72716.f90 @@ -0,0 +1,6 @@ +! PR fortran/72716 +! { dg-do compile } + +block data + !$omp declare simd (z) ! { dg-error "statement is not allowed inside of BLOCK DATA" } +end block data Index: Fortran/gfortran/regression/gomp/pr72744.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr72744.f90 @@ -0,0 +1,18 @@ +! PR fortran/72744 +! { dg-do compile } +! { dg-additional-options "-Ofast" } + +program pr72744 + integer, parameter :: n = 20 + integer :: i, z(n), h(n) + z = [(i, i=1,n)] + h = [(i, i=n,1,-1)] + call sub (n, h) + if ( any(h/=z) ) STOP 1 +end +subroutine sub (n, x) + integer :: n, x(n) +!$omp parallel + x(:) = x(n:1:-1) +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr77352.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77352.f90 @@ -0,0 +1,16 @@ +! PR fortran/77352 +! { dg-do compile } +! { dg-additional-options "-fstack-arrays -O2" } +! { dg-additional-options "-fopenacc" { target fopenacc } } + +program pr77352 + real, allocatable :: a(:,:), b(:) + integer :: m, n + m = 4 + n = 2 + allocate (a(m,n), b(m)) + a = 1.0 +!$omp parallel workshare + b(:) = [ sum(a, dim=1) ] +!$omp end parallel workshare +end Index: Fortran/gfortran/regression/gomp/pr77374.f08 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77374.f08 @@ -0,0 +1,21 @@ +! PR fortran/77374 +! { dg-do compile } + +subroutine foo (a, b) + integer :: a, b +!$omp atomic + b = b + a +!$omp atomic + z(1) = z(1) + 1 ! { dg-error "must have the pointer attribute" } +end subroutine +subroutine bar (a, b) + integer :: a, b + interface + function baz (i) result (res) + integer, pointer :: res + integer :: i + end function + end interface +!$omp atomic + baz (i) = 1 ! { dg-error "unexpected" } +end subroutine Index: Fortran/gfortran/regression/gomp/pr77500.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77500.f90 @@ -0,0 +1,9 @@ +! PR fortran/77500 +! { dg-do compile } + +program pr77500 + real :: x +!$omp atomic write + x = f() +!$omp end atomic +end Index: Fortran/gfortran/regression/gomp/pr77516.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77516.f90 @@ -0,0 +1,12 @@ +! PR fortran/77516 +! { dg-do compile } + +program pr77516 + integer :: i, x + x = 0 +!$omp simd safelen(0) reduction(+:x) ! { dg-warning "must be positive" } + do i = 1, 8 + x = x + 1 + end do + print *, x +end Index: Fortran/gfortran/regression/gomp/pr77665.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77665.f90 @@ -0,0 +1,18 @@ +! PR fortran/77665 +! { dg-do compile } +! { dg-additional-options "-O2" } + +program pr77665 + type t + integer :: a = 0 + end type + type(t) :: x + integer :: i + !$omp declare reduction (+:t: omp_out%a = omp_out%a + omp_in%a) + !$omp simd reduction(+:x) + do i = 1, 8 + if (abs(i) < 5) STOP 1 + x%a = x%a + 1 + end do + print *, x%a +end Index: Fortran/gfortran/regression/gomp/pr77666.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77666.f90 @@ -0,0 +1,26 @@ +! PR fortran/77666 +! { dg-do compile } + +subroutine foo(x) + interface + subroutine baz(x, y) + integer, allocatable :: x(:), y + end subroutine + end interface + integer, allocatable :: x(:), y +!$omp parallel private(x, y) + call baz (x, y) +!$omp end parallel +end +subroutine bar + interface + subroutine baz(x, y) + integer, allocatable :: x(:), y + end subroutine + end interface + integer, allocatable :: x(:), y + call baz (x, y) +!$omp parallel private(x, y) + call baz (x, y) +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr77973.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr77973.f90 @@ -0,0 +1,12 @@ +! PR fortran/77973 +! { dg-do compile } + +subroutine s(x) + integer :: x(:) + integer :: i +!$omp parallel +!$omp target + x(1) = 1 +!$omp end target +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr78026.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78026.f03 @@ -0,0 +1,5 @@ +! PR fortran/78026 +select type (a) ! { dg-error "Selector shall be polymorphic in SELECT TYPE statement" } +end select +!$omp declare simd(b) ! { dg-error "Unexpected !.OMP DECLARE SIMD statement" } +end ! { dg-error "should refer to containing procedure" "" { target *-*-* } .-1 } Index: Fortran/gfortran/regression/gomp/pr78260-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78260-2.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-original" } + +! PR fortran/78260 + +module m + implicit none + integer :: n = 0 +contains + integer function f1() + !$omp target data map(f1) + !$omp target update to(f1) + f1 = 5 + !$omp end target data + end function f1 + + integer function f2() + dimension :: f2(1) + !$omp target data map(f2) + !$omp target update to(f2) + f2(1) = 5 + !$omp end target data + end function f2 + + integer function f3() result(res) + dimension :: res(1) + !$omp target data map(res) + !$omp target update to(res) + res(1) = 5 + !$omp end target data + end function f3 + + integer function f4() result(res) + allocatable :: res + dimension :: res(:) + !$omp target data map(res) + !$omp target update to(res) + res = [5] + !$omp end target data + end function f4 + + subroutine sub() + integer, allocatable :: arr(:) + !$omp target data map(arr) + !$omp target update to(arr) + arr = [5] + !$omp end target data + end subroutine sub +end module m + +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[len: D.\[0-9\]+ \\* 4\\\]\\) map\\(to:arr \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data \\\[len: D.\[0-9\]+ \\* 4\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[len: D.\[0-9\]+ \\* 4\\\]\\) map\\(to:\\*__result \\\[pointer set, len: ..\\\]\\) map\\(alloc:\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[pointer assign, bias: 0\\\]\\) map\\(alloc:__result \\\[pointer assign, bias: 0\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data \\\[len: D.\[0-9\]+ \\* 4\\\]\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:\\*__result.0\\) map\\(alloc:__result.0 \\\[pointer assign, bias: 0\\\]\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(\\*__result.0\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target data map\\(tofrom:__result_f1\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target update to\\(__result_f1\\)" 1 "original" } } + Index: Fortran/gfortran/regression/gomp/pr78260-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78260-3.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-original" } + +! PR fortran/78260 + +integer function f1() + implicit none + + f1 = 0 + + !$omp task depend(inout:f1) + !$omp end task + + !$omp task depend(inout:f1) + !$omp end task +end function f1 + +integer function f2() + implicit none + dimension :: f2(1) + + f2(1) = 0 + + !$omp task depend(inout:f2) + !$omp end task + + !$omp task depend(inout:f2) + !$omp end task +end function f2 + +integer function f3() result(res) + implicit none + dimension :: res(1) + + res(1) = 0 + + !$omp task depend(inout:res) + !$omp end task + + !$omp task depend(inout:res) + !$omp end task +end function f3 + +integer function f4() result(res) + implicit none + allocatable :: res + dimension :: res(:) + + res = [0] + + !$omp task depend(inout:res) + !$omp end task + + !$omp task depend(inout:res) + !$omp end task +end function f4 + +subroutine sub() + implicit none + integer, allocatable :: arr(:) + + arr = [3] + + !$omp task depend(inout:arr) + !$omp end task + + !$omp task depend(inout:arr) + !$omp end task +end subroutine sub + +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(inout:__result_f1\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(inout:\\*__result.0\\)" 4 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(inout:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) __result->data\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task depend\\(inout:\\*\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) arr.data\\)" 2 "original" } } Index: Fortran/gfortran/regression/gomp/pr78260.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78260.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! PR fortran/78260 + +module m + implicit none + integer :: n = 0 +contains + subroutine s + !$omp target data map(m) ! { dg-error "Object .m. is not a variable" } + !$omp target update to(m) ! { dg-error "Object .m. is not a variable" } + n = n + 1 + !$omp end target data + end subroutine s + subroutine s2 + !$omp target data map(s2) ! { dg-error "Object .s2. is not a variable" } + !$omp target update to(s2) ! { dg-error "Object .s2. is not a variable" } + n = n + 1 + !$omp end target data + end subroutine s2 + integer function f1() + !$omp target data map(f1) ! OK, f1 is also the result variable + !$omp target update to(f1) ! OK, f1 is also the result variable + f1 = 5 + !$omp end target data + end function f1 + integer function f2() result(res) + !$omp target data map(f2) ! { dg-error "Object .f2. is not a variable" } + !$omp target update to(f2) ! { dg-error "Object .f2. is not a variable" } + res = 5 + !$omp end target data + end function f2 +end module m Index: Fortran/gfortran/regression/gomp/pr78298.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78298.f90 @@ -0,0 +1,28 @@ +! PR fortran/78298 +! { dg-do compile } +! { dg-additional-options "-O2" } + +program pr78298 + integer :: i, j, n + n = 2 + !$omp parallel + !$omp do + do i = 1, n + !$omp parallel + !$omp do + do j = 1, n + call sub(i) + end do + !$omp end parallel + end do + !$omp end parallel + !call unused() +contains + subroutine sub(x) + integer :: x + end + subroutine unused() + i = 0 + j = 0 + end +end Index: Fortran/gfortran/regression/gomp/pr78299.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78299.f90 @@ -0,0 +1,55 @@ +! PR fortran/78299 +! { dg-do compile } +! { dg-additional-options "-fcheck=bounds" } + +program pr78299 + integer, parameter :: n = 8 + integer :: i, j + real :: x(n), y(n) + x = 1.0 + y = 2.0 + do j = 1, 9 + !$omp parallel workshare + !$omp parallel default(shared) + !$omp do + do i = 1, n + x(i) = x(i) * y(9) ! { dg-warning "is out of bounds" } + end do + !$omp end do + !$omp end parallel + !$omp end parallel workshare + end do + do j = 1, 9 + !$omp parallel workshare + !$omp parallel default(shared) + !$omp do schedule(static) + do i = 1, n + x(i) = x(i) * y(9) ! { dg-warning "is out of bounds" } + end do + !$omp end do + !$omp end parallel + !$omp end parallel workshare + end do + do j = 1, 9 + !$omp parallel workshare + !$omp parallel default(shared) + !$omp do schedule(static, 2) + do i = 1, n + x(i) = x(i) * y(9) ! { dg-warning "is out of bounds" } + end do + !$omp end do + !$omp end parallel + !$omp end parallel workshare + end do + do j = 1, 9 + !$omp parallel workshare + !$omp parallel default(shared) + !$omp do schedule(dynamic, 3) + do i = 1, n + x(i) = x(i) * y(9) ! { dg-warning "is out of bounds" } + end do + !$omp end do + !$omp end parallel + !$omp end parallel workshare + end do +end Index: Fortran/gfortran/regression/gomp/pr78866-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78866-1.f90 @@ -0,0 +1,19 @@ +! PR fortran/78866 +! { dg-do compile } + +subroutine pr78866(x) + integer :: x(*) +!$omp target map(x) ! { dg-error "Assumed size array" } + x(1) = 1 +!$omp end target +!$omp target data map(tofrom: x) ! { dg-error "Assumed size array" } +!$omp target update to(x) ! { dg-error "Assumed size array" } +!$omp target update from(x) ! { dg-error "Assumed size array" } +!$omp end target data +!$omp target map(x(:23)) ! { dg-bogus "Assumed size array" } + x(1) = 1 +!$omp end target +!$omp target map(x(:)) ! { dg-error "upper bound of assumed size array section" } + x(1) = 1 ! { dg-error "not a proper array section" "" { target *-*-* } .-1 } +!$omp end target +end Index: Fortran/gfortran/regression/gomp/pr78866-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr78866-2.f90 @@ -0,0 +1,9 @@ +! PR fortran/78866 +! { dg-do compile } + +subroutine pr78866(x) + integer :: x(*) +!$omp target ! { dg-error "implicit mapping of assumed size array" } + x(1) = 1 +!$omp end target +end Index: Fortran/gfortran/regression/gomp/pr79154-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr79154-1.f90 @@ -0,0 +1,37 @@ +! PR fortran/79154 +! { dg-do compile } + +pure real function foo (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +!$omp declare simd(foo) ! { dg-bogus "may not appear in PURE" } + real, intent(in) :: a, b + foo = a + b +end function foo +pure function bar (a, b) + real, intent(in) :: a(8), b(8) + real :: bar(8) + integer :: i +!$omp simd ! { dg-bogus "may not appear in PURE" } + do i = 1, 8 + bar(i) = a(i) + b(i) + end do +end function bar +pure real function baz (a, b) +!$omp declare target ! { dg-bogus "may not appear in PURE" } + real, intent(in) :: a, b + baz = a + b +end function baz +elemental real function fooe (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } +!$omp declare simd(fooe) ! { dg-bogus "may not appear in PURE" } + real, intent(in) :: a, b + fooe = a + b +end function fooe +elemental real function baze (a, b) +!$omp declare target ! { dg-bogus "may not appear in PURE" } + real, intent(in) :: a, b + baze = a + b +end function baze +elemental impure real function bazei (a, b) +!$omp declare target ! { dg-bogus "may not appear in PURE" } + real, intent(in) :: a, b + baze = a + b +end function bazei Index: Fortran/gfortran/regression/gomp/pr79154-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr79154-2.f90 @@ -0,0 +1,56 @@ +! PR fortran/79154 +! { dg-do compile } + +pure real function foo (a, b) + real, intent(in) :: a, b +!$omp taskwait ! { dg-error "may not appear in PURE" } + foo = a + b +end function foo +pure function bar (a, b) + real, intent(in) :: a(8), b(8) + real :: bar(8) + integer :: i +!$omp do simd ! { dg-error "may not appear in PURE" } + do i = 1, 8 + bar(i) = a(i) + b(i) + end do +end function bar +pure function baz (a, b) + real, intent(in) :: a(8), b(8) + real :: baz(8) + integer :: i +!$omp do ! { dg-error "may not appear in PURE" } + do i = 1, 8 + baz(i) = a(i) + b(i) + end do +!$omp end do ! { dg-error "may not appear in PURE" } +end function baz +pure real function baz2 (a, b) + real, intent(in) :: a, b +!$omp target map(from:baz2) ! { dg-error "may not appear in PURE" } + baz2 = a + b +!$omp end target ! { dg-error "may not appear in PURE" } +end function baz2 +! ELEMENTAL implies PURE +elemental real function fooe (a, b) + real, intent(in) :: a, b +!$omp taskyield ! { dg-error "may not appear in PURE" } + fooe = a + b +end function fooe +elemental real function baze (a, b) + real, intent(in) :: a, b +!$omp target map(from:baz) ! { dg-error "may not appear in PURE" } + baze = a + b +!$omp end target ! { dg-error "may not appear in PURE" } +end function baze +elemental impure real function fooei (a, b) + real, intent(in) :: a, b +!$omp taskyield ! { dg-bogus "may not appear in PURE" } + fooe = a + b +end function fooei +elemental impure real function bazei (a, b) + real, intent(in) :: a, b +!$omp target map(from:baz) ! { dg-bogus "may not appear in PURE" } + baze = a + b +!$omp end target ! { dg-bogus "may not appear in PURE" } +end function bazei Index: Fortran/gfortran/regression/gomp/pr79154-simd.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr79154-simd.f90 @@ -0,0 +1,16 @@ +! { dg-options "-fno-openmp -fopenmp-simd" } +! +pure subroutine bar(a) + integer, intent(in) :: a(:) + !$omp target enter data map(to:a) ! Ignored with -fopenmp-simd otherwise invalid in PURE +end + +pure subroutine foo(a,b) + integer, intent(out) :: a(5) + integer, intent(in) :: b(5) + !$omp target teams distribute simd ! { dg-error "may not appear in PURE procedures" } + do i=1, 5 + a(i) = b(i) + end do + !$omp end target teams distribute +end subroutine Index: Fortran/gfortran/regression/gomp/pr80918.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr80918.f90 @@ -0,0 +1,10 @@ +! PR fortran/80918 +! { dg-do compile } + +subroutine foo (a) + integer :: a(*) + !$omp task depend(inout:a) + !$omp end task + !$omp task depend(inout:a) + !$omp end task +end subroutine foo Index: Fortran/gfortran/regression/gomp/pr81887.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr81887.f90 @@ -0,0 +1,61 @@ +! PR c/81887 +! { dg-do compile } +! { dg-options "-fno-openmp -fopenmp-simd -fdump-tree-gimple" } +! { dg-final { scan-tree-dump-times "#pragma omp simd" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp ordered simd\[ \t]*\[\n\r]" 2 "gimple" } } +! { dg-final { scan-tree-dump-times "#pragma omp" 4 "gimple" } } + +subroutine f1 (x) + integer :: i, x(100) + !$omp simd + do i = 2, 101 + !$omp ordered simd + x(i / 2) = i + !$omp end ordered + end do +end subroutine + +subroutine f2 (x) + integer :: i, x(100) + !$omp parallel do simd ordered + do i = 2, 101 + !$omp ordered threads simd + x(i / 2) = i + !$omp end ordered + end do +end subroutine + +subroutine f3 (x) + integer :: i, x(100) + !$omp parallel do ordered + do i = 2, 101 + !$omp ordered + x(i / 2) = i + !$omp end ordered + end do +end subroutine + +subroutine f4 (x) + integer :: i, x(100) + !$omp parallel do ordered + do i = 2, 101 + !$omp ordered threads + x(i / 2) = i + !$omp end ordered + end do +end subroutine + +subroutine f5(x, n) + integer :: i, j, k, n, x(100,100,100) + !$omp parallel do ordered(3) + do i = 1, n + do j = 1, n + do k = 1, n + !$omp ordered depend(sink:i-8,j-2,k+2) depend(sink:i, j-1,k) depend(sink:i-4,j-3,k+6) depend(sink:i-6,j-4,k-6) + x(i, j, k) = i + j + k + !$omp ordered depend(source) + end do + end do + end do + !$omp end parallel do +end subroutine Index: Fortran/gfortran/regression/gomp/pr82568.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr82568.f90 @@ -0,0 +1,75 @@ +! PR fortran/82568 + +MODULE PR82568_MOD + INTEGER :: N +END MODULE +PROGRAM PR82568 + INTEGER :: I, L + !$OMP PARALLEL DO + DO I=1,2 + BLOCK + USE PR82568_MOD + INTEGER :: J + DO J=1,2 + PRINT*,I,J + END DO + DO K=1,2 + PRINT*,I,K + END DO + DO L=1,2 + PRINT*,I,L + END DO + DO N=1,2 + PRINT*,I,N + END DO + END BLOCK + DO M=1,2 + PRINT*,I,M + END DO + END DO + !$OMP TASK + DO I=1,2 + BLOCK + USE PR82568_MOD + INTEGER :: J + DO J=1,2 + PRINT*,I,J + END DO + DO K=1,2 + PRINT*,I,K + END DO + DO L=1,2 + PRINT*,I,L + END DO + DO N=1,2 + PRINT*,I,N + END DO + END BLOCK + DO M=1,2 + PRINT*,I,M + END DO + END DO + !$OMP END TASK + !$OMP TASKLOOP + DO I=1,2 + BLOCK + USE PR82568_MOD + INTEGER :: J + DO J=1,2 + PRINT*,I,J + END DO + DO K=1,2 + PRINT*,I,K + END DO + DO L=1,2 + PRINT*,I,L + END DO + DO N=1,2 + PRINT*,I,N + END DO + END BLOCK + DO M=1,2 + PRINT*,I,M + END DO + END DO +END PROGRAM PR82568 Index: Fortran/gfortran/regression/gomp/pr83977.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr83977.f90 @@ -0,0 +1,15 @@ +! PR middle-end/83977 +! { dg-do compile } + +integer function foo (a, b) ! { dg-warning "GCC does not currently support mixed size types for 'simd' functions" "" { target aarch64*-*-* } } + integer :: a, b +!$omp declare simd uniform(b) linear(ref(a):b) + a = a + 1 +! This function can't be called from simd loops, +! because it violates declare simd restrictions. +! We shouldn't ICE on it though, nor attempt to generate +! simd clones for the *omp_fn* functions. +!$omp parallel + call sub +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/pr84116.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr84116.f90 @@ -0,0 +1,12 @@ +! PR fortran/84116 +! { dg-do compile } + +program pr84116 + integer :: i, j + !$omp simd linear ((i)) ! { dg-error "Syntax error" } + do i = 1, 2 + end do + !$omp simd linear () ! { dg-error "Syntax error" } + do j = 1, 2 + end do +end Index: Fortran/gfortran/regression/gomp/pr85313.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr85313.f90 @@ -0,0 +1,25 @@ +! PR fortran/85313 +! { dg-do compile } + +!$omp do collapse(3) + do i = 1, 10 + do j = i, 20 + do k = 1, 2 + end do + end do + end do +!$omp do collapse(3) + do i = 1, 10 + do j = 1, 5 + do k = i, 20 + end do + end do + end do +!$omp do collapse(3) + do i = 1, 10 + do j = 1, 5 + do k = j, 20 + end do + end do + end do +end Index: Fortran/gfortran/regression/gomp/pr85703.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr85703.f90 @@ -0,0 +1,8 @@ +! PR fortran/85703 +! { dg-do compile } + +character function f() + !$omp single + !$omp end single + f = 'a' +end Index: Fortran/gfortran/regression/gomp/pr86470.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr86470.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! PR fortran/86470 - ICE with OpenMP, class(*) + +program p + implicit none + class(*), allocatable :: val +!$OMP PARALLEL private(val) + allocate(integer::val) + val = 1 + deallocate(val) +!$OMP END PARALLEL +end Index: Fortran/gfortran/regression/gomp/pr87752.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr87752.f90 @@ -0,0 +1,12 @@ +! PR fortran/87752 +! { dg-do compile } +! { dg-additional-options "-Ofast" } + +subroutine foo (n, u, v) + integer :: n + real, pointer :: u(:), v(:) + !$omp parallel do simd + do i = 1, n + u(:) = v(:) + end do +end Index: Fortran/gfortran/regression/gomp/pr88377.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr88377.f90 @@ -0,0 +1,15 @@ +! PR fortran/88377 +! { dg-do compile } + +program pr88377 + call s(3) +contains + subroutine s(n) + integer :: n + character(n), allocatable :: x + x = 'abc' + !$omp task + print *, x, (x == 'abc') + !$omp end task + end +end Index: Fortran/gfortran/regression/gomp/pr88933.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr88933.f90 @@ -0,0 +1,39 @@ +! PR ipa/88933 +! { dg-do compile } +! { dg-options "-O1 -fexceptions -fipa-cp -fnon-call-exceptions -fopenmp -fno-inline-functions-called-once" } + +!$omp parallel +!$omp single + call a +!$omp end single +!$omp end parallel +contains + subroutine b (c, d, e, f, g, h, i, j, k, m) + character (*) c + character d + integer, dimension (m) :: e + integer, dimension (m) :: f + character g + character h + real, dimension (:, :, :) :: i + double precision, dimension (:, :, :) :: j + integer, dimension (:, :, :) :: k + + integer, dimension (m) :: l +!$omp task firstprivate (k) firstprivate (l) + !$omp end task + c = '' + end + subroutine a + character c + character d + integer, dimension (7) :: e + integer, dimension (7) :: f + character g + character h + real, dimension (5, 6, 7) :: i + double precision, dimension (6, 6, 7) :: j + integer, dimension (5, 7, 6) :: k + call b (c, d, e, f, g, h, i, j, k, 7) + end +end Index: Fortran/gfortran/regression/gomp/pr89027.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr89027.f90 @@ -0,0 +1,22 @@ +! PR tree-optimization/89027 +! { dg-do compile } +! { dg-additional-options "-O2 -fexceptions -fno-tree-dce" } + +subroutine bar + integer :: a, b + a = 1 + b = 2 + call foo +contains + subroutine foo +!$omp simd linear(a:2) linear(b:1) + do a = 1, 20, 2 + b = b + 1 + end do +!$omp end simd + if (a /= 21 .or. b /= 12) STOP 1 +!$omp task depend(out : a) + a = a + 1 +!$omp end task + end subroutine foo +end subroutine bar Index: Fortran/gfortran/regression/gomp/pr89621.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr89621.f90 @@ -0,0 +1,18 @@ +! PR middle-end/89621 +! { dg-do compile } + +subroutine sub(str) + character(*), intent(in) :: str +end subroutine sub + +program pr89621 + implicit none + integer i + character(len=:), allocatable :: str + str = "test" + !$omp parallel do + do i = 1, 10 + call sub(str) + enddo + !$omp end parallel do +end program pr89621 Index: Fortran/gfortran/regression/gomp/pr89651.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr89651.f90 @@ -0,0 +1,21 @@ +! PR fortran/89651 +! { dg-do compile } +! { dg-additional-options "-Wuninitialized" } + +program pr89651 + integer :: n + real, allocatable :: t(:) + n = 10 + allocate (t(n), source = 0.0) +!$omp parallel firstprivate(t) + print *, sum (t) ! { dg-bogus "lbound' may be used uninitialized in this function" } + ! { dg-bogus "ubound' may be used uninitialized in this function" "" { target *-*-* } .-1 } + ! { dg-bogus "offset' may be used uninitialized in this function" "" { target *-*-* } .-2 } +!$omp end parallel +!$omp parallel private(t) + t = 0.0 + print *, sum (t) ! { dg-bogus "lbound' may be used uninitialized in this function" } + ! { dg-bogus "ubound' may be used uninitialized in this function" "" { target *-*-* } .-1 } + ! { dg-bogus "offset' may be used uninitialized in this function" "" { target *-*-* } .-2 } +!$omp end parallel +end program pr89651 Index: Fortran/gfortran/regression/gomp/pr92977.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr92977.f90 @@ -0,0 +1,15 @@ +! PR fortran/92977 +! { dg-do compile } +! { dg-additional-options "-O2" } + +program pr92977 + integer :: n = 1 + integer :: a +!$omp atomic write + a = f(n) - f(n) +contains + integer function f(x) + integer, intent(in) :: x + f = x + end +end Index: Fortran/gfortran/regression/gomp/pr93555.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr93555.f90 @@ -0,0 +1,11 @@ +! PR middle-end/93555 +! { dg-do compile } + +subroutine foo + !$omp declare simd(foo) + !$omp declare simd(foo) inbranch +end +subroutine bar + !$omp declare simd(bar) inbranch + !$omp declare simd(bar) +end Index: Fortran/gfortran/regression/gomp/pr94672.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr94672.f90 @@ -0,0 +1,127 @@ +! { dg-do compile } + +SUBROUTINE foo(n,array) + IMPLICIT NONE + INTEGER, INTENT (IN) :: n + REAL, INTENT(INOUT),OPTIONAL:: array(:) + INTEGER:: i + + !$OMP PARALLEL DO DEFAULT(none) SHARED(array,n) PRIVATE(i) + DO i = 1,n + IF (PRESENT(array)) THEN + array(i) = array(i) + i + ENDIF + ENDDO + !$OMP END PARALLEL DO +END SUBROUTINE foo + +subroutine s1 (array) + real, optional :: array(:) + !$omp parallel default(none) firstprivate (array) + if (present (array)) array(:) = 3 + !$omp end parallel +end subroutine + +subroutine s2 (array) + real, optional :: array(:) + !$omp parallel default(none) shared (array) + !$omp master + if (present (array)) array(:) = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s3 (array) + real, optional :: array(:) + !$omp parallel default(none) private (array) + if (present (array)) array(:) = 3 + !$omp end parallel +end subroutine + +subroutine s4 (arg) + real, optional :: arg + !$omp parallel default(none) firstprivate (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s5 (arg) + real, optional :: arg + !$omp parallel default(none) shared (arg) + !$omp master + if (present (arg)) arg = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s6 (arg) + real, optional :: arg + !$omp parallel default(none) private (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s7 (arg) + real, value, optional :: arg + !$omp parallel default(none) firstprivate (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s8 (arg) + real, value, optional :: arg + !$omp parallel default(none) shared (arg) + !$omp master + if (present (arg)) arg = 3 + !$omp end master + !$omp end parallel +end subroutine + +subroutine s9 (arg) + real, value, optional :: arg + !$omp parallel default(none) private (arg) + if (present (arg)) arg = 3 + !$omp end parallel +end subroutine + +subroutine s10 (arg) + real, optional :: arg(..) + !$omp parallel default(none) private (arg) + if (present (arg)) stop 10 + !$omp end parallel +end subroutine + +subroutine w1 (array) + real, optional :: array(:) + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } + if (.not.present (array)) stop 1 ! { dg-error "'array' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine + +subroutine w2 (array2) + real, optional :: array2(*) + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" "TODO" { xfail *-*-* } } + if (.not.present (array2)) stop 2 ! { dg-error "'array2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-* } } + !$omp end parallel +end subroutine + +subroutine w3 (arg) + real, optional :: arg + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } + if (.not.present (arg)) stop 3 ! { dg-error "'arg' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine + +subroutine w4 (arg2) + real, value, optional :: arg2 + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel" "TODO" { xfail *-*-* } } + if (.not.present (arg2)) stop 4 ! { dg-error "'arg2' not specified in enclosing 'parallel'" "TODO" { xfail *-*-*} } + !$omp end parallel +end subroutine + +subroutine w5 (array3) + real, optional :: array3(..) + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } + if (.not.present (array3)) stop 5 ! { dg-error "'array3' not specified in enclosing 'parallel'" } + !$omp end parallel +end subroutine Index: Fortran/gfortran/regression/gomp/pr95869.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr95869.f90 @@ -0,0 +1,18 @@ +! PR fortran/95869 +! { dg-do compile } + +program pr95869 + implicit none + + integer, parameter :: N = 100 + integer, parameter :: LIMIT = 60 + integer :: i, j + integer, dimension(N) :: a = (/ (i, i = 1,N) /) + do j = 1, N + !$omp target parallel if(j .lt. LIMIT) map(tofrom: a(1:N)) + do i = 1, N + a(i) = a(i) + 1 + end do + !$omp end target parallel + end do +end program Index: Fortran/gfortran/regression/gomp/pr99226.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99226.f90 @@ -0,0 +1,13 @@ +! PR fortran/99226 + +subroutine sub (n) + integer :: n, i + !$omp target ! { dg-error "construct with nested 'teams' construct contains directives outside of the 'teams' construct" } + !$omp teams distribute dist_schedule (static,n+4) + do i = 1, 8 + end do + !$omp teams distribute dist_schedule (static,n+4) + do i = 1, 8 + end do + !$omp end target +end Index: Fortran/gfortran/regression/gomp/pr99928-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-1.f90 @@ -0,0 +1,239 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: f00, f01, f02, f03, f04, f05, f06, f07, f08, f09 + integer :: f12, f13, f14, f15, f16, f17, f18, f19 + integer :: f20, f21, f22, f23, f24, f25, f26, f27, f28, f29 + +contains + +subroutine foo () + integer :: i + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*firstprivate\\(f00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f00\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f00\\)" "gimple" } } ! FIXME. + !$omp distribute parallel do firstprivate (f00) default(none) + do i = 1, 64 + f00 = f00 + 1 + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*firstprivate\\(f01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f01\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f01\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f01\\)" "gimple" } } + !$omp distribute parallel do simd firstprivate (f01) default(none) + do i = 1, 64 + f01 = f01 + 1 + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*firstprivate\\(f02\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f02\\)" "gimple" } } + !$omp distribute simd firstprivate (f02) + do i = 1, 64 + f02 = f02 + 1 + end do +end + +subroutine bar () + integer :: f10, f11 + integer :: i + f10 = 0; f11 = 0 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*firstprivate\\(f03\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f03\\)" "gimple" } } + !$omp do simd firstprivate (f03) + do i = 1, 64 + f03 = f03 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(f04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(f04\\)" "gimple" } } + !$omp master taskloop firstprivate (f04) default(none) + do i = 1, 64 + f04 = f04 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(f05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(f05\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f05\\)" "gimple" } } + !$omp master taskloop simd firstprivate (f05) default(none) + do i = 1, 64 + f05 = f05 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f06\\)" "gimple" } } ! FIXME. + !$omp parallel do firstprivate (f06) default(none) + do i = 1, 64 + f06 = f06 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f07\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f07\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f07\\)" "gimple" } } + !$omp parallel do simd firstprivate (f07) default(none) + do i = 1, 64 + f07 = f07 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f08\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f08\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f08\\)" "gimple" } } + !$omp parallel loop firstprivate (f08) default(none) + do i = 1, 64 + f08 = f08 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f09\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(f09\\)" "gimple" } } + !$omp parallel master firstprivate (f09) default(none) + f09 = f09 + 1 + !$omp end parallel master + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(f10\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(f10\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(f10\\)" "gimple" } } + !$omp parallel master taskloop firstprivate (f10) default(none) + do i = 1, 64 + f10 = f10 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(f11\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(f11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(f11\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f11\\)" "gimple" } } + !$omp parallel master taskloop simd firstprivate (f11) default(none) + do i = 1, 64 + f11 = f11 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f12\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp sections\[^\n\r]*firstprivate\\(f12\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp section \[^\n\r]*firstprivate\\(f12\\)" "gimple" } } + !$omp parallel sections firstprivate (f12) default(none) + f12 = f12 + 1 + !$omp section + f12 = f12 + 1 + !$omp end parallel sections + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f13\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f13\\)" "gimple" } } + !$omp target parallel firstprivate (f13) default(none) defaultmap(none) + f13 = f13 + 1 + !$omp end target parallel + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f14\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f14\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f14\\)" "gimple" } } ! FIXME. + !$omp target parallel do firstprivate (f14) default(none) defaultmap(none) + do i = 1, 64 + f14 = f14 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f15\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f15\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f15\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f15\\)" "gimple" } } + !$omp target parallel do simd firstprivate (f15) default(none) defaultmap(none) + do i = 1, 64 + f15 = f15 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f16\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f16\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f16\\)" "gimple" } } + !$omp target parallel loop firstprivate (f16) default(none) defaultmap(none) + do i = 1, 64 + f16 = f16 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f17\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f17\\)" "gimple" } } + !$omp target teams firstprivate (f17) default(none) defaultmap(none) + f17 = f17 + 1 + !$omp end target teams + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f18\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f18\\)" "gimple" } } ! FIXME: This should be on distribute instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f18\\)" "gimple" } } ! FIXME. + !$omp target teams distribute firstprivate (f18) default(none) defaultmap(none) + do i = 1, 64 + f18 = f18 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f19\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f19\\)" "gimple" } } ! FIXME: This should be on distribute instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f19\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f19\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f19\\)" "gimple" } } ! FIXME. + !$omp target teams distribute parallel do firstprivate (f19) default(none) defaultmap(none) + do i = 1, 64 + f19 = f19 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f20\\)" "gimple" } } + !$omp target teams distribute parallel do simd firstprivate (f20) default(none) defaultmap(none) + do i = 1, 64 + f20 = f20 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f21\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f21\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f21\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f21\\)" "gimple" } } + !$omp target teams distribute simd firstprivate (f21) default(none) defaultmap(none) + do i = 1, 64 + f21 = f21 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f22\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(f22\\)" "gimple" } } ! NOTE: This is an implementation detail. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f22\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f22\\)" "gimple" } } + !$omp target teams loop firstprivate (f22) default(none) defaultmap(none) + do i = 1, 64 + f22 = f22 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*firstprivate\\(f23\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f23\\)" "gimple" } } + !$omp target simd firstprivate (f23) defaultmap(none) + do i = 1, 64 + f23 = f23 + 1 + end do + !$omp end target simd + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(f24\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f24\\)" "gimple" } } + !$omp taskloop simd firstprivate (f24) default(none) + do i = 1, 64 + f24 = f24 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f25\\)" "gimple" } } ! FIXME: This should be on distribute instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f25\\)" "gimple" } } ! FIXME. + !$omp teams distribute firstprivate (f25) default(none) + do i = 1, 64 + f25 = f25 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f26\\)" "gimple" } } ! FIXME: This should be on distribute instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f26\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f26\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f26\\)" "gimple" } } ! FIXME. + !$omp teams distribute parallel do firstprivate (f26) default(none) + do i = 1, 64 + f26 = f26 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f27\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f27\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(f27\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f27\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f27\\)" "gimple" } } + !$omp teams distribute parallel do simd firstprivate (f27) default(none) + do i = 1, 64 + f27 = f27 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f28\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f28\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f28\\)" "gimple" } } + !$omp teams distribute simd firstprivate (f28) default(none) + do i = 1, 64 + f28 = f28 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*firstprivate\\(f29\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*firstprivate\\(f29\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(f29\\)" "gimple" } } ! NOTE: This is an implementation detail. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(f29\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(f29\\)" "gimple" } } + !$omp teams loop firstprivate (f29) default(none) + do i = 1, 64 + f29 = f29 + 1 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-11.f90 @@ -0,0 +1,35 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: r00, r01, r02 + +contains + +subroutine bar () + integer :: i + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*in_reduction\\(\\+:r00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*in_reduction\\(\\+:r00\\)" "gimple" } } + !$omp master taskloop in_reduction(+:r00) + do i = 1, 64 + r00 = r00 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*in_reduction\\(\\+:r01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*in_reduction\\(\\+:r01\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*in_reduction\\(\\+:r01\\)" "gimple" } } + !$omp master taskloop simd in_reduction(+:r01) + do i = 1, 64 + r01 = r01 + 1 + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*in_reduction\\(\\+:r02\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*in_reduction\\(\\+:r02\\)" "gimple" } } + !$omp taskloop simd in_reduction(+:r02) + do i = 1, 64 + r02 = r02 + 1 + end do + ! FIXME: We don't support in_reduction clause on target yet, once we do, should + ! add testcase coverage for all combined/composite constructs with target as leaf construct. +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-2.f90 @@ -0,0 +1,233 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: l00, l01, l02, l03, l04, l05, l06, l07 + integer :: l10, l11, l12, l13, l14, l15, l16, l17, l18 + +contains + +subroutine foo () + integer :: i + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } ! FIXME. + !$omp distribute parallel do lastprivate (l00) default(none) + do i = 1, 64 + l00 = i + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + !$omp distribute parallel do simd lastprivate (l01) default(none) + do i = 1, 64 + l01 = i + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l02\\)" "gimple" } } + !$omp distribute simd lastprivate (l02) + do i = 1, 64 + l02 = i + end do +end + +subroutine bar () + integer :: j00, j01, j02, j03 + integer :: l08, l09, l19, l20, l21, l22 + integer :: i + l08 = 0; l09 = 0; l19 = 0; l20 = 0; l21 = 0; l22 = 0 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } + !$omp do simd lastprivate (l03) + do i = 1, 64 + l03 = i + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(l04\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } + !$omp master taskloop lastprivate (l04) default(none) + do i = 1, 64 + l04 = i + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(l05\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l05\\)" "gimple" } } + !$omp master taskloop simd lastprivate (l05) default(none) + do i = 1, 64 + l05 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } ! FIXME. + !$omp parallel do lastprivate (l06) default(none) + do i = 1, 64 + l06 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l07\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l07\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l07\\)" "gimple" } } + !$omp parallel do simd lastprivate (l07) default(none) + do i = 1, 64 + l07 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp parallel loop lastprivate (j00) default(none) + do j00 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l08\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(l08\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l08\\)" "gimple" } } + !$omp parallel master taskloop lastprivate (l08) default(none) + do i = 1, 64 + l08 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l09\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(l09\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } + !$omp parallel master taskloop simd lastprivate (l09) default(none) + do i = 1, 64 + l09 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l10\\)" "gimple" } } ! FIXME: This should be on sections instead. + ! { dg-final { scan-tree-dump-not "omp sections\[^\n\r]*lastprivate\\(l10\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp section \[^\n\r]*lastprivate\\(l10\\)" "gimple" } } + !$omp parallel sections lastprivate (l10) default(none) + l10 = 1 + !$omp section + l10 = 2 + !$omp end parallel sections + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l11" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l11\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l11\\)" "gimple" } } ! FIXME. + !$omp target parallel do lastprivate (l11) default(none) defaultmap(none) + do i = 1, 64 + l11 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l12" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l12\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l12\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l12\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l12\\)" "gimple" } } + !$omp target parallel do simd lastprivate (l12) default(none) defaultmap(none) + do i = 1, 64 + l12 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j01" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j01\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(j01\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp target parallel loop lastprivate (j01) default(none) defaultmap(none) + do j01 = 0, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l13" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l13\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l13\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l13\\)" "gimple" } } + !$omp target teams distribute lastprivate (l13) default(none) defaultmap(none) + do i = 1, 64 + l13 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l14" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l14\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l14\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l14\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l14\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l14\\)" "gimple" } } ! FIXME. + !$omp target teams distribute parallel do lastprivate (l14) default(none) defaultmap(none) + do i = 1, 64 + l14 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l15" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l15\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l15\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l15\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l15\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l15\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l15\\)" "gimple" } } + !$omp target teams distribute parallel do simd lastprivate (l15) default(none) defaultmap(none) + do i = 1, 64 + l15 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l16" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l16\\)" "gimple" } } + !$omp target teams distribute simd lastprivate (l16) default(none) defaultmap(none) + do i = 1, 64 + l16 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j02" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j02\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j02\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j02\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(j02\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp target teams loop lastprivate (j02) default(none) defaultmap(none) + do j02 = 0, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l17" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l17\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l17\\)" "gimple" } } + !$omp target simd lastprivate (l17) defaultmap(none) + do i = 1, 64 + l17 = i + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(l18\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l18\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l18\\)" "gimple" } } + !$omp taskloop simd lastprivate (l18) default(none) + do i = 1, 64 + l18 = i + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l19\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l19\\)" "gimple" } } + !$omp teams distribute lastprivate (l19) default(none) + do i = 1, 64 + l19 = i + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l20\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l20\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l20\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l20\\)" "gimple" } } ! FIXME. + !$omp teams distribute parallel do lastprivate (l20) default(none) + do i = 1, 64 + l20 = i + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l21\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l21\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l21\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l21\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l21\\)" "gimple" } } + !$omp teams distribute parallel do simd lastprivate (l21) default(none) + do i = 1, 64 + l21 = i + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(l22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(l22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l22\\)" "gimple" } } + !$omp teams distribute simd lastprivate (l22) default(none) + do i = 1, 64 + l22 = i + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp teams loop lastprivate (j03) default(none) + do j03 = 1, 64 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-3.f90 @@ -0,0 +1,139 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: l00, l01, l02, l03, l04, l07, l08, l09 + integer :: l10, l11 + +contains + +subroutine bar () + integer :: l05, l06 + integer :: i + l05 = 0; l06 = 0 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*firstprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } + !$omp do simd firstprivate (l00) lastprivate (l00) + do i = 1, 64 + l00 = i + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + !$omp master taskloop firstprivate (l01) lastprivate (l01) default(none) + do i = 1, 64 + l01 = i + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l02\\)" "gimple" } } + !$omp master taskloop simd firstprivate (l02) lastprivate (l02) default(none) + do i = 1, 64 + l02 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l03\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l03\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } ! FIXME. + !$omp parallel do firstprivate (l03) lastprivate (l03) default(none) + do i = 1, 64 + l03 = i + end do + !$omp end parallel do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l04\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l04\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } + !$omp parallel do simd firstprivate (l04) lastprivate (l04) default(none) + do i = 1, 64 + l04 = i + end do + !$omp end parallel do simd + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l05\\)" "gimple" } } + !$omp parallel master taskloop firstprivate (l05) lastprivate (l05) default(none) + do i = 1, 64 + l05 = i + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } + !$omp parallel master taskloop simd firstprivate (l06) lastprivate (l06) default(none) + do i = 1, 64 + l06 = i + end do + !$omp end parallel master taskloop simd + ! FIXME: OpenMP 5.0/5.1 broken here, conceptually it should be shared on parallel and + ! firstprivate+lastprivate on sections, in GCC implementation we put firstprivate+lastprivate + ! on parallel for historic reasons, but OpenMP 5.0/5.1 mistakenly say firstprivate + ! should be on parallel and lastprivate on sections. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp sections\[^\n\r]*firstprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp sections\[^\n\r]*lastprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp section \[^\n\r]*firstprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp section \[^\n\r]*lastprivate\\(l07\\)" "gimple" } } + !$omp parallel sections firstprivate (l07) lastprivate (l07) default(none) + l07 = 1 + !$omp section + l07 = 2 + !$omp end parallel sections + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l08" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l08\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l08\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l08\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l08\\)" "gimple" } } ! FIXME. + !$omp target parallel do firstprivate (l08) lastprivate (l08) default(none) defaultmap(none) + do i = 1, 64 + l08 = i + end do + !$omp end target parallel do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l09" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l09\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l09\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l09\\)" "gimple" } } + !$omp target parallel do simd firstprivate (l09) lastprivate (l09) default(none) defaultmap(none) + do i = 1, 64 + l09 = i + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l10" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l10\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l10\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l10\\)" "gimple" } } + !$omp target simd firstprivate (l10) lastprivate (l10) defaultmap(none) + do i = 1, 64 + l10 = i + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l11\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp simd\[^\n\r]*firstprivate\\(l11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*lastprivate\\(l11\\)" "gimple" } } + !$omp taskloop simd firstprivate (l11) lastprivate (l11) default(none) + do i = 1, 64 + l11 = i + end do + !$omp end taskloop simd +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-4.f90 @@ -0,0 +1,90 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: l00, l01, l05, l06, l07, l08 + +contains + +subroutine bar () + integer :: l02, l03, l04 + integer :: i + l02 = 0; l03 = 0; l04 = 0 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*firstprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(l00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l00:1\\)" "gimple" } } + !$omp do simd linear (l00) + do i = 1, 64 + l00 = l00 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l01:1\\)" "gimple" } } + !$omp master taskloop simd linear (l01) default(none) + do i = 1, 64 + l01 = l01 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*linear\\(l02:1\\)" "gimple" } } + !$omp parallel do linear (l02) default(none) + do i = 1, 64 + l02 = l02 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l03\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l03\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l03\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l03:1\\)" "gimple" } } + !$omp parallel do simd linear (l03) default(none) + do i = 1, 64 + l03 = l03 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*firstprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l04:1\\)" "gimple" } } + !$omp parallel master taskloop simd linear (l04) default(none) + do i = 1, 64 + l04 = l04 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l05" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(l05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*linear\\(l05:1\\)" "gimple" } } + !$omp target parallel do linear (l05) default(none) defaultmap(none) + do i = 1, 64 + l05 = l05 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l06" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*firstprivate\\(l06\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(l06\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l06:1\\)" "gimple" } } + !$omp target parallel do simd linear (l06) default(none) defaultmap(none) + do i = 1, 64 + l06 = l06 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:l07" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(l07\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l07:1\\)" "gimple" } } + !$omp target simd linear (l07) defaultmap(none) + do i = 1, 64 + l07 = l07 + 1 + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*firstprivate\\(l08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(l08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(l08:1\\)" "gimple" } } + !$omp taskloop simd linear (l08) default(none) + do i = 1, 64 + l08 = l08 + 1 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-5.f90 @@ -0,0 +1,108 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: j00, j01, j02, j03, j04, j06, j07, j08, j09 + integer :: j10 + +contains + +subroutine foo () + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j00:1\\)" "gimple" } } + !$omp distribute parallel do simd linear (j00) default(none) + do j00 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j01:1\\)" "gimple" } } + !$omp distribute simd linear (j01) + do j01 = 1, 64 + end do +end + +subroutine bar () + integer :: j05, j11, j12 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j02:1\\)" "gimple" } } + !$omp do simd linear (j02) + do j02 = 1, 64 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j03:1\\)" "gimple" } } + !$omp master taskloop simd linear (j03) default(none) + do j03 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j04\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j04\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j04:1\\)" "gimple" } } + !$omp parallel do simd linear (j04) default(none) + do j04 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j05\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j05:1\\)" "gimple" } } + !$omp parallel master taskloop simd linear (j05) default(none) + do j05 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j06" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j06\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j06:1\\)" "gimple" } } + !$omp target parallel do simd linear (j06) default(none) defaultmap(none) + do j06 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j07" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j07\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j07:1\\)" "gimple" } } + !$omp target simd linear (j07) defaultmap(none) + do j07 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j08" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j08:1\\)" "gimple" } } + !$omp target teams distribute parallel do simd linear (j08) default(none) defaultmap(none) + do j08 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j09" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j09:1\\)" "gimple" } } + !$omp target teams distribute simd linear (j09) default(none) defaultmap(none) + do j09 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j10\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j10\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j10:1\\)" "gimple" } } + !$omp taskloop simd linear (j10) default(none) + do j10 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j11:1\\)" "gimple" } } + !$omp teams distribute parallel do simd linear (j11) default(none) + do j11 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j12\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j12\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j12:1\\)" "gimple" } } + !$omp teams distribute simd linear (j12) default(none) + do j12 = 1, 64 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-6.f90 @@ -0,0 +1,108 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: j00, j01, j02, j03, j04, j06, j07, j08, j09 + integer :: j10 + +contains + +subroutine foo () + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j00\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j00:1\\)" "gimple" } } + !$omp distribute parallel do simd default(none) + do j00 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j01:1\\)" "gimple" } } + !$omp distribute simd + do j01 = 1, 64 + end do +end + +subroutine bar () + integer :: j05, j11, j12; + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*lastprivate\\(j02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j02:1\\)" "gimple" } } + !$omp do simd + do j02 = 1, 64 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j03\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j03:1\\)" "gimple" } } + !$omp master taskloop simd default(none) + do j03 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j04\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j04\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j04:1\\)" "gimple" } } + !$omp parallel do simd default(none) + do j04 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*lastprivate\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j05\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j05:1\\)" "gimple" } } + !$omp parallel master taskloop simd default(none) + do j05 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j06" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j06\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j06\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j06:1\\)" "gimple" } } + !$omp target parallel do simd default(none) defaultmap(none) + do j06 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j07" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j07\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j07:1\\)" "gimple" } } + !$omp target simd defaultmap(none) + do j07 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j08" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j08\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j08:1\\)" "gimple" } } + !$omp target teams distribute parallel do simd default(none) defaultmap(none) + do j08 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:j09" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j09\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j09:1\\)" "gimple" } } + !$omp target teams distribute simd default(none) defaultmap(none) + do j09 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*shared\\(j10\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*lastprivate\\(j10\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j10:1\\)" "gimple" } } + !$omp taskloop simd default(none) + do j10 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*lastprivate\\(j11\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j11:1\\)" "gimple" } } + !$omp teams distribute parallel do simd default(none) + do j11 = 1, 64 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(j12\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*lastprivate\\(j12\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*linear\\(j12:1\\)" "gimple" } } + !$omp teams distribute simd default(none) + do j12 = 1, 64 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/pr99928-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/pr99928-8.f90 @@ -0,0 +1,253 @@ +! PR middle-end/99928 +! { dg-do compile } +! { dg-options "-fopenmp -fdump-tree-gimple" } + +module m + implicit none + integer :: r00, r01, r02, r03, r04, r05 + integer :: r13, r14, r15, r16, r17, r18, r19 + integer :: r20, r21, r22, r23, r24 + +contains + +subroutine foo () + integer :: i + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r00\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r00\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r00\\)" "gimple" } } ! FIXME. + !$omp distribute parallel do reduction(+:r00) default(none) + do i = 1, 64 + r00 = r00 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r01\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r01\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r01\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r01\\)" "gimple" } } + !$omp distribute parallel do simd reduction(+:r01) default(none) + do i = 1, 64 + r01 = r01 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r02\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r02\\)" "gimple" } } + !$omp distribute simd reduction(+:r02) + do i = 1, 64 + r02 = r02 + 1 + end do +end + +subroutine bar () + integer :: r06, r07, r08, r09 + integer :: r10, r11, r12 + integer :: r25, r26, r27, r28, r29 + integer :: i + r06 = 0; r07 = 0; r08 = 0; r09 = 0 + r10 = 0; r11 = 0; r12 = 0 + r25 = 0; r26 = 0; r27 = 0; r28 = 0; r29 = 0 + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*reduction\\(\\+:r03\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r03\\)" "gimple" } } + !$omp do simd reduction(+:r03) + do i = 1, 64 + r03 = r03 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*reduction\\(\\+:r04\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*reduction\\(\\+:r04\\)" "gimple" } } + !$omp master taskloop reduction(+:r04) default(none) + do i = 1, 64 + r04 = r04 + 1 + end do + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*reduction\\(\\+:r05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*reduction\\(\\+:r05\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r05\\)" "gimple" } } + !$omp master taskloop simd reduction(+:r05) default(none) + do i = 1, 64 + r05 = r05 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r06\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r06\\)" "gimple" } } ! FIXME. + !$omp parallel do reduction(+:r06) default(none) + do i = 1, 64 + r06 = r06 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r07\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r07\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r07\\)" "gimple" } } + !$omp parallel do simd reduction(+:r07) default(none) + do i = 1, 64 + r07 = r07 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r08\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*reduction\\(\\+:r08\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r08\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp parallel loop reduction(+:r08) default(none) + do i = 1, 64 + r08 = r08 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r09\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*reduction\\(\\+:r09\\)" "gimple" } } + !$omp parallel master reduction(+:r09) default(none) + r09 = r09 + 1 + !$omp end parallel master + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r10\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*reduction\\(\\+:r10\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*reduction\\(\\+:r10\\)" "gimple" } } + !$omp parallel master taskloop reduction(+:r10) default(none) + do i = 1, 64 + r10 = r10 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r11\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp master\[^\n\r]*reduction\\(\\+:r11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*reduction\\(\\+:r11\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r11\\)" "gimple" } } + !$omp parallel master taskloop simd reduction(+:r11) default(none) + do i = 1, 64 + r11 = r11 + 1 + end do + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r12\\)" "gimple" } } ! FIXME: This should be on sections instead. + ! { dg-final { scan-tree-dump-not "omp sections\[^\n\r]*reduction\\(\\+:r12\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump-not "omp section \[^\n\r]*reduction\\(\\+:r12\\)" "gimple" } } + !$omp parallel sections reduction(+:r12) default(none) + r12 = r12 + 1 + !$omp section + r12 = r12 + 1 + !$omp end parallel sections + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r13" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r13\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r13\\)" "gimple" } } + !$omp target parallel reduction(+:r13) default(none) defaultmap(none) + r13 = r13 + 1 + !$omp end target parallel + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r14" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r14\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r14\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r14\\)" "gimple" } } ! FIXME. + !$omp target parallel do reduction(+:r14) default(none) defaultmap(none) + do i = 1, 64 + r14 = r14 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r15" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r15\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r15\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r15\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r15\\)" "gimple" } } + !$omp target parallel do simd reduction(+:r15) default(none) defaultmap(none) + do i = 1, 64 + r15 = r15 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r16" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r16\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*reduction\\(\\+:r16\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r16\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp target parallel loop reduction(+:r16) default(none) defaultmap(none) + do i = 1, 64 + r16 = r16 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r17" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r17\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r17\\)" "gimple" } } + !$omp target teams reduction(+:r17) default(none) defaultmap(none) + r17 = r17 + 1 + !$omp end target teams + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r18" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r18\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r18\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r18\\)" "gimple" } } + !$omp target teams distribute reduction(+:r18) default(none) defaultmap(none) + do i = 1, 64 + r18 = r18 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r19" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r19\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r19\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r19\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r19\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r19\\)" "gimple" } } ! FIXME. + !$omp target teams distribute parallel do reduction(+:r19) default(none) defaultmap(none) + do i = 1, 64 + r19 = r19 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r20" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r20\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r20\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r20\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r20\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r20\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r20\\)" "gimple" } } + !$omp target teams distribute parallel do simd reduction(+:r20) default(none) defaultmap(none) + do i = 1, 64 + r20 = r20 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r21" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r21\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r21\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r21\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r21\\)" "gimple" } } + !$omp target teams distribute simd reduction(+:r21) default(none) defaultmap(none) + do i = 1, 64 + r21 = r21 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r22" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(r22\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*reduction\\(\\+:r22\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r22\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*reduction\\(\\+:r22\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r22\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp target teams loop reduction(+:r22) default(none) defaultmap(none) + do i = 1, 64 + r22 = r22 + 1 + end do + ! { dg-final { scan-tree-dump "omp target\[^\n\r]*map\\(tofrom:r23" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp target\[^\n\r]*firstprivate\\(r23\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r23\\)" "gimple" } } + !$omp target simd reduction(+:r23) defaultmap(none) + do i = 1, 64 + r23 = r23 + 1 + end do + ! { dg-final { scan-tree-dump "omp taskloop\[^\n\r]*reduction\\(\\+:r24\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r24\\)" "gimple" } } + !$omp taskloop simd reduction(+:r24) default(none) + do i = 1, 64 + r24 = r24 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r25\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r25\\)" "gimple" } } + !$omp teams distribute reduction(+:r25) default(none) + do i = 1, 64 + r25 = r25 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r26\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r26\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r26\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r26\\)" "gimple" } } ! FIXME. + !$omp teams distribute parallel do reduction(+:r26) default(none) + do i = 1, 64 + r26 = r26 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r27\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r27\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*reduction\\(\\+:r27\\)" "gimple" } } ! FIXME: This should be on for instead. + ! { dg-final { scan-tree-dump-not "omp for\[^\n\r]*reduction\\(\\+:r27\\)" "gimple" } } ! FIXME. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r27\\)" "gimple" } } + !$omp teams distribute parallel do simd reduction(+:r27) default(none) + do i = 1, 64 + r27 = r27 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*reduction\\(\\+:r28\\)" "gimple" } } + ! { dg-final { scan-tree-dump-not "omp distribute\[^\n\r]*reduction\\(\\+:r28\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r28\\)" "gimple" } } + !$omp teams distribute simd reduction(+:r28) default(none) + do i = 1, 64 + r28 = r28 + 1 + end do + ! { dg-final { scan-tree-dump "omp teams\[^\n\r]*shared\\(r29\\)" "gimple" } } + ! { dg-final { scan-tree-dump "omp distribute\[^\n\r]*reduction\\(\\+:r29\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp parallel\[^\n\r]*shared\\(r29\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp for\[^\n\r]*reduction\\(\\+:r29\\)" "gimple" } } ! NOTE: This is implementation detail. + ! { dg-final { scan-tree-dump "omp simd\[^\n\r]*reduction\\(\\+:r29\\)" "gimple" } } ! NOTE: This is implementation detail. + !$omp teams loop reduction(+:r29) default(none) + do i = 1, 64 + r29 = r29 + 1 + end do +end +end module m Index: Fortran/gfortran/regression/gomp/proc_ptr_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/proc_ptr_1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! PR 46271: [F03] OpenMP default(none) and procedure pointers +! +! Contributed by Marco Restelli + +program test + implicit none + integer :: i + real :: s(1000) + procedure(f), pointer :: pf + + pf => f + + !$omp parallel do schedule(static) private(i) shared(s,pf) default(none) + do i=1,1000 + call pf(real(i),s(i)) + enddo + !$omp end parallel do + + write(*,*) 'Sum ',sum(s) +contains + pure subroutine f(x,y) + real, intent(in) :: x + real, intent(out) :: y + y = sin(x)*cos(x) + end subroutine +end Index: Fortran/gfortran/regression/gomp/proc_ptr_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/proc_ptr_2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } + procedure(foo), pointer :: ptr + integer :: i + ptr => foo +!$omp do reduction (+ : ptr) ! { dg-error "Procedure pointer|not found" } + do i = 1, 10 + end do +!$omp simd linear (ptr) ! { dg-error "must be INTEGER" } + do i = 1, 10 + end do +contains + subroutine foo + end subroutine +end Index: Fortran/gfortran/regression/gomp/reduction-task-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction-task-1.f90 @@ -0,0 +1,112 @@ +module m + implicit none + integer v + interface + subroutine foo(x) + integer, value :: x + end + end interface +contains + +subroutine bar + integer i + !$omp do reduction (task, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp sections reduction (task, +: v) + call foo (-2) + !$omp section + call foo (-3) + !$omp end sections + !$omp parallel reduction (task, +: v) + call foo (-1) + !$omp end parallel + !$omp parallel do reduction (task, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp end parallel do + !$omp parallel sections reduction (task, +: v) + call foo (-2) + !$omp section + call foo (-3) + !$omp end parallel sections + !$omp teams distribute parallel do reduction (task, +: v) ! { dg-bogus "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" "PR101948" { xfail *-*-* } } + do i = 0, 63 + call foo (i) + end do + !$omp end teams distribute parallel do + !$omp do reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp sections reduction (default, +: v) + call foo (-2) + !$omp section + call foo (-3) + !$omp end sections + !$omp parallel reduction (default, +: v) + call foo (-1) + !$omp end parallel + !$omp parallel do reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp end parallel do + !$omp parallel sections reduction (default, +: v) + call foo (-2) + !$omp section + call foo (-3) + !$omp end parallel sections + !$omp teams distribute parallel do reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp end teams distribute parallel do + !$omp do reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp end do nowait + !$omp sections reduction (default, +: v) + call foo (-2) + !$omp section + call foo (-3) + !$omp end sections nowait + !$omp simd reduction (default, +: v) + do i = 0, 63 + v = v + 1 + end do + !$omp do simd reduction (default, +: v) + do i = 0, 63 + v = v + 1 + end do + !$omp parallel do simd reduction (default, +: v) + do i = 0, 63 + v = v + 1 + end do + !$omp end parallel do simd + !$omp teams distribute parallel do simd reduction (default, +: v) + do i = 0, 63 + v = v + 1 + end do + !$omp end teams distribute parallel do simd + !$omp taskloop reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp taskloop simd reduction (default, +: v) + do i = 0, 63 + v = v + 1 + end do + !$omp teams reduction (default, +: v) + call foo (i) + !$omp end teams + !$omp teams distribute reduction (default, +: v) + do i = 0, 63 + call foo (i) + end do + !$omp end teams distribute +end +end Index: Fortran/gfortran/regression/gomp/reduction-task-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction-task-2.f90 @@ -0,0 +1,45 @@ +module m + integer :: v + interface + subroutine foo(i) + integer :: i + end + end interface +end + +subroutine bar + use m + implicit none + integer :: i + !$omp do reduction (task, +: v) ! { dg-error "'task' reduction modifier on a construct with a 'nowait' clause" } + do i = 0, 63 + call foo (i) + end do + !$omp end do nowait + !$omp sections reduction (task, +: v) ! { dg-error "'task' reduction modifier on a construct with a 'nowait' clause" } + call foo (-2) + !$omp section + call foo (-3) + !$omp end sections nowait + !$omp scope reduction (task, +: v) ! { dg-error "'task' reduction modifier on a construct with a 'nowait' clause" } + call foo (-4) + !$omp end scope nowait + !$omp simd reduction (task, +: v) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } + do i = 0, 63 + v = v + 1 + end do + !$omp do simd reduction (task, +: v) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } + do i = 0, 63 + v = v + 1 + end do + !$omp parallel do simd reduction (task, +: v) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } + do i = 0, 63 + v = v + 1 + end do + !$omp end parallel do simd + !$omp teams distribute parallel do simd reduction (task, +: v) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } + do i = 0, 63 + v = v + 1 + end do + !$omp end teams distribute parallel do simd +end Index: Fortran/gfortran/regression/gomp/reduction-task-2a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction-task-2a.f90 @@ -0,0 +1,30 @@ +module m + integer :: v + interface + subroutine foo(i) + integer :: i + end + end interface +end + +subroutine bar + use m + implicit none + integer :: i + !$omp taskloop reduction (task, +: v) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } + do i = 0, 63 + call foo (i) + end do + !$omp taskloop simd reduction (task, +: v) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } + do i = 0, 63 + v = v + 1 + end do + !$omp teams reduction (task, +: v) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } + call foo (i) + !$omp end teams + !$omp teams distribute reduction (task, +: v) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } + do i = 0, 63 + call foo (i) + end do + !$omp end teams distribute +end Index: Fortran/gfortran/regression/gomp/reduction-task-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction-task-3.f90 @@ -0,0 +1,15 @@ +! Fortran testcase of reduction-task-3.f90 ( PR c/91149 ) + +module m + integer :: r +end + +subroutine foo + use m + !$omp parallel reduction(task, +: r) + r = r + 1 + !$omp end parallel + !$omp target parallel reduction(task, +: r) + r = r + 1 + !$omp end target parallel +end Index: Fortran/gfortran/regression/gomp/reduction1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction1.f90 @@ -0,0 +1,132 @@ +! { dg-do compile } +! { dg-options "-fopenmp -fmax-errors=100" } +! { dg-require-effective-target tls } + +subroutine foo (ia1) +integer :: i1, i2, i3 +integer, dimension (*) :: ia1 +integer, dimension (10) :: ia2 +real :: r1 +real, dimension (5) :: ra1 +double precision :: d1 +double precision, dimension (4) :: da1 +complex :: c1 +complex, dimension (7) :: ca1 +logical :: l1 +logical, dimension (3) :: la1 +character (5) :: a1 +type t + integer :: i +end type +type(t) :: t1 +type(t), dimension (2) :: ta1 +real, pointer :: p1 => NULL() +integer, allocatable :: aa1 (:,:) +save i2 +!$omp threadprivate (i2) +common /blk/ i1 + +!$omp parallel reduction (+:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (*:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (-:i3, ia2, r1, ra1, d1, da1, c1, ca1) +!$omp end parallel +!$omp parallel reduction (.and.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.or.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.eqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (.neqv.:l1, la1) +!$omp end parallel +!$omp parallel reduction (min:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (max:i3, ia2, r1, ra1, d1, da1) +!$omp end parallel +!$omp parallel reduction (iand:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ior:i3, ia2) +!$omp end parallel +!$omp parallel reduction (ieor:i3, ia2) +!$omp end parallel +!$omp parallel reduction (+:/blk/) ! { dg-error "Syntax error" } +!$omp end parallel ! { dg-error "Unexpected" } +!$omp parallel reduction (+:i2) ! { dg-error "THREADPRIVATE object" } +!$omp end parallel +!$omp parallel reduction (*:p1) ! { dg-error "POINTER object" } +!$omp end parallel +!$omp parallel reduction (-:aa1) +!$omp end parallel +!$omp parallel reduction (*:ia1) ! { dg-error "Assumed size" } +!$omp end parallel +!$omp parallel reduction (+:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (*:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (-:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (+:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (*:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.and.:i3) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.or.:ia2) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.eqv.:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.and.:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.or.:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.eqv.:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.neqv.:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.and.:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.or.:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (.eqv.:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (min:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (max:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (max:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (min:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (max:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (min:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (max:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (iand:r1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ior:ra1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ieor:d1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ior:da1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (iand:c1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ior:ca1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ieor:l1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (iand:la1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ior:a1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (ieor:t1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel +!$omp parallel reduction (iand:ta1) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found for type" } +!$omp end parallel + +end subroutine Index: Fortran/gfortran/regression/gomp/reduction2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction2.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +subroutine f1 + integer :: i + i = 0 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +!$omp parallel reduction (ior:i) + i = ior (i, 16) +!$omp end parallel +end subroutine f1 +subroutine f2 + integer :: i + i = ior (2, 4) +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f2 +subroutine f3 + integer :: i + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f3 +subroutine f4 + integer :: i, ior + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f4 Index: Fortran/gfortran/regression/gomp/reduction3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction3.f90 @@ -0,0 +1,64 @@ +! { dg-do compile } + +module mreduction3 + interface + function ior (a, b) + integer :: ior, a, b + end function + end interface +contains + function iand (a, b) + integer :: iand, a, b + iand = a + b + end function +end module mreduction3 +subroutine f1 + integer :: i, ior + ior = 6 + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" } +!$omp end parallel +end subroutine f1 +subroutine f2 + integer :: i + interface + function ior (a, b) + integer :: ior, a, b + end function + end interface + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" } + i = ior (i, 3) +!$omp end parallel +end subroutine f2 +subroutine f3 + integer :: i + intrinsic ior + i = 6 +!$omp parallel reduction (ior:i) + i = ior (i, 3) +!$omp end parallel +end subroutine f3 +subroutine f4 + integer :: i, ior + i = 6 +!$omp parallel reduction (ior:i) + ior = 4 ! { dg-error "is not a variable" } +!$omp end parallel +end subroutine f4 +subroutine f5 + use mreduction3 + integer :: i + i = 6 +!$omp parallel reduction (ior:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" } + i = ior (i, 7) +!$omp end parallel +end subroutine f5 +subroutine f6 + use mreduction3 + integer :: i + i = 6 +!$omp parallel reduction (iand:i) ! { dg-error "OMP DECLARE REDUCTION\[^\n\r\]*not found" } + i = iand (i, 18) +!$omp end parallel +end subroutine f6 Index: Fortran/gfortran/regression/gomp/reduction4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction4.f90 @@ -0,0 +1,143 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! (in_)reduction clause +! Test all in-principle valid combinations, even if +! not valid in this context (some fail at ME level) +! +implicit none +integer :: a, b, i +a = 0 + +! ------------ parallel ------------ +!$omp parallel reduction(+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +!$omp parallel reduction(default,+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +!$omp parallel reduction(task,+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + + +! ------------ simd ------------ +!$omp simd reduction(+:a) +do i=1,10 + a = a + 1 +end do + +!$omp simd reduction(default,+:a) +do i=1,10 + a = a + 1 +end do + +!$omp simd reduction(task,+:a) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } +do i=1,10 + a = a + 1 +end do + +! ------------ do ------------ +!$omp parallel +!$omp do reduction(+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +!$omp parallel +!$omp do reduction(default,+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +!$omp parallel +!$omp do reduction(task,+:a) +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +! ------------ section ------------ +!$omp parallel +!$omp sections reduction(+:a) + !$omp section + a = a + 1 +!$omp end sections +!$omp end parallel + +!$omp parallel +!$omp sections reduction(default,+:a) + !$omp section + a = a + 1 +!$omp end sections +!$omp end parallel + +!$omp parallel +!$omp sections reduction(task,+:a) + !$omp section + a = a + 1 +!$omp end sections +!$omp end parallel + +! ------------ task ------------ +!$omp task in_reduction(+:a) + a = a + 1 +!$omp end task + +! ------------ taskloop ------------ +!$omp taskloop reduction(+:a) in_reduction(+:b) +do i=1,10 + a = a + 1 +end do + +!$omp taskloop reduction(default,+:a) in_reduction(+:b) +do i=1,10 + a = a + 1 +end do + +! ------------ target ------------ +!$omp target in_reduction(+:b) + a = a + 1 +!$omp end target + +! ------------ teams ------------ +!$omp teams reduction(+:b) + a = a + 1 +!$omp end teams + +!$omp teams reduction(default, +:b) + a = a + 1 +!$omp end teams + +! ------------ taskgroup -------- + +!$omp taskgroup task_reduction(+:b) + a = a + 1 +!$omp end taskgroup + +end + +! { dg-final { scan-tree-dump-times "#pragma omp for reduction\\(\\\+:a\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for reduction\\(task,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel\[\n\r\]" 6 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel private\\(i\\) reduction\\(\\\+:a\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp parallel private\\(i\\) reduction\\(task,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp section\[\n\r\]" 3 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp sections reduction\\(\\\+:a\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp sections reduction\\(task,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) reduction\\(\\\+:a\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) reduction\\(task,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target map\\(always,tofrom:b\\) in_reduction\\(\\\+:b\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp task in_reduction\\(\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp teams reduction\\(\\\+:b\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp taskloop reduction\\(\\\+:a\\) in_reduction\\(\\\+:b\\)" 2 "original" } } Index: Fortran/gfortran/regression/gomp/reduction5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction5.f90 @@ -0,0 +1,57 @@ +! { dg-do compile } +! +implicit none +integer :: a, b, i +a = 0 + +!$omp parallel reduction(foo,+:a) ! { dg-error "26: Failed to match clause" } +do i=1,10 + a = a + 1 +end do +!$omp end parallel ! { dg-error "Unexpected !.OMP END PARALLEL statement" } + +!$omp parallel reduction(task +:a) ! { dg-error "30: Comma expected at" } +do i=1,10 + a = a + 1 +end do +!$omp end parallel ! { dg-error "Unexpected !.OMP END PARALLEL statement" } + +!$omp task in_reduction(foo,+:a) ! { dg-error "25: Failed to match clause" } + a = a + 1 +!$omp end task ! { dg-error "Unexpected !.OMP END TASK statement" } + +!$omp taskloop reduction(inscan,+:a) in_reduction(+:b) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "34: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } + ! { dg-error "'inscan' and non-'inscan' 'reduction' clauses on the same construct" "" { target *-*-* } .-2 } +do i=1,10 + a = a + 1 +end do + +!$omp taskloop reduction(task,+:a) in_reduction(+:b) ! { dg-error "32: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i=1,10 + a = a + 1 +end do + +!$omp teams reduction(inscan,+:b) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + a = a + 1 +!$omp end teams + +!$omp teams reduction(task, +:b) ! { dg-error "30: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } + a = a + 1 +!$omp end teams + +!$omp parallel reduction(inscan,+:a) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } +do i=1,10 + a = a + 1 +end do +!$omp end parallel + +!$omp parallel +!$omp sections reduction(inscan,+:a) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + !$omp section + a = a + 1 +!$omp end sections +!$omp end parallel + + +end Index: Fortran/gfortran/regression/gomp/reduction6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction6.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +implicit none +integer :: a, b, i +a = 0 + +!$omp simd reduction(inscan,+:a) ! { dg-error "30: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } +do i=1,10 + a = a + 1 +end do + +!$omp parallel +!$omp do reduction(inscan,+:a) ! { dg-error "28: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } +do i=1,10 + a = a + 1 +end do +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/reduction7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/reduction7.f90 @@ -0,0 +1,9 @@ +implicit none +integer :: a, b, i +a = 0 + +!$omp simd reduction(task,+:a) ! { dg-error "invalid 'task' reduction modifier on construct other than 'parallel', 'do', 'sections' or 'scope'" } +do i=1,10 + a = a + 1 +end do +end Index: Fortran/gfortran/regression/gomp/ref_inquiry.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/ref_inquiry.f90 @@ -0,0 +1,35 @@ +! Check for %re, ...%im, ...%kind, ...%len +! Cf. also OpenACC's ../goacc/ref_inquiry.f90 +! Cf. also OpenMP spec issue 2661 +implicit none +type t + integer :: i + character :: c + complex :: z + complex :: zz(5) +end type t + +integer :: i +character(kind=4, len=5) :: c +complex :: z, zz(5) +type(t) :: x + +print *, is_contiguous(zz(:)%re) + +! inquiry function; expr_type != EXPR_VARIABLE: +!$omp target enter data map(to: i%kind, c%len) ! { dg-error "not a proper array section" } +!$omp target enter data map(to: x%i%kind) ! { dg-error "not a proper array section" } +!$omp target enter data map(to: x%c%len) ! { dg-error "not a proper array section" } + +! EXPR_VARIABLE +!$omp target enter data map(to: z%re) ! { dg-error "Unexpected complex-parts designator" } +!$omp target enter data map(to: z%im) ! { dg-error "Unexpected complex-parts designator" } +!$omp target enter data map(to: zz%re) ! { dg-error "not a proper array section" } +!$omp target enter data map(to: zz%im) ! { dg-error "not a proper array section" } + +!$omp target enter data map(to: x%z%re) ! { dg-error "Unexpected complex-parts designator" } +!$omp target enter data map(to: x%z%im) ! { dg-error "Unexpected complex-parts designator" } +!$omp target enter data map(to: x%zz%re) ! { dg-error "not a proper array section" } +!$omp target enter data map(to: x%zz%im) ! { dg-error "not a proper array section" } + +end Index: Fortran/gfortran/regression/gomp/requires-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-1.f90 @@ -0,0 +1,13 @@ +subroutine foo +!$omp requires unified_address +!$omp requires unified_shared_memory +!$omp requires unified_shared_memory unified_address +!$omp requires dynamic_allocators,reverse_offload +end + +subroutine bar +!$omp requires unified_shared_memory unified_address +!$omp requires atomic_default_mem_order(seq_cst) +end + +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-2.f90 @@ -0,0 +1,14 @@ +!$omp requires ! { dg-error "Clause expected" } +!$omp requires unified_shared_memory,unified_shared_memory ! { dg-error "specified more than once" } +!$omp requires unified_address unified_address ! { dg-error "specified more than once" } +!$omp requires reverse_offload reverse_offload ! { dg-error "specified more than once" } +!$omp requires foobarbaz ! { dg-error "Expected UNIFIED_ADDRESS, UNIFIED_SHARED_MEMORY, DYNAMIC_ALLOCATORS, REVERSE_OFFLOAD, or ATOMIC_DEFAULT_MEM_ORDER clause" } +!$omp requires dynamic_allocators , dynamic_allocators ! { dg-error "specified more than once" } +!$omp requires atomic_default_mem_order(seq_cst) atomic_default_mem_order(seq_cst) ! { dg-error "specified more than once" } +!$omp requires atomic_default_mem_order (seq_cst) +!$omp requires atomic_default_mem_order (seq_cst) +!$omp requires atomic_default_mem_order (acq_rel) ! { dg-error "overrides a previous 'atomic_default_mem_order\\(seq_cst\\)'" } +!$omp requires atomic_default_mem_order (foo) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +end + +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-3.f90 @@ -0,0 +1,4 @@ +!$omp requires atomic_default_mem_order(acquire) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +!$omp requires atomic_default_mem_order(release) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +!$omp requires atomic_default_mem_order(foobar) ! { dg-error "Expected SEQ_CST, ACQ_REL or RELAXED for ATOMIC_DEFAULT_MEM_ORDER clause" } +end Index: Fortran/gfortran/regression/gomp/requires-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-4.f90 @@ -0,0 +1,36 @@ +subroutine bar +!$omp requires unified_shared_memory,unified_address,reverse_offload +end + +module m +!$omp requires unified_shared_memory,unified_address,reverse_offload +end module m + +subroutine foo + !$omp target + !$omp end target +! { dg-error "OpenMP device constructs/routines but does not set !.OMP REQUIRES REVERSE_OFFLOAD but other program units do" "" { target *-*-* } 9 } +! { dg-error "OpenMP device constructs/routines but does not set !.OMP REQUIRES UNIFIED_ADDRESS but other program units do" "" { target *-*-* } 9 } +! { dg-error "OpenMP device constructs/routines but does not set !.OMP REQUIRES UNIFIED_SHARED_MEMORY but other program units do" "" { target *-*-* } 9 } +end + +subroutine foobar +i = 5 ! < execution statement +!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "Unexpected ..OMP REQUIRES statement" } +end + +program main +!$omp requires dynamic_allocators ! OK +!$omp requires unified_shared_memory +!$omp requires unified_address +!$omp requires reverse_offload +contains + subroutine foo + !$omp target + !$omp end target + end subroutine + subroutine bar + !$omp requires unified_address ! { dg-error "must appear in the specification part of a program unit" } + end subroutine bar +end +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-5.f90 @@ -0,0 +1,16 @@ +subroutine bar +!$omp requires atomic_default_mem_order(seq_cst) +!$omp requires unified_shared_memory +end + +subroutine foo +!$omp requires unified_shared_memory +!$omp requires unified_shared_memory +!$omp requires atomic_default_mem_order(relaxed) +!$omp requires atomic_default_mem_order(relaxed) +!$omp requires atomic_default_mem_order(seq_cst) ! { dg-error "overrides a previous 'atomic_default_mem_order\\(seq_cst\\)'" } + !$omp target + !$omp end target +end + +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-6.f90 @@ -0,0 +1,16 @@ +subroutine bar +!$omp atomic + i = i + 5 +end + +subroutine foo +!$omp requires atomic_default_mem_order(seq_cst) +end + +subroutine foobar +!$omp atomic + i = i + 5 +!$omp requires atomic_default_mem_order(acq_rel) ! { dg-error "Unexpected !.OMP REQUIRES statement" } +end + +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-7.f90 @@ -0,0 +1,41 @@ +subroutine bar2 + block + !$omp requires unified_shared_memory ! { dg-error "must appear in the specification part of a program unit" } + end block +end + +subroutine bar +contains + subroutine foo + !$omp requires unified_shared_memory ! { dg-error "must appear in the specification part of a program unit" } + end +end + +module m +contains + subroutine foo + !$omp requires unified_shared_memory ! { dg-error "must appear in the specification part of a program unit" } + end +end + +module m2 + interface + module subroutine foo() + end + end interface +end + +submodule (m2) m2_sub + !$omp requires unified_shared_memory +contains + module procedure foo + end +end + +program main +contains + subroutine foo + !$omp requires unified_shared_memory ! { dg-error "must appear in the specification part of a program unit" } + end +end +! { dg-prune-output "not yet supported" } Index: Fortran/gfortran/regression/gomp/requires-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-8.f90 @@ -0,0 +1,30 @@ +module m0 + integer :: x +end module m0 + +module m ! { dg-error "has OpenMP device constructs/routines but does not set !.OMP REQUIRES UNIFIED_SHARED_MEMORY but other program units do" } + !$omp requires reverse_offload +contains + subroutine foo + interface + subroutine bar2 + !$omp requires dynamic_allocators + end subroutine + end interface + !$omp target + call bar2() + !$omp end target + end subroutine foo +end module m + +subroutine bar + !use m + !$omp requires unified_shared_memory ! Possibly OK - needs OpenMP Lang Spec clarification (-> #3240) + !$omp declare target +end subroutine bar + +subroutine foobar ! { dg-error "has OpenMP device constructs/routines but does not set !.OMP REQUIRES REVERSE_OFFLOAD but other program units do" } + use m0 + !$omp requires unified_shared_memory + !$omp target enter data map(to:x) +end subroutine foobar Index: Fortran/gfortran/regression/gomp/requires-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/requires-9.f90 @@ -0,0 +1,85 @@ +! { dg-additional-options "-fdump-tree-original" } + +module relaxed + !$omp requires atomic_default_mem_order(relaxed) +end module relaxed + +module seq + !$omp requires atomic_default_mem_order(seq_cst) +end module seq + +module acq + !$omp requires atomic_default_mem_order(acq_rel) +end module acq + +subroutine sub1 + !$omp atomic ! <= relaxed + i1 = i1 + 5 +end subroutine + +subroutine sub2 + !$omp atomic seq_cst + i2 = i2 + 5 +end subroutine + +subroutine sub3 + use relaxed + !$omp atomic + i3 = i3 + 5 +end subroutine + +subroutine sub4 + use relaxed + !$omp atomic seq_cst + i4 = i4 + 5 +end subroutine + +subroutine sub5 + use seq + !$omp atomic + i5 = i5 + 5 +contains + subroutine bar + block + !$omp atomic + i5b = i5b + 5 + end block + end +end subroutine + +subroutine sub6 + use seq + !$omp atomic seq_cst + i6 = i6 + 5 +end subroutine + +subroutine sub7 + use acq + !$omp atomic + i7 = i7 + 5 +contains + subroutine foobar + block + !$omp atomic + i7b = i7b + 5 + end block + end +end subroutine + +subroutine sub8 + use acq + !$omp atomic seq_cst + i8 = i8 + 5 +end subroutine + +! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed\[\n\r]\[^\n\r]*&i1 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i2 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic relaxed\[\n\r]\[^\n\r]*&i3 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i4 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i5 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i5 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i5b =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i6 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic release\[\n\r]\[^\n\r]*&i7 =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic release\[\n\r]\[^\n\r]*&i7b =" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp atomic seq_cst\[\n\r]\[^\n\r]*&i8 =" 1 "original" } } Index: Fortran/gfortran/regression/gomp/scan-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-1.f90 @@ -0,0 +1,218 @@ +module m + integer a, b +end module m + +subroutine f1 + use m + !$omp scan inclusive (a) ! { dg-error "Unexpected ..OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + !$omp scan exclusive (b) ! { dg-error "Unexpected ..OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } +end + +subroutine f2 (c, d, e, f) + use m + implicit none + integer i, l, c(*), d(*), e(64), f(64) + l = 1 + + !$omp do reduction (inscan, +: a) reduction (+: b) ! { dg-error "'inscan' and non-'inscan' 'reduction' clauses on the same construct" } + do i = 1, 64 + block + b = b + 1 + a = a + c(i) + end block + !$omp scan inclusive (a) + d(i) = a + end do + + !$omp do reduction (+: a) reduction (inscan, +: b) ! { dg-error "'inscan' and non-'inscan' 'reduction' clauses on the same construct" } + do i = 1, 64 + block + a = a + 1 + b = b + c(i) + end block + !$omp scan inclusive (b) + d(i) = b + end do + + !$omp do reduction (inscan, +: e) + do i = 1, 64 + block + e(1) = e(1) + c(i) + e(2) = e(2) + c(i) + end block + !$omp scan inclusive (a, e) + block + d(1) = e(1) + f(2) = e(2) + end block + end do + + !$omp do reduction (inscan, +: e(:2)) ! { dg-error "Syntax error in OpenMP variable list" } + do i = 1, 64 + block + e(1) = e(1) + c(i) + e(2) = e(2) + c(i) + end block + !$omp scan inclusive (a, e) ! { dg-error "outside loop construct with 'inscan' REDUCTION clause" } + block + d(1) = e(1) + f(2) = e(2) + end block + end do + + !$omp do reduction (inscan, +: a) ordered ! { dg-error "ORDERED clause specified together with 'inscan' REDUCTION clause" } + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) + d(i) = a + end do + + !$omp do reduction (inscan, +: a) ordered(1) ! { dg-error "ORDERED clause specified together with 'inscan' REDUCTION clause" } + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) + d(i) = a + end do + + !$omp do reduction (inscan, +: a) schedule(static) ! { dg-error "SCHEDULE clause specified together with 'inscan' REDUCTION clause" } + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) + d(i) = a + end do + + !$omp do reduction (inscan, +: a) schedule(static, 2) ! { dg-error "SCHEDULE clause specified together with 'inscan' REDUCTION clause" } + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) + d(i) = a + end do + + !$omp do reduction (inscan, +: a) schedule(nonmonotonic: dynamic, 2) ! { dg-error "SCHEDULE clause specified together with 'inscan' REDUCTION clause" } + do i = 1, 64 + a = a + c(i) + !$omp scan inclusive (a) + d(i) = a + end do +end + +subroutine f3 (c, d) + use m + implicit none + integer i, c(64), d(64) + !$omp teams reduction (inscan, +: a) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + ! ... + !$omp end teams + + !$omp scope reduction (inscan, +: a) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + ! ... + !$omp end scope + + !$omp target parallel do reduction (inscan, +: a) map (c, d) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do + !$omp teams + !$omp distribute parallel do reduction (inscan, +: a) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do + !$omp end teams + + !$omp distribute parallel do simd reduction (inscan, +: a) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do +end + +subroutine f4 (c, d) + use m + implicit none + integer i, c(64), d(64) + !$omp taskloop reduction (inscan, +: a) + ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" "" { target *-*-* } .-1 } + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do +end + +subroutine f7 + use m + implicit none + integer i + !$omp simd reduction (inscan, +: a) + do i = 1, 64 + if (i == 23) then ! { dg-error "invalid exit from OpenMP structured block" "" { target c++ } .+1 } + cycle ! { dg-error "invalid branch to/from OpenMP structured block" "" { target c } } + elseif (i == 27) then + goto 123 ! Diagnostic by ME, see scan-7.f90 + ! { dg-warning "is not in the same block as the GOTO statement" "" { target *-*-* } .-1 } + endif + !$omp scan exclusive (a) + block +123 a = 0 ! { dg-error "jump to label 'l1'" "" { target c++ } } + ! { dg-warning "is not in the same block as the GOTO statement" "" { target *-*-* } .-1 } + if (i == 33) then ! { dg-error "invalid exit from OpenMP structured block" "" { target c++ } .+1 } + cycle ! { dg-error "invalid branch to/from OpenMP structured block" "" { target c } } + end if + end block + end do +end + +subroutine f8 (c, d, e, f) + use m + implicit none + integer i, c(64), d(64), e(64), f(64) + !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + do i = 1, 64 + block + a = a + c(i) + b = b + d(i) + end block + !$omp scan inclusive (a) inclusive (b) ! { dg-error "Unexpected junk after ..OMP SCAN" } + block + e(i) = a + f(i) = b + end block + end do + + !$omp do reduction (inscan, +: a, b) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + do i = 1, 64 + block + a = a + c(i) + b = b + d(i) + end block + !$omp scan ! { dg-error "Expected INCLUSIVE or EXCLUSIVE clause" } + block + e(i) = a + f(i) = b + end block + end do +end + +subroutine f9 + use m + implicit none + integer i +! The first error (exit) causes two follow-up errors: + !$omp simd reduction (inscan, +: a) ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" } + do i = 1, 64 + if (i == 23) & + exit ! { dg-error "EXIT statement at .1. terminating ..OMP DO loop" } */ + !$omp scan exclusive (a) ! { dg-error "Unexpected ..OMP SCAN at .1. outside loop construct with 'inscan' REDUCTION clause" } + a = a + 1 + end do +end Index: Fortran/gfortran/regression/gomp/scan-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-2.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +module m + integer :: a, b +end module m + +subroutine f1 (c, d) + use m + implicit none + integer i, c(*), d(*) + !$omp simd reduction (inscan, +: a) + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do +end + +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) reduction\\(inscan,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp scan exclusive\\(a\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/scan-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-3.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +module m + integer :: a, b +end module m + +subroutine f1 (c, d) + use m + implicit none + integer i, c(*), d(*) + !$omp do reduction (inscan, +: a) + do i = 1, 64 + d(i) = a + !$omp scan inclusive (a) + a = a + c(i) + end do +end + +! { dg-final { scan-tree-dump-times "#pragma omp for reduction\\(inscan,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp scan inclusive\\(a\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/scan-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-4.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +module m + integer a, b +end module m + +subroutine f1 (c, d) + use m + implicit none + integer c(*), d(*), i + !$omp do simd reduction (inscan, +: a) + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do +end + +! { dg-final { scan-tree-dump-times "#pragma omp for reduction\\(inscan,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp simd linear\\(i:1\\) reduction\\(inscan,\\\+:a\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp scan exclusive\\(a\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/scan-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-5.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +integer function foo(a,b, n) result(r) + implicit none + integer :: a(n), b(n), n, i + r = 0 + !$omp parallel do reduction (inscan, +:r) default(none) firstprivate (a, b) + do i = 1, n + r = r + a(i) + !$omp scan inclusive (r) + b(i) = r + end do +end + +! { dg-final { scan-tree-dump-times "#pragma omp parallel firstprivate\\(a\\) firstprivate\\(b\\) shared\\(r\\) default\\(none\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp for reduction\\(inscan,\\\+:r\\) nowait" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp scan inclusive\\(r\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/scan-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-6.f90 @@ -0,0 +1,16 @@ +module m + integer a, b +end module m + +subroutine f3 (c, d) + use m + implicit none + integer i, c(64), d(64) + !$omp parallel reduction (inscan, +: a) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! ... + !$omp end parallel + !$omp sections reduction (inscan, +: a) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + !$omp section + ! ... + !$omp end sections +end Index: Fortran/gfortran/regression/gomp/scan-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scan-7.f90 @@ -0,0 +1,60 @@ +module m + integer a, b +end module m + +subroutine f2 (c, d, e, f) + use m + implicit none + integer i, l, c(*), d(*), e(64), f(64) + l = 1 + + !$omp do reduction (inscan, +: a) linear (l) ! { dg-error "'inscan' 'reduction' clause used together with 'linear' clause for a variable other than loop iterator" } + do i = 1, 64 + block + a = a + c(i) + l = l + 1 + end block + !$omp scan inclusive (a) + d(i) = a + end do +end + +subroutine f5 (c, d) + use m + implicit none + integer i, c(64), d(64) + !$omp simd reduction (inscan, +: a) + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a, b) ! { dg-error "'b' specified in 'exclusive' clause but not in 'inscan' 'reduction' clause on the containing construct" } + a = a + c(i) + end do +end + +subroutine f6 (c, d) + use m + implicit none + integer i, c(64), d(64) + !$omp simd reduction (inscan, +: a, b) ! { dg-error "'b' specified in 'inscan' 'reduction' clause but not in 'scan' directive clause" } + do i = 1, 64 + d(i) = a + !$omp scan exclusive (a) + a = a + c(i) + end do +end + +subroutine f7 + use m + implicit none + integer i + !$omp simd reduction (inscan, +: a) + do i = 1, 64 + if (i == 27) goto 123 ! { dg-error "invalid branch to/from OpenMP structured block" } + ! { dg-warning "is not in the same block as the GOTO statement" "" { target *-*-* } .-1 } + !$omp scan exclusive (a) + block +123 a = 0 ! { dg-error "jump to label 'l1'" "" { target c++ } } + ! { dg-warning "is not in the same block as the GOTO statement" "" { target *-*-* } .-1 } + end block + end do +end Index: Fortran/gfortran/regression/gomp/schedule-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/schedule-1.f90 @@ -0,0 +1,11 @@ + integer :: i + !$omp do schedule(static, 1) + do i = 1, 10 + end do + !$omp do schedule(static, 0) ! { dg-warning "must be positive" } + do i = 1, 10 + end do + !$omp do schedule(static, -7) ! { dg-warning "must be positive" } + do i = 1, 10 + end do +end Index: Fortran/gfortran/regression/gomp/schedule-modifiers-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/schedule-modifiers-1.f90 @@ -0,0 +1,63 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo + integer :: i + !$omp do simd schedule (simd, simd: static, 5) + do i = 0, 64 + end do + !$omp do simd schedule (monotonic, simd: static) + do i = 0, 64 + end do + !$omp do simd schedule (simd , monotonic : static, 6) + do i = 0, 64 + end do + !$omp do schedule (monotonic, monotonic : static, 7) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic, nonmonotonic : dynamic) + do i = 0, 64 + end do + !$omp do simd schedule (nonmonotonic , simd : dynamic, 3) + do i = 0, 64 + end do + !$omp do simd schedule (nonmonotonic,simd:guided,4) + do i = 0, 64 + end do + !$omp do schedule (monotonic: static, 2) + do i = 0, 64 + end do + !$omp do schedule (monotonic : static) + do i = 0, 64 + end do + !$omp do schedule (monotonic : dynamic) + do i = 0, 64 + end do + !$omp do schedule (monotonic : dynamic, 3) + do i = 0, 64 + end do + !$omp do schedule (monotonic : guided) + do i = 0, 64 + end do + !$omp do schedule (monotonic : guided, 7) + do i = 0, 64 + end do + !$omp do schedule (monotonic : runtime) + do i = 0, 64 + end do + !$omp do schedule (monotonic : auto) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : dynamic) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : dynamic, 3) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : guided) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : guided, 7) + do i = 0, 64 + end do +end subroutine foo Index: Fortran/gfortran/regression/gomp/schedule-modifiers-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/schedule-modifiers-2.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo + integer :: i + !$omp do schedule (nonmonotonic: static, 2) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : static) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : runtime) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : auto) + do i = 0, 64 + end do + !$omp do schedule (nonmonotonic : dynamic) ordered ! { dg-error "NONMONOTONIC schedule modifier specified with ORDERED clause" } + do i = 0, 64 + !$omp ordered + !$omp end ordered + end do + !$omp do ordered schedule(nonmonotonic : dynamic, 5) ! { dg-error "NONMONOTONIC schedule modifier specified with ORDERED clause" } + do i = 0, 64 + !$omp ordered + !$omp end ordered + end do + !$omp do schedule (nonmonotonic : guided) ordered(1) ! { dg-error "NONMONOTONIC schedule modifier specified with ORDERED clause" } + do i = 0, 64 + !$omp ordered depend(sink: i - 1) + !$omp ordered depend(source) + end do + !$omp do ordered(1) schedule(nonmonotonic : guided, 2) ! { dg-error "NONMONOTONIC schedule modifier specified with ORDERED clause" } + do i = 0, 64 + !$omp ordered depend(source) + !$ordered depend(sink: i - 1) + end do + !$omp do schedule (nonmonotonic , monotonic : dynamic) ! { dg-error "Both MONOTONIC and NONMONOTONIC schedule modifiers specified" } + do i = 0, 64 + end do + !$omp do schedule (monotonic,nonmonotonic:dynamic) ! { dg-error "Both MONOTONIC and NONMONOTONIC schedule modifiers specified" } + do i = 0, 64 + end do +end subroutine foo Index: Fortran/gfortran/regression/gomp/scope-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scope-1.f90 @@ -0,0 +1,39 @@ +module m + implicit none (external, type) + integer :: r, r2, r3 +contains + +subroutine foo + integer :: i, j, k + i = 0; j = 0; k = 0 + !$omp scope private (i) reduction (+:r) + i = 1 + r = r + 1 + !$omp end scope nowait + + !$omp scope private (i) reduction (task, +:r) + !$omp scope private (j) reduction (task, +:r2) + !$omp scope private (k) reduction (task, +:r3) + i = 1 + j = 2 + k = 3 + r = r + 1 + r2 = r2 + 1 + r3 = r3 + 1 + !$omp end scope + !$omp end scope + !$omp end scope + !$omp parallel + !$omp scope reduction (+:r) private (i) + !$omp scope reduction (+:r2) private (j) + !$omp single + i = 1 + j = 2 + r = r + 1 + r2 = r2 + 1 + !$omp end single + !$omp end scope nowait + !$omp end scope nowait + !$omp end parallel +end +end module Index: Fortran/gfortran/regression/gomp/scope-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scope-2.f90 @@ -0,0 +1,40 @@ +module m + implicit none (type, external) + integer :: r, r2, r3 = 1 + interface + logical function bar(); end + end interface +contains + +subroutine foo + integer :: i, j, k + i = 0; j = 0; k = 0 + !$omp parallel + if (bar ()) then + !$omp cancel parallel + end if + !$omp scope reduction (+:r) private (i) + !$omp scope reduction (+:r2) private (j) + !$omp single + i = 1; + j = 2; + r = r + 1 + r2 = r2 + 1 + !$omp end single nowait + !$omp end scope + !$omp end scope + !$omp end parallel + + !$omp parallel + if (bar ()) then + !$omp cancel parallel + end if + !$omp scope reduction (task, +:r) private (i) + !$omp scope reduction (task, *:r3) + r = r + 1 + r3 = r3 + 1 + !$omp end scope + !$omp end scope + !$omp end parallel +end +end module Index: Fortran/gfortran/regression/gomp/scope-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scope-5.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +subroutine foo () + integer f + f = 0; + !$omp scope firstprivate(f) ! { dg-error "firstprivate variable 'f' is private in outer context" } + f = f + 1 + !$omp end scope +end Index: Fortran/gfortran/regression/gomp/scope-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/scope-6.f90 @@ -0,0 +1,23 @@ +! { dg-additional-options "-fdump-tree-original" } + +module m + use iso_c_binding + !use omp_lib, only: omp_allocator_handle_kind + implicit none + integer, parameter :: omp_allocator_handle_kind = c_intptr_t + integer :: a = 0, b = 42, c = 0 + +contains + subroutine foo (h) + integer(omp_allocator_handle_kind), value :: h + !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( h : a , b , c) + if (b /= 42) & + error stop + a = 36 + b = 15 + c = c + 1 + !$omp end scope + end +end + +! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } } Index: Fortran/gfortran/regression/gomp/sharing-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/sharing-1.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-require-effective-target tls } + + integer :: thrpriv, thr, i, j, s, g1, g2, m + integer, dimension (6) :: p + common /thrblk/ thr + common /gblk/ g1 + save thrpriv, g2 +!$omp threadprivate (/thrblk/, thrpriv) + s = 1 +!$omp parallel do default (none) & +!$omp & private (p) shared (s) ! { dg-message "note: enclosing 'parallel'" } + do i = 1, 64 + call foo (thrpriv) ! Predetermined - threadprivate + call foo (thr) ! Predetermined - threadprivate + call foo (i) ! Predetermined - omp do iteration var + do j = 1, 64 ! Predetermined - sequential loop + call foo (j) ! iteration variable + end do + call bar ((/ (k * 4, k = 1, 8) /)) ! Predetermined - implied do + forall (l = 1 : i) &! Predetermined - forall indice + p(l) = 6 ! Explicitly determined - private + call foo (s) ! Explicitly determined - shared + call foo (g1) ! { dg-error "not specified in" } + call foo (g2) ! { dg-error "not specified in" } + call foo (m) ! { dg-error "not specified in" } + end do +end Index: Fortran/gfortran/regression/gomp/sharing-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/sharing-2.f90 @@ -0,0 +1,84 @@ + integer :: i, j, k, l + integer, dimension (10, 10) :: a +!$omp parallel do default (none) shared (a) + do i = 1, 10 + j = 4 + do j = 1, 10 + a(i, j) = i + j + end do + j = 8 + end do +!$omp end parallel do +!$omp parallel default (none) shared (a) ! { dg-message "note: enclosing 'parallel'" } + i = 1 + j = 1 + k = 1 + l = 1 ! { dg-error "not specified in" } + do i = 1, 10 + a(i, 1) = 1 + end do +!$omp critical + do j = 1, 10 + a(1, j) = j + end do +!$omp end critical +!$omp single + do k = 1, 10 + a(k, k) = k + end do +!$omp end single +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-message "note: enclosing 'parallel'" } + i = 1 ! { dg-error "not specified in" } + j = 1 ! { dg-error "not specified in" } + k = 1 ! { dg-error "not specified in" } +!$omp parallel default (none) shared (a) + i = 1 + j = 1 + k = 1 + do i = 1, 10 + a(i, 1) = 1 + end do +!$omp critical + do j = 1, 10 + a(1, j) = j + end do +!$omp end critical +!$omp single + do k = 1, 10 + a(k, k) = k + end do +!$omp end single +!$omp end parallel + i = 1 + j = 1 + k = 1 +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-message "note: enclosing 'parallel'" } + i = 1 ! { dg-error "not specified in" } +!$omp do + do i = 1, 10 + a(i, 1) = i + 1 + end do +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-message "note: enclosing 'parallel'" } + i = 1 ! { dg-error "not specified in" } +!$omp parallel do default (none) shared (a) + do i = 1, 10 + a(i, 1) = i + 1 + end do +!$omp end parallel +!$omp parallel default (none) shared (a) ! { dg-message "note: enclosing 'parallel'" } + i = 1 ! { dg-error "not specified in" } +!$omp parallel default (none) shared (a, i) + i = 2 +!$omp parallel default (none) shared (a) + do i = 1, 10 + a(i, 1) = i + end do +!$omp end parallel + i = 3 +!$omp end parallel + i = 4 +!$omp end parallel +end Index: Fortran/gfortran/regression/gomp/sharing-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/sharing-3.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo (vara, varb, varc, vard, n) + integer :: n, vara(n), varb(*), varc(:), vard(6), vare(6) + vare(:) = 0 + !$omp parallel default(none) shared(vara, varb, varc, vard, vare) + !$omp master + vara(1) = 1 + varb(1) = 1 + varc(1) = 1 + vard(1) = 1 + vare(1) = 1 + !$omp end master + !$omp end parallel + !$omp parallel default(none) private(vara, varc, vard, vare) + vara(1) = 1 + varc(1) = 1 + vard(1) = 1 + vare(1) = 1 + !$omp end parallel + !$omp parallel default(none) firstprivate(vara, varc, vard, vare) + vara(1) = 1 + varc(1) = 1 + vard(1) = 1 + vare(1) = 1 + !$omp end parallel + !$omp parallel default(none) ! { dg-message "note: enclosing 'parallel'" } + !$omp master + vara(1) = 1 ! { dg-error "not specified" } + varb(1) = 1 ! Assumed-size is predetermined + varc(1) = 1 ! { dg-error "not specified" } + vard(1) = 1 ! { dg-error "not specified" } + vare(1) = 1 ! { dg-error "not specified" } + !$omp end master + !$omp end parallel +end subroutine foo Index: Fortran/gfortran/regression/gomp/sharing-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/sharing-4.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +subroutine foo (v, n, r) + integer :: n + integer, intent(in) :: v(:) + integer, intent(out) :: r + integer :: i + + r = 0 + +!$omp parallel +!$omp single + + do i = 1, n +!$omp task shared (v) + r = r + v(i) +!$omp end task + enddo + +!$omp end single +!$omp end parallel + +end Index: Fortran/gfortran/regression/gomp/strictly-structured-block-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/strictly-structured-block-1.f90 @@ -0,0 +1,214 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +program main + integer :: x, i, n + + x = 0 + n = 10 + + !$omp parallel + block + call do_work + end block + + !$omp parallel + block + call do_work + end block + !$omp end parallel + + !$omp teams + block + call do_work + end block + + !$omp teams + block + call do_work + end block + !$omp end teams + + !$omp masked + block + x = x + 1 + end block + + !$omp masked + block + x = x + 1 + end block + !$omp end masked + + !$omp scope + block + call do_work + end block + + !$omp scope + block + call do_work + end block + !$omp end scope + + !$omp single + block + x = x + 1 + end block + + !$omp single + block + x = x + 1 + end block + !$omp end single + + !$omp workshare + block + x = x + 1 + end block + + !$omp workshare + block + x = x + 1 + end block + !$omp end workshare + + !$omp task + block + call do_work + end block + + !$omp task + block + call do_work + end block + !$omp end task + + !$omp target data map(x) + block + x = x + 1 + end block + + !$omp target data map(x) + block + x = x + 1 + end block + !$omp end target data + + !$omp target + block + x = x + 1 + end block + + !$omp target + block + x = x + 1 + end block + !$omp end target + + !$omp parallel workshare + block + x = x + 1 + end block + + !$omp parallel workshare + block + x = x + 1 + end block + !$omp end parallel workshare + + !$omp parallel masked + block + x = x + 1 + end block + + !$omp parallel masked + block + x = x + 1 + end block + !$omp end parallel masked + + !$omp target parallel + block + call do_work + end block + + !$omp target parallel + block + call do_work + end block + !$omp end target parallel + + !$omp target teams + block + call do_work + end block + + !$omp target teams + block + call do_work + end block + !$omp end target teams + + !$omp critical + block + x = x + 1 + end block + + !$omp critical + block + x = x + 1 + end block + !$omp end critical + + !$omp taskgroup + block + x = x + 1 + end block + + !$omp taskgroup + block + x = x + 1 + end block + !$omp end taskgroup + + !$omp do ordered + do i = 1, n + !$omp ordered + block + call do_work + end block + end do + + !$omp do ordered + do i = 1, n + !$omp ordered + block + call do_work + end block + !$omp end ordered + end do + + !$omp master + block + x = x + 1 + end block + + !$omp master + block + x = x + 1 + end block + !$omp end master + + !$omp parallel master + block + x = x + 1 + end block + + !$omp parallel master + block + x = x + 1 + end block + !$omp end parallel master + +end program Index: Fortran/gfortran/regression/gomp/strictly-structured-block-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/strictly-structured-block-2.f90 @@ -0,0 +1,139 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +program main + integer :: x, i, n + + x = 0 + n = 10 + + !$omp parallel + block + call do_work + end block + call do_work + !$omp end parallel ! { dg-error "Unexpected !.OMP END PARALLEL statement" } + + !$omp teams + block + call do_work + end block + call do_work + !$omp end teams ! { dg-error "Unexpected !.OMP END TEAMS statement" } + + !$omp masked + block + x = x + 1 + end block + x = x + 1 + !$omp end masked ! { dg-error "Unexpected !.OMP END MASKED statement" } + + !$omp scope + block + call do_work + end block + call do_work + !$omp end scope ! { dg-error "Unexpected !.OMP END SCOPE statement" } + + !$omp single + block + x = x + 1 + end block + x = x + 1 + !$omp end single ! { dg-error "Unexpected !.OMP END SINGLE statement" } + + !$omp workshare + block + x = x + 1 + end block + x = x + 1 + !$omp end workshare ! { dg-error "Unexpected !.OMP END WORKSHARE statement" } + + !$omp task + block + call do_work + end block + call do_work + !$omp end task ! { dg-error "Unexpected !.OMP END TASK statement" } + + !$omp target data map(x) + block + x = x + 1 + end block + x = x + 1 + !$omp end target data ! { dg-error "Unexpected !.OMP END TARGET DATA statement" } + + !$omp target + block + x = x + 1 + end block + x = x + 1 + !$omp end target ! { dg-error "Unexpected !.OMP END TARGET statement" } + + !$omp parallel workshare + block + x = x + 1 + end block + x = x + 1 + !$omp end parallel workshare ! { dg-error "Unexpected !.OMP END PARALLEL WORKSHARE statement" } + + !$omp parallel masked + block + x = x + 1 + end block + x = x + 1 + !$omp end parallel masked ! { dg-error "Unexpected !.OMP END PARALLEL MASKED statement" } + + !$omp target parallel + block + call do_work + end block + call do_work + !$omp end target parallel ! { dg-error "Unexpected !.OMP END TARGET PARALLEL statement" } + + !$omp target teams + block + call do_work + end block + call do_work + !$omp end target teams ! { dg-error "Unexpected !.OMP END TARGET TEAMS statement" } + + !$omp critical + block + x = x + 1 + end block + x = x + 1 + !$omp end critical ! { dg-error "Unexpected !.OMP END CRITICAL statement" } + + !$omp taskgroup + block + x = x + 1 + end block + x = x + 1 + !$omp end taskgroup ! { dg-error "Unexpected !.OMP END TASKGROUP statement" } + + !$omp do ordered + do i = 1, n + !$omp ordered + block + call do_work + end block + call do_work + !$omp end ordered ! { dg-error "Unexpected !.OMP END ORDERED statement" } + end do + + !$omp master + block + x = x + 1 + end block + x = x + 1 + !$omp end master ! { dg-error "Unexpected !.OMP END MASTER statement" } + + !$omp parallel master + block + x = x + 1 + end block + x = x + 1 + !$omp end parallel master ! { dg-error "Unexpected !.OMP END PARALLEL MASTER statement" } + +end program Index: Fortran/gfortran/regression/gomp/strictly-structured-block-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/strictly-structured-block-3.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +program main + integer :: x, y + + x = 0 + y = 0 + + !$omp parallel + !$omp parallel + block + call do_work + end block + !$omp end parallel + !$omp end parallel + + !$omp workshare + block + x = 1 + !$omp critical + block + y = 3 + end block + end block + + !$omp sections + block + !$omp section + block + x = 1 + end block + x = x + 2 + !$omp section + call do_work + end block + + !$omp sections + !$omp section + block + end block + x = 1 + !$omp end sections + + !$omp sections + block + block + end block + x = 1 + end block + +end program main Index: Fortran/gfortran/regression/gomp/strictly-structured-block-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/strictly-structured-block-4.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +implicit none +integer ::x,z +x = 42 +print '(*(z16:" "))', loc(x) +!$omp target map(x, z) +block + integer :: y + x = 123 + y = 99 + !$omp target device(ancestor:1) map(always,tofrom:x) map(y) ! { dg-error "'ancestor' device modifier not preceded by 'requires' directive with 'reverse_offload' clause" } + print '(*(z16:" "))', loc(x), loc(y) + print * ,x, y + x = -x + y = -y + !$omp end target ! { dg-error "Unexpected ..OMP END TARGET statement" } + z = y +end block + print * ,x !, z +end + Index: Fortran/gfortran/regression/gomp/substring.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/substring.f90 @@ -0,0 +1,22 @@ +implicit none +character(len=10) :: str1, str2(5,5) + +type t + character(len=10) :: str1, str2(5,5) +end type t +type(t) :: v + +!$omp target enter data map(to: str1) ! OK +!$omp target enter data map(to: str2) ! OK +!$omp target enter data map(to: str2(2,5)) ! OK + +!$omp target enter data map(to: str1(2,5)) ! { dg-error "Syntax error in OpenMP variable list" } +!$omp target enter data map(to: str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } + +!$omp target enter data map(to: v%str1) ! OK +!$omp target enter data map(to: v%str2) ! OK +!$omp target enter data map(to: v%str2(1,2)) ! OK + +!$omp target enter data map(to: v%str1(2:5)) ! { dg-error "Unexpected substring reference in MAP clause" } +!$omp target enter data map(to: v%str2(1,2)(2:4)) ! { dg-error "Unexpected substring reference in MAP clause" } +end Index: Fortran/gfortran/regression/gomp/target-data-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-data-1.f90 @@ -0,0 +1,17 @@ +! { dg-additional-options "-fdump-tree-original" } +! +! In OpenMP 5.2 permits tofrom for enter/exit data +! in the FE, it is already converted to 'to' and 'from', respectively. +module m + integer :: x, y, z +contains +subroutine copyin + !$omp target enter data map(x) map(tofrom: y) map(always, tofrom: z) +end +subroutine copyout + !$omp target exit data map(x) map(tofrom: y) map(always, tofrom: z) +end +end + +! { dg-final { scan-tree-dump-times "#pragma omp target enter data map\\(to:x\\) map\\(to:y\\) map\\(always,to:z\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp target exit data map\\(from:x\\) map\\(from:y\\) map\\(always,from:z\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/target-data-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-data-2.f90 @@ -0,0 +1,14 @@ +! In OpenMP 5.2 permits tofrom for enter/exit data +! in the FE, it is already converted to 'to' and 'from', respectively. +module m + integer :: y, z +contains +subroutine copyin + !$omp target enter data map(from: y) ! { dg-error "TARGET ENTER DATA with map-type other than TO, TOFROM or ALLOC on MAP clause" } + !$omp target enter data map(always, from: z) ! { dg-error "TARGET ENTER DATA with map-type other than TO, TOFROM or ALLOC on MAP clause" } +end +subroutine copyout + !$omp target exit data map(to: y) ! { dg-error "TARGET EXIT DATA with map-type other than FROM, TOFROM, RELEASE, or DELETE on MAP clause" } + !$omp target exit data map(always, to: z) ! { dg-error "TARGET EXIT DATA with map-type other than FROM, TOFROM, RELEASE, or DELETE on MAP clause" } +end +end Index: Fortran/gfortran/regression/gomp/target-device-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-1.f90 @@ -0,0 +1,67 @@ +! { dg-do compile } + +implicit none + +integer :: n + +!$omp target device (1) +!$omp end target + +!$omp target device (n) +!$omp end target + +!$omp target device (n + 1) +!$omp end target + +!$omp target device (device_num : 1) +!$omp end target + +!$omp target device (device_num : n) +!$omp end target + +!$omp target device (device_num : n + 1) +!$omp end target + +!$omp target device (invalid : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device ( : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device ( , : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (ancestor, device_num : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (ancestor, device_num, ancestor : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (device_num device_num : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (ancestor device_num : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (device_num, invalid : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (ancestor, invalid : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (ancestor, , , : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (invalid, ancestor : 1) ! { dg-error "xpected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (invalid, invalid, ancestor : 1) ! { dg-error "xpected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (device_num invalid : 1) ! { dg-error "Expected integer expression or a single device-modifier 'device_num' or 'ancestor' at" } +! !$omp end target + +!$omp target device (device_num : n, n) ! { dg-error "Expected integer expression" } +! !$omp end target + +end Index: Fortran/gfortran/regression/gomp/target-device-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-2.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! Test to ensure that device-modifier 'device_num' is parsed correctly in +! device clauses. + +!$omp target device (device_num : 42) +!$omp end target + +end + +! { dg-final { scan-tree-dump "pragma omp target \[^\n\r)]*device\\(42\\)" "original" } } Index: Fortran/gfortran/regression/gomp/target-device-ancestor-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-1.f90 @@ -0,0 +1,9 @@ +! { dg-do compile } + +! Ensure that a 'requires' directive with the 'reverse_offload' clause was +! specified. + +!$omp target device (ancestor:1) ! { dg-error "'ancestor' device modifier not preceded by 'requires' directive with 'reverse_offload' clause" } +! !$omp end target + +end \ No newline at end of file Index: Fortran/gfortran/regression/gomp/target-device-ancestor-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } + +implicit none + +integer :: a, b, c + +!$omp requires reverse_offload + + +!$omp target device (ancestor: 1) +!$omp end target + +!$omp target device (ancestor : a) +!$omp end target + +!$omp target device (ancestor : a + 1) +!$omp end target + + +! Ensure that the integer expression in the 'device' clause for +! device-modifier 'ancestor' evaluates to '1' in case of a constant. + +!$omp target device (ancestor: 42) ! { dg-error "the 'device' clause expression must evaluate to '1'" } +! !$omp end target + +!$omp target device (device_num:42) +!$omp end target + +!$omp target device (42) +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/target-device-ancestor-2a.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-2a.f90 @@ -0,0 +1,80 @@ +! { dg-do compile } + +implicit none + +integer :: a, b, c + +!$omp requires reverse_offload + +!$omp target device (ancestor: 1) +!$omp end target + +!$omp target device (ancestor : a) +!$omp end target + +!$omp target device (ancestor : a + 1) +!$omp end target + + +!$omp target device (device_num:42) +!$omp end target + +!$omp target device (42) +!$omp end target + + +! Ensure that no OpenMP constructs appear inside target regions with 'ancestor'. + +!$omp target device (ancestor: 1) + !$omp teams ! { dg-error "OpenMP constructs are not allowed in target region with 'ancestor'" } + !$omp end teams +!$omp end target + +!$omp target device (device_num: 1) + !$omp teams + !$omp end teams +!$omp end target + +!$omp target device (1) + !$omp teams + !$omp end teams +!$omp end target + + +! Ensure that with 'ancestor' only the 'device', 'firstprivate', 'private', +! 'defaultmap', and 'map' clauses appear on the construct. + +!$omp target nowait device (ancestor: 1) ! { dg-error "with 'ancestor', only the 'device', 'firstprivate', 'private', 'defaultmap', and 'map' clauses may appear on the construct" } +!$omp end target + +!$omp target device (ancestor: 1) nowait ! { dg-error "with 'ancestor', only the 'device', 'firstprivate', 'private', 'defaultmap', and 'map' clauses may appear on the construct" } +!$omp end target + +!$omp target nowait device (device_num: 1) +!$omp end target + +!$omp target nowait device (1) +!$omp end target + +!$omp target device (ancestor: 1) firstprivate (a) private (b) defaultmap (none) map (c) +!$omp end target + + +! Ensure that 'ancestor' is only used with 'target' constructs (not with +! 'target data', 'target update' etc.). +! The following test case is marked with 'xfail' because a previous 'sorry' from +! 'reverse_offload' suppresses the 'sorry' for 'ancestor'. + +!$omp target data map (a) device (ancestor: 1) ! { dg-error "'device' clause with 'ancestor' is only allowed on 'target' construct" } +!$omp end target data + +!$omp target enter data map (to: a) device (ancestor: 1) ! { dg-error "'device' clause with 'ancestor' is only allowed on 'target' construct" } +!$omp target exit data map (from: a) device (ancestor: 1) ! { dg-error "'device' clause with 'ancestor' is only allowed on 'target' construct" } + +!$omp target update to (a) device (ancestor: 1) ! { dg-error "'device' clause with 'ancestor' is only allowed on 'target' construct" } + +!$omp target device (ancestor: 1) if(.false.) +! { dg-error "with 'ancestor', only the 'device', 'firstprivate', 'private', 'defaultmap', and 'map' clauses may appear on the construct" "" { target *-*-* } .-1 } +!$omp end target + +end Index: Fortran/gfortran/regression/gomp/target-device-ancestor-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-3.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } + +! This testcase ensure that no calls to OpenMP API runtime routines are allowed +! inside the corresponding target region. + +module my_omp_mod + use iso_c_binding + interface + integer function omp_get_thread_num () + end + end interface +end + +subroutine f1 () + use my_omp_mod + implicit none + integer :: n + + !$omp requires reverse_offload + + !$omp target device (ancestor : 1) + n = omp_get_thread_num () ! { dg-error "OpenMP runtime API call 'omp_get_thread_num' in a region with 'device\\(ancestor\\)' clause" } + !$omp end target + + !$omp target device (device_num : 1) + n = omp_get_thread_num () + !$omp end target + + !$omp target device (1) + n = omp_get_thread_num () + !$omp end target + +end Index: Fortran/gfortran/regression/gomp/target-device-ancestor-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-4.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! Test to ensure that device-modifier 'ancestor' is parsed correctly in +! device clauses. + +!$omp requires reverse_offload + +!$omp target device (ancestor : 1) +!$omp end target + +end + +! { dg-final { scan-tree-dump-times "pragma omp target \[^\n\r)]*device\\(ancestor:1\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/target-device-ancestor-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-5.f90 @@ -0,0 +1,69 @@ +! { dg-do compile } +! +! Check that a requires directive is still recognized +! if it is in the associated parent namespace of the +! target directive. +! + +module m + !$omp requires reverse_offload +contains + subroutine foo() + !$omp target device(ancestor:1) + !$omp end target + end subroutine foo + + subroutine bar() + block + block + block + !$omp target device(ancestor:1) + !$omp end target + end block + end block + end block + end subroutine bar +end module m + +subroutine foo() + !$omp requires reverse_offload + block + block + block + !$omp target device(ancestor:1) + !$omp end target + end block + end block + end block +contains + subroutine bar() + block + block + block + !$omp target device(ancestor:1) + !$omp end target + end block + end block + end block + end subroutine bar +end subroutine foo + +program main + !$omp requires reverse_offload +contains + subroutine foo() + !$omp target device(ancestor:1) + !$omp end target + end subroutine foo + + subroutine bar() + block + block + block + !$omp target device(ancestor:1) + !$omp end target + end block + end block + end block + end subroutine bar +end Index: Fortran/gfortran/regression/gomp/target-device-ancestor-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-device-ancestor-6.f90 @@ -0,0 +1,17 @@ +! PR middle-end/107236 + +! Did ICE before because IFN .GOMP_TARGET_REV was not +! processed in omp-offload.cc. +! Note: Test required ENABLE_OFFLOADING being true inside GCC. + +implicit none +!$omp requires reverse_offload +!$omp target parallel num_threads(4) + !$omp target device(ancestor:1) + call foo() + !$omp end target +!$omp end target parallel +contains + subroutine foo + end +end Index: Fortran/gfortran/regression/gomp/target-exit-data.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-exit-data.f90 @@ -0,0 +1,20 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-omplower" } +! +! PR middle-end/94635 + +integer, allocatable :: one(:), two(:), three(:) + +!$omp target enter data map(alloc:one) +!$omp target enter data map(alloc:two) +!$omp target enter data map(to:three) + +! ... +!$omp target exit data map(delete:one) +!$omp target exit data map(release:two) +!$omp target exit data map(from:three) +end + +! { dg-final { scan-tree-dump "omp target exit data map\\(delete:.*\\) map\\(delete:one \\\[len: .*\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "omp target exit data map\\(release:.*\\) map\\(release:two \\\[len: .*\\\]\\)" "omplower" } } +! { dg-final { scan-tree-dump "omp target exit data map\\(from:.*\\) map\\(release:three \\\[len: .*\\\]\\)" "omplower" } } Index: Fortran/gfortran/regression/gomp/target-has-device-addr-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-has-device-addr-1.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } + +implicit none + +integer, target :: x +integer, pointer :: ptr +integer :: a(5) + +!$omp target has_device_addr(x) +!$omp end target +!$omp target has_device_addr(ptr) +!$omp end target +!$omp target has_device_addr(a) +!$omp end target +!$omp target has_device_addr(a(2:3)) +!$omp end target +!$omp target has_device_addr(a(:3)) +!$omp end target +!$omp target has_device_addr(a(2:)) +!$omp end target +!$omp target has_device_addr(a(2)) +!$omp end target + +!$omp target has_device_addr(x) has_device_addr(x) ! { dg-error "'x' present on multiple clauses" } +!$omp end target + +!$omp target private(x) has_device_addr(x) ! { dg-error "'x' present on multiple clauses" } +!$omp end target +!$omp target has_device_addr(x) private(x) ! { dg-error "'x' present on multiple clauses" } +!$omp end target +!$omp target firstprivate(x) has_device_addr(x) ! { dg-error "'x' present on multiple clauses" } +!$omp end target +!$omp target has_device_addr(x) firstprivate(x) ! { dg-error "'x' present on multiple clauses" } +!$omp end target + +end \ No newline at end of file Index: Fortran/gfortran/regression/gomp/target-has-device-addr-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-has-device-addr-2.f90 @@ -0,0 +1,27 @@ +! Test to ensure that HAS_DEVICE_ADDR is removed for non-used variables. + +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + use iso_c_binding + implicit none + + integer :: x, y + call foo (x, y) + +contains + subroutine foo (a, b) + integer :: a, b + + !$omp target data map(a) use_device_addr(a) + !$omp target has_device_addr(a) + a = 42 + !$omp end target + !$omp end target data + end subroutine foo + +end program main + +! { dg-final { scan-tree-dump "has_device_addr\\(a\\)" "gimple" } } +! { dg-final { scan-tree-dump-not "has_device_addr\\(b\\)" "gimple" } } Index: Fortran/gfortran/regression/gomp/target-parallel1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target-parallel1.f90 @@ -0,0 +1,4 @@ +!$omp target parallel + print *, 'Hello, world' +!$omp end target parallel +end Index: Fortran/gfortran/regression/gomp/target1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target1.f90 @@ -0,0 +1,495 @@ +! { dg-do compile } + +module target1 + interface + subroutine dosomething (a, n, m) + integer :: a (:), n, m + !$omp declare target + end subroutine dosomething + end interface +contains + subroutine foo (n, o, p, q, r, pp) + integer :: n, o, p, q, r, s, i, j + integer :: a (2:o) + integer, pointer :: pp + !$omp target data device (n + 1) if (n .ne. 6) map (tofrom: n, r) + !$omp target device (n + 1) if (n .ne. 6) map (from: n) map (alloc: a(2:o)) + call dosomething (a, n, 0) + !$omp end target + !$omp target teams device (n + 1) num_teams (n + 4) thread_limit (n * 2) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) + r = r + 1 + p = q + call dosomething (a, n, p + q) + !$omp end target teams + !$omp target teams distribute device (n + 1) num_teams (n + 4) collapse (2) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp target teams distribute device (n + 1) num_teams (n + 4) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end target teams distribute + !$omp target teams distribute parallel do device (n + 1) num_teams (n + 4) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) & + !$omp & schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + s = i * 10 + j + end do + end do + !$omp target teams distribute parallel do device (n + 1) num_teams (n + 4) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + s = i * 10 + end do + !$omp end target teams distribute parallel do + !$omp target teams distribute parallel do simd device (n + 1) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) & + !$omp & schedule (static, 8) num_teams (n + 4) safelen(8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp target teams distribute parallel do simd device (n + 1) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) & + !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end target teams distribute parallel do simd + !$omp target teams distribute simd device (n + 1) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & lastprivate (s) num_teams (n + 4) safelen(8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp target teams distribute simd device (n + 1) & + !$omp & if (n .ne. 6)map (from: n) map (alloc: a(2:o)) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) lastprivate (s) & + !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end target teams distribute simd + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams num_teams (n + 4) thread_limit (n * 2) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) + r = r + 1 + p = q + call dosomething (a, n, p + q) + !$omp end teams + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute num_teams (n + 4) collapse (2) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute num_teams (n + 4) default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end teams distribute + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute parallel do num_teams (n + 4) & + !$omp & if (n .ne. 6) default(shared) schedule (static, 8) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + s = i * 10 + j + end do + end do + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute parallel do num_teams (n + 4)if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + s = i * 10 + end do + !$omp end teams distribute parallel do + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute parallel do simd if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) & + !$omp & schedule (static, 8) num_teams (n + 4) safelen(8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute parallel do simd if (n .ne. 6)default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) & + !$omp & num_teams (n + 4) safelen(16) linear(i:1) aligned (pp:4) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end teams distribute parallel do simd + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute simd default(shared) safelen(8) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) collapse (2) & + !$omp & lastprivate (s) num_teams (n + 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target + !$omp target device (n + 1) if (n .ne. 6)map (from: n) map (alloc: a(2:o)) + !$omp teams distribute simd default(shared) aligned (pp:4) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & thread_limit (n * 2) dist_schedule (static, 4) lastprivate (s) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end teams distribute simd + !$omp end target + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction ( + : r ) + !$omp distribute collapse (2) firstprivate (q) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute firstprivate (q) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end distribute + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do if (n .ne. 6) default(shared) & + !$omp & schedule (static, 8) private (p) firstprivate (q) & + !$omp & shared(n)reduction(+:r)dist_schedule(static,4)collapse(2)& + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + s = i * 10 + end do + !$omp end distribute parallel do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do simd if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) collapse (2) safelen(8) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) & + !$omp & schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do simd if (n .ne. 6)default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) & + !$omp & safelen(16) linear(i:1) aligned (pp:4) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end distribute parallel do simd + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute simd safelen(8) lastprivate(s) & + !$omp & private (p) firstprivate (q) reduction (+: r) & + !$omp & dist_schedule (static, 4) collapse (2) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute simd aligned (pp:4) & + !$omp & private (p) firstprivate (q) reduction (+: r) & + !$omp & dist_schedule (static, 4) lastprivate (s) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end distribute simd + !$omp end target teams + !$omp end target data + end subroutine + subroutine bar (n, o, p, r, pp) + integer :: n, o, p, q, r, s, i, j + integer :: a (2:o) + integer, pointer :: pp + common /blk/ i, j, q + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction ( + : r ) + !$omp distribute collapse (2) firstprivate (q) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute firstprivate (q) dist_schedule (static, 4) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + end do + !$omp end distribute + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do if (n .ne. 6) default(shared) & + !$omp & schedule (static, 8) private (p) firstprivate (q) & + !$omp & shared(n)reduction(+:r)dist_schedule(static,4)collapse(2)& + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + call dosomething (a, n, p + q) + end do + s = i * 10 + end do + !$omp end distribute parallel do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do simd if(n.ne.6)default(shared)& + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) collapse (2) safelen(8) & + !$omp & num_threads (n + 4) proc_bind (spread) lastprivate (s) & + !$omp & schedule (static, 8) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute parallel do simd if (n .ne. 6)default(shared) & + !$omp & private (p) firstprivate (q) shared (n) reduction (+: r) & + !$omp & dist_schedule (static, 4) num_threads (n + 4) & + !$omp & proc_bind (master) lastprivate (s) schedule (static, 8) & + !$omp & safelen(16) linear(i:1) aligned (pp:4) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end distribute parallel do simd + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute simd safelen(8) lastprivate(s) & + !$omp & private (p) firstprivate (q) reduction (+: r) & + !$omp & dist_schedule (static, 4) collapse (2) + do i = 1, 10 + do j = 1, 10 + r = r + 1 + p = q + a(2+i*10+j) = p + q + s = i * 10 + j + end do + end do + !$omp end target teams + !$omp target teams device (n + 1) if (n .ne. 6)map (from: n) & + !$omp & map (alloc: a(2:o)) num_teams (n + 4) thread_limit (n * 2) & + !$omp & default(shared) shared(n) private (p) reduction(+:r) + !$omp distribute simd aligned (pp:4) & + !$omp & private (p) firstprivate (q) reduction (+: r) & + !$omp & dist_schedule (static, 4) lastprivate (s) + do i = 1, 10 + r = r + 1 + p = q + a(1+i) = p + q + s = i * 10 + end do + !$omp end distribute simd + !$omp end target teams + end subroutine +end module Index: Fortran/gfortran/regression/gomp/target2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target2.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } +! { dg-additional-options "-ffree-line-length-160" } + +subroutine foo (n, s, t, u, v, w) + integer :: n, i, s, t, u, v, w + common /bar/ i + !$omp simd safelen(s + 1) + do i = 1, n + end do + !$omp do schedule (static, t * 2) + do i = 1, n + end do + !$omp do simd safelen(s + 1) schedule (static, t * 2) + do i = 1, n + end do + !$omp parallel do schedule (static, t * 2) num_threads (u - 1) + do i = 1, n + end do + !$omp parallel do simd safelen(s + 1) schedule (static, t * 2) num_threads (u - 1) + do i = 1, n + end do + !$omp distribute dist_schedule (static, v + 8) + do i = 1, n + end do + !$omp distribute simd dist_schedule (static, v + 8) safelen(s + 1) + do i = 1, n + end do + !$omp distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) & + !$omp & schedule (static, t * 2) num_threads (u - 1) + do i = 1, n + end do + !$omp distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) & + !$omp & schedule (static, t * 2) + do i = 1, n + end do + !$omp target + !$omp teams distribute dist_schedule (static, v + 8) num_teams (w + 8) + do i = 1, n + end do + !$omp end target + !$omp target + !$omp teams distribute simd dist_schedule (static, v + 8) safelen(s + 1) & + !$omp & num_teams (w + 8) + do i = 1, n + end do + !$omp end target + !$omp target + !$omp teams distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) & + !$omp & schedule (static, t * 2) num_threads (u - 1) num_teams (w + 8) + do i = 1, n + end do + !$omp end target + !$omp target + !$omp teams distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) & + !$omp & schedule (static, t * 2) num_teams (w + 8) + do i = 1, n + end do + !$omp end target + !$omp target teams distribute dist_schedule (static, v + 8) num_teams (w + 8) + do i = 1, n + end do + !$omp target teams distribute simd dist_schedule (static, v + 8) safelen(s + 1) & + !$omp & num_teams (w + 8) + do i = 1, n + end do + !$omp target teams distribute parallel do simd dist_schedule (static, v + 8) safelen(s + 1) & + !$omp & schedule (static, t * 2) num_threads (u - 1) num_teams (w + 8) + do i = 1, n + end do + !$omp target teams distribute parallel do dist_schedule (static, v + 8) num_threads (u - 1) & + !$omp & schedule (static, t * 2) num_teams (w + 8) + do i = 1, n + end do +end subroutine Index: Fortran/gfortran/regression/gomp/target3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/target3.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + +subroutine foo (r) + integer :: i, r + !$omp target + !$omp target teams distribute parallel do reduction (+: r) ! { dg-warning ".target. construct inside of .target. region" } + do i = 1, 10 + r = r + 1 + end do + !$omp end target +end subroutine Index: Fortran/gfortran/regression/gomp/task-detach-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/task-detach-1.f90 @@ -0,0 +1,29 @@ +! { dg-do compile } +! { dg-options "-fopenmp" } + +program task_detach_1 + use iso_c_binding, only: c_intptr_t + implicit none + + integer, parameter :: omp_event_handle_kind = c_intptr_t + integer (kind=omp_event_handle_kind) :: x, y + integer(1) :: z + + !$omp task detach(x) detach(y) ! { dg-error "Failed to match clause at \\\(1\\\)" } + !$omp end task ! { dg-error "Unexpected !\\\$OMP END TASK statement at \\\(1\\\)" } + + !$omp task mergeable detach(x) ! { dg-error "'DETACH' clause at \\\(1\\\) must not be used together with 'MERGEABLE' clause" } + !$omp end task + + !$omp task detach(x) mergeable ! { dg-error "'DETACH' clause at \\\(1\\\) must not be used together with 'MERGEABLE' clause" } + !$omp end task + + !$omp task detach(z) ! { dg-error "'z' at \\\(1\\\) should be a scalar of type integer\\\(kind=omp_event_handle_kind\\\)" } + !$omp end task + + !$omp task detach (x) firstprivate (x) ! { dg-error "DETACH event handle 'x' in FIRSTPRIVATE clause at \\\(1\\\)" } + !$omp end task + + !$omp task detach (x) shared (x) ! { dg-error "DETACH event handle 'x' in SHARED clause at \\\(1\\\)" } + !$omp end task +end program Index: Fortran/gfortran/regression/gomp/taskloop-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/taskloop-1.f90 @@ -0,0 +1,126 @@ +module m + implicit none + integer :: t + !$omp threadprivate (t) + integer :: f, l, ll, r, r2 + !$omp declare target to(f, l, ll, r, r2) +end module m + +subroutine foo(fi, p, pp, g, s, nta, nth, ntm, i1, i2, i3, q) + use m + implicit none + integer, value :: p, pp, g, s, nta, nth, ntm + logical, value :: fi, i1, i2, i3 + integer, pointer :: q(:) + integer :: i + + !$omp taskgroup task_reduction(+:r2) !allocate (r2) + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) untied if(taskloop: i1) & + !$omp& if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction(+:r) !allocate (r) + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) & + !$omp& collapse(1) untied if(i1) final(fi) mergeable nogroup priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) in_reduction(+:r) nontemporal(ntm) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp taskwait + + !$omp taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) & + !$omp& collapse(1) if(taskloop: i1) final(fi) priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(+:r) if (simd: i3) nontemporal(ntm) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) !allocate (r2) + !$omp master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) & + !$omp& collapse(1) untied if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) in_reduction(+:r2) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) !allocate (r2) + !$omp master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) & + !$omp& collapse(1) untied if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp parallel master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) & + !$omp& collapse(1) untied if(taskloop: i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp parallel master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) grainsize (g) collapse(1) & + !$omp& untied if(taskloop: i1) if(simd: i2) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) nontemporal(ntm) & + !$omp& if (parallel: i2) num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp taskgroup task_reduction (+:r2) !allocate (r2) + !$omp master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) & + !$omp& collapse(1) untied if(i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) in_reduction(+:r2) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp taskgroup task_reduction (+:r2) !allocate (r2) + !$omp master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) & + !$omp& collapse(1) untied if(i1) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) in_reduction(+:r2) nontemporal(ntm) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + !$omp end taskgroup + + !$omp parallel master taskloop & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) & + !$omp& collapse(1) untied if(i1) final(fi) mergeable priority (pp) & + !$omp& reduction(default, +:r) num_threads (nth) proc_bind(spread) copyin(t) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do + + !$omp parallel master taskloop simd & + !$omp& private (p) firstprivate (f) lastprivate (l) shared (s) default(shared) num_tasks (nta) & + !$omp& collapse(1) untied if(i1) final(fi) mergeable priority (pp) & + !$omp& safelen(8) simdlen(4) linear(ll: 1) aligned(q: 32) reduction(default, +:r) & + !$omp& nontemporal(ntm) num_threads (nth) proc_bind(spread) copyin(t) & + !$omp& order(concurrent) !allocate (f) + do i = 1, 64 + ll = ll + 1 + end do +end Index: Fortran/gfortran/regression/gomp/taskloop-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/taskloop-2.f90 @@ -0,0 +1,74 @@ +subroutine foo() +implicit none +integer :: i, r +!$omp taskloop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp taskloop simd reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp master taskloop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp master taskloop simd reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp parallel master taskloop reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do +!$omp parallel master taskloop simd reduction(task, +: r) ! { dg-error "Only DEFAULT permitted as reduction-modifier in REDUCTION clause" } +do i = 1, 64 +end do + +!$omp taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +end do +!$omp taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +end do +!$omp master taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp master taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } + ! { dg-error "With INSCAN at .1., expected loop body with ..OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +do i = 1, 64 +end do +!$omp parallel master taskloop reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +end do +!$omp parallel master taskloop simd reduction(inscan, +: r) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" } +do i = 1, 64 ! { dg-error "OMP SCAN between two structured-block-sequences" "" { target *-*-* } .-1 } +end do +end + + +subroutine bar() +implicit none +integer :: i, r +r = 0 +!$omp parallel reduction(+:r) + !$omp master taskloop in_reduction(+:r) + do i = 1, 64 + end do + !$omp master taskloop simd in_reduction(+:r) + do i = 1, 64 + end do + !$omp master + !$omp taskloop in_reduction(+:r) + do i = 1, 64 + end do + !$omp taskloop simd in_reduction(+:r) + do i = 1, 64 + end do + !$omp end master +!$omp end parallel + +!$omp parallel master taskloop in_reduction(+:r) ! { dg-error "Failed to match clause" } + do i = 1, 64 + end do + +!$omp parallel master taskloop simd in_reduction(+:r) ! { dg-error "Failed to match clause" } + do i = 1, 64 + end do +end Index: Fortran/gfortran/regression/gomp/taskwait-depend-nowait-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/taskwait-depend-nowait-1.f90 @@ -0,0 +1,14 @@ +subroutine foo (p) + integer :: p(*) + !$omp taskwait depend(iterator(i = 1:17) , in : p(i)) nowait depend(out : p(32)) +end + +subroutine bar (p) + implicit none + integer :: p(*) + !$omp taskwait depend(mutexinoutset : p(1)) nowait ! { dg-error "'mutexinoutset' kind in 'depend' clause on a 'taskwait' construct" } +end + +subroutine baz + !$omp taskwait nowait ! { dg-error "'taskwait' construct with 'nowait' clause but no 'depend' clauses" } +end Index: Fortran/gfortran/regression/gomp/taskwait.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/taskwait.f90 @@ -0,0 +1,7 @@ +! { dg-additional-options "-fdump-tree-original" } +!$omp taskwait +!$omp taskwait depend(out:foo) +end + +! { dg-final { scan-tree-dump-times "__builtin_GOMP_taskwait \\(\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "#pragma omp taskwait depend\\(out:foo\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/teams-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/teams-3.f90 @@ -0,0 +1,65 @@ +! PR middle-end/102972 + +module m +implicit none (type, external) +interface +subroutine omp_set_num_teams (num_teams); integer :: num_teams; end +subroutine omp_set_teams_thread_limit (thread_limit); integer :: thread_limit; end +subroutine omp_set_num_teams_8 (num_teams); integer(8) :: num_teams; end +subroutine omp_set_num_teams_9 (num_teams); integer :: num_teams; end +subroutine omp_set_teams_thread_limit_8 (thread_limit); integer(8) :: thread_limit; end +integer function omp_get_num_teams (); end +integer function omp_get_team_size (level); integer :: level; end +integer function omp_get_team_num (); end +integer function omp_get_max_teams (); end +integer function omp_get_teams_thread_limit (); end +logical function omp_is_initial_device (); end +integer function omp_get_num_threads (); end +end interface + +contains + +subroutine valid () + integer :: i, n + !$omp teams + !$omp distribute + do i = 1, 64 + end do + + n = omp_get_num_teams () + if (n >= omp_get_team_num ()) & + error stop + + !$omp parallel do + do i = 1, 64 + if (.not.omp_is_initial_device () .or. omp_get_num_threads () < 0) & + error stop + end do + + !$omp loop + do i = 1, 64 + end do + !$omp end teams +end + +subroutine invalid_nest () + integer :: i, n + !$omp teams + !$omp distribute parallel do simd + do i = 1, 64 + end do + + n = 0 + n = n + omp_get_team_size (0) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_team_size\[^\n\r]*' strictly nested in a 'teams' region" } + n = n + omp_get_num_teams () + n = n + omp_get_team_num () + call omp_set_num_teams (n) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_set_num_teams\[^\n\r]*' strictly nested in a 'teams' region" } + call omp_set_num_teams_8 (4_8) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_set_num_teams_8\[^\n\r]*' strictly nested in a 'teams' region" } + call omp_set_num_teams_9 (4) ! OK - but misnamed user function + n = n + omp_get_max_teams () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_max_teams\[^\n\r]*' strictly nested in a 'teams' region" } + n = n + omp_get_teams_thread_limit () ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_get_teams_thread_limit\[^\n\r]*' strictly nested in a 'teams' region" } + call omp_set_teams_thread_limit (n) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_set_teams_thread_limit'\[^\n\r]* strictly nested in a 'teams' region" } + call omp_set_teams_thread_limit_8 (3_8) ! { dg-error "OpenMP runtime API call '\[^\n\r]*omp_set_teams_thread_limit_8'\[^\n\r]* strictly nested in a 'teams' region" } + !$omp end teams +end +end module Index: Fortran/gfortran/regression/gomp/teams-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/teams-4.f90 @@ -0,0 +1,47 @@ +! PR middle-end/102972 + +module m +implicit none (type, external) + +! Note: Those are module functions - not an interface +! Hence, they are internally manged to contain the module name! + +contains + +subroutine omp_set_num_teams (num_teams); integer :: num_teams; end +subroutine omp_set_teams_thread_limit (thread_limit); integer :: thread_limit; end +subroutine omp_set_num_teams_8 (num_teams); integer(8) :: num_teams; end +subroutine omp_set_num_teams_9 (num_teams); integer :: num_teams; end +subroutine omp_set_teams_thread_limit_8 (thread_limit); integer(8) :: thread_limit; end +integer function omp_get_num_teams (); omp_get_num_teams = 0; end +integer function omp_get_team_size (level); integer :: level; omp_get_team_size = 0; end +integer function omp_get_team_num (); omp_get_team_num = 0; end +integer function omp_get_max_teams (); omp_get_max_teams = 0; end +integer function omp_get_teams_thread_limit (); omp_get_teams_thread_limit = 0; end +logical function omp_is_initial_device (); omp_is_initial_device = .true.; end +integer function omp_get_num_threads (); omp_get_num_threads = 0; end +end module + +subroutine nest_test () + use m + implicit none (type, external) + + integer :: i, n + !$omp teams + !$omp distribute parallel do simd + do i = 1, 64 + end do + + n = 0 + n = n + omp_get_team_size (0) + n = n + omp_get_num_teams () + n = n + omp_get_team_num () + call omp_set_num_teams (n) + call omp_set_num_teams_8 (4_8) + call omp_set_num_teams_9 (4) + n = n + omp_get_max_teams () + n = n + omp_get_teams_thread_limit () + call omp_set_teams_thread_limit (n) + call omp_set_teams_thread_limit_8 (3_8) + !$omp end teams +end Index: Fortran/gfortran/regression/gomp/teams1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/teams1.f90 @@ -0,0 +1,8 @@ +! PR fortran/92756 + +program pr92756 + integer :: i + !$omp teams distribute parallel do + do i = 1, 64 + end do +end Index: Fortran/gfortran/regression/gomp/threadprivate-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/threadprivate-1.f90 @@ -0,0 +1,11 @@ +! PR fortran/99514 +! +! NTest in DATA is implicitly SAVE, unless in COMMON +! Was failing before as the implicit SAVE was not +! honoured by the threadprivate check. +! + +program main + DATA NTest /1/ + !$omp threadprivate(Ntest) +end program main Index: Fortran/gfortran/regression/gomp/udr1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr1.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } + +subroutine f1 +!$omp declare reduction (.le.:integer:omp_out = omp_out + omp_in) ! { dg-error "Invalid operator for" } +end subroutine f1 +subroutine f2 +!$omp declare reduction (bar:real(kind=4):omp_out = omp_out + omp_in) + real(kind=4) :: r + integer :: i + r = 0.0 +!$omp parallel do reduction (bar:r) + do i = 1, 10 + r = r + i + end do +!$omp parallel do reduction (foo:r) ! { dg-error "foo not found" } + do i = 1, 10 + r = r + i + end do +!$omp parallel do reduction (.gt.:r) ! { dg-error "cannot be used as a defined operator" } + do i = 1, 10 + r = r + i + end do +end subroutine f2 +subroutine f3 +!$omp declare reduction (foo:blah:omp_out=omp_out + omp_in) ! { dg-error "Unclassifiable OpenMP directive" } +end subroutine f3 +subroutine f4 +!$omp declare reduction (foo:integer:a => null()) ! { dg-error "Invalid character in name" } +!$omp declare reduction (foo:integer:omp_out = omp_in + omp_out) & +!$omp & initializer(a => null()) ! { dg-error "Invalid character in name" } +end subroutine f4 +subroutine f5 + integer :: a, b +!$omp declare reduction (foo:integer:a = b + 1) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" } +!$omp declare reduction (bar:integer:omp_out = omp_out * omp_in) & +!$omp & initializer(b = a + 1) ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" } +end subroutine f5 +subroutine f6 +!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_orig=omp_priv) +end subroutine f6 Index: Fortran/gfortran/regression/gomp/udr2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr2.f90 @@ -0,0 +1,53 @@ +! { dg-do compile } + +subroutine f6 +!$omp declare reduction (foo:real:omp_out (omp_in)) ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction (bar:real:omp_out = omp_in * omp_out) & ! { dg-error "Unclassifiable OpenMP directive" } +!$omp & initializer (omp_priv (omp_orig)) +end subroutine f6 +subroutine f7 + integer :: a +!$omp declare reduction (foo:integer:a (omp_out, omp_in)) ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction (bar:real:omp_out = omp_out.or.omp_in) ! { dg-error "Operands of logical operator" } +!$omp declare reduction (baz:real:omp_out = omp_out + omp_in) +!$omp & initializer (a (omp_priv, omp_orig)) ! { dg-error "Unclassifiable OpenMP directive" } + real :: r + r = 0.0 +!$omp parallel reduction (bar:r) +!$omp end parallel +end subroutine f7 +subroutine f8 + interface + subroutine f8a (x) + integer :: x + end subroutine f8a + end interface +!$omp declare reduction (baz:integer:omp_out = omp_out + omp_in) & +!$omp & initializer (f8a (omp_orig)) ! { dg-error "One of actual subroutine arguments in INITIALIZER clause" } +!$omp declare reduction (foo:integer:f8a) ! { dg-error "is not a variable" } +!$omp declare reduction (bar:integer:omp_out = omp_out - omp_in) & +!$omp & initializer (f8a) ! { dg-error "is not a variable" } +end subroutine f8 +subroutine f9 + type dt ! { dg-error "which is not consistent with the CALL" } + integer :: x = 0 + integer :: y = 0 + end type dt + integer :: i +!$omp declare reduction (foo:integer:dt (omp_out, omp_in)) ! { dg-error "which is not consistent with the CALL" } +!$omp declare reduction (bar:integer:omp_out = omp_out + omp_in) & +!$omp & initializer (dt (omp_priv, omp_orig)) ! { dg-error "which is not consistent with the CALL" } + i = 0 +!$omp parallel reduction (foo : i) +!$omp end parallel +!$omp parallel reduction (bar : i) +!$omp end parallel +end subroutine f9 +subroutine f10 + integer :: a, b +!$omp declare reduction(foo:character(len=64) & +!$omp & :omp_out(a:b) = omp_in(a:b)) ! { dg-error "Variable other than OMP_OUT or OMP_IN used in combiner" } +!$omp declare reduction(bar:character(len=16) & +!$omp & :omp_out = trim(omp_out) // omp_in) & +!$omp & initializer (omp_priv(a:b) = ' ') ! { dg-error "Variable other than OMP_PRIV or OMP_ORIG used in INITIALIZER clause" } +end subroutine f10 Index: Fortran/gfortran/regression/gomp/udr3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr3.f90 @@ -0,0 +1,75 @@ +! { dg-do compile } + +subroutine f1 + type dt + logical :: l = .false. + end type + type dt2 + logical :: l = .false. + end type +!$omp declare reduction (foo:integer(kind = 4) & ! { dg-error "Previous !.OMP DECLARE REDUCTION" } +!$omp & :omp_out = omp_out + omp_in) +!$omp declare reduction (foo:integer(kind = 4) : & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" } +!$omp & omp_out = omp_out + omp_in) +!$omp declare reduction (bar:integer, & +!$omp & real:omp_out = omp_out + omp_in) +!$omp declare reduction (baz:integer,real,integer & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" } +!$omp & : omp_out = omp_out + omp_in) +!$omp declare reduction (id1:dt,dt2:omp_out%l=omp_out%l & +!$omp & .or.omp_in%l) +!$omp declare reduction (id2:dt,dt:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" } +!$omp & .or.omp_in%l) +!$omp declare reduction (id3:dt2,dt:omp_out%l=omp_out%l & ! { dg-error "Previous !.OMP DECLARE REDUCTION" } +!$omp & .or.omp_in%l) +!$omp declare reduction (id3:dt2:omp_out%l=omp_out%l & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" } +!$omp & .or.omp_in%l) +end subroutine f1 +subroutine f2 + interface + subroutine f2a (x, y, z) + character (len = *) :: x, y + logical :: z + end subroutine + end interface + interface f2b + subroutine f2b (x, y, z) + character (len = *, kind = 1) :: x, y + logical :: z + end subroutine + subroutine f2c (x, y, z) + character (kind = 4, len = *) :: x, y + logical :: z + end subroutine + end interface +!$omp declare reduction (foo:character(len=*): & +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (bar:character(len=:): & +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (baz:character(len=4): & +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (baz:character(len=5): & +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (baz:character(len=6): & +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (id:character(len=*): & ! { dg-error "Previous !.OMP DECLARE REDUCTION" } +!$omp & f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (id: & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION" } +!$omp & character(len=:) : f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction & ! { dg-error "Redefinition of !.OMP DECLARE REDUCTION|Previous" } +!$omp (id2:character(len=*), character(len=:): & +!$omp f2a (omp_out, omp_in, .false.)) & +!$omp & initializer (f2a (omp_priv, omp_orig, .true.)) +!$omp declare reduction (id3:character(len=*, kind = 1), character(kind=4, len=:): & +!$omp f2b (omp_out, omp_in, .false.)) & +!$omp & initializer (f2b (omp_priv, omp_orig, .true.)) +!$omp declare reduction (id4:character(kind=4, len=4), character(kind =1, len=4): & +!$omp f2b (omp_out, omp_in, .false.)) & +!$omp & initializer (f2b (omp_priv, omp_orig, .true.)) +end subroutine f2 Index: Fortran/gfortran/regression/gomp/udr4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr4.f90 @@ -0,0 +1,74 @@ +! { dg-do compile } + +subroutine f3 +!$omp declare reduction ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction foo ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction (foo) ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction (foo:integer) ! { dg-error "Unclassifiable OpenMP directive" } +!$omp declare reduction (foo:integer:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=0) initializer(omp_priv=0) ! { dg-error "Unexpected junk after" } +end subroutine f3 +subroutine f4 + implicit integer (o) + implicit real (b) +!$omp declare reduction (foo:integer:omp_priv(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine omp_priv" } +!$omp declare reduction (foo:real:bar(omp_out,omp_in)) ! { dg-error "Implicitly declared subroutine bar used" } +!$omp declare reduction (bar:integer:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_out (omp_priv)) ! { dg-error "Implicitly declared subroutine omp_out used" } +!$omp declare reduction (bar:real:omp_out=omp_out+omp_in) & +!$omp & initializer(bar (omp_priv, omp_orig)) ! { dg-error "Implicitly declared subroutine bar used" } +!$omp declare reduction (id1:integer:omp_out=omp_orig(omp_out,omp_in)) ! { dg-error "Implicitly declared function omp_orig used" } +!$omp declare reduction (id1:real:omp_out=foo(omp_out,omp_in)) ! { dg-error "Implicitly declared function foo used" } +!$omp declare reduction (id2:integer:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv = omp_in (omp_orig)) ! { dg-error "Implicitly declared function omp_in used" } +!$omp declare reduction (id2:real:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv = baz (omp_orig)) ! { dg-error "Implicitly declared function baz used" } + integer :: i + real :: r + i = 0 + r = 0 +!$omp parallel reduction (foo: i, r) +!$omp end parallel +!$omp parallel reduction (bar: i, r) +!$omp end parallel +!$omp parallel reduction (id1: i, r) +!$omp end parallel +!$omp parallel reduction (id2: i, r) +!$omp end parallel +end subroutine f4 +subroutine f5 + interface + subroutine f5a (x, *, y) + double precision :: x, y + end subroutine f5a + end interface +!$omp declare reduction (foo:double precision: & ! { dg-error "Subroutine call with alternate returns in combiner" } +!$omp & f5a (omp_out, *10, omp_in)) +!$omp declare reduction (bar:double precision: & +!$omp omp_out = omp_in + omp_out) & +!$omp & initializer (f5a (omp_priv, *20, omp_orig)) ! { dg-error "Subroutine call with alternate returns in INITIALIZER clause" } +10 continue +20 continue +end subroutine f5 +subroutine f6 + integer :: a +!$omp declare reduction(foo:character(len=a*2) & ! { dg-error "cannot appear in the expression|not constant" } +!$omp & :omp_out=trim(omp_out)//omp_in) & +!$omp & initializer(omp_priv=' ') +end subroutine f6 +subroutine f7 + type dt1 + integer :: a = 1 + integer :: b + end type + type dt2 + integer :: a = 2 + integer :: b = 3 + end type + type dt3 + integer :: a + integer :: b + end type dt3 +!$omp declare reduction(foo:dt1,dt2:omp_out%a=omp_out%a+omp_in%a) +!$omp declare reduction(foo:dt3:omp_out%a=omp_out%a+omp_in%a) ! { dg-error "Missing INITIALIZER clause for !.OMP DECLARE REDUCTION of derived type without default initializer" } +end subroutine f7 Index: Fortran/gfortran/regression/gomp/udr5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr5.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } + +module udr5m1 + type dt + real :: r + end type dt +end module udr5m1 +module udr5m2 + use udr5m1 + interface operator(+) + module procedure addm2 + end interface +!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) +!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) + interface operator(.myadd.) + module procedure addm2 + end interface +contains + type(dt) function addm2 (x, y) + type(dt), intent (in):: x, y + addm2%r = x%r + y%r + end function +end module udr5m2 +module udr5m3 + use udr5m1 + interface operator(.myadd.) + module procedure addm3 + end interface +!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) +!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) + interface operator(+) + module procedure addm3 + end interface +contains + type(dt) function addm3 (x, y) + type(dt), intent (in):: x, y + addm3%r = x%r + y%r + end function +end module udr5m3 +subroutine f1 + use udr5m2 + type(dt) :: d, e + integer :: i + d=dt(0.0) + e = dt (0.0) +!$omp parallel do reduction (+ : d) reduction ( .myadd. : e) + do i=1,100 + d=d+dt(i) + e=e+dt(i) + end do +end subroutine f1 +subroutine f2 + use udr5m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" } + use udr5m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION|Ambiguous interfaces" } +end subroutine f2 Index: Fortran/gfortran/regression/gomp/udr6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr6.f90 @@ -0,0 +1,205 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000 -fopenmp -ffree-line-length-160" } + +module udr6 + type dt + integer :: i + end type +end module udr6 +subroutine f1 + use udr6, only : dt +!$omp declare reduction (+:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (+:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (+:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (+:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" } +!$omp & :omp_out = omp_out + omp_in) +!$omp declare reduction (+:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (+:complex(kind=8):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(+) + function addf1 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: addf1 + end function + end interface +end subroutine f1 +subroutine f2 + use udr6, only : dt + interface operator(-) + function subf2 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: subf2 + end function + end interface +!$omp declare reduction (-:integer:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (-:real(kind=4):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (-:double precision:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (-:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" } +!$omp & :omp_out = omp_out + omp_in) +!$omp declare reduction (-:complex:omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (-:complex(kind=8):omp_out = omp_out + omp_in) ! { dg-error "Redefinition of predefined" } +end subroutine f2 +subroutine f3 + use udr6, only : dt + interface operator(*) + function mulf3 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: mulf3 + end function + end interface +!$omp declare reduction (*:integer:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (*:real(kind=4):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (*:double precision:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (*:integer(kind=8),integer(kind=1) & ! { dg-error "Redefinition of predefined" } +!$omp & :omp_out = omp_out * omp_in) +!$omp declare reduction (*:complex:omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (*:complex(kind=8):omp_out = omp_out * omp_in) ! { dg-error "Redefinition of predefined" } +end subroutine f3 +subroutine f4 + use udr6, only : dt + interface operator(.and.) + function andf4 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: andf4 + end function + end interface +!$omp declare reduction (.neqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.or.) + function orf4 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: orf4 + end function + end interface +!$omp declare reduction (.eqv.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.eqv.) + function eqvf4 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: eqvf4 + end function + end interface +!$omp declare reduction (.or.:logical:omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.neqv.) + function neqvf4 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: neqvf4 + end function + end interface +!$omp declare reduction (.and.:logical:omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" } +end subroutine f4 +subroutine f5 + use udr6, only : dt + interface operator(.and.) + function andf5 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: andf5 + end function + end interface +!$omp declare reduction (.neqv.:logical(kind =4):omp_out = omp_out .neqv. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.or.) + function orf5 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: orf5 + end function + end interface +!$omp declare reduction (.eqv.:logical(kind= 4):omp_out = omp_out .eqv. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.eqv.) + function eqvf5 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: eqvf5 + end function + end interface +!$omp declare reduction (.or.:logical(kind=4):omp_out = omp_out .or. omp_in) ! { dg-error "Redefinition of predefined" } + interface operator(.neqv.) + function neqvf5 (x, y) + use udr6, only : dt + type(dt), intent (in) :: x, y + type(dt) :: neqvf5 + end function + end interface +!$omp declare reduction (.and.:logical(kind = 4):omp_out = omp_out .and. omp_in) ! { dg-error "Redefinition of predefined" } +end subroutine f5 +subroutine f6 +!$omp declare reduction (min:integer:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:integer:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (iand:integer:omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (ior:integer:omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (ieor:integer:omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (min:real:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:real:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +end subroutine f6 +subroutine f7 +!$omp declare reduction (min:integer(kind=2):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:integer(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (iand:integer(kind=1):omp_out = iand (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (ior:integer(kind=8):omp_out = ior (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (ieor:integer(kind=4):omp_out = ieor (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (min:real(kind=4):omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:real(kind=4):omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (min:double precision:omp_out = min (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +!$omp declare reduction (max:double precision:omp_out = max (omp_out, omp_in)) ! { dg-error "Redefinition of predefined" } +end subroutine f7 +subroutine f8 + integer :: min +!$omp declare reduction (min:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (min:real:omp_out = omp_out + omp_in) +!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in) +end subroutine f8 +subroutine f9 + integer :: max +!$omp declare reduction (max:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (max:real:omp_out = omp_out + omp_in) +!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in) +end subroutine f9 +subroutine f10 + integer :: iand +!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (iand:real:omp_out = omp_out + omp_in) +end subroutine f10 +subroutine f11 + integer :: ior +!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (ior:real:omp_out = omp_out + omp_in) +end subroutine f11 +subroutine f12 + integer :: ieor +!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in) +end subroutine f12 +subroutine f13 +!$omp declare reduction (min:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (min:real:omp_out = omp_out + omp_in) +!$omp declare reduction (min:double precision:omp_out = omp_out + omp_in) + integer :: min +end subroutine f13 +subroutine f14 +!$omp declare reduction (max:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (max:real:omp_out = omp_out + omp_in) +!$omp declare reduction (max:double precision:omp_out = omp_out + omp_in) + integer :: max +end subroutine f14 +subroutine f15 +!$omp declare reduction (iand:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (iand:real:omp_out = omp_out + omp_in) + integer :: iand +end subroutine f15 +subroutine f16 +!$omp declare reduction (ior:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (ior:real:omp_out = omp_out + omp_in) + integer :: ior +end subroutine f16 +subroutine f17 +!$omp declare reduction (ieor:integer:omp_out = omp_out + omp_in) +!$omp declare reduction (ieor:real:omp_out = omp_out + omp_in) + integer :: ieor +end subroutine f17 Index: Fortran/gfortran/regression/gomp/udr7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr7.f90 @@ -0,0 +1,90 @@ +! { dg-do compile } + +module udr7m1 + type dt + real :: r + end type dt +end module udr7m1 +module udr7m2 + use udr7m1 + interface operator(+) + module procedure addm2 + end interface +!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) +!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) + interface operator(.myadd.) + module procedure addm2 + end interface + private + public :: operator(+), operator(.myadd.), dt +contains + type(dt) function addm2 (x, y) + type(dt), intent (in):: x, y + addm2%r = x%r + y%r + end function +end module udr7m2 +module udr7m3 + use udr7m1 + private + public :: operator(.myadd.), operator(+), dt + interface operator(.myadd.) + module procedure addm3 + end interface +!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) +!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) + interface operator(+) + module procedure addm3 + end interface +contains + type(dt) function addm3 (x, y) + type(dt), intent (in):: x, y + addm3%r = x%r + y%r + end function +end module udr7m3 +module udr7m4 + use udr7m1 + private + interface operator(.myadd.) + module procedure addm4 + end interface +!$omp declare reduction(+:dt:omp_out=omp_out+omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) +!$omp declare reduction(.myadd.:dt:omp_out=omp_out.myadd.omp_in) & +!$omp & initializer(omp_priv=dt(0.0)) + interface operator(+) + module procedure addm4 + end interface +contains + type(dt) function addm4 (x, y) + type(dt), intent (in):: x, y + addm4%r = x%r + y%r + end function +end module udr7m4 +subroutine f1 + use udr7m2 + type(dt) :: d, e + integer :: i + d=dt(0.0) + e = dt (0.0) +!$omp parallel do reduction (+ : d) reduction ( .myadd. : e) + do i=1,100 + d=d+dt(i) + e=e+dt(i) + end do +end subroutine f1 +subroutine f2 + use udr7m3 ! { dg-error "Previous !.OMP DECLARE REDUCTION|Ambiguous interfaces" } + use udr7m2 ! { dg-error "Ambiguous !.OMP DECLARE REDUCTION|Ambiguous interfaces" } +end subroutine f2 +subroutine f3 + use udr7m4 + use udr7m2 +end subroutine f3 +subroutine f4 + use udr7m3 + use udr7m4 +end subroutine f4 Index: Fortran/gfortran/regression/gomp/udr8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/udr8.f90 @@ -0,0 +1,351 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000 -fopenmp" } + +module m +contains + function fn1 (x, y) + integer, intent(in) :: x, y + integer :: fn1 + fn1 = x + 2 * y + end function + subroutine sub1 (x, y) + integer, intent(in) :: y + integer, intent(out) :: x + x = y + end subroutine + function fn2 (x) + integer, intent(in) :: x + integer :: fn2 + fn2 = x + end function + subroutine sub2 (x, y) + integer, intent(in) :: y + integer, intent(inout) :: x + x = x + y + end subroutine + function fn3 (x, y) + integer, intent(in) :: x(:), y(:) + integer :: fn3(lbound(x, 1):ubound(x, 1)) + fn3 = x + 2 * y + end function + subroutine sub3 (x, y) + integer, intent(in) :: y(:) + integer, intent(out) :: x(:) + x = y + end subroutine + function fn4 (x) + integer, intent(in) :: x(:) + integer :: fn4(lbound(x, 1):ubound(x, 1)) + fn4 = x + end function + subroutine sub4 (x, y) + integer, intent(in) :: y(:) + integer, intent(inout) :: x(:) + x = x + y + end subroutine + function fn5 (x, y) + integer, intent(in) :: x(10), y(10) + integer :: fn5(10) + fn5 = x + 2 * y + end function + subroutine sub5 (x, y) + integer, intent(in) :: y(10) + integer, intent(out) :: x(10) + x = y + end subroutine + function fn6 (x) + integer, intent(in) :: x(10) + integer :: fn6(10) + fn6 = x + end function + subroutine sub6 (x, y) + integer, intent(in) :: y(10) + integer, intent(inout) :: x(10) + x = x + y + end subroutine + function fn7 (x, y) + integer, allocatable, intent(in) :: x(:), y(:) + integer, allocatable :: fn7(:) + fn7 = x + 2 * y + end function + subroutine sub7 (x, y) + integer, allocatable, intent(in) :: y(:) + integer, allocatable, intent(out) :: x(:) + x = y + end subroutine + function fn8 (x) + integer, allocatable, intent(in) :: x(:) + integer, allocatable :: fn8(:) + fn8 = x + end function + subroutine sub8 (x, y) + integer, allocatable, intent(in) :: y(:) + integer, allocatable, intent(inout) :: x(:) + x = x + y + end subroutine +end module +subroutine test1 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test1 +subroutine test2 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig)) + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test2 +subroutine test3 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp & initializer (sub1 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } +!$omp initializer (omp_priv = fn2 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*scalar and rank-1" } + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test3 +subroutine test4 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn1 (omp_out, omp_in)) & +!$omp & initializer (sub1 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub2 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn2 (omp_orig)) + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test4 +subroutine test5 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & +!$omp & initializer (sub3 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn4 (omp_orig)) + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test5 +subroutine test6 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test6 +subroutine test7 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & +!$omp & initializer (sub3 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn4 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test7 +subroutine test8 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn3 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub3 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub4 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn4 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test8 +subroutine test9 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & +!$omp & initializer (sub5 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn6 (omp_orig)) + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test9 +subroutine test10 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test10 +subroutine test11 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & +!$omp & initializer (sub5 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn6 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test11 +subroutine test12 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn5 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn6 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test12 +subroutine test13 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" } +!$omp & fn5 (omp_out, omp_in)) & ! { dg-error "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp & initializer (sub5 (omp_priv, omp_orig)) ! { dg-error "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp declare reduction (baz : integer : sub6 (omp_out, omp_in)) & ! { dg-error "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } +!$omp initializer (omp_priv = & ! { dg-error "Different shape for array assignment at \[^\n\r]* on dimension 1 .9 and 10" } +!$omp & fn6 (omp_orig)) ! { dg-error "Actual argument contains too few elements for dummy argument \[^\n\r]* .9/10" } + integer :: a(9) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test13 +subroutine test14 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Actual argument for \[^\n\r]* must be ALLOCATABLE" } + integer :: a(10) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test14 +subroutine test15 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer :: a +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test15 +subroutine test16 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & +!$omp & initializer (sub7 (omp_priv, omp_orig)) +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & +!$omp initializer (omp_priv = fn8 (omp_orig)) + integer, allocatable :: a(:) + allocate (a(10)) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test16 +subroutine test17 + use m +!$omp declare reduction (foo : integer : omp_out = omp_out + omp_in) initializer (omp_priv = 0) +!$omp declare reduction (bar : integer : omp_out = fn7 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } +!$omp & initializer (sub7 (omp_priv, omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp declare reduction (baz : integer : sub8 (omp_out, omp_in)) & ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar" } +!$omp initializer (omp_priv = fn8 (omp_orig)) ! { dg-error "Rank mismatch in argument\[^\n\r]*rank-1 and scalar|Incompatible ranks 0 and 1 in assignment" } + integer, allocatable :: a + allocate (a) +!$omp parallel reduction (foo : a) +!$omp end parallel +!$omp parallel reduction (bar : a) +!$omp end parallel +!$omp parallel reduction (baz : a) +!$omp end parallel +end subroutine test17 Index: Fortran/gfortran/regression/gomp/unexpected-end.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/unexpected-end.f90 @@ -0,0 +1,123 @@ +! PR fortran/102313 + +!$omp end ATOMIC ! { dg-error "Unexpected !.OMP END ATOMIC" } + +!$omp end CRITICAL ! { dg-error "Unexpected !.OMP END CRITICAL" } + +!$omp end DISTRIBUTE ! { dg-error "Unexpected !.OMP END DISTRIBUTE" } + +!$omp end DISTRIBUTE PARALLEL DO ! { dg-error "Unexpected !.OMP END DISTRIBUTE PARALLEL DO" } + +!$omp end DISTRIBUTE PARALLEL DO SIMD ! { dg-error "Unexpected !.OMP END DISTRIBUTE PARALLEL DO SIMD" } + +!$omp end DISTRIBUTE SIMD ! { dg-error "Unexpected !.OMP END DISTRIBUTE SIMD" } + +!$omp end DO ! { dg-error "Unexpected !.OMP END DO" } + +!$omp end DO SIMD ! { dg-error "Unexpected !.OMP END DO SIMD" } + +!$omp end LOOP ! { dg-error "Unexpected !.OMP END LOOP" } + +!$omp parallel loop +do i = 1, 5 +end do +!$omp end LOOP ! { dg-error "Unexpected !.OMP END LOOP" } + +!$omp end MASKED ! { dg-error "Unexpected !.OMP END MASKED" } + +!$omp end MASKED TASKLOOP ! { dg-error "Unexpected !.OMP END MASKED TASKLOOP" } + +!$omp end MASKED TASKLOOP SIMD ! { dg-error "Unexpected !.OMP END MASKED TASKLOOP SIMD" } + +!$omp end MASTER ! { dg-error "Unexpected !.OMP END MASTER" } + +!$omp end MASTER TASKLOOP ! { dg-error "Unexpected !.OMP END MASTER TASKLOOP" } + +!$omp end MASTER TASKLOOP SIMD ! { dg-error "Unexpected !.OMP END MASTER TASKLOOP SIMD" } + +!$omp end ORDERED ! { dg-error "Unexpected !.OMP END ORDERED" } + +!$omp end PARALLEL ! { dg-error "Unexpected !.OMP END PARALLEL" } + +!$omp end PARALLEL DO ! { dg-error "Unexpected !.OMP END PARALLEL DO" } + +!$omp end PARALLEL DO SIMD ! { dg-error "Unexpected !.OMP END PARALLEL DO SIMD" } + +!$omp loop +!$omp end PARALLEL LOOP ! { dg-error "Unexpected !.OMP END PARALLEL LOOP" } + +!$omp end PARALLEL MASKED ! { dg-error "Unexpected !.OMP END PARALLEL MASKED" } + +!$omp end PARALLEL MASKED TASKLOOP ! { dg-error "Unexpected !.OMP END PARALLEL MASKED TASKLOOP" } + +!$omp end PARALLEL MASKED TASKLOOP SIMD ! { dg-error "Unexpected !.OMP END PARALLEL MASKED TASKLOOP SIMD" } + +!$omp end PARALLEL MASTER ! { dg-error "Unexpected !.OMP END PARALLEL MASTER" } + +!$omp end PARALLEL MASTER TASKLOOP ! { dg-error "Unexpected !.OMP END PARALLEL MASTER TASKLOOP" } + +!$omp end PARALLEL MASTER TASKLOOP SIMD ! { dg-error "Unexpected !.OMP END PARALLEL MASTER TASKLOOP SIMD" } + +!$omp end PARALLEL SECTIONS ! { dg-error "Unexpected !.OMP END PARALLEL SECTIONS" } + +!$omp end PARALLEL WORKSHARE ! { dg-error "Unexpected !.OMP END PARALLEL WORKSHARE" } + +!$omp end SCOPE ! { dg-error "Unexpected !.OMP END SCOPE" } + +!$omp end SECTIONS ! { dg-error "Unexpected !.OMP END SECTIONS" } + +!$omp end SIMD ! { dg-error "Unexpected !.OMP END SIMD" } + +!$omp end SINGLE ! { dg-error "Unexpected !.OMP END SINGLE" } + +!$omp end TARGET ! { dg-error "Unexpected !.OMP END TARGET" } + +!$omp end TARGET DATA ! { dg-error "Unexpected !.OMP END TARGET DATA" } + +!$omp end TARGET PARALLEL ! { dg-error "Unexpected !.OMP END TARGET PARALLEL" } + +!$omp end TARGET PARALLEL DO ! { dg-error "Unexpected !.OMP END TARGET PARALLEL DO" } + +!$omp end TARGET PARALLEL DO SIMD ! { dg-error "Unexpected !.OMP END TARGET PARALLEL DO SIMD" } + +!$omp end TARGET PARALLEL LOOP ! { dg-error "Unexpected !.OMP END TARGET PARALLEL LOOP" } + +!$omp end TARGET SIMD ! { dg-error "Unexpected !.OMP END TARGET SIMD" } + +!$omp end TARGET TEAMS ! { dg-error "Unexpected !.OMP END TARGET TEAMS" } + +!$omp end TARGET TEAMS DISTRIBUTE ! { dg-error "Unexpected !.OMP END TARGET TEAMS DISTRIBUTE" } + +!$omp end TARGET TEAMS DISTRIBUTE PARALLEL DO ! { dg-error "Unexpected !.OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO" } + +!$omp end TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD ! { dg-error "Unexpected !.OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD" } + +!$omp end TARGET TEAMS DISTRIBUTE SIMD ! { dg-error "Unexpected !.OMP END TARGET TEAMS DISTRIBUTE SIMD" } + +!$omp end TARGET TEAMS LOOP ! { dg-error "Unexpected !.OMP END TARGET TEAMS LOOP" } + +!$omp end TASK ! { dg-error "Unexpected !.OMP END TASK" } + +!$omp end TASKGROUP ! { dg-error "Unexpected !.OMP END TASKGROUP" } + +!$omp end TASKLOOP ! { dg-error "Unexpected !.OMP END TASKLOOP" } + +!$omp end TASKLOOP SIMD ! { dg-error "Unexpected !.OMP END TASKLOOP SIMD" } + +!$omp end TEAMS ! { dg-error "Unexpected !.OMP END TEAMS" } + +!$omp end TEAMS DISTRIBUTE ! { dg-error "Unexpected !.OMP END TEAMS DISTRIBUTE" } + +!$omp end TEAMS DISTRIBUTE PARALLEL DO ! { dg-error "Unexpected !.OMP END TEAMS DISTRIBUTE PARALLEL DO" } + +!$omp end TEAMS DISTRIBUTE PARALLEL DO SIMD ! { dg-error "Unexpected !.OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD" } + +!$omp end TEAMS DISTRIBUTE SIMD ! { dg-error "Unexpected !.OMP END TEAMS DISTRIBUTE SIMD" } + +!$omp end TEAMS LOOP ! { dg-error "Unexpected !.OMP END TEAMS LOOP" } + +!$omp end WORKSHARE ! { dg-error "Unexpected !.OMP END WORKSHARE" } + +end ! { dg-error "Unexpected END statement" } + +! { dg-error "Unexpected end of file" "" { target "*-*-*" } 0 } Index: Fortran/gfortran/regression/gomp/use_device_ptr-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/use_device_ptr-1.f90 @@ -0,0 +1,25 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } + +! PR fortran/98476 + +use iso_c_binding, only: c_ptr +implicit none (external, type) + +interface + subroutine bar(x) + import + type(c_ptr), value :: x + end +end interface + +type(c_ptr) :: x + +!$omp target data map(alloc: x) +!$omp target data use_device_ptr(x) + call bar(x) +!$omp end target data +!$omp end target data +end + +! { dg-final { scan-tree-dump-times "pragma omp target data use_device_ptr\\(x\\)" 1 "original" } } Index: Fortran/gfortran/regression/gomp/warn_truncated.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/warn_truncated.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-Wall" } +! +! PR fortran/94709 +! +! Check that 'Line truncated' gets printed as appropriate +! +c$omp target ! map() +c$omp end target + +c$omp target map() ! { dg-warning "Line truncated" } +c$acc declare map() +ca = 5 +c$omp end target + end Index: Fortran/gfortran/regression/gomp/warn_truncated.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/warn_truncated.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! +! PR fortran/94709 +! +! Check that 'Line truncated' gets printed as appropriate +! +integer i +i = 0 +!$omp target ! map() +!$omp end target + +!$omp target map() ! { dg-error "Line truncated" } +!$acc kernels copy() +!a = 5 +!$acc end kernels +!$omp end target +end + +! { dg-message "some warnings being treated as errors" "" {target "*-*-*"} 0 } Index: Fortran/gfortran/regression/gomp/workshare-59.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-59.f90 @@ -0,0 +1,26 @@ +! PR fortran/100633 + +module defined_assign + interface assignment(=) + module procedure work_assign + end interface + + contains + subroutine work_assign(a,b) + integer, intent(out) :: a + logical, intent(in) :: b(:) + end subroutine work_assign +end module defined_assign + +program omp_workshare + use defined_assign + + integer :: a + logical :: l(10) + l = .TRUE. + + !$omp workshare + a = l ! { dg-error "Expected intrinsic assignment in OMP WORKSHARE" } + !$omp end workshare + +end program omp_workshare Index: Fortran/gfortran/regression/gomp/workshare-reduction-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-1.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 0, 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_maybe_nonmonotonic_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-10.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-11.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-11.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 2, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-12.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483650|-2147483646), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-13.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-13.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 2, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-14.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-14.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 2, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-15.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-15.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483650|-2147483646), 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-16.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-16.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 2, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-17.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-17.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 3, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-18.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483651|-2147483645), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-19.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-19.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 3, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-2.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483648|-2147483648), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-20.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-20.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 3, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-21.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-21.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483651|-2147483645), 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-22.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-22.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, 3, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-23.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-23.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-24.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-24.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-25.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-25.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-26.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-26.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 0, 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_maybe_nonmonotonic_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-27.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, (?:2147483648|-2147483648), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-28.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 4, 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-29.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-29.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-3.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 4, 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: runtime) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-30.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-30.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-31.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-31.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-32.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-32.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-33.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-33.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-34.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-34.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-35.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-35.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-36.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-36.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 2, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-37.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-37.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, (?:2147483650|-2147483646), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-38.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-38.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 2, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: dynamic) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-39.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-39.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 2, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-4.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-40.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-40.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, (?:2147483650|-2147483646), 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-41.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-41.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 2, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: dynamic, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-42.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-42.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 3, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-43.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-43.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, (?:2147483651|-2147483645), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-44.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-44.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 3, 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: guided) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-45.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-45.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 3, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-46.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-46.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, (?:2147483651|-2147483645), 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-47.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-47.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_start \[^\n\r]*, 3, 3, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_nonmonotonic_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: guided, 3) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-48.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-48.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-49.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-49.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-5.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-50.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-50.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop_ull\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: auto) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-51.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-51.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_start \[^\n\r]*, (?:2147483648|-2147483648), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_start " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered reduction (task, *: j) schedule (runtime) + do i = a, b, c + call bar (j) + !$omp ordered + j = j + 1 + !$omp end ordered + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-52.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-52.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_start \[^\n\r]*, (?:2147483649|-2147483647), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_start " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_static_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered reduction (task, *: j) + do i = a, b, c + call bar (j) + !$omp ordered + j = j + 1 + !$omp end ordered + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-53.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-53.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_start \[^\n\r]*, (?:2147483650|-2147483646), 4, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_start " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered reduction (task, *: j) schedule (dynamic, 4) + do i = a, b, c + call bar (j) + !$omp ordered + j = j + 1 + !$omp end ordered + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-54.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-54.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_start \[^\n\r]*, (?:2147483651|-2147483645), 6, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_start " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_ordered_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_ordered_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered reduction (task, *: j) schedule (guided, 6) + do i = a, b, c + call bar (j) + !$omp ordered + j = j + 1 + !$omp end ordered + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-55.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-55.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_doacross_start \[^\n\r]*, (?:2147483648|-2147483648), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross_post " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross_wait " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_runtime_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered(1) reduction (task, *: j) schedule (runtime) + do i = a, b, c + call bar (j) + !$omp ordered depend(sink: i - 1) + j = j + 1 + !$omp ordered depend(source) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-56.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-56.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_doacross_start \[^\n\r]*, (?:2147483649|-2147483647), 0, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross(?:_ull)?_post " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross(?:_ull)?_wait " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_static_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do ordered(1) reduction (task, *: j) + do i = a, b, c + call bar (j) + !$omp ordered depend(sink: i - 1) + j = j + 1 + !$omp ordered depend(source) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-57.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-57.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_doacross_start \[^\n\r]*, (?:2147483650|-2147483646), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross(?:_ull)?_post " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross(?:_ull)?_wait " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop(?:_ull)?_dynamic_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer(8) :: j + interface + subroutine bar(i) + integer(8) :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer(8) :: a, b ,c + integer(8) :: i + !$omp parallel + !$omp do ordered(1) reduction (task, *: j) schedule (dynamic) + do i = a, b, c + call bar (j) + !$omp ordered depend(sink: i - 1) + j = j + 1 + !$omp ordered depend(source) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-58.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-58.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_doacross_start \[^\n\r]*, (?:2147483651|-2147483645), 1, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross_post " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_doacross_wait " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_guided_next " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do ordered(1) reduction (task, *: j) schedule (guided) + do i = a, b, c + call bar (j) + !$omp ordered depend(sink: i - 1) + j = j + 1 + !$omp ordered depend(source) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-6.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-7.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (nonmonotonic: static) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-8.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare-reduction-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare-reduction-9.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O2 -fopenmp -fdump-tree-optimized" } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_start \[^\n\r]*, (?:2147483649|-2147483647), 0, 0B, 0B, " 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_loop_end " 1 "optimized" } } +! { dg-final { scan-tree-dump-not "__builtin_GOMP_loop\[^\n\r]*_next " "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_workshare_task_reduction_unregister \\(0\\)" 1 "optimized" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_parallel " 1 "optimized" } } + +module m + implicit none (type, external) + integer :: j + interface + subroutine bar(i) + integer :: i + end subroutine + end interface +end module m + +subroutine foo(a, b, c) + use m + implicit none (type, external) + integer :: a, b ,c + integer :: i + !$omp parallel + !$omp do reduction (task, *: j) schedule (monotonic: static, 2) + do i = a, b, c + j = j + 1 + call bar (j) + end do + !$omp end parallel +end Index: Fortran/gfortran/regression/gomp/workshare1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare1.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } + +interface + subroutine foo + end subroutine + function bar () + integer :: bar + end function bar + elemental function baz () + integer :: baz + end function baz +end interface + + integer :: i, j + real :: a, b (10), c + a = 0.5 + b = 0.25 +!$omp parallel workshare + a = sin (a) + b = sin (b) + forall (i = 1:10) b(i) = cos (b(i)) - 0.5 + j = baz () +!$omp parallel if (bar () .gt. 2) & +!$omp & num_threads (bar () + 1) + i = bar () +!$omp end parallel +!$omp parallel do schedule (static, bar () + 4) + do j = 1, 10 + i = bar () + end do +!$omp end parallel do +!$omp end parallel workshare +!$omp parallel workshare + call foo ! { dg-error "CALL statement" } + i = bar () ! { dg-error "non-ELEMENTAL" } +!$omp critical + i = bar () ! { dg-error "non-ELEMENTAL" } +!$omp end critical +!$omp atomic + j = j + bar () ! { dg-error "non-ELEMENTAL" } +!$omp end parallel workshare +end Index: Fortran/gfortran/regression/gomp/workshare2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare2.f90 @@ -0,0 +1,52 @@ +! { dg-do compile } +! { dg-options "-fopenmp -ffrontend-optimize -fdump-tree-original" } +! PR 50690 - this used to ICE because workshare could not handle +! BLOCKs. +! To test for correct execution, run this program (but don't forget +! to unset the stack limit). +program foo + implicit none + integer, parameter :: n = 10000000 + real, parameter :: eps = 3e-7 + integer :: i,j + real :: A(n), B(5), C(n) + real :: tmp + B(1) = 3.344 + tmp = B(1) + do i=1,10 + call random_number(a) + c = a + !$omp parallel default(shared) + !$omp workshare + A(:) = A(:)*cos(B(1))+A(:)*cos(B(1)) + !$omp end workshare nowait + !$omp end parallel ! sync is implied here + end do + + c = c*tmp + c*tmp + + do j=1,n + if (abs(a(j)-c(j)) > eps) then + print *,1,j,a(j), c(j) + STOP 1 + end if + end do + + do i=1,10 + call random_number(a) + c = a + !$omp parallel workshare default(shared) + A(:) = A(:)*cos(B(1))+A(:)*cos(B(1)) + !$omp end parallel workshare + end do + + c = c*tmp + c*tmp + do j=1,n + if (abs(a(j)-c(j)) > eps) then + print *,2,j,a(j), c(j) + STOP 2 + end if + end do + +end program foo +! { dg-final { scan-tree-dump-times "__var" 0 "original" } } Index: Fortran/gfortran/regression/gomp/workshare3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/gomp/workshare3.f90 @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-ffrontend-optimize -fdump-tree-original -fopenmp" } +! Test that common function elimination is done within the OMP parallel +! blocks even if there is a workshare around it. +program foo + implicit none + integer, parameter :: n = 10000000 + real, parameter :: eps = 3e-7 + integer :: i,j + real :: A(n), B(5), C(n) + real :: tmp + B(1) = 3.344 + tmp = B(1) + do i=1,10 + call random_number(a) + c = a + !$omp parallel workshare + !$omp parallel default(shared) + !$omp do + do j=1,n + A(j) = A(j)*cos(B(1))+A(j)*cos(B(1)) + end do + !$omp end do + !$omp end parallel + !$omp end parallel workshare + end do + + c = c*cos(b(1))+ c*cos(b(1)) + + do j=1,n + if (abs(a(j)-c(j)) > eps) then + print *,1,j,a(j), c(j) + STOP 1 + end if + end do + +end program foo +! { dg-final { scan-tree-dump-times "__builtin_cosf" 2 "original" } } Index: Fortran/gfortran/regression/graphite/PR53852.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/PR53852.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -O2 -ffast-math" } +! PR53852 : compile time / memory hog +SUBROUTINE build_d_tensor_gks(d5f,v,d5) + INTEGER, PARAMETER :: dp=8 + REAL(KIND=dp), DIMENSION(3, 3, 3, 3, 3), & + INTENT(OUT) :: d5f + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: v + REAL(KIND=dp), INTENT(IN) :: d5 + INTEGER :: k1, k2, k3, k4, k5 + REAL(KIND=dp) :: w + + d5f = 0.0_dp + DO k1=1,3 + DO k2=1,3 + DO k3=1,3 + DO k4=1,3 + DO k5=1,3 + d5f(k5,k4,k3,k2,k1)=d5f(k5,k4,k3,k2,k1)+ & + v(k1)*v(k2)*v(k3)*v(k4)*v(k5)*d5 + ENDDO + w=v(k1)*v(k2)*v(k3)*d4 + d5f(k1,k2,k3,k4,k4)=d5f(k1,k2,k3,k4,k4)+w + d5f(k1,k2,k4,k3,k4)=d5f(k1,k2,k4,k3,k4)+w + d5f(k1,k4,k2,k3,k4)=d5f(k1,k4,k2,k3,k4)+w + d5f(k4,k1,k2,k3,k4)=d5f(k4,k1,k2,k3,k4)+w + d5f(k1,k2,k4,k4,k3)=d5f(k1,k2,k4,k4,k3)+w + d5f(k1,k4,k2,k4,k3)=d5f(k1,k4,k2,k4,k3)+w + d5f(k4,k1,k2,k4,k3)=d5f(k4,k1,k2,k4,k3)+w + d5f(k1,k4,k4,k2,k3)=d5f(k1,k4,k4,k2,k3)+w + d5f(k4,k1,k4,k2,k3)=d5f(k4,k1,k4,k2,k3)+w + d5f(k4,k4,k1,k2,k3)=d5f(k4,k4,k1,k2,k3)+w + ENDDO + ENDDO + ENDDO + ENDDO +END SUBROUTINE build_d_tensor_gks Index: Fortran/gfortran/regression/graphite/PR67518.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/PR67518.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -O2 -ffast-math" } +! PR67518 : isl: position out of bounds +MODULE ao_util + INTEGER, PARAMETER :: dp=8 +CONTAINS + FUNCTION exp_radius(l,alpha,threshold,prefactor,epsin) RESULT(radius) + REAL(KIND=dp), INTENT(IN) :: alpha, threshold, prefactor + REAL(KIND=dp), INTENT(IN), OPTIONAL :: epsin + DO + IF (iter.gt.maxiter) THEN + CALL stop_program(routineN,moduleN,1,"exceeded") + ENDIF + ENDDO + CALL stop_program(routineN,moduleN,1,"exceeded") + END FUNCTION exp_radius + FUNCTION exp_radius_very_extended(la_min,la_max,lb_min,lb_max,pab,o1,o2,ra,rb,rp,& + zetp,eps,prefactor,cutoff,epsin) RESULT(radius) + REAL(KIND=dp), DIMENSION(:, :), & + OPTIONAL, POINTER :: pab + REAL(KIND=dp), INTENT(IN) :: ra(3), rb(3), rp(3), zetp, & + eps, prefactor, cutoff + REAL(KIND=dp) :: bini, binj, coef(0:20), & + epsin_local, polycoef(0:60), & + rad_b, s1, s2 + IF (PRESENT(pab)) THEN + ENDIF + DO lxa=0,la_max + DO lxb=0,lb_max + coef(0:la_max+lb_max)=0.0_dp + DO i=0,lxa + DO j=0,lxb + coef(lxa+lxb-i-j)=coef(lxa+lxb-i-j) + bini*binj*s1*s2 + ENDDO + ENDDO + DO i=0,lxa+lxb + polycoef(i)=MAX(polycoef(i),coef(i)) + ENDDO + ENDDO + ENDDO + DO i=0,la_max+lb_max + radius=MAX(radius,exp_radius(i,zetp,eps,polycoef(i),epsin_local) ) + ENDDO + END FUNCTION exp_radius_very_extended +END MODULE ao_util Index: Fortran/gfortran/regression/graphite/block-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/block-1.f90 @@ -0,0 +1,11 @@ +subroutine matrix_multiply(a,b,c,n) + +real(8), dimension(n,n) :: a,b,c + +! The following code is disabled for the moment. +c=0.d0 + +end subroutine matrix_multiply + +! Disabled for now as it requires delinearization. +! { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/block-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/block-2.f @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } + SUBROUTINE MATRIX_MUL_UNROLLED (A, B, C, L, M, N) + DIMENSION A(L,M), B(M,N), C(L,N) + + DO 100 K = 1, N + DO 100 I = 1, L + C(I,K) = 0. +100 CONTINUE + DO 110 J = 1, M, 4 + DO 110 K = 1, N + DO 110 I = 1, L + C(I,K) = C(I,K) + A(I,J) * B(J,K) + $ + A(I,J+1) * B(J+1,K) + A(I,J+2) * B(J+2,K) + $ + A(I,J+3) * B(J+3,K) +110 CONTINUE + + RETURN + END + +! Disabled for now as it requires delinearization. +! { dg-final { scan-tree-dump-times "number of SCoPs: 2" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/block-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/block-3.f90 @@ -0,0 +1,17 @@ +subroutine matrix_multiply(a,b,c,n) + +real(8), dimension(n,n) :: a,b,c + +do i = 1,n + do j = 1,n + do k = 1,n + c(j,i) = c(j,i) + a(k,i) * b(j,k) + enddo + enddo +enddo + +end subroutine matrix_multiply + +! { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "will be loop blocked" 1 "graphite" { xfail *-*-* } } } + Index: Fortran/gfortran/regression/graphite/block-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/block-4.f90 @@ -0,0 +1,20 @@ +subroutine matrix_multiply(a,b,c,n) + +real(8), dimension(n,n) :: a,b,c + +! The following code is disabled for the moment. +! c=0.d0 + +do i = 1,n + do j = 1,n + do k = 1,n + c(j,i) = c(j,i) + a(k,i) * b(j,k) + enddo + enddo +enddo + +end subroutine matrix_multiply + +! { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } +! { dg-final { scan-tree-dump-times "will be loop blocked" 1 "graphite" { xfail *-*-* } } } + Index: Fortran/gfortran/regression/graphite/graphite.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/graphite.exp @@ -0,0 +1,82 @@ +# Copyright (C) 2008-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp + +if ![check_effective_target_fgraphite] { + return +} + +# Remove VALUE from LIST_VARIABLE. +proc lremove {list_variable value} { + upvar 1 $list_variable var + set idx [lsearch -exact $var $value] + set var [lreplace $var $idx $idx] +} + +# The default action for a test is 'compile'. Save current default. +global dg-do-what-default +set save-dg-do-what-default ${dg-do-what-default} + +# Initialize `dg'. +dg-init + +set wait_to_run_files [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] +set id_files [lsort [glob -nocomplain $srcdir/$subdir/id-*.\[fF\]{,90,95,03,08} ] ] +set opt_files [lsort [glob -nocomplain $srcdir/$subdir/interchange-*.\[fF\]{,90,95,03,08} \ + $srcdir/$subdir/block-*.\[fF\]{,90,95,03,08} ] ] +set scop_files [lsort [glob -nocomplain $srcdir/$subdir/scop-*.\[fF\]{,90,95,03,08} ] ] +set run_id_files [lsort [glob -nocomplain $srcdir/$subdir/run-id-*.\[fF\]{,90,95,03,08} ] ] +set vect_files [lsort [glob -nocomplain $srcdir/$subdir/vect-*.\[fF\]{,90,95,03,08} ] ] + +# Tests to be compiled. +set dg-do-what-default compile +gfortran-dg-runtest $scop_files "" "-O2 -fgraphite -fdump-tree-graphite-all" +gfortran-dg-runtest $id_files "" "-O2 -fgraphite-identity -ffast-math" +gfortran-dg-runtest $opt_files "" "-O2 -floop-nest-optimize -ffast-math -fdump-tree-graphite-all" + +# Set up a list of effective targets to run vector tests for all supported +# targets. +global EFFECTIVE_TARGETS +set EFFECTIVE_TARGETS "" + +# Vectorizer tests, to be run or compiled, depending on target capabilities. +if [check_vect_support_and_set_flags] { + et-dg-runtest gfortran-dg-runtest $vect_files "" \ + "-O2 -fgraphite-identity -ftree-vectorize -fno-vect-cost-model -fdump-tree-vect-details -ffast-math" +} + +# Tests to be run. +set dg-do-what-default run +gfortran-dg-runtest $run_id_files "" "-O2 -fgraphite-identity" + +# The default action for the rest of the files is 'compile'. +set dg-do-what-default compile +foreach f $id_files {lremove wait_to_run_files $f} +foreach f $opt_files {lremove wait_to_run_files $f} +foreach f $scop_files {lremove wait_to_run_files $f} +foreach f $run_id_files {lremove wait_to_run_files $f} +foreach f $vect_files {lremove wait_to_run_files $f} +gfortran-dg-runtest $wait_to_run_files "" "" + +# Clean up. +set dg-do-what-default ${save-dg-do-what-default} + +# All done. +dg-finish Index: Fortran/gfortran/regression/graphite/id-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-1.f90 @@ -0,0 +1,11 @@ +program NF +end program NF +subroutine mattest(nx,ny,nz,band1,band2,band3,stiffness,maxiter,targrms,method) + integer,parameter :: dpkind=kind(1.0D0) + character(*) :: method + real(dpkind),allocatable,dimension(:) :: ad,au1,au2,au3,x,b + allocate(ad(nxyz),au1(nxyz),au2(nxyz),au3(nxyz),x(nxyz),b(nxyz)) + au1(nx:nxyz:nx) = 0.0 + if ( method=='NFCG' ) then + endif +end subroutine mattest Index: Fortran/gfortran/regression/graphite/id-10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-10.f90 @@ -0,0 +1,11 @@ +subroutine foo ( uplo, ap, y ) + character*1 uplo + complex(kind((1.0d0,1.0d0))) ap( * ), y( * ) + if ( .not. scan( uplo, 'uu' )>0.and. & + .not. scan( uplo, 'll' )>0 )then + do 60, j = 1, n + y( j ) = y( j ) + dble( ap( kk ) ) + kk = kk + j + 60 continue + end if + end Index: Fortran/gfortran/regression/graphite/id-11.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-11.f @@ -0,0 +1,14 @@ + subroutine foo(bar) + dimension bar(100) + common l_ + 50 continue + do i=1,20 + bar(i)=0 + enddo + do 100 j=1,l_ + if(sum.gt.r) then + bar(n2)=j + end if + 100 continue + if(bar(4).ne.0) go to 50 + end Index: Fortran/gfortran/regression/graphite/id-12.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-12.f @@ -0,0 +1,19 @@ + subroutine foo(a) + logical bar + dimension a(12,2) + dimension b(12,8) + if(cd .eq. 1) then + if (bar) write(iw,*) norb + if(ef.ne.1) then + do i=1,norb + end do + end if + end if + do 400 j = 1,8 + b(i,j) = 0 + 400 continue + do 410 j=1,norb + a(i,j) = 0 + 410 continue + call rdrsym(b) + end Index: Fortran/gfortran/regression/graphite/id-13.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-13.f @@ -0,0 +1,12 @@ + DIMENSION FF(19) + COMMON UF(9) + CALL RYSNOD(K) + DO 150 K=2,N + JMAX=K-1 + DUM = ONE/FF(1) + DO 110 J=1,JMAX + DUM=DUM+POLY*POLY + 110 CONTINUE + 150 CONTINUE + UF(K)=DUM/(ONE-DUM) + END Index: Fortran/gfortran/regression/graphite/id-14.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-14.f @@ -0,0 +1,20 @@ + SUBROUTINE ORDORB(IORBTP,IORBCD) + LOGICAL MASWRK + DIMENSION IORBTP(12,12) + DIMENSION IORBCD(12) + DIMENSION NSYMTP(12,8) + IF (MASWRK) WRITE(IW) K,NORB + DO 280 I=1,NFZV + IORBCD(K+I) = 3 + 280 CONTINUE + DO 420 I = 1,NTPS + DO 400 J = 1,8 + NSYMTP(I,J) = 0 + 400 CONTINUE + DO 410 J=1,NORB + IORBTP(I,J) = 0 + 410 CONTINUE + 420 CONTINUE + CALL RDRSYM(ICODE,NSYMTP,NSYM) + 9055 FORMAT(I5) + END Index: Fortran/gfortran/regression/graphite/id-15.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-15.f @@ -0,0 +1,16 @@ + SUBROUTINE ORDORB(IORBTP) + LOGICAL MASWRK + DIMENSION IORBTP(12,12) + DIMENSION NSYMTP(12,8) + IF (MASWRK) WRITE(IW) K,NORB + DO 420 I = 1,NTPS + DO 400 J = 1,8 + NSYMTP(I,J) = 0 + 400 CONTINUE + DO 410 J=1,NORB + IORBTP(I,J) = 0 + 410 CONTINUE + 420 CONTINUE + CALL RDRSYM(ICODE,NSYMTP,NSYM) + 9055 FORMAT(I5) + END Index: Fortran/gfortran/regression/graphite/id-16.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-16.f @@ -0,0 +1,10 @@ + SUBROUTINE BFN(X,BF) + DIMENSION BF(13) + DIMENSION FACT(17) + DO 70 M=0,LAST + XF = 1 + IF(M.NE.0) XF = FACT(M) + Y = Y + XF + 70 CONTINUE + BF(1)=Y + END Index: Fortran/gfortran/regression/graphite/id-17.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-17.f @@ -0,0 +1,16 @@ + SUBROUTINE SPECTOP(Dr,N) + DIMENSION d1(0:32,0:32) , Dr(0:32,0:32) , x(0:32) + DO k = 0 , N + fctr2 = o + DO j = 0 , N + fctr = fctr1*fctr2 + IF ( j.NE.k ) THEN + d1(k,j) = ck*fctr/(cj*(x(k)-x(j))) + ENDIF + fctr2 = -o*fctr2 + ENDDO + DO j = 0 , N + Dr(k,j) = d1(N-k,N-j) + ENDDO + ENDDO + END Index: Fortran/gfortran/regression/graphite/id-18.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-18.f90 @@ -0,0 +1,25 @@ +MODULE spherical_harmonics + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 ) +CONTAINS + FUNCTION dlegendre (x, l, m) RESULT (dplm) + SELECT CASE ( l ) + CASE ( 0 ) + dplm = 0.0_dp + CASE ( 1 ) + dplm = 1.0_dp + CASE DEFAULT + IF ( mm > 0 ) THEN + dpmm = -m + DO im = 1, mm + dpmm = -dpmm + END DO + IF ( l == mm + 1 ) THEN + DO il = mm + 2, l + dpll = dpmm + END DO + dplm = dpll + END IF + END IF + END SELECT + END FUNCTION dlegendre +END MODULE spherical_harmonics Index: Fortran/gfortran/regression/graphite/id-19.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-19.f @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } + SUBROUTINE ECCODR(FPQR) + DIMENSION FPQR(25,25,25) + INTEGER P,Q,R + DIMENSION REC(73) + DO 150 P=1,N4MAX,2 + QM2=-ONE + DO 140 Q=1,N4MAX,2 + DO 130 R=1,N4MAX,2 + IF(P.GT.1) THEN + FPQR(P,Q,R)= QM2*FPQR(P,Q-2,R)*REC(P+Q-2+R) + END IF + 130 RM2= RM2+TWO + 140 QM2= QM2+TWO + 150 PM2= PM2+TWO + END Index: Fortran/gfortran/regression/graphite/id-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-2.f90 @@ -0,0 +1,13 @@ +module solv_cap + integer, parameter, public :: dp = selected_real_kind(5) +contains + subroutine prod0( G, X ) + real(kind=dp), intent(in out), dimension(:,:) :: X + real(kind=dp), dimension(size(X,1),size(X,2)) :: Y + X = Y + end subroutine prod0 + function Ginteg(xq1,yq1, xq2,yq2, xp,yp) result(G) + end function Ginteg + subroutine fourir(A,ntot,kconjg, E,useold) + end subroutine fourir +end module solv_cap Index: Fortran/gfortran/regression/graphite/id-20.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-20.f @@ -0,0 +1,10 @@ +! { dg-options "-O3 -ffast-math -std=legacy" } + + DIMENSION FPQR(25,25,25) + INTEGER P,Q,R + DO 130 R=1,N4MAX,2 + IF(P.GT.1) THEN + FPQR(P,Q,R)= RM2*FPQR(P,Q,R-2)*REC(P+Q+R-2) + END IF + 130 RM2= RM2+TWO + END Index: Fortran/gfortran/regression/graphite/id-21.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-21.f @@ -0,0 +1,20 @@ + MODULE LES3D_DATA + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:) :: + > P, T, H + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:) :: + > HF + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:,:) :: + > Q + END MODULE LES3D_DATA + USE LES3D_DATA + DO K = 1, KMAX - 1 + DO J = 1, JMAX - 1 + DO I = 1, I2 + T(I,J,K) = (EI - HF(I,J,K,1)) / HF(I,J,K,3) + ENDDO + P(1:I2,J,K) = Q(1:I2,J,K,1,M) * HF(1:I2,J,K,4) * T(1:I2,J,K) + IF(ISGSK .EQ. 1) H(1:I2,J,K) = + > (Q(1:I2,J,K,5,M) + P(1:I2,J,K)) + END DO + ENDDO + END Index: Fortran/gfortran/regression/graphite/id-22.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-22.f @@ -0,0 +1,10 @@ +! { dg-options "-O3 -ffast-math" } + + COMMON /NONEQ / UNZOR + DO ITS = 1, NTS + DO JATOM = 1, NAT + IF(IEF.EQ.5.OR.IEF.EQ.8) + * UNZOR = UNZOR + 8 + ENDDO + ENDDO + END Index: Fortran/gfortran/regression/graphite/id-23.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-23.f @@ -0,0 +1,13 @@ + SUBROUTINE CAMB(RX2,RTX,NUM) + DIMENSION RX2(NUM,NUM),RTX(NUM,NUM) + DO I=1,NUM + DO J=1,I + DO M=1,NUM + RX2(I,J)=RX2(I,J)+RTX(M,I) + END DO + END DO + END DO + IF (RX2(I,1).LE.EIGCT2) THEN + RTX(I,1)=4.0D+00 + END IF + END Index: Fortran/gfortran/regression/graphite/id-24.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-24.f @@ -0,0 +1,9 @@ + SUBROUTINE TFTRAB(A,NA) + DIMENSION A(NA,NA) + DO 160 K=1,NA + DUM = DUM + A(K,I) + 160 CONTINUE + DO 180 I=1,NA + A(I,J) = DUM + 180 CONTINUE + END Index: Fortran/gfortran/regression/graphite/id-25.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-25.f @@ -0,0 +1,10 @@ + SUBROUTINE TFTRAB(NA,NC,D,WRK) + DIMENSION D(NA,NC), WRK(NA) + DO 160 K=1,NA + DUM = DUM + D(K,J) + 160 CONTINUE + WRK(I) = DUM + DO 180 I=1,NA + D(I,J) = WRK(I) + 180 CONTINUE + END Index: Fortran/gfortran/regression/graphite/id-26.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-26.f03 @@ -0,0 +1,132 @@ +! { dg-options "-fcray-pointer -floop-nest-optimize" } + + use iso_c_binding, only : c_ptr, c_ptrdiff_t, c_loc + interface + subroutine foo (x, y, z, w) + use iso_c_binding, only : c_ptr + real, pointer :: x(:), y(:), w(:) + type(c_ptr) :: z + end subroutine + subroutine bar (x, y, z, w) + use iso_c_binding, only : c_ptr + real, pointer :: x(:), y(:), w(:) + type(c_ptr) :: z + end subroutine + subroutine baz (x, c) + real, pointer :: x(:) + real, allocatable :: c(:) + end subroutine + end interface + type dt + real, allocatable :: a(:) + end type + type (dt) :: b(64) + real, target :: a(4096+63) + real, pointer :: p(:), q(:), r(:), s(:) + real, allocatable :: c(:) + integer(c_ptrdiff_t) :: o + integer :: i + o = 64 - mod (loc (a), 64) + if (o == 64) o = 0 + o = o / sizeof(0.0) + p => a(o + 1:o + 1024) + q => a(o + 1025:o + 2048) + r => a(o + 2049:o + 3072) + s => a(o + 3073:o + 4096) + do i = 1, 1024 + p(i) = i + q(i) = i + r(i) = i + s(i) = i + end do + call foo (p, q, c_loc (r(1)), s) + do i = 1, 1024 + if (p(i) /= i * i + 3 * i + 2) STOP 1 + p(i) = i + end do + call bar (p, q, c_loc (r(1)), s) + do i = 1, 1024 + if (p(i) /= i * i + 3 * i + 2) STOP 2 + end do + ! Attempt to create 64-byte aligned allocatable + do i = 1, 64 + allocate (c(1023 + i)) + if (iand(int(loc(c(1)), 8), 63_8) == 0) exit + deallocate (c) + allocate (b(i)%a(1023 + i)) + allocate (c(1023 + i)) + if (iand(int(loc(c(1)), 8), 63_8) == 0) exit + deallocate (c) + end do + if (allocated (c)) then + do i = 1, 1024 + c(i) = 2 * i + end do + call baz (p, c) + do i = 1, 1024 + if (p(i) /= i * i + 5 * i + 2) STOP 3 + end do + end if +end +subroutine foo (x, y, z, w) + use iso_c_binding, only : c_ptr, c_f_pointer + real, pointer :: x(:), y(:), w(:), p(:) + type(c_ptr) :: z + integer :: i + real :: pt(1024) + pointer (ip, pt) + ip = loc (w) +!$omp simd aligned (x, y : 64) + do i = 1, 1024 + x(i) = x(i) * y(i) + 2.0 + end do +!$omp simd aligned (x, z : 64) private (p) + do i = 1, 1024 + call c_f_pointer (z, p, shape=[1024]) + x(i) = x(i) + p(i) + end do +!$omp simd aligned (x, ip : 64) + do i = 1, 1024 + x(i) = x(i) + 2 * pt(i) + end do +!$omp end simd +end subroutine +subroutine bar (x, y, z, w) + use iso_c_binding, only : c_ptr, c_f_pointer + real, pointer :: x(:), y(:), w(:), a(:), b(:) + type(c_ptr) :: z, c + integer :: i + real :: pt(1024) + pointer (ip, pt) + ip = loc (w) + a => x + b => y + c = z +!$omp simd aligned (a, b : 64) + do i = 1, 1024 + a(i) = a(i) * b(i) + 2.0 + end do +!$omp simd aligned (a, c : 64) + do i = 1, 1024 + block + real, pointer :: p(:) + call c_f_pointer (c, p, shape=[1024]) + a(i) = a(i) + p(i) + end block + end do +!$omp simd aligned (a, ip : 64) + do i = 1, 1024 + a(i) = a(i) + 2 * pt(i) + end do +!$omp end simd +end subroutine +subroutine baz (x, c) + real, pointer :: x(:) + real, allocatable :: c(:) + integer :: i +!$omp simd aligned (x, c : 64) + do i = 1, 1024 + x(i) = x(i) + c(i) + end do +!$omp end simd +end subroutine baz Index: Fortran/gfortran/regression/graphite/id-27.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-27.f90 @@ -0,0 +1,41 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast -std=legacy" } +MODULE module_ra_gfdleta + INTEGER, PARAMETER :: NBLY=15 + REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), & + TABLE2(28,180),TABLE3(28,180),EM3(28,180), & + SOURCE(28,NBLY), DSRCE(28,NBLY) +CONTAINS + SUBROUTINE TABLE + INTEGER, PARAMETER :: NBLX=47 + INTEGER , PARAMETER:: NBLW = 163 + REAL :: & + SUM(28,180),PERTSM(28,180),SUM3(28,180), & + SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), & + DBDTNB(28,NBLW) + REAL :: & + ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), & + TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), & + R1T(28),R2(28),S2(28),T3(28),R1WD(28) + REAL :: EXPO(180),FAC(180) + I = 0 + DO 417 J=121,180 + FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) +417 CONTINUE + DO 421 J=121,180 + SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J) +421 CONTINUE + IF (CENT.GT.160. .AND. CENT.LT.560.) THEN + DO 420 J=1,180 + DO 420 I=1,28 + SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J) +420 CONTINUE + ENDIF + DO 433 J=121,180 + EM3(I,J)=SUM3(I,J)/FORTCU(I) +433 CONTINUE + DO 501 I=1,28 + EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I) +501 CONTINUE + END SUBROUTINE TABLE + END MODULE module_RA_GFDLETA Index: Fortran/gfortran/regression/graphite/id-28.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-28.f90 @@ -0,0 +1,15 @@ +! Verify we elide modulo operations we cannot represent +module OPMATRIX_MODULE + implicit none + type opmatrix_type + real(kind=kind(1.0d0)), dimension(:,:), pointer :: restricted + end type + interface zero_ + module procedure zero + end interface +contains + subroutine zero(self) + type(opmatrix_type) :: self + self%restricted = 0.0d0 + end subroutine +end Index: Fortran/gfortran/regression/graphite/id-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-3.f90 @@ -0,0 +1,19 @@ +subroutine gentrs (ptrst, ncls, xmin, dcls, xdont, ndon) +do icls1 = 1, ncls + prec: do + select case (isns) + case (-1) + do icls = icls1, 1, -1 + enddo + case (+1) + do icls = icls1, ncls + if (xale > rtrst (icls1, icls)) then + endif + enddo + end select + enddo prec +enddo +contains +real function genuni (jsee) +end function genuni +end subroutine gentrs Index: Fortran/gfortran/regression/graphite/id-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-4.f90 @@ -0,0 +1,32 @@ +MODULE Vcimage + CHARACTER (LEN=80), SAVE :: CARD, FIELD +END MODULE Vcimage +MODULE Vimage + LOGICAL, SAVE :: EOFF +END MODULE Vimage +SUBROUTINE READIN(PROB, TITLE, CSTOP, FCYCLE, DCYCLE, DHIST, VHIST& + & , IMAX, PHIST, DEBUG, NSTAT, STATS, MAXSTA, NCORE, PPLOT, & + & DPLOT, VPLOT, TPLOT, SLIST, D0, E0, NODES, SHEAT, GAMMA, COLD & + & , THIST, NVISC, SCREEN, WEIGHT, TSTOP, STABF) + USE Vcimage + USE Vimage + INTEGER, DIMENSION(MAXSTA) :: STATS + IF (.NOT.EOFF) THEN + IF (FIELD=='PROB' .OR. FIELD=='PROBLEM_NUMBER') THEN + CALL QSORT (STATS(1:NSTAT)) + WRITE (16, & + &'(//'' YOU HAVE REQUESTED A PRINTOUT OF THE STATION'', & + & '' ABORT''//)') + ENDIF + ENDIF +CONTAINS + RECURSIVE SUBROUTINE QSORT (LIST) + INTEGER, DIMENSION(:), INTENT(INOUT) :: LIST + INTEGER, DIMENSION(SIZE(LIST)) :: SMALLER,LARGER + IF (SIZE(LIST) > 1) THEN + LIST(NUMBER_SMALLER+1:NUMBER_SMALLER+NUMBER_EQUAL) = CHOSEN + CALL QSORT (LARGER(1:NUMBER_LARGER)) + LIST(NUMBER_SMALLER+NUMBER_EQUAL+1:) = LARGER(1:NUMBER_LARGER) + END IF + END SUBROUTINE QSORT +END SUBROUTINE READIN Index: Fortran/gfortran/regression/graphite/id-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-5.f @@ -0,0 +1,19 @@ + subroutine shell(Re,Pr,nx,ny,nz, + $nuim,nuex2,nuex4,cfl,scheme,conf,ni,maxit) + real*8 q(5,nx,ny,nz),dq(5,nx,ny,nz),rhs(5,nx,ny,nz),e(5,nx,ny,nz), + 1 f(5,nx,ny,nz),g(5,nx,ny,nz),ev(5,nx,ny,nz),fv(5,nx,ny,nz), + 2 gv(5,nx,ny,nz),diss(5,nx,ny,nz) + do k=1,nz + do j=1,ny + do i=1,nx + do l=1,5 + t1= -0.5d0*dt*( + 3 (g(l,i,j,kp1)-g(l,i,j,km1))/dz) + + 4 dt/Re*((ev(l,i,j,k)-ev(l,im1,j,k))/dx + + 6 (gv(l,i,j,k)-gv(l,i,j,km1))/dz) + rhs(l,i,j,k)=t1+t2 + enddo + enddo + enddo + enddo + end Index: Fortran/gfortran/regression/graphite/id-6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-6.f @@ -0,0 +1,22 @@ + SUBROUTINE EIJDEN(EPS,V,E,IA,WRK,L1,L2,L3,L0,ECI) + DIMENSION V(L1,L0),EPS(L2),E(*),IA(L1),WRK(L1),ECI(L0,L0) + IF(SCFTYP.EQ.RHF .AND. MPLEVL.EQ.0 .AND. + * CITYP.NE.GUGA .AND. CITYP.NE.CIS) THEN + CALL DCOPY(NORB,E(IADDE),1,E(IADD),1) + END IF + IF (CITYP.NE.GUGA) THEN + DO 500 I = 1,L1 + DO 430 L = 1,NORB + DO 420 K = 1,NORB + IF(K.LE.L) THEN + WRK(L) = WRK(L) - V(I,K)*ECI(K,L) + ELSE + WRK(L) = WRK(L) - V(I,K)*ECI(L,K) + END IF + 420 CONTINUE + 430 CONTINUE + DO 440 L = 1,NORB + 440 CONTINUE + 500 CONTINUE + END IF + END Index: Fortran/gfortran/regression/graphite/id-7.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-7.f @@ -0,0 +1,14 @@ + subroutine dasol(al,au,ad,b,jp,neq,energy) + real*8 al(*),au(*),ad(*),b(*),zero,energy,bd,dot + do 100 is=1,neq + if(b(is).ne.zero) go to 200 + 100 continue + return + 200 if(is.lt.neq) then + endif + do 400 j = is,neq + energy=energy+bd*b(j) + 400 continue + if(neq.gt.1)then + endif + end Index: Fortran/gfortran/regression/graphite/id-8.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-8.f @@ -0,0 +1,17 @@ + subroutine foo(mxgtot,mxsh) + logical b + dimension ex(mxgtot),cs(mxgtot) + do 500 jg = k1,ig + u = ex(ig)+ex(jg) + z = u*sqrt(u) + x = cs(ig)*cs(jg)/z + if (ig .eq. jg) go to 480 + x = x+x + 480 continue + y = y+x + 500 continue + if(y.gt.t) z=1/sqrt(y) + if (b) then + write(9) z + endif + end Index: Fortran/gfortran/regression/graphite/id-9.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-9.f @@ -0,0 +1,20 @@ + subroutine foo(bar) + real*8 bar(3,3),coefm + do ii=istart,iend + do i=1,21 + bar(k,l)=4 + enddo + do m=1,ne + do l=1,3 + do k=1,l + enddo + bar(k,l)=bar(k,l)+(v3b-1.d0) + enddo + enddo + do m=1,ne + do k=1,l + l = l*(v3b**(-coefm)) + enddo + enddo + enddo + end Index: Fortran/gfortran/regression/graphite/id-pr43354.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-pr43354.f @@ -0,0 +1,18 @@ + SUBROUTINE POFUN2(DIM,GRDENT,FPART,FPARTL) + DOUBLE PRECISION GRDENT(*) + DOUBLE COMPLEX FPART(*) + DOUBLE COMPLEX FPARTL(*) + INTEGER REFLCT,XRIREF + IF (DIM.GT.1) THEN + ABCS3=XRCELL(1) + IF (ABCS2.EQ.ABCS3) THEN + END IF + ELSE + DO REFLCT=1,XRIREF,1 + FPARTL(REFLCT)=FPART(REFLCT) + END DO + END IF + IF (ABCS2.EQ.ABCS3) THEN + GRDENT(1)=GRDENT(3) + END IF + END Index: Fortran/gfortran/regression/graphite/id-pr45370.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-pr45370.f90 @@ -0,0 +1,100 @@ +! + type :: t + real :: r + integer :: i + character(3) :: chr + end type t + + type :: t2 + real :: r(2, 2) + integer :: i + character(3) :: chr + end type t2 + + type :: s + type(t), pointer :: t(:) + end type s + + integer, parameter :: sh(2) = (/2,2/) + real, parameter :: a1(2,2) = reshape ((/1.0,2.0,3.0,4.0/),sh) + real, parameter :: a2(2,2) = reshape ((/5.0,6.0,7.0,8.0/),sh) + + type(t), target :: tar1(2) = (/t(1.0, 2, "abc"), t(3.0, 4, "efg")/) + character(4), target :: tar2(2) = (/"abcd","efgh"/) + type(s), target :: tar3 + character(2), target :: tar4(2) = (/"ab","cd"/) + type(t2), target :: tar5(2) = (/t2(a1, 2, "abc"), t2(a2, 4, "efg")/) + + integer, pointer :: ptr(:) + character(2), pointer :: ptr2(:) + real, pointer :: ptr3(:) + +!_______________component subreference___________ + ptr => tar1%i + ptr = ptr + 1 ! check the scalarizer is OK + + if (any (ptr .ne. (/3, 5/))) STOP 1 + if (any ((/ptr(1), ptr(2)/) .ne. (/3, 5/))) STOP 2 + if (any (tar1%i .ne. (/3, 5/))) STOP 3 + +! Make sure that the other components are not touched. + if (any (tar1%r .ne. (/1.0, 3.0/))) STOP 4 + if (any (tar1%chr .ne. (/"abc", "efg"/))) STOP 5 + +! Check that the pointer is passed correctly as an actual argument. + call foo (ptr) + if (any (tar1%i .ne. (/2, 4/))) STOP 6 + +! And that dummy pointers are OK too. + call bar (ptr) + if (any (tar1%i .ne. (/101, 103/))) STOP 7 + +!_______________substring subreference___________ + ptr2 => tar2(:)(2:3) + ptr2 = ptr2(:)(2:2)//"z" ! again, check the scalarizer + + if (any (ptr2 .ne. (/"cz", "gz"/))) STOP 8 + if (any ((/ptr2(1), ptr2(2)/) .ne. (/"cz", "gz"/))) STOP 9 + if (any (tar2 .ne. (/"aczd", "egzh"/))) STOP 10 + +!_______________substring component subreference___________ + ptr2 => tar1(:)%chr(1:2) + ptr2 = ptr2(:)(2:2)//"q" ! yet again, check the scalarizer + if (any (ptr2 .ne. (/"bq","fq"/))) STOP 11 + if (any (tar1%chr .ne. (/"bqc","fqg"/))) STOP 12 + +!_______________trailing array element subreference___________ + ptr3 => tar5%r(1,2) + ptr3 = (/99.0, 999.0/) + if (any (tar5(1)%r .ne. reshape ((/1.0,2.0,99.0,4.0/), sh))) STOP 13 + if (any (tar5(2)%r .ne. reshape ((/5.0,6.0,999.0,8.0/), sh))) STOP 14 + +!_______________forall assignment___________ + ptr2 => tar2(:)(1:2) + forall (i = 1:2) ptr2(i)(1:1) = "z" + if (any (tar2 .ne. (/"zczd", "zgzh"/))) STOP 15 + +!_______________something more complicated___________ + tar3%t => tar1 + ptr3 => tar3%t%r + ptr3 = cos (ptr3) + if (any (abs(ptr3 - (/cos(1.0_4), cos(3.0_4)/)) >= epsilon(1.0_4))) STOP 16 + + ptr2 => tar3%t(:)%chr(2:3) + ptr2 = " x" + if (any (tar1%chr .ne. (/"b x", "f x"/))) STOP 17 + +!_______________check non-subref works still___________ + ptr2 => tar4 + if (any (ptr2 .ne. (/"ab","cd"/))) STOP 18 + +contains + subroutine foo (arg) + integer :: arg(:) + arg = arg - 1 + end subroutine + subroutine bar (arg) + integer, pointer :: arg(:) + arg = arg + 99 + end subroutine +end Index: Fortran/gfortran/regression/graphite/id-pr46994.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-pr46994.f90 @@ -0,0 +1,14 @@ +! { dg-options "-O -ffast-math -fgraphite-identity -fno-tree-dce" } + +subroutine foo (m) + integer :: m, i, j, k + real :: s + s = 0 + do i = 1, 9 + do j = 1, 2*m + do k = 1, 2*m + s = s + 1 + end do + end do + end do +end subroutine foo Index: Fortran/gfortran/regression/graphite/id-pr46995.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-pr46995.f90 @@ -0,0 +1,16 @@ +! { dg-options "-O -ffast-math -fgraphite-identity -fno-tree-dce" } + +subroutine foo (m, l, zw) + integer :: m, i, j, k + real, dimension(1:9) :: zw + real :: l, s + s = 0 + do i = 1, 9 + do j = 1, 2*m + do k = 1, 2*m + s = s + 1 + end do + end do + l = l + zw(i)*s + end do +end subroutine foo Index: Fortran/gfortran/regression/graphite/id-pr47691.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/id-pr47691.f @@ -0,0 +1,7 @@ +! { dg-options "-O -fgraphite-identity -ffast-math -fno-tree-scev-cprop" } + dimension b(12,8) + do i=1,norb + end do + b(i,j) = 0 + call rdrsym(b) + end Index: Fortran/gfortran/regression/graphite/interchange-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/interchange-1.f @@ -0,0 +1,44 @@ + subroutine foo(f1,f2,f3,f4,f5,f6,f7,f8,f9,f0,g1,g2,g3) + implicit none + integer f4,f3,f2,f1 + integer g4,g5,g6,g7,g8,g9 + integer i1,i2,i3,i4,i5 + + real*8 g1(5,f3,f2,f1),g2(5,5,f3,f2,f1),g3(5,f3,f2,f1) + real*8 f0(5,5,f3,f2,f1),f9(5,5,f3,f2,f1),f8(5,5,f3,f2,f1) + real*8 f7(5,5,f3,f2,f1),f6(5,5,f3,f2,f1),f5(5,5,f3,f2,f1) + + do i3=1,f1 + g8=mod(i3+f1-2,f1)+1 + g9=mod(i3,f1)+1 + do i4=1,f2 + g6=mod(i4+f2-2,f2)+1 + g7=mod(i4,f2)+1 + do i5=1,f3 + g4=mod(i5+f3-2,f3)+1 + g5=mod(i5,f3)+1 + do i1=1,5 + g3(i1,i5,i4,i3)=0.0d0 + do i2=1,5 + g3(i1,i5,i4,i3)=g3(i1,i5,i4,i3)+ + 1 g2(i1,i2,i5,i4,i3)*g1(i2,i5,i4,i3)+ + 2 f0(i1,i2,i5,i4,i3)*g1(i2,g5,i4,i3)+ + 3 f9(i1,i2,i5,i4,i3)*g1(i2,i5,g7,i3)+ + 4 f8(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g9)+ + 5 f7(i1,i2,i5,i4,i3)*g1(i2,g4,i4,i3)+ + 6 f6(i1,i2,i5,i4,i3)*g1(i2,i5,g6,i3)+ + 7 f5(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g8) + enddo + enddo + enddo + enddo + enddo + return + end + + +! We should be able to interchange this as the number of iterations is +! known to be 4 in the inner two loops. See interchange-2.f for the +! kernel from bwaves. + +! { dg-final { scan-tree-dump-times "will be interchanged" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/interchange-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/interchange-2.f @@ -0,0 +1,42 @@ + subroutine foo(f1,f2,f3,f4,f5,f6,f7,f8,f9,f0,g1,g2,g3) + implicit none + integer f4,f3,f2,f1 + integer g4,g5,g6,g7,g8,g9 + integer i1,i2,i3,i4,i5 + + real*8 g1(f4,f3,f2,f1),g2(f4,f4,f3,f2,f1),g3(f4,f3,f2,f1) + real*8 f0(f4,f4,f3,f2,f1),f9(f4,f4,f3,f2,f1),f8(f4,f4,f3,f2,f1) + real*8 f7(f4,f4,f3,f2,f1),f6(f4,f4,f3,f2,f1),f5(f4,f4,f3,f2,f1) + + do i3=1,f1 + g8=mod(i3+f1-2,f1)+1 + g9=mod(i3,f1)+1 + do i4=1,f2 + g6=mod(i4+f2-2,f2)+1 + g7=mod(i4,f2)+1 + do i5=1,f3 + g4=mod(i5+f3-2,f3)+1 + g5=mod(i5,f3)+1 + do i1=1,f4 + g3(i1,i5,i4,i3)=0.0d0 + do i2=1,f4 + g3(i1,i5,i4,i3)=g3(i1,i5,i4,i3)+ + 1 g2(i1,i2,i5,i4,i3)*g1(i2,i5,i4,i3)+ + 2 f0(i1,i2,i5,i4,i3)*g1(i2,g5,i4,i3)+ + 3 f9(i1,i2,i5,i4,i3)*g1(i2,i5,g7,i3)+ + 4 f8(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g9)+ + 5 f7(i1,i2,i5,i4,i3)*g1(i2,g4,i4,i3)+ + 6 f6(i1,i2,i5,i4,i3)*g1(i2,i5,g6,i3)+ + 7 f5(i1,i2,i5,i4,i3)*g1(i2,i5,i4,g8) + enddo + enddo + enddo + enddo + enddo + return + end + +! This is the kernel extracted from bwaves: this cannot be interchanged +! as the number of iterations for f4 is not known. + +! { dg-final { scan-tree-dump-times "will be interchanged" 0 "graphite" } } Index: Fortran/gfortran/regression/graphite/interchange-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/interchange-3.f90 @@ -0,0 +1,25 @@ +! Formerly known as ltrans-7.f90 + +Program FOO + IMPLICIT INTEGER (I-N) + IMPLICIT REAL*8 (A-H, O-Z) + PARAMETER (N1=1335, N2=1335) + COMMON U(N1,N2), V(N1,N2), P(N1,N2) + + PC = 0.0D0 + UC = 0.0D0 + VC = 0.0D0 + + do I = 1, M + do J = 1, M + PC = PC + abs(P(I,J)) + UC = UC + abs(U(I,J)) + VC = VC + abs(V(I,J)) + end do + U(I,I) = U(I,I) * ( mod (I, 100) /100.) + end do + + write(6,366) PC, UC, VC +366 format(/, ' PC = ',E12.4,/,' UC = ',E12.4,/,' VC = ',E12.4,/) + +end Program FOO Index: Fortran/gfortran/regression/graphite/interchange-4.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/interchange-4.f @@ -0,0 +1,28 @@ + subroutine s231 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) +c +c loop interchange +c loop with multiple dimension recursion +c + integer ntimes, ld, n, i, nl, j + double precision a(n), b(n), c(n), d(n), e(n), aa(ld,n), + + bb(ld,n), cc(ld,n) + double precision chksum, cs2d + real t1, t2, second, ctime, dtime + + call init(ld,n,a,b,c,d,e,aa,bb,cc,'s231 ') + t1 = second() + do 1 nl = 1,ntimes/n + do 10 i=1,n + do 20 j=2,n + aa(i,j) = aa(i,j-1) + bb(i,j) + 20 continue + 10 continue + call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1.d0) + 1 continue + t2 = second() - t1 - ctime - ( dtime * float(ntimes/n) ) + chksum = cs2d(n,aa) + call check (chksum,(ntimes/n)*n*(n-1),n,t2,'s231 ') + return + end + +! { dg-final { scan-tree-dump-times "will be interchanged" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/interchange-5.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/interchange-5.f @@ -0,0 +1,29 @@ + subroutine s235 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) +c +c loop interchanging +c imperfectly nested loops +c + integer ntimes, ld, n, i, nl, j + double precision a(n), b(n), c(n), d(n), e(n), aa(ld,n), + + bb(ld,n), cc(ld,n) + double precision chksum, cs1d, cs2d + real t1, t2, second, ctime, dtime + + call init(ld,n,a,b,c,d,e,aa,bb,cc,'s235 ') + t1 = second() + do 1 nl = 1,ntimes/n + do 10 i = 1,n + a(i) = a(i) + b(i) * c(i) + do 20 j = 2,n + aa(i,j) = aa(i,j-1) + bb(i,j) * a(i) + 20 continue + 10 continue + call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1.d0) + 1 continue + t2 = second() - t1 - ctime - ( dtime * float(ntimes/n) ) + chksum = cs2d(n,aa) + cs1d(n,a) + call check (chksum,(ntimes/n)*n*(n-1),n,t2,'s235 ') + return + end + +! { dg-final { scan-tree-dump-times "will be interchanged" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/pr107865.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr107865.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O1 -floop-parallelize-all -ftree-parallelize-loops=2" } + + SUBROUTINE FNC (F) + + IMPLICIT REAL (A-H) + DIMENSION F(N) + + DO I = 1, 6 + DO J = 1, 6 + IF (J .NE. I) THEN + F(I) = F(I) + 1 + END IF + END DO + END DO + + RETURN + END Index: Fortran/gfortran/regression/graphite/pr14741.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr14741.f90 @@ -0,0 +1,27 @@ +! { dg-options "-O3 -ffast-math -floop-nest-optimize -floop-block -fdump-tree-graphite-all" } + + INTEGER, PARAMETER :: N=1024 + REAL*8 :: A(N,N), B(N,N), C(N,N) + REAL*8 :: t1,t2 + A=0.1D0 + B=0.1D0 + C=0.0D0 + CALL cpu_time(t1) + CALL mult(A,B,C,N) + CALL cpu_time(t2) + write(6,*) t2-t1,C(1,1) +END program + +SUBROUTINE mult(A,B,C,N) + REAL*8 :: A(N,N), B(N,N), C(N,N) + INTEGER :: I,J,K,N + DO J=1,N + DO I=1,N + DO K=1,N + C(I,J)=C(I,J)+A(I,K)*B(K,J) + ENDDO + ENDDO + ENDDO +END SUBROUTINE mult + +! { dg-final { scan-tree-dump "tiled by" "graphite" } } Index: Fortran/gfortran/regression/graphite/pr29290.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr29290.f90 @@ -0,0 +1,9 @@ +! PR tree-optimization/29290 +! { dg-do compile } +! { dg-options "-O3 -ftree-loop-linear" } + +subroutine pr29290 (a, b, c, d) + integer c, d + real*8 a(c,c), b(c,c) + a(1:d,1:d) = b(1:d,1:d) +end Index: Fortran/gfortran/regression/graphite/pr29581.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr29581.f90 @@ -0,0 +1,28 @@ +! PR tree-optimization/29581 +! { dg-do run } +! { dg-skip-if "" { *-*-* } { "-O0" } { "" } } +! { dg-additional-options "-ftree-loop-linear" } + + SUBROUTINE FOO (K) + INTEGER I, J, K, A(5,5), B + COMMON A + A(1,1) = 1 + 10 B = 0 + DO 30 I = 1, K + DO 20 J = 1, K + B = B + A(I,J) + 20 CONTINUE + A(I,I) = A(I,I) * 2 + 30 CONTINUE + IF (B.GE.3) RETURN + GO TO 10 + END SUBROUTINE + + PROGRAM BAR + INTEGER A(5,5) + COMMON A + CALL FOO (2) + IF (A(1,1).NE.8) STOP 1 + A(1,1) = 0 + IF (ANY(A.NE.0)) STOP 2 + END Index: Fortran/gfortran/regression/graphite/pr29832.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr29832.f90 @@ -0,0 +1,26 @@ +! { dg-do run } +! { dg-skip-if "" { *-*-* } { "-O0" } { "" } } +! { dg-additional-options "-ftree-loop-linear" } + +! Program to test the scalarizer +program testarray + implicit none + integer, dimension (6, 5) :: a, b + integer n + + a = 0 + do n = 1, 5 + a(4, n) = n + end do + + b(:, 5:1:-1) = a + a(1:5, 2) = a(4, :) + 1 + + ! The following expression should cause loop reordering + a(:, 2:4) = a(:, 1:3) + + do n = 1, 5 + if (a(n, 3) .ne. (n + 1)) STOP 1 + if (b(4, n) .ne. (6 - n)) STOP 2 + end do +end program Index: Fortran/gfortran/regression/graphite/pr36286.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr36286.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-O1 -ftree-loop-linear" } +! PR tree-optimization/36286 + +program test_count + integer, dimension(2,3) :: a, b + a = reshape( (/ 1, 3, 5, 2, 4, 6 /), (/ 2, 3 /)) + b = reshape( (/ 0, 3, 5, 7, 4, 8 /), (/ 2, 3 /)) + print '(3l6)', a.ne.b + print *, a(1,:).ne.b(1,:) + print *, a(2,:).ne.b(2,:) + print *, count(a.ne.b) +end program test_count + Index: Fortran/gfortran/regression/graphite/pr36922.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr36922.f @@ -0,0 +1,16 @@ +C PR tree-optimization/36922 +C { dg-do compile } +C { dg-options "-O2 -ftree-loop-linear" } + SUBROUTINE PR36922(N,F,Z,C) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + DIMENSION C(23821),Z(0:2*N+1),F(0:2*N) + I=0 + DO L=0,N + DO M=0,L + DO M2=M,L + I=I+1 + C(I)=F(L+M)*F(L-M)*Z(L-M2)/(F(M2+M)*F(M2-M)*F(L-M2)*F(L-M2)) + ENDDO + ENDDO + ENDDO + END Index: Fortran/gfortran/regression/graphite/pr37852.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr37852.f90 @@ -0,0 +1,13 @@ +! { dg-options "-O2 " } + +PROGRAM TEST_FPU +CHARACTER (LEN=36) :: invert_id(1) = & + (/ 'Test1 - Gauss 2000 (101x101) inverts'/) +END PROGRAM TEST_FPU + +SUBROUTINE Gauss (a,n) +INTEGER, PARAMETER :: RK8 = SELECTED_REAL_KIND(15, 300) +REAL(RK8) :: a(n,n) +INTEGER :: ipvt(n) +a(:,ipvt) = b +END SUBROUTINE Gauss Index: Fortran/gfortran/regression/graphite/pr37857.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr37857.f90 @@ -0,0 +1,9 @@ +! { dg-options "-O2 " } + +program superficie_proteina + integer, parameter :: LONGreal = selected_real_kind(12,90) + integer :: number_of_polypeptides, maximum_polypeptide_length + real (kind = LONGreal), dimension (:,:), allocatable :: individual_conformations + allocate (individual_conformations(-number_of_bins:0,number_of_polypeptides)) + individual_conformations = 0.0_LONGreal +end program superficie_proteina Index: Fortran/gfortran/regression/graphite/pr37980.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr37980.f90 @@ -0,0 +1,11 @@ +! { dg-options "-O2 " } + +module INT_MODULE +contains + pure function spher_cartesians(in1) result(out1) + integer(kind=kind(1)) :: in1 + intent(in) :: in1 + real(kind=kind(1.0d0)), dimension(0:in1,0:in1,0:in1) :: mat0 + mat0 = 0.0d0 + end function spher_cartesians +end module INT_MODULE Index: Fortran/gfortran/regression/graphite/pr38083.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr38083.f90 @@ -0,0 +1,16 @@ +! { dg-options "-O3 " } + +SUBROUTINE IVSORT (IL,IH,NSEGS,IOUNIT) + INTEGER IOUNIT + + INTEGER, PARAMETER :: MAXGS = 32 + +10 IF (IL .GE. IH) GO TO 80 +20 NSEGS = (IH + IL) / 2 + IF (NSEGS .GT. MAXSGS) THEN + WRITE (IOUNIT) MAXSGS + ENDIF +80 NSEGS = NSEGS - 1 +90 IF (IH - IL .GE. 11) GO TO 20 +110 IF (IL .EQ. IH) GO TO 80 +END SUBROUTINE IVSORT Index: Fortran/gfortran/regression/graphite/pr38459.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr38459.f90 @@ -0,0 +1,14 @@ +! { dg-options "-O2 -fgraphite-identity" } +# 1 "mltfftsg.F" +# 1 "" +SUBROUTINE mltfftsg ( a, ldax, lday, b, ldbx, ldby, & + n, m) + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + +! Arguments + INTEGER, INTENT ( IN ) :: ldbx, ldby, n, m + COMPLEX ( dbl ), INTENT ( INOUT ) :: b ( ldbx, ldby ) + + B(N+1:LDBX,1:M) = CMPLX(0._dbl,0._dbl,dbl) + +END SUBROUTINE mltfftsg Index: Fortran/gfortran/regression/graphite/pr38953.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr38953.f90 @@ -0,0 +1,115 @@ +! { dg-options "-O3 -fgraphite-identity" } + + MODULE MAIN1 + INTEGER , PARAMETER :: IFMAX = 40 , IKN = 85 , ISTRG = 132 , & + & IERRN = 170 , ILEN_FLD = 80 + CHARACTER PATH*2 , PPATH*2 , KEYWRD*8 , PKEYWD*8 , KEYWD*8 , & + & KTYPE*5 , RUNST*1 + DIMENSION FIELD(IFMAX) , KEYWD(IKN) , RUNST(ISTRG) + LOGICAL :: DFAULT , CONC , DEPOS , DDEP , WDEP , RURAL , URBAN , & + & GRDRIS , NOSTD , NOBID , CLMPRO , MSGPRO , PERIOD , & + & OLM=.FALSE. + INTEGER :: NSRC , NREC , NGRP , NQF, & + & NARC , NOLM + CHARACTER NETID*8 , NETIDT*8 , PNETID*8 , NTID*8 , NTTYP*8 , & + & RECTYP*2 , PXSOID*8 , PESOID*8 , ARCID*8 + ALLOCATABLE ::NETID(:) , RECTYP(:) , NTID(:) , NTTYP(:) , ARCID(:) + DATA (KEYWD(I),I=1,IKN)/'STARTING' , 'FINISHED' , 'TITLEONE' , & + & 'TITLETWO' , 'MODELOPT' , 'AVERTIME' , 'POLLUTID' , & + & 'HALFLIFE' , 'DCAYCOEF' , 'DEBUGOPT' , 'ELEVUNIT' , & + & 'FLAGPOLE' , 'RUNORNOT' , 'EVENTFIL' , 'SAVEFILE' , & + & 'INITFILE' , 'MULTYEAR' , 'ERRORFIL' , 'GASDEPDF' , & + & 'GDSEASON' , 'GASDEPVD' , 'GDLANUSE' , 'EVENTFIL' , & + & 'URBANOPT' , 'METHOD_2' , 'LOCATION' , 'SRCPARAM' , & + & 'BUILDHGT' , 'BUILDWID' , 'BUILDLEN' , 'XBADJ ' , & + & 'YBADJ ' , 'EMISFACT' , 'EMISUNIT' , 'PARTDIAM' , & + & 'MASSFRAX' , 'PARTDENS' , ' ' , ' ' , & + & ' ' , 'CONCUNIT' , 'DEPOUNIT' , 'HOUREMIS' , & + & 'GASDEPOS' , 'URBANSRC' , 'EVENTPER' , 'EVENTLOC' , & + & 'SRCGROUP' , 'GRIDCART' , 'GRIDPOLR' , 'DISCCART' , & + & 'DISCPOLR' , 'SURFFILE' , 'PROFFILE' , 'PROFBASE' , & + & ' ' , 'SURFDATA' , 'UAIRDATA' , 'SITEDATA' , & + & 'STARTEND' , 'DAYRANGE' , 'WDROTATE' , 'DTHETADZ' , & + & 'WINDCATS' , 'RECTABLE' , 'MAXTABLE' , 'DAYTABLE' , & + & 'MAXIFILE' , 'POSTFILE' , 'PLOTFILE' , 'TOXXFILE' , & + & 'EVENTOUT' , 'INCLUDED' , 'SCIMBYHR' , 'SEASONHR' , & + & 'AREAVERT' , 'PARTSIZE' , 'RANKFILE' , 'EVALCART' , & + & 'EVALFILE' , 'NO2EQUIL' , 'OZONEVAL' , 'OZONEFIL' , & + & 'NO2RATIO' , 'OLMGROUP'/ + DIMENSION RESTAB(9,6,5) , STAB(9) + DATA (((RESTAB(I,J,K),I=1,9),J=1,6),K=1,5)/1.E07 , 60. , 120. , & + & 100. , 200. , 150. , 1.E07 , 1.E07 , 80. , 1.E07 , 2000. , & + & 2000. , 2000. , 2000. , 2000. , 1.E07 , 1.E07 , 2500. , & + & 1.E07 , 1000. , 1000. , 1000. , 2000. , 2000. , 1.E07 , & + & 1.E07 , 1000. , 100. , 200. , 100. , 2000. , 100. , 1500. , & + & 0. , 0. , 300. , 400. , 150. , 350. , 300. , 500. , 450. , & + & 0. , 1000. , 0. , 300. , 150. , 200. , 200. , 300. , 300. , & + & 2000. , 400. , 1000. , 1.E07 , 1.E07 , 1.E07 , 350. , & + & 1.E07 , 700. , 1.E07 , 1.E07 , 1.E07 , 1.E07 , 6500. , & + & 6500. , 3000. , 2000. , 2000. , 1.E07 , 1.E07 , 6500. , & + & 1.E07 , 400. , 300. , 500. , 600. , 1000. , 1.E07 , 1.E07 , & + & 300. , 100. , 150. , 100. , 1700. , 100. , 1200. , 0. , 0. ,& + & 200. , 400. , 200. , 350. , 300. , 500. , 450. , 0. , & + & 1000. , 0. , 300. , 150. , 200. , 200. , 300. , 300. , & + & 2000. , 400. , 800. , 1.E07 , 1.E07 , 1.E07 , 500. , 1.E07 ,& + & 1000. , 1.E07 , 1.E07 , 1.E07 , 1.E07 , 1.E07 , 9000. , & + & 6000. , 2000. , 2000. , 1.E07 , 1.E07 , 9000. , 1.E07 , & + & 1.E07 , 400. , 600. , 800. , 1600. , 1.E07 , 1.E07 , 800. , & + & 100. , 0. , 100. , 1500. , 100. , 1000. , 0. , 0. , 100. , & + & 400. , 150. , 350. , 300. , 500. , 450. , 0. , 0. , 1000. , & + & 300. , 150. , 200. , 200. , 300. , 300. , 2000. , 400. , & + & 1000. , 1.E07 , 1.E07 , 1.E07 , 800. , 1.E07 , 1600. , & + & 1.E07 , 1.E07 , 1.E07 , 1.E07 , 1.E07 , 1.E07 , 400. , & + & 1.E07 , 800. , 1.E07 , 1.E07 , 9000. , 1.E07 , 2000. , & + & 1000. , 600. , 2000. , 1200. , 1.E07 , 1.E07 , 800. , 100. ,& + & 0. , 10. , 1500. , 100. , 1000. , 0. , 0. , 50. , 100. , & + & 100. , 100. , 100. , 200. , 200. , 0. , 1000. , 100. , & + & 600. , 3500. , 3500. , 3500. , 500. , 500. , 2000. , 400. , & + & 3500. , 1.E07 , 100. , 120. , 100. , 200. , 150. , 1.E07 , & + & 1.E07 , 80. , 1.E07 , 2000. , 2000. , 1500. , 2000. , & + & 2000. , 1.E07 , 1.E07 , 2000. , 1.E07 , 1000. , 250. , & + & 350. , 500. , 700. , 1.E07 , 1.E07 , 300. , 100. , 50. , & + & 80. , 1500. , 100. , 1000. , 0. , 0. , 200. , 500. , 150. , & + & 350. , 300. , 500. , 450. , 0. , 1000. , 0. , 300. , 150. , & + & 200. , 200. , 300. , 300. , 2000. , 400. , 1000./ + END + SUBROUTINE SHAVE + USE MAIN1 + IF ( PERIOD ) THEN + 9020 FORMAT ('(''*'',8X,''X'',13X,''Y'',4X,',I1, & + &'(2X,3A4),4X,''ZELEV'', 4X,''ZHILL'',4X,''ZFLAG'',4X,''AVE'',5X,& + &_______ ________ ________'')') + ENDIF + DO IGRP = 1 , NUMGRP + IF ( IANPST(IGRP).EQ.1 ) THEN + IF ( IANFRM(IGRP).EQ.0 ) THEN + DO IREC = 1 , NUMREC + ENDDO + ENDIF + DO IREC = 1 , NUMREC + IF ( RECTYP(IREC).EQ.'DC' ) THEN + WRITE (IOUNIT,9082) SRCID(ISRF) , SRCTYP(ISRF) , & + & AXS(ISRF) , AYS(ISRF) , AZS(ISRF) & + & , (J,AXR(IREC+J-1),AYR(IREC+J-1), & + & HCLMSG(IREC+J-1,IHNUM,IGRP,IAVE, & + & ITYP),J=1,36) + 9082 FORMAT (' BOUNDARY RECEPTOR NETWORK OF SOURCE ID: ', & + & 18(2(1X,I4,3X,F10.2,', ',F10.2,',',F13.5,A1, & + & '(',I8.8,')',7X),/),/) + ENDIF + ENDDO + ENDIF + ENDDO + END + USE MAIN1 + IF ( ICOUNT.NE.0 .AND. JCOUNT.NE.0 ) THEN + DO J = 1 , JCOUNT + DO I = 1 , ICOUNT + IF ( ISET.GT.NREC ) THEN + GOTO 999 + ENDIF + ENDDO + ENDDO + ENDIF + 999 CONTINUE + END Index: Fortran/gfortran/regression/graphite/pr39516.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr39516.f @@ -0,0 +1,20 @@ +C PR tree-optimization/39516 +C { dg-do compile } +C { dg-options "-O2 -ftree-loop-linear" } + SUBROUTINE SUB(A, B, M) + IMPLICIT NONE + DOUBLE PRECISION A(20,20), B(20) + INTEGER*8 I, J, K, M + DO I=1,M + DO J=1,M + A(I,J)=A(I,J)+1 + END DO + END DO + DO K=1,20 + DO I=1,M + DO J=1,M + B(I)=B(I)+A(I,J) + END DO + END DO + END DO + END SUBROUTINE Index: Fortran/gfortran/regression/graphite/pr40982.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr40982.f90 @@ -0,0 +1,69 @@ +! { dg-options "-O3 -fgraphite-identity -floop-nest-optimize " } + +module mqc_m + + +implicit none + +private +public :: mutual_ind_quad_cir_coil + +integer, parameter, private :: longreal = selected_real_kind(15,90) +real (kind = longreal), parameter, private :: pi = 3.141592653589793_longreal +real (kind = longreal), parameter, private :: small = 1.0e-10_longreal + +contains + + subroutine mutual_ind_quad_cir_coil (r_coil, x_coil, y_coil, z_coil, h_coil, n_coil, & + rotate_coil, m, mu, l12) + real (kind = longreal), intent(in) :: r_coil, x_coil, y_coil, z_coil, h_coil, n_coil, & + mu + real (kind = longreal), dimension(:,:), intent(in) :: rotate_coil + integer, intent(in) :: m + real (kind = longreal), intent(out) :: l12 + real (kind = longreal), dimension(3,3) :: rotate_quad + real (kind = longreal), dimension(9), save :: x2gauss, y2gauss, w2gauss, z1gauss, & + w1gauss + real (kind = longreal) :: xxvec, xyvec, xzvec, yxvec, yyvec, yzvec, zxvec, zyvec, & + zzvec, magnitude, l12_lower, l12_upper, dx, dy, dz, theta, & + a, b1, b2, numerator, denominator, coefficient, angle + real (kind = longreal), dimension(3) :: c_vector, q_vector, rot_c_vector, & + rot_q_vector, current_vector, & + coil_current_vec, coil_tmp_vector + integer :: i, j, k + logical, save :: first = .true. + + do i = 1, 2*m + theta = pi*real(i,longreal)/real(m,longreal) + c_vector(1) = r_coil * cos(theta) + c_vector(2) = r_coil * sin(theta) + coil_tmp_vector(1) = -sin(theta) + coil_tmp_vector(2) = cos(theta) + coil_tmp_vector(3) = 0.0_longreal + coil_current_vec(1) = dot_product(rotate_coil(1,:),coil_tmp_vector(:)) + coil_current_vec(2) = dot_product(rotate_coil(2,:),coil_tmp_vector(:)) + coil_current_vec(3) = dot_product(rotate_coil(3,:),coil_tmp_vector(:)) + do j = 1, 9 + c_vector(3) = 0.5 * h_coil * z1gauss(j) + rot_c_vector(1) = dot_product(rotate_coil(1,:),c_vector(:)) + dx + rot_c_vector(2) = dot_product(rotate_coil(2,:),c_vector(:)) + dy + rot_c_vector(3) = dot_product(rotate_coil(3,:),c_vector(:)) + dz + do k = 1, 9 + q_vector(1) = 0.5_longreal * a * (x2gauss(k) + 1.0_longreal) + q_vector(2) = 0.5_longreal * b1 * (y2gauss(k) - 1.0_longreal) + q_vector(3) = 0.0_longreal + rot_q_vector(1) = dot_product(rotate_quad(1,:),q_vector(:)) + rot_q_vector(2) = dot_product(rotate_quad(2,:),q_vector(:)) + rot_q_vector(3) = dot_product(rotate_quad(3,:),q_vector(:)) + numerator = w1gauss(j) * w2gauss(k) * & + dot_product(coil_current_vec,current_vector) + denominator = sqrt(dot_product(rot_c_vector-rot_q_vector, & + rot_c_vector-rot_q_vector)) + l12_lower = l12_lower + numerator/denominator + end do + end do + end do + l12 = coefficient * (b1 * l12_lower + b2 * l12_upper) + end subroutine mutual_ind_quad_cir_coil + +end module mqc_m Index: Fortran/gfortran/regression/graphite/pr41924.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr41924.f90 @@ -0,0 +1,15 @@ +! { dg-options "-O2 -fgraphite-identity " } + +MODULE MAIN1 + REAL , ALLOCATABLE :: HRVALD(:) +END MODULE MAIN1 + +SUBROUTINE VOLCALC() + USE MAIN1 + INTEGER :: ITYP + LOGICAL :: WETSCIM + + DO ITYP = 1 , 100 + IF ( WETSCIM ) HRVALD(ITYP) = 0.0 + ENDDO +END SUBROUTINE VOLCALC Index: Fortran/gfortran/regression/graphite/pr42050.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42050.f90 @@ -0,0 +1,25 @@ +! { dg-options "-O2 -fgraphite-identity " } + +MODULE qs_ks_methods + INTEGER, PARAMETER :: sic_list_all=1 + TYPE dft_control_type + INTEGER :: sic_list_id + END TYPE +CONTAINS + SUBROUTINE sic_explicit_orbitals( ) + TYPE(dft_control_type), POINTER :: dft_control + INTEGER, ALLOCATABLE, DIMENSION(:, :) :: sic_orbital_list + INTEGER, DIMENSION(:), & + POINTER :: mo_derivs + SELECT CASE(dft_control%sic_list_id) + CASE(sic_list_all) + DO i=1,k_alpha + IF (SIZE(mo_derivs,1)==1) THEN + ELSE + sic_orbital_list(3,iorb)=2 + ENDIF + ENDDO + END SELECT + CALL test() + END SUBROUTINE sic_explicit_orbitals +END MODULE qs_ks_methods Index: Fortran/gfortran/regression/graphite/pr42180.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42180.f90 @@ -0,0 +1,22 @@ +! { dg-options "-ffast-math -O2 -fgraphite-identity" } + +module mcc_m + integer, parameter, private :: longreal = selected_real_kind(15,90) +contains + subroutine mutual_ind_cir_cir_coils (m, l12) + real (kind = longreal), intent(out) :: l12 + real (kind = longreal), dimension(1:9), save :: zw + gauss:do i = 1, 9 + theta_l12 = 0.0_longreal + theta1: do n1 = 1, 2*m + theta_1 = pi*real(n1,longreal)/real(m,longreal) + theta2: do n2 = 1, 2*m + numerator = -sin(theta_1)*tvx + cos(theta_1)*tvy + theta_l12 = theta_l12 + numerator/denominator + end do theta2 + end do theta1 + l12 = l12 + zw(i)*theta_l12 + end do gauss + l12 = coefficient * l12 + end subroutine mutual_ind_cir_cir_coils +end module mcc_m Index: Fortran/gfortran/regression/graphite/pr42181.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42181.f90 @@ -0,0 +1,19 @@ +! { dg-options "-O1 -fgraphite" } + +MODULE powell + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE newuob (n,npt,x,rhobeg,rhoend,maxfun,xbase,& + xopt,xnew,xpt,fval,gq,hq,pq,bmat,zmat,ndim,d,vlag,w,opt) + REAL(dp), DIMENSION(npt, *), & + INTENT(inout) :: xpt + REAL(dp), DIMENSION(*), INTENT(inout) :: fval, gq, hq, pq +120 IF (dsq <= 1.0e-3_dp*xoptsq) THEN + DO k=1,npt + DO i=1,n + gq(i)=gq(i)+temp*xpt(k,i) + END DO + END DO + END IF + END SUBROUTINE newuob +END MODULE powell Index: Fortran/gfortran/regression/graphite/pr42185.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42185.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-fgraphite -O -ffast-math" } + +MODULE powell + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE trsapp (n,npt,xopt,xpt,gq,hq,pq,delta,step,d,g,hd,hs,crvmin) + REAL(dp), DIMENSION(*), INTENT(INOUT) :: step, d, g, hd, hs + LOGICAL :: jump1, jump2 + REAL(dp) :: alpha, angle, angtest, bstep, cf, cth, dd, delsq, dg, dhd, & + reduc, sg, sgk, shs, ss, sth, temp, tempa, tempb + DO i=1,n + dd=dd+d(i)**2 + END DO + mainloop : DO + IF ( .NOT. jump2 ) THEN + IF ( .NOT. jump1 ) THEN + bstep=temp/(ds+SQRT(ds*ds+dd*temp)) + IF (alpha < bstep) THEN + IF (ss < delsq) CYCLE mainloop + END IF + IF (gg <= 1.0e-4_dp*ggbeg) EXIT mainloop + END IF + END IF + END DO mainloop + END SUBROUTINE trsapp +END MODULE powell Index: Fortran/gfortran/regression/graphite/pr42186.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42186.f90 @@ -0,0 +1,14 @@ +! { dg-options "-fgraphite-identity -g -O3 -ffast-math" } +MODULE erf_fn +CONTAINS + SUBROUTINE CALERF(ARG,RESULT,JINT) + DIMENSION A(5),B(4),C(9),D(8),P(6),Q(5) + IF (Y <= THRESH) THEN + DO I = 1, 3 + XNUM = (XNUM + A(I)) * YSQ + XDEN = (XDEN + B(I)) * YSQ + END DO + RESULT = X * (XNUM + A(4)) / (XDEN + B(4)) + END IF + END SUBROUTINE CALERF +END MODULE erf_fn Index: Fortran/gfortran/regression/graphite/pr42285.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42285.f90 @@ -0,0 +1,24 @@ +! { dg-options "-O2 -floop-nest-optimize" } + +SUBROUTINE EFGRDM(NCF,NFRG,G,RTRMS,GM,IOPT,K1) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION G(*),RTRMS(*),GM(*) + + DUM = 0 + DO I=1,NFRG + DO J=1,3 + IF (IOPT.EQ.0) THEN + GM(K1)=G(K1) + END IF + END DO + DO J=1,3 + JDX=NCF*9+IOPT*9*NFRG + DO M=1,3 + DUM=DUM+RTRMS(JDX+M) + END DO + GM(K1)=DUM + END DO + END DO + RETURN +END SUBROUTINE EFGRDM + Index: Fortran/gfortran/regression/graphite/pr42326-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42326-1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-require-effective-target ilp32 } +! { dg-require-effective-target sse2 } +! { dg-options "-O2 -floop-parallelize-all -fprefetch-loop-arrays -msse2" } + +subroutine phasad(t,i,ium) + implicit none + real t(5,4) + integer i,l,ll,ium + + do l=1,2 + ll=2*l + do i=1,ium + t(i,ll-1)=t(i,ll-1)+t(i,ll) + enddo + enddo + return +end subroutine phasad Index: Fortran/gfortran/regression/graphite/pr42326.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42326.f90 @@ -0,0 +1,35 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-require-effective-target ilp32 } +! { dg-require-effective-target sse2 } +! { dg-options "-O2 -floop-strip-mine -fprefetch-loop-arrays -msse2" } + +subroutine blts ( ldmx, ldmy, v, tmp1, i, j, k) + implicit none + integer ldmx, ldmy, i, j, k, ip, m, l + real*8 tmp, tmp1, v( 5, ldmx, ldmy, *), tmat(5,5) + + do ip = 1, 4 + do m = ip+1, 5 + tmp = tmp1 * tmat( m, ip ) + do l = ip+1, 5 + tmat( m, l ) = tmat( m, l ) - tmat( ip, l ) + end do + v( m, i, j, k ) = tmp + end do + end do + return +end subroutine blts + +subroutine phasad(t,i,ium) + implicit none + real t(5,4) + integer i,l,ll,ium + + do l=1,2 + ll=2*l + do i=1,ium + t(i,ll-1)=t(i,ll-1)+t(i,ll) + enddo + enddo + return +end subroutine phasad Index: Fortran/gfortran/regression/graphite/pr42334-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42334-1.f @@ -0,0 +1,16 @@ +! { dg-options "-O2 -floop-nest-optimize" } + + subroutine linel(icmdl,stre,anisox) + real*8 stre(6),tkl(3,3),ekl(3,3),anisox(3,3,3,3) + do m1=1,3 + do m2=1,m1 + do m3=1,3 + do m4=1,3 + tkl(m1,m2)=tkl(m1,m2)+ + & anisox(m1,m2,m3,m4)*ekl(m3,m4) + enddo + enddo + enddo + enddo + stre(1)=tkl(1,1) + end Index: Fortran/gfortran/regression/graphite/pr42334.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42334.f90 @@ -0,0 +1,20 @@ +! { dg-options "-O2 -floop-nest-optimize -ftree-loop-distribution" } + +subroutine blockdis(bl1eg,bl2eg) + implicit real*8 (a-h,o-z) + parameter(nblo=300) + common/str /mblo + common/str2 /mel(nblo) + dimension h(nblo,2,6),g(nblo,2,6) + dimension bl1eg(nblo,2,6),bl2eg(nblo,2,6) + do k=1,mblo + jm=mel(k) + do l=1,2 + do m=1,6 + bl1eg(k,l,m)=h(jm,l,m) + bl2eg(k,l,m)=g(jm,l,m) + enddo + enddo + enddo + return +end subroutine blockdis Index: Fortran/gfortran/regression/graphite/pr42393-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42393-1.f90 @@ -0,0 +1,24 @@ +! { dg-options "-O2 -fgraphite-identity -fno-loop-block -fno-loop-interchange -fno-loop-strip-mine" } + +MODULE beta_gamma_psi + INTEGER, PARAMETER :: dp=KIND(0.0D0) +CONTAINS + FUNCTION basym () RESULT(fn_val) + REAL(dp) :: b0(21), bsum, d(21) + DO n = 2, num, 2 + DO i = n, np1 + b0(1) = 1 + DO m = 2, i + mm1 = m - 1 + DO j = 1, mm1 + bsum = bsum + b0(j) + END DO + b0(m) = bsum + END DO + d(i) = -b0(i) + END DO + sum = sum + d(n) + END DO + fn_val = sum + END FUNCTION basym +END MODULE beta_gamma_psi Index: Fortran/gfortran/regression/graphite/pr42393.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42393.f90 @@ -0,0 +1,30 @@ +! { dg-options "-O2 -fgraphite-identity -fno-loop-block -fno-loop-interchange -fno-loop-strip-mine" } + +MODULE beta_gamma_psi + INTEGER, PARAMETER :: dp=KIND(0.0D0) +CONTAINS + FUNCTION basym (a, b, lambda, eps) RESULT(fn_val) + REAL(dp) :: a0(21), b0(21), bsum, c(21), d(21), dsum, & + j0, j1, r, r0, r1, s, sum, t, t0, t1, & + u, w, w0, z, z0, z2, zn, znm1 + DO n = 2, num, 2 + DO i = n, np1 + b0(1) = r*a0(1) + DO m = 2, i + bsum = 0.0e0_dp + mm1 = m - 1 + DO j = 1, mm1 + mmj = m - j + bsum = bsum + (j*r - mmj)*a0(j)*b0(mmj) + END DO + b0(m) = r*a0(m) + bsum/m + END DO + c(i) = b0(i)/(i + 1.0e0_dp) + d(i) = -(dsum + c(i)) + END DO + t0 = d(n)*w*j0 + sum = sum + (t0 + t1) + END DO + fn_val = e0*t*u*sum + END FUNCTION basym +END MODULE beta_gamma_psi Index: Fortran/gfortran/regression/graphite/pr42732.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr42732.f @@ -0,0 +1,23 @@ +! { dg-options "-O2 -fgraphite-identity" } + + parameter(in = 128+5 + & , jn = 128+5 + & , kn = 128+5) + real*8 d (in,jn,kn) + real*8 dcopy(in,jn,kn) + call pdv (is, dcopy) + do k=ks,ke + do j=je+1,je+2 + do i=is-2,ie+2 + dcopy(i,j,k) = d(i,j,k) + enddo + enddo + enddo + do k=ks,ke + do j=js,je + do i=is-2,is-1 + dcopy(i,j,k) = d(i,j,k) + enddo + enddo + enddo + end Index: Fortran/gfortran/regression/graphite/pr43097.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr43097.f @@ -0,0 +1,25 @@ +! { dg-options "-O2 -fgraphite-identity" } + + subroutine foo (ldmx,ldmy,nx,ny,v) + implicit real*8 (a-h, o-z) + dimension v(5,ldmx,ldmy,*) + dimension tmat(5,5) + + k = 2 + do j = 2, ny-1 + do i = 2, nx-1 + do ip = 1, 4 + do m = ip+1, 5 + v(m,i,j,k) = v(m,i,j,k) * m + end do + end do + do m = 5, 1, -1 + do l = m+1, 5 + v(m,i,j,k) = v(l,i,j,k) + end do + v(m,i,j,k) = m + end do + end do + end do + return + end Index: Fortran/gfortran/regression/graphite/pr43349.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr43349.f @@ -0,0 +1,35 @@ +! { dg-options "-O2 -floop-nest-optimize" } + + SUBROUTINE BUG(A,B,X,Y,Z,N) + IMPLICIT NONE + DOUBLE PRECISION A(*),B(*),X(*),Y(*),Z(*) + INTEGER N,J,K + K = 0 + DO J = 1,N + K = K+1 + X(K) = B(J+N*7) + Y(K) = B(J+N*8) + Z(K) = B(J+N*2) + A(J+N*2) + K = K+1 + X(K) = B(J+N*3) + A(J+N*3) + Y(K) = B(J+N*9) + A(J) + Z(K) = B(J+N*15) + K = K+1 + X(K) = B(J+N*4) + A(J+N*4) + Y(K) = B(J+N*15) + Z(K) = B(J+N*10) + A(J) + K = K+1 + X(K) = B(J+N*11) + A(J+N) + Y(K) = B(J+N*5) + A(J+N*5) + Z(K) = B(J+N*16) + K = K+1 + X(K) = B(J+N*16) + Y(K) = B(J+N*6) + A(J+N*6) + Z(K) = B(J+N*12) + A(J+N) + K = K+1 + X(K) = B(J+N*13) + A(J+N*2) + Y(K) = B(J+N*17) + Z(K) = B(J+N*7) + A(J+N*7) + ENDDO + RETURN + END Index: Fortran/gfortran/regression/graphite/pr45758.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr45758.f90 @@ -0,0 +1,40 @@ +! { dg-options "-O3 -floop-block" } + +MODULE util + INTEGER, PARAMETER :: int_4=4 + INTERFACE sort + MODULE PROCEDURE sort_int_4v + END INTERFACE +CONTAINS + SUBROUTINE sort_int_4v ( arr, n, index ) + INTEGER(KIND=int_4), INTENT(INOUT) :: arr(1:n) + INTEGER, INTENT(OUT) :: INDEX(1:n) + DO i = 1, n + INDEX(i) = i + END DO +1 IF (ir-l accdrv_binning_binsize) THEN + params_out(:, top:top+bin_top(bin_id)-2) = bin_arr(:, 1:bin_top(bin_id)-1, bin_id) + ENDIF + bin_arr(:, bin_top(bin_id), bin_id) = val(:) + bin_top(bin_id) = bin_top(bin_id) + 1 + END DO + END SUBROUTINE stack_binning +END MODULE Index: Fortran/gfortran/regression/graphite/pr68335.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68335.f90 @@ -0,0 +1,45 @@ +! { dg-options "-O2 -floop-nest-optimize" } + +MODULE whittaker + INTEGER, PARAMETER :: dp=8 + INTEGER, PARAMETER :: maxfac = 30 + REAL(KIND=dp), PARAMETER, DIMENSION (-1:2*maxfac+1) :: dfac = (/& + 0.10000000000000000000E+01_dp, 0.10000000000000000000E+01_dp, 0.10000000000000000000E+01_dp,& + 0.20000000000000000000E+01_dp, 0.30000000000000000000E+01_dp, 0.80000000000000000000E+01_dp,& + 0.15000000000000000000E+02_dp, 0.48000000000000000000E+02_dp, 0.10500000000000000000E+03_dp,& + 0.38400000000000000000E+03_dp, 0.94500000000000000000E+03_dp, 0.38400000000000000000E+04_dp,& + 0.10395000000000000000E+05_dp, 0.46080000000000000000E+05_dp, 0.13513500000000000000E+06_dp,& + 0.64512000000000000000E+06_dp, 0.20270250000000000000E+07_dp, 0.10321920000000000000E+08_dp,& + 0.34459425000000000000E+08_dp, 0.18579456000000000000E+09_dp, 0.65472907500000000000E+09_dp,& + 0.37158912000000000000E+10_dp, 0.13749310575000000000E+11_dp, 0.81749606400000000000E+11_dp,& + 0.31623414322500000000E+12_dp, 0.19619905536000000000E+13_dp, 0.79058535806250000000E+13_dp,& + 0.51011754393600000000E+14_dp, 0.21345804667687500000E+15_dp, 0.14283291230208000000E+16_dp,& + 0.61902833536293750000E+16_dp, 0.42849873690624000000E+17_dp, 0.19189878396251062500E+18_dp,& + 0.13711959580999680000E+19_dp, 0.63326598707628506250E+19_dp, 0.46620662575398912000E+20_dp,& + 0.22164309547669977187E+21_dp, 0.16783438527143608320E+22_dp, 0.82007945326378915594E+22_dp,& + 0.63777066403145711616E+23_dp, 0.31983098677287777082E+24_dp, 0.25510826561258284646E+25_dp,& + 0.13113070457687988603E+26_dp, 0.10714547155728479551E+27_dp, 0.56386202968058350995E+27_dp,& + 0.47144007485205310027E+28_dp, 0.25373791335626257948E+29_dp, 0.21686243443194442612E+30_dp,& + 0.11925681927744341235E+31_dp, 0.10409396852733332454E+32_dp, 0.58435841445947272053E+32_dp,& + 0.52046984263666662269E+33_dp, 0.29802279137433108747E+34_dp, 0.27064431817106664380E+35_dp,& + 0.15795207942839547636E+36_dp, 0.14614793181237598765E+37_dp, 0.86873643685617511998E+37_dp,& + 0.81842841814930553085E+38_dp, 0.49517976900801981839E+39_dp, 0.47468848252659720789E+40_dp,& + 0.29215606371473169285E+41_dp, 0.28481308951595832474E+42_dp, 0.17821519886598633264E+43_dp/) +CONTAINS + SUBROUTINE whittaker_c0 ( wc, r, expa, erfa, alpha, l, n ) + INTEGER, INTENT(IN) :: n, l + REAL(KIND=dp), INTENT(IN) :: alpha + REAL(KIND=dp), DIMENSION(n) :: erfa, expa, r, wc + INTEGER :: i, k + REAL(dp) :: t1,x + SELECT CASE (l) + CASE DEFAULT + DO i = 1, n + DO k = 0, l/2 + wc(i) = wc(i) + expa(i)*x**(2*k+1)*t1**(2*k+3)*& + dfac(l+1)/dfac(2*k+1)*2**(k+1) + END DO + END DO + END SELECT + END SUBROUTINE whittaker_c0 +END MODULE whittaker Index: Fortran/gfortran/regression/graphite/pr68453.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68453.f90 @@ -0,0 +1,24 @@ +! { dg-options "-floop-nest-optimize -O2" } + +MODULE dbcsr_geev + INTEGER, PARAMETER :: real_8=8 +CONTAINS + SUBROUTINE dbcsr_dgeev(jobvl,jobvr,matrix,ndim,evals,revec,levec) + CHARACTER(1) :: jobvl, jobvr + REAL(real_8), DIMENSION(:, :) :: matrix + INTEGER :: ndim + COMPLEX(real_8), DIMENSION(:) :: evals + COMPLEX(real_8), DIMENSION(:, :) :: revec, levec + INTEGER :: i, info, lwork + REAL(real_8) :: norm, tmp_array(ndim,ndim), & + work(20*ndim) + REAL(real_8), DIMENSION(ndim) :: eval1, eval2 + REAL(real_8), DIMENSION(ndim, ndim) :: evec_l, evec_r + DO WHILE (i.le.ndim) + IF(ABS(eval2(i)).LT.EPSILON(REAL(0.0,real_8)))THEN + norm=SQRT(SUM(evec_r(:,i)**2.0_real_8)+SUM(evec_r(:,i+1)**2.0_real_8)) + revec(:,i)=CMPLX(evec_r(:,i),evec_r(:,i+1),real_8)/norm + END IF + END DO + END SUBROUTINE dbcsr_dgeev +END MODULE dbcsr_geev Index: Fortran/gfortran/regression/graphite/pr68550-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68550-1.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -O2" } + +SUBROUTINE integrate_core_1(grid,coef_xyz,pol_x,pol_y,& + pol_z,map,sphere_bounds,cmax,gridbounds) + INTEGER, PARAMETER :: dp=8 + INTEGER, INTENT(IN) :: sphere_bounds(*), cmax, & + map(-cmax:cmax,1:3), & + gridbounds(2,3) + REAL(dp), INTENT(IN) :: grid(gridbounds(1,1):gridbounds(2,1), & + gridbounds(1,2):gridbounds(2,2),& + gridbounds(1,3):gridbounds(2,3)) + INTEGER, PARAMETER :: lp = 1 + REAL(dp), INTENT(IN) :: pol_x(0:lp,-cmax:cmax), & + pol_y(1:2,0:lp,-cmax:0), & + pol_z(1:2,0:lp,-cmax:0) + REAL(dp), INTENT(OUT) :: coef_xyz(((lp+1)*(lp+2)*(lp+3))/6) + INTEGER :: i, ig, igmax, igmin, j, j2, & + jg, jg2, jgmin, k, k2, kg, & + kg2, kgmin, lxp, sci + REAL(dp) :: coef_x(4,0:lp), & + coef_xy(2,((lp+1)*(lp+2))/2), & + s(4) + DO kg=kgmin,0 + DO jg=jgmin,0 + coef_x=0.0_dp + DO ig=igmin,igmax + DO lxp=0,lp + coef_x(:,lxp)=coef_x(:,lxp)+s(:)*pol_x(lxp,ig) + ENDDO + END DO + coef_xy(:,3)=coef_xy(:,3)+coef_x(3:4,0)*pol_y(2,1,jg) + END DO + coef_xyz(3)=coef_xyz(3)+coef_xy(1,3)*pol_z(1,0,kg) + END DO + END SUBROUTINE integrate_core_1 Index: Fortran/gfortran/regression/graphite/pr68550-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68550-2.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -fcheck=bounds -O1" } + +SUBROUTINE PD2VAL(RES,NDERIV,TG1,TG2,C0) + INTEGER, PARAMETER :: dp=8 + REAL(KIND=dp), INTENT(OUT) :: res(*) + REAL(KIND=dp), INTENT(IN) :: TG1, TG2, C0(105,*) + REAL(KIND=dp) :: T1(0:13), T2(0:13) + DO K=1,NDERIV+1 + RES(K)=RES(K)+DOT_PRODUCT(T1(0:7),C0(70:77,K))*T2(6) + RES(K)=RES(K)+DOT_PRODUCT(T1(0:4),C0(91:95,K))*T2(9) + RES(K)=RES(K)+DOT_PRODUCT(T1(0:3),C0(96:99,K))*T2(10) + ENDDO +END SUBROUTINE PD2VAL Index: Fortran/gfortran/regression/graphite/pr68565.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68565.f90 @@ -0,0 +1,30 @@ +! { dg-do run } +! { dg-options "-floop-nest-optimize" } + +MODULE test + IMPLICIT NONE + TYPE subset_type + INTEGER :: ncon_tot + REAL(KIND=8),DIMENSION(:,:),ALLOCATABLE :: coeff + END TYPE +CONTAINS + SUBROUTINE foo(subset) + TYPE(subset_type) :: subset + INTEGER :: icon1 + DO icon1=1,subset%ncon_tot + subset%coeff(:,icon1)=subset%coeff(:,icon1)/& + SQRT(DOT_PRODUCT(subset%coeff(:,icon1),subset%coeff(:,icon1))) + END DO + END SUBROUTINE +END MODULE + +USE test + TYPE(subset_type) :: subset + INTEGER, VOLATILE :: n1=7,n2=4 + ALLOCATE(subset%coeff(n1,n2)) + CALL RANDOM_NUMBER(subset%coeff) + subset%coeff=subset%coeff-0.5 + subset%ncon_tot=n2 + CALL foo(subset) + WRITE(6,*) MAXVAL(subset%coeff) +END Index: Fortran/gfortran/regression/graphite/pr68692.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68692.f90 @@ -0,0 +1,64 @@ +! { dg-options "-floop-nest-optimize -O3" } + +MODULE spme + INTEGER, PARAMETER :: dp=8 + PRIVATE + PUBLIC :: get_patch +CONTAINS + SUBROUTINE get_patch ( part, box, green, npts, p, rhos, is_core, is_shell,& + unit_charge, charges, coeff, n ) + INTEGER, POINTER :: box + REAL(KIND=dp), & + DIMENSION(-(n-1):n-1, 0:n-1), & + INTENT(IN) :: coeff + INTEGER, DIMENSION(3), INTENT(IN) :: npts + REAL(KIND=dp), DIMENSION(:, :, :), & + INTENT(OUT) :: rhos + REAL(KIND=dp) :: q + REAL(KIND=dp), DIMENSION(3) :: delta, r + CALL get_delta ( box, r, npts, delta, nbox ) + CALL spme_get_patch ( rhos, nbox, delta, q, coeff ) + END SUBROUTINE get_patch + SUBROUTINE spme_get_patch ( rhos, n, delta, q, coeff ) + REAL(KIND=dp), DIMENSION(:, :, :), & + INTENT(OUT) :: rhos + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: delta + REAL(KIND=dp), INTENT(IN) :: q + REAL(KIND=dp), & + DIMENSION(-(n-1):n-1, 0:n-1), & + INTENT(IN) :: coeff + INTEGER, PARAMETER :: nmax = 12 + REAL(KIND=dp), DIMENSION(3, -nmax:nmax) :: w_assign + REAL(KIND=dp), DIMENSION(3, 0:nmax-1) :: deltal + REAL(KIND=dp), DIMENSION(3, 1:nmax) :: f_assign + DO l = 1, n-1 + deltal ( 3, l ) = deltal ( 3, l-1 ) * delta ( 3 ) + END DO + DO j = -(n-1), n-1, 2 + DO l = 0, n-1 + w_assign ( 1, j ) = w_assign ( 1, j ) + & + coeff ( j, l ) * deltal ( 1, l ) + END DO + f_assign (3, i ) = w_assign ( 3, j ) + DO i2 = 1, n + DO i1 = 1, n + rhos ( i1, i2, i3 ) = r2 * f_assign ( 1, i1 ) + END DO + END DO + END DO + END SUBROUTINE spme_get_patch + SUBROUTINE get_delta ( box, r, npts, delta, n ) + INTEGER, POINTER :: box + REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: r + INTEGER, DIMENSION(3), INTENT(IN) :: npts + REAL(KIND=dp), DIMENSION(3), INTENT(OUT) :: delta + INTEGER, DIMENSION(3) :: center + REAL(KIND=dp), DIMENSION(3) :: ca, grid_i, s + CALL real_to_scaled(s,r,box) + s = s - REAL ( NINT ( s ),KIND=dp) + IF ( MOD ( n, 2 ) == 0 ) THEN + ca ( : ) = REAL ( center ( : ) ) + END IF + delta ( : ) = grid_i ( : ) - ca ( : ) + END SUBROUTINE get_delta +END MODULE spme Index: Fortran/gfortran/regression/graphite/pr68693.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68693.f90 @@ -0,0 +1,35 @@ +! { dg-options "-floop-nest-optimize -O2" } +MODULE dbcsr_index_operations + INTERFACE dbcsr_build_row_index + END INTERFACE +CONTAINS + SUBROUTINE merge_index_arrays (new_row_i, new_col_i, new_blk_p, new_size,& + old_row_i, old_col_i, old_blk_p, old_size,& + add_ip, add_size, new_blk_d, old_blk_d,& + added_size_offset, added_sizes, added_size, added_nblks, error) + INTEGER, DIMENSION(new_size), & + INTENT(OUT) :: new_blk_p, new_col_i, & + new_row_i + INTEGER, INTENT(IN) :: old_size + INTEGER, DIMENSION(old_size), INTENT(IN) :: old_blk_p, old_col_i, & + old_row_i + INTEGER, DIMENSION(new_size), & + INTENT(OUT), OPTIONAL :: new_blk_d + INTEGER, DIMENSION(old_size), & + INTENT(IN), OPTIONAL :: old_blk_d + INTEGER, DIMENSION(:), INTENT(IN), & + OPTIONAL :: added_sizes + INTEGER, INTENT(OUT), OPTIONAL :: added_size, added_nblks + LOGICAL :: multidata + IF (add_size .GT. 0) THEN + IF (old_size .EQ. 0) THEN + IF (PRESENT (added_size)) added_size = SUM (added_sizes) + ENDIF + ELSE + new_row_i(1:old_size) = old_row_i(1:old_size) + new_col_i(1:old_size) = old_col_i(1:old_size) + new_blk_p(1:old_size) = old_blk_p(1:old_size) + IF (multidata) new_blk_d(1:old_size) = old_blk_d(1:old_size) + ENDIF + END SUBROUTINE merge_index_arrays +END MODULE dbcsr_index_operations Index: Fortran/gfortran/regression/graphite/pr68715.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr68715.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -O1" } + +SUBROUTINE se_core_core_interaction(calculate_forces) + INTEGER, PARAMETER :: dp=8 + LOGICAL, INTENT(in) :: calculate_forces + REAL(KIND=dp), DIMENSION(3) :: force_ab, rij + LOGICAL :: lfoo,kfoo,mfoo,nfoo,ffoo + INTEGER, PARAMETER :: mi2=42 + CALL dummy(lfoo,kfoo,mfoo,nfoo,method_id,core_core) + IF (lfoo) THEN + DO WHILE (ffoo()) + IF (lfoo) CYCLE + IF (kfoo) CYCLE + dr1 = DOT_PRODUCT(rij,rij) + IF (dr1 > rij_threshold) THEN + SELECT CASE (method_id) + CASE (mi2) + IF (calculate_forces) THEN + CALL dummy2(force_ab) + IF (nfoo) THEN + force_ab = force_ab + core_core*dr3inv + END IF + END IF + END SELECT + END IF + enuclear = enuclear + enucij + END DO + CALL dummy3(enuclear) + END IF +END SUBROUTINE se_core_core_interaction Index: Fortran/gfortran/regression/graphite/pr69728.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr69728.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-options "-O3 -floop-nest-optimize" } +SUBROUTINE rk_addtend_dry ( t_tend, t_tendf, t_save, rk_step, & + h_diabatic, mut, msft, ide, jde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + IMPLICIT NONE + INTEGER , INTENT(IN ) :: ide, jde, ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN ) :: rk_step + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: t_tend, t_tendf + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & + INTENT(IN ) :: t_save, h_diabatic + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, msft + INTEGER :: i, j, k + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + IF(rk_step == 1)t_tendf(i,k,j) = t_tendf(i,k,j) + t_save(i,k,j) + t_tend(i,k,j) = t_tend(i,k,j) + t_tendf(i,k,j)/msft(i,j) & + + mut(i,j)*h_diabatic(i,k,j)/msft(i,j) + ENDDO + ENDDO + ENDDO +END SUBROUTINE rk_addtend_dry Index: Fortran/gfortran/regression/graphite/pr71351.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr71351.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -floop-nest-optimize" } + +SUBROUTINE print_crys_symmetry(nc,v) + INTEGER :: nc + REAL(KIND=8), DIMENSION(3,48) :: v + INTEGER :: n,i + vs = 0.0_8 + DO n = 1, nc + DO i = 1, 3 + vs = vs + ABS(v(i,n)) + END DO + END DO + CALL foo(vs) +END SUBROUTINE print_crys_symmetry Index: Fortran/gfortran/regression/graphite/pr71898.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr71898.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-options "-floop-nest-optimize -O1" } + +MODULE d3_poly + INTEGER, PUBLIC, PARAMETER :: max_grad2=5 + INTEGER, PUBLIC, PARAMETER :: max_grad3=3 + INTEGER, PUBLIC, PARAMETER :: cached_dim2=(max_grad2+1)*(max_grad2+2)/2 + INTEGER, PUBLIC, PARAMETER :: cached_dim3=(max_grad3+1)*(max_grad3+2)*(max_grad3+3)/6 + INTEGER, SAVE, DIMENSION(3,cached_dim3) :: a_mono_exp3 + INTEGER, SAVE, DIMENSION(cached_dim2,cached_dim2) :: a_mono_mult2 + INTEGER, SAVE, DIMENSION(cached_dim3,cached_dim3) :: a_mono_mult3 + INTEGER, SAVE, DIMENSION(4,cached_dim3) :: a_mono_mult3a +CONTAINS +SUBROUTINE init_d3_poly_module() + INTEGER :: grad, i, ii, ij, j, subG + INTEGER, DIMENSION(3) :: monoRes3 + DO grad=0,max_grad2 + DO i=grad,0,-1 + DO j=grad-i,0,-1 + END DO + END DO + END DO + DO ii=1,cached_dim3 + DO ij=ii,cached_dim2 + a_mono_mult2(ij,ii)=a_mono_mult2(ii,ij) + END DO + END DO + DO ii=1,cached_dim3 + DO ij=ii,cached_dim3 + monoRes3=a_mono_exp3(:,ii)+a_mono_exp3(:,ij) + a_mono_mult3(ii,ij)=mono_index3(monoRes3(1),monoRes3(2),monoRes3(3))+1 + a_mono_mult3(ij,ii)=a_mono_mult3(ii,ij) + END DO + END DO + DO i=1,cached_dim3 + DO j=1,4 + a_mono_mult3a(j,i)=a_mono_mult3(j,i) + END DO + END DO +END SUBROUTINE +PURE FUNCTION mono_index3(i,j,k) RESULT(res) + INTEGER, INTENT(in) :: i, j, k + res=grad*(grad+1)*(grad+2)/6+(sgrad)*(sgrad+1)/2+k +END FUNCTION +END MODULE d3_poly Index: Fortran/gfortran/regression/graphite/pr82449.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr82449.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-options "-O2 -floop-nest-optimize -std=legacy" } + + SUBROUTINE JDFIDX(MKL,KGSH) + DIMENSION MKL(6,6) + NKL=0 + 400 DO 40 KG = 1,KGSH + DO 40 LG = 1,KG + NKL = NKL + 1 + 40 MKL(LG,KG) = NKL + END Index: Fortran/gfortran/regression/graphite/pr82451.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr82451.f @@ -0,0 +1,39 @@ +! { dg-do compile } +! { dg-options "-O2 -floop-nest-optimize" } + MODULE LES3D_DATA + PARAMETER ( NSCHEME = 4, ICHEM = 0, ISGSK = 0, IVISC = 1 ) + DOUBLE PRECISION DT, TIME, STATTIME, CFL, RELNO, TSTND, ALREF + INTEGER IDYN, IMAX, JMAX, KMAX + PARAMETER( RUNIV = 8.3145D3, + > TPRANDLT = 0.91D0) + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:) :: + > U, V, W, P, T, H, EK, + > UAV, VAV, WAV, PAV, TAV, HAV, EKAV + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:) :: + > CONC, HF, QAV, COAV, HFAV, DU + DOUBLE PRECISION,ALLOCATABLE,DIMENSION(:,:,:,:,:) :: + > Q + END MODULE LES3D_DATA + SUBROUTINE FLUXJ() + USE LES3D_DATA + ALLOCATABLE QS(:), FSJ(:,:,:) + ALLOCATABLE DWDX(:),DWDY(:),DWDZ(:) + ALLOCATABLE DHDY(:), DKDY(:) + PARAMETER ( R12I = 1.0D0 / 12.0D0, + > TWO3 = 2.0D0 / 3.0D0 ) + ALLOCATE( QS(IMAX-1), FSJ(IMAX-1,0:JMAX-1,ND)) + ALLOCATE( DWDX(IMAX-1),DWDY(IMAX-1),DWDZ(IMAX-1)) + I1 = 1 + DO K = K1,K2 + DO J = J1,J2 + DO I = I1, I2 + FSJ(I,J,5) = FSJ(I,J,5) + PAV(I,J,K) * QS(I) + END DO + DO I = I1, I2 + DWDX(I) = DXI * R12I * (WAV(I-2,J,K) - WAV(I+2,J,K) + + > 8.0D0 * (WAV(I+1,J,K) - WAV(I-1,J,K))) + END DO + END DO + END DO + DEALLOCATE( QS, FSJ, DHDY, DKDY) + END Index: Fortran/gfortran/regression/graphite/pr82672.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr82672.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-O2 -floop-nest-optimize" } + + character(len=20,kind=4) :: s4 + character(len=20,kind=1) :: s1 + + s1 = "foo\u0000" + s1 = "foo\u00ff" + s1 = "foo\u0100" + s1 = "foo\u0101" + s1 = "foo\U00000101" + + s1 = 4_"foo bar" + s1 = 4_"foo\u00ff" + s1 = 4_"foo\u0101" + s1 = 4_"foo\u1101" + s1 = 4_"foo\UFFFFFFFF" + + s4 = "foo\u0000" + s4 = "foo\u00ff" + s4 = "foo\u0100" + s4 = "foo\U00000100" + + s4 = 4_"foo bar" + s4 = 4_"\xFF\x96" + s4 = 4_"\x00\x96" + s4 = 4_"foo\u00ff" + s4 = 4_"foo\u0101" + s4 = 4_"foo\u1101" + s4 = 4_"foo\Uab98EF56" + s4 = 4_"foo\UFFFFFFFF" + +end Index: Fortran/gfortran/regression/graphite/pr83887.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr83887.f @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-options "-O2 -floop-nest-optimize" } + SUBROUTINE STONG(IGAUSS) + DIMENSION EXX(6) + PARAMETER (MXSH=1000, MXGTOT=5000) + COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),NSHELL + 100 CONTINUE + NSHELL = NSHELL+1 + IF(NSHELL.GT.MXSH) THEN + RETURN + END IF + DO 320 I = 1,IGAUSS + K = K1+I-1 + EX(K) = EXX(I)*SCALE + 320 CONTINUE + IF(TNORM.GT.TOLNRM) THEN + STOP + END IF + DO 460 IG = K1,K2 + CS(IG) = FACS*CS(IG) + 460 CONTINUE + GO TO 100 + END Index: Fortran/gfortran/regression/graphite/pr83887.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr83887.f90 @@ -0,0 +1,59 @@ +! { dg-do compile } +! { dg-options "-O -floop-nest-optimize" } + SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, & + B, LDB ) + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + complex(kind((1.0d0,1.0d0))) ALPHA + complex(kind((1.0d0,1.0d0))) A( LDA, * ), B( LDB, * ) + EXTERNAL XERBLA + INTRINSIC CONJG, MAX + LOGICAL LSIDE, NOCONJ, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + complex(kind((1.0d0,1.0d0))) TEMP + complex(kind((1.0d0,1.0d0))) ONE + PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) + complex(kind((1.0d0,1.0d0))) ZERO + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) + LSIDE = scan( SIDE , 'Ll' )>0 + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOCONJ = scan( TRANSA, 'Tt' )>0 + NOUNIT = scan( DIAG , 'Nn' )>0 + UPPER = scan( UPLO , 'Uu' )>0 + INFO = 0 + IF( N.EQ.0 ) & + RETURN + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF + DO 160, J = 1, N + DO 150, I = 1, M + TEMP = B( I, J ) + IF( NOCONJ )THEN + IF( NOUNIT ) & + TEMP = TEMP*A( I, I ) + DO 130, K = I + 1, M + TEMP = TEMP + A( K, I )*B( K, J ) + 130 CONTINUE + ELSE + IF( NOUNIT ) & + TEMP = TEMP*CONJG( A( I, I ) ) + DO 140, K = I + 1, M + TEMP = TEMP + CONJG( A( K, I ) )*B( K, J ) + 140 CONTINUE + END IF + B( I, J ) = ALPHA*TEMP + 150 CONTINUE + 160 CONTINUE + RETURN + END + Index: Fortran/gfortran/regression/graphite/pr83963.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr83963.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O -floop-nest-optimize" } + + SUBROUTINE DAVCI(NORB,NCOR,NCI,NA,NB, + * CI,MAXP,MAXW1, + * IHMCON,ISTRB,ISTRP,ISTAR,II) + DIMENSION EC(MAXP,MAXP),IWRK1(2*MAXW1) + EC(II,II) = 1.0D+00 + DO 1396 II=1,MAXP + DO 1398 JJ=1,II-1 + EC(II,JJ) = 0.0D+00 + 1398 CONTINUE + 1396 CONTINUE + IF (NA.EQ.NB) THEN + CALL RINAB0(SI1,SI2,NORB,NCOR,NCI,NA,NB,CI(1,IP),IACON1,IBCON1, + * IWRK1,IHMCON,ISTRB,ISTRP,ISTAR) + ENDIF + END Index: Fortran/gfortran/regression/graphite/pr84223.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr84223.f90 @@ -0,0 +1,3 @@ +! { dg-do compile } +! { dg-options "-fgraphite-identity -O1 --param sccvn-max-alias-queries-per-access=0" } + include "../assumed_rank_bounds_2.f90" Index: Fortran/gfortran/regression/graphite/pr89182.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr89182.f90 @@ -0,0 +1,31 @@ +! { dg-do compile } +! { dg-options "-O3 -fgraphite-identity --param max-completely-peeled-insns=8" } + +MODULE hfx_contract_block + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE contract_block(mb_max,mc_max,kbc,ks_bc) + REAL(KIND=dp) :: kbc(mb_max*mc_max), ks_bc + CALL block_1_2_1_2(kbc,ks_bc) + CALL block_1_2_1_3(kbc,ks_bc) + CALL block_1_2_1_3(kbc,ks_bc) + END SUBROUTINE contract_block + SUBROUTINE block_1_2_1_2(kbc,ks_bc) + REAL(KIND=dp) :: kbc(2*1), ks_bc + DO mc = 1,2 + DO mb = 1,2 + kbc((mc-1)*2+mb) = ks_bc + END DO + END DO + END SUBROUTINE block_1_2_1_2 + SUBROUTINE block_1_2_1_3(kbc,ks_bc) + REAL(KIND=dp) :: kbc(2*1), ks_bc + DO md = 1,3 + DO mc = 1,1 + DO mb = 1,2 + kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc + END DO + END DO + END DO + END SUBROUTINE block_1_2_1_3 +END MODULE hfx_contract_block Index: Fortran/gfortran/regression/graphite/pr90240.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr90240.f @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-O1 -floop-nest-optimize" } + + PARAMETER (n=1335, N2=1335) + COMMON a(n,N2), b(n,N2), c(n,N2), + * d(n,N2), + 2 e(n,N2), f(n,N2), + * g(n,N2), h(n,N2) + DO 200 j=1,i + DO 300 k=1,l + a(k,j) = c(k,j)*g(k,j)*f(k+1,m)+f(k,m)+f(k,j) + 2 +f(k+1,j)*h(k+1,j) + b(k,j+1) = d(k,j+1)*g(k,m)+g(k,j+1) + 1 *e(k,m)+e(k,j+1)+e(k,j)+e(k+1,j) + 2 *h(k,j+1)-h(k,j) + 300 ENDDO + 200 ENDDO + END Index: Fortran/gfortran/regression/graphite/pr93439.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/pr93439.f90 @@ -0,0 +1,21 @@ +! { dg-additional-options "-O2 -floop-parallelize-all -floop-unroll-and-jam -ftree-parallelize-loops=2" } + +module ai + integer, parameter :: dp = 8 +contains + subroutine qu(ja, nq, en, p5) + real(kind = dp) :: nq(ja), en(ja), p5(ja) + call tl(ja, nq, en, p5) + end subroutine qu + + subroutine tl(ja, nq, en, p5) + real(kind = dp) :: nq(9), en(9 * ja), p5(3 * ja) + do mc = 1, ja + do mb = 1, 9 + do ma = 1, 3 + p5((mc - 1) * 3 + ma) = p5((mc - 1) * 3 + ma) - 1 + end do + end do + end do + end subroutine tl +end module ai Index: Fortran/gfortran/regression/graphite/run-id-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/run-id-1.f @@ -0,0 +1,47 @@ + subroutine mul66(rt,rtt,r) + real*8 rt(6,6),r(6,6),rtt(6,6) + do i=1,6 + do j=1,6 + do ia=1,6 + rtt(i,ia)=rt(i,j)*r(j,ia)+rtt(i,ia) + end do + end do + end do + end + + program test + real*8 xj(6,6),w(6,6),w1(6,6) + parameter(idump=0) + integer i,j + + do i=1,6 + do j=1,6 + xj(i,j) = 0.0d0 + w1(i,j) = 0.0d0 + w(i,j) = i * 10.0d0 + j; + end do + end do + + xj(1,2) = 1.0d0 + xj(2,1) = -1.0d0 + xj(3,4) = 1.0d0 + xj(4,3) = -1.0d0 + xj(5,6) = 1.0d0 + xj(6,5) = -1.0d0 + + call mul66(xj,w1,w) + + if (idump.ne.0) then + write(6,*) 'w1 after call to mul66' + do i = 1,6 + do j = 1,6 + write(6,'(D15.7)') w1(i,j) + end do + end do + end if + + if (w1(1,1).ne.21.0d0) then + STOP 1 + end if + + end Index: Fortran/gfortran/regression/graphite/run-id-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/run-id-2.f90 @@ -0,0 +1,66 @@ + IMPLICIT NONE + INTEGER, PARAMETER :: dp=KIND(0.0D0) + REAL(KIND=dp) :: res + + res=exp_radius_very_extended( 0 , 1 , 0 , 1, & + (/0.0D0,0.0D0,0.0D0/),& + (/1.0D0,0.0D0,0.0D0/),& + (/1.0D0,0.0D0,0.0D0/),& + 1.0D0,1.0D0,1.0D0,1.0D0) + if (res.ne.1.0d0) STOP 1 + +CONTAINS + + FUNCTION exp_radius_very_extended(la_min,la_max,lb_min,lb_max,ra,rb,rp,& + zetp,eps,prefactor,cutoff) RESULT(radius) + + INTEGER, INTENT(IN) :: la_min, la_max, lb_min, lb_max + REAL(KIND=dp), INTENT(IN) :: ra(3), rb(3), rp(3), zetp, & + eps, prefactor, cutoff + REAL(KIND=dp) :: radius + + INTEGER :: i, ico, j, jco, la(3), lb(3), & + lxa, lxb, lya, lyb, lza, lzb + REAL(KIND=dp) :: bini, binj, coef(0:20), & + epsin_local, polycoef(0:60), & + prefactor_local, rad_a, & + rad_b, s1, s2 + + epsin_local=1.0E-2_dp + + prefactor_local=prefactor*MAX(1.0_dp,cutoff) + rad_a=SQRT(SUM((ra-rp)**2)) + rad_b=SQRT(SUM((rb-rp)**2)) + + polycoef(0:la_max+lb_max)=0.0_dp + DO lxa=0,la_max + DO lxb=0,lb_max + coef(0:la_max+lb_max)=0.0_dp + bini=1.0_dp + s1=1.0_dp + DO i=0,lxa + binj=1.0_dp + s2=1.0_dp + DO j=0,lxb + coef(lxa+lxb-i-j)=coef(lxa+lxb-i-j) + bini*binj*s1*s2 + binj=(binj*(lxb-j))/(j+1) + s2=s2*(rad_b) + ENDDO + bini=(bini*(lxa-i))/(i+1) + s1=s1*(rad_a) + ENDDO + DO i=0,lxa+lxb + polycoef(i)=MAX(polycoef(i),coef(i)) + ENDDO + ENDDO + ENDDO + + polycoef(0:la_max+lb_max)=polycoef(0:la_max+lb_max)*prefactor_local + radius=0.0_dp + DO i=0,la_max+lb_max + radius=MAX(radius,polycoef(i)**(i+1)) + ENDDO + + END FUNCTION exp_radius_very_extended + +END Index: Fortran/gfortran/regression/graphite/run-id-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/run-id-3.f90 @@ -0,0 +1,13 @@ +! { dg-do run } +! { dg-skip-if "" { *-*-* } { "-O0" } { "" } } +! { dg-additional-options "-ffrontend-optimize -floop-nest-optimize" } +! PR 56872 - wrong front-end optimization with a single constructor. +! Original bug report by Rich Townsend. + integer :: k + real :: s + integer :: m + s = 2.0 + m = 4 + res = SUM([(s**(REAL(k-1)/REAL(m-1)),k=1,m)]) + if (abs(res - 5.84732246) > 1e-6) STOP 1 + end Index: Fortran/gfortran/regression/graphite/scop-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/scop-1.f @@ -0,0 +1,12 @@ + dimension p1(2),t(6,4),b1(2),b2(2),al1(2),al2(2),g1(2),g2(2) + save + if(nlin.eq.0) then + do 20 l=1,2 + ll=2*l + b2(l)=t(6-ll,ll-1)*t(6-ll,ll-1)+t(7-ll,ll-1)*t(7-ll,ll-1) + write(*,*) b2(l) + 20 continue + endif + end + +! { dg-final { scan-tree-dump-times "number of SCoPs: 1" 1 "graphite" { xfail *-*-* } } } Index: Fortran/gfortran/regression/graphite/vect-pr40979.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/vect-pr40979.f90 @@ -0,0 +1,26 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-msse2" { target { { i?86-*-* x86_64-*-* } && ilp32 } } } + +module mqc_m +integer, parameter, private :: longreal = selected_real_kind(15,90) +contains + subroutine mutual_ind_quad_cir_coil (m, l12) + real (kind = longreal), dimension(9), save :: w2gauss, w1gauss + real (kind = longreal) :: l12_lower, num, l12 + real (kind = longreal), dimension(3) :: current, coil + w2gauss(1) = 16.0_longreal/81.0_longreal + w1gauss(5) = 0.3302393550_longreal + do i = 1, 2*m + do j = 1, 9 + do k = 1, 9 + num = w1gauss(j) * w2gauss(k) * dot_product(coil,current) + l12_lower = l12_lower + num + end do + end do + end do + l12 = l12_lower + end subroutine mutual_ind_quad_cir_coil +end module mqc_m + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } Index: Fortran/gfortran/regression/graphite/vect-pr94043.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/graphite/vect-pr94043.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-additional-options "-O3 -ftree-parallelize-loops=2 -fno-tree-dce" } + +! As PR94043, test it to be compiled successfully without ICE. + +program yw + integer :: hx(6, 6) + integer :: ps = 1, e2 = 1 + + do ps = 1, 6 + do e2 = 1, 6 + hx(e2, ps) = 0 + if (ps >= 5 .and. e2 >= 5) then + hx(e2, ps) = hx(1, 1) + end if + end do + end do +end program Index: Fortran/gfortran/regression/guality/arg1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/guality/arg1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-options "-g" } + integer :: a(10), b(12) + call sub (a, 10) + call sub (b, 12) + write (*,*) a, b +end + +subroutine sub (a, n) + integer :: a(n), n + do i = 1, n + a(i) = i + end do + write (*,*) a ! { dg-final { gdb-test 14 "a(10)" "10" } } +end subroutine Index: Fortran/gfortran/regression/guality/guality.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/guality/guality.exp @@ -0,0 +1,49 @@ +# This harness is for tests that should be run at all optimisation levels. + +load_lib gfortran-dg.exp +load_lib gcc-gdb-test.exp + +# Disable on darwin until radr://7264615 is resolved. +if { [istarget *-*-darwin*] } { + return +} + +if { [istarget hppa*-*-hpux*] } { + return +} + +if { [istarget "powerpc-ibm-aix*"] } { + set torture_execute_xfail "powerpc-ibm-aix*" + return +} + +dg-init + +global GDB +if ![info exists ::env(GUALITY_GDB_NAME)] { + if [info exists GDB] { + set guality_gdb_name "$GDB" + } elseif { [info exists rootme] && [file exists $rootme/../gdb/gdb] } { + # If we're doing a combined build, and gdb is available, use it. + set guality_gdb_name "$rootme/../gdb/gdb" + } else { + set guality_gdb_name "[transform gdb]" + } + setenv GUALITY_GDB_NAME "$guality_gdb_name" +} +report_gdb $::env(GUALITY_GDB_NAME) [info script] + +global DG_TORTURE_OPTIONS +set guality_dg_torture_options [guality_minimal_options $DG_TORTURE_OPTIONS] +torture-init +set-torture-options \ + $guality_dg_torture_options \ + +gfortran-dg-runtest [lsort [glob $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] "" "" + +if [info exists guality_gdb_name] { + unsetenv GUALITY_GDB_NAME +} + +torture-finish +dg-finish Index: Fortran/gfortran/regression/guality/pr41558.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/guality/pr41558.f90 @@ -0,0 +1,11 @@ +! PR debug/41558 +! { dg-do run } +! { dg-skip-if "PR testsuite/51875" { { hppa*-*-hpux* } && { ! lp64 } } } +! { dg-options "-g" } + +subroutine f (s) + character(len=3) :: s + write (*,*) s ! { dg-final { gdb-test 7 "s" "'foo'" } } +end + call f ('foo') +end Index: Fortran/gfortran/regression/ieee/dec_math_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/dec_math_1.f90 @@ -0,0 +1,231 @@ +! { dg-do run } +! { dg-additional-options "-cpp -std=gnu" } +! +! Test values for degree-valued trigonometric intrinsics. +! +! Run under ieee/ as +! use ieee_arithmetic +! (used for result checking) is not available on all platforms) + +module dec_math_5 + + + ! Use the highest precision available. + ! Note however that if both __GFC_REAL_10__ and __GFC_REAL_16__ are defined, + ! the size of real(16) is actually that of REAL(10) (80 bits) in which case + ! we should not over-estimate the precision available, or the test will fail. +#if defined(__GFC_REAL_10__) + integer, parameter :: real_kind = 10 + real(real_kind), parameter :: eps = 5e-11_10 + + real(real_kind), parameter :: pi_2 = 1.57079632679489656_10 + real(real_kind), parameter :: pi = 3.14159265358979312_10 + real(real_kind), parameter :: tau = 6.28318530717958623_10 + +#elif defined(__GFC_REAL_16__) + integer, parameter :: real_kind = 16 + real(real_kind), parameter :: eps = 5e-16_16 + + real(real_kind), parameter :: pi_2 = 1.5707963267948966192313216916397514_16 + real(real_kind), parameter :: pi = 3.1415926535897932384626433832795_16 + real(real_kind), parameter :: tau = 6.28318530717958647692528676655900559_16 + +#else + integer, parameter :: real_kind = 8 + real(real_kind), parameter :: eps = 5e-10_8 + + real(real_kind), parameter :: pi_2 = 1.57079632679490_8 + real(real_kind), parameter :: pi = 3.14159265358979_8 + real(real_kind), parameter :: tau = 6.28318530717959_8 + +#endif + + ! Important angles in canonical form. + + integer, parameter :: nangle = 16 + + real(real_kind), dimension(nangle), parameter :: degrees = (/ & + 0, & ! 180 * 0 + 30, & ! 180 * 1/6 + 45, & ! 180 * 1/4 + 60, & ! 180 * 1/3 + 90, & ! 180 * 1/2 + 120, & ! 180 * 2/3 + 135, & ! 180 * 3/4 + 150, & ! 180 * 5/6 + 180, & ! 180 + 210, & ! 180 * 7/6 + 225, & ! 180 * 5/4 + 240, & ! 180 * 4/3 + 270, & ! 180 * 3/2 + 300, & ! 180 * 5/3 + 315, & ! 180 * 7/4 + 330 & ! 180 * 11/6 + /) + + real(real_kind), dimension(nangle), parameter :: radians = (/ & +#ifdef __GFC_REAL_10__ + 0.000000000000000000_10, & ! pi * 0 + 0.523598775598298873_10, & ! pi * 1/6 + 0.785398163397448310_10, & ! pi * 1/4 + 1.047197551196597750_10, & ! pi * 1/3 + 1.570796326794896620_10, & ! pi * 1/2 + 2.094395102393195490_10, & ! pi * 2/3 + 2.356194490192344930_10, & ! pi * 3/4 + 2.617993877991494370_10, & ! pi * 5/6 + 3.141592653589793240_10, & ! pi + 3.665191429188092110_10, & ! pi * 7/6 + 3.926990816987241550_10, & ! pi * 5/4 + 4.188790204786390980_10, & ! pi * 4/3 + 4.712388980384689860_10, & ! pi * 3/2 + 5.235987755982988730_10, & ! pi * 5/3 + 5.497787143782138170_10, & ! pi * 7/4 + 5.759586531581287600_10 & ! pi * 11/6 + +#elif defined(__GFC_REAL_16__) + 0.000000000000000000000000000000000_16, & ! pi * 0 + 0.523598775598298873077107230546584_16, & ! pi * 1/6 + 0.785398163397448309615660845819876_16, & ! pi * 1/4 + 1.047197551196597746154214461093170_16, & ! pi * 1/3 + 1.570796326794896619231321691639750_16, & ! pi * 1/2 + 2.094395102393195492308428922186330_16, & ! pi * 2/3 + 2.356194490192344928846982537459630_16, & ! pi * 3/4 + 2.617993877991494365385536152732920_16, & ! pi * 5/6 + 3.141592653589793238462643383279500_16, & ! pi + 3.665191429188092111539750613826090_16, & ! pi * 7/6 + 3.926990816987241548078304229099380_16, & ! pi * 5/4 + 4.188790204786390984616857844372670_16, & ! pi * 4/3 + 4.712388980384689857693965074919250_16, & ! pi * 3/2 + 5.235987755982988730771072305465840_16, & ! pi * 5/3 + 5.497787143782138167309625920739130_16, & ! pi * 7/4 + 5.759586531581287603848179536012420_16 & ! pi * 11/6 + +#else + 0.000000000000000_8, & ! pi * 0 + 0.523598775598299_8, & ! pi * 1/6 + 0.785398163397448_8, & ! pi * 1/4 + 1.047197551196600_8, & ! pi * 1/3 + 1.570796326794900_8, & ! pi * 1/2 + 2.094395102393200_8, & ! pi * 2/3 + 2.356194490192340_8, & ! pi * 3/4 + 2.617993877991490_8, & ! pi * 5/6 + 3.141592653589790_8, & ! pi + 3.665191429188090_8, & ! pi * 7/6 + 3.926990816987240_8, & ! pi * 5/4 + 4.188790204786390_8, & ! pi * 4/3 + 4.712388980384690_8, & ! pi * 3/2 + 5.235987755982990_8, & ! pi * 5/3 + 5.497787143782140_8, & ! pi * 7/4 + 5.759586531581290_8 & ! pi * 11/6 +#endif + /) + + ! sind, cosd, tand, cotand + + ! Ensure precision degrades minimally for large values. + integer, parameter :: nphase = 5 + + integer, dimension(nphase), parameter :: phases = (/ & + 0, 1, 5, 100, 10000 & + /) + +contains + + subroutine compare(strl, xl_in, xl_out, strr, xr_in, xr_out, eps) + use ieee_arithmetic + implicit none + character(*), intent(in) :: strl, strr + real(real_kind), intent(in) :: xl_in, xl_out, xr_in, xr_out, eps + + if ((ieee_is_nan(xl_out) .neqv. ieee_is_nan(xr_out)) & + .or. (ieee_is_finite(xl_out) .neqv. ieee_is_finite(xr_out)) & + .or. (abs(xl_out - xr_out) .gt. eps)) then + write (*, 100) strl, "(", xl_in, "): ", xl_out + write (*, 100) strr, "(", xr_in, "): ", xr_out + + if ((ieee_is_nan(xl_out) .eqv. ieee_is_nan(xr_out)) & + .and. ieee_is_finite(xl_out) .and. ieee_is_finite(xr_out)) then + write (*, 300) "|xl - xr| = ", abs(xl_out - xr_out) + write (*, 300) " > eps = ", eps + endif + + call abort() + endif + +#ifdef __GFC_REAL_16__ + 100 format((A8,A,F34.30,A,F34.30,F34.30)) + 200 format((A12,F34.30)) + !500 format((A8,A,G34.29,A,G34.29,G34.29)) +#elif defined(__GFC_REAL_10__) + 100 format((A8,A,F21.17,A,F21.17,F21.17)) + 200 format((A12,F21.17)) + !500 format((A8,A,G21.16,A,G21.16,G21.16)) +#else + 100 format((A8,A,F18.14,A,F18.14,F18.14)) + 200 format((A12,F18.14)) + !500 format((A8,A,G18.13,A,G18.13,G18.13)) +#endif + 300 format((A12,G8.2)) + endsubroutine + +endmodule + +use dec_math_5 +use ieee_arithmetic +implicit none + +integer :: phase_index, angle_index, phase +real(real_kind) :: deg_in, deg_out, deg_out2, rad_in, rad_out + +! Try every value in degrees, and make sure they are correct compared to the +! corresponding radian function. + +do phase_index = 1, size(phases) + phase = phases(phase_index) + + do angle_index = 1, size(degrees) + ! eqv to degrees(angle_index) modulo 360 + deg_in = degrees(angle_index) + phase * 360 + rad_in = radians(angle_index) + phase * tau + + ! sind vs. sin + deg_out = sind(deg_in) + rad_out = sin(rad_in) + call compare("sind", deg_in, deg_out, "sin", rad_in, rad_out, eps) + + ! cosd vs. cos + deg_out = cosd(deg_in) + rad_out = cos(rad_in) + call compare("cosd", deg_in, deg_out, "cos", rad_in, rad_out, eps) + + ! tand vs. tan + deg_out = tand(deg_in) + rad_out = tan(rad_in) + if ( ieee_is_finite(deg_out) ) then + call compare("tand", deg_in, deg_out, "tan", rad_in, rad_out, eps) + endif + + ! cotand vs. cotan + deg_out = cotand(deg_in) + rad_out = cotan(rad_in) + + ! Skip comparing infinity, because cotan does not return infinity + if ( ieee_is_finite(deg_out) ) then + call compare("cotand", deg_in, deg_out, "cotan", rad_in, rad_out, eps) + + ! cotand vs. tand + deg_out = cotand(deg_in) + deg_out2 = -tand(deg_in + 90) + + call compare("cotand", deg_in, deg_out, "-tand+90", deg_in, deg_out2, eps) + deg_out2 = 1 / tand(deg_in) + call compare("cotand", deg_in, deg_out, "1/tand", deg_in, deg_out2, eps) + endif + + enddo + + +enddo + + +end Index: Fortran/gfortran/regression/ieee/fma_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/fma_1.f90 @@ -0,0 +1,96 @@ +! Test IEEE_FMA +! { dg-do run } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_exceptions + use, intrinsic :: ieee_arithmetic + implicit none + + integer :: ex + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: lx1, lx2, lx3 + real(kind=k2) :: wx1, wx2, wx3 + + ! Float + + sx1 = 3 ; sx2 = 2 ; sx3 = 1 + if (ieee_fma(sx1, sx2, sx3) /= 7) stop 1 + sx1 = 0 ; sx2 = 2 ; sx3 = 1 + if (ieee_fma(sx1, sx2, sx3) /= 1) stop 2 + sx1 = 3 ; sx2 = 2 ; sx3 = 0 + if (ieee_fma(sx1, sx2, sx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(sx1)))) / log(real(2, kind(sx1)))) - 1 + sx1 = 1 + spacing(real(1, kind(sx1))) + sx2 = 2 ; sx2 = sx2 ** ex ; sx2 = sx2 * 3 + sx3 = -sx2 + + print *, sx1 * sx2 + sx3 + print *, ieee_fma(sx1, sx2, sx3) + if (ieee_fma(sx1, sx2, sx3) /= real(3, kind(sx1)) / 2) stop 4 + + ! Double + + dx1 = 3 ; dx2 = 2 ; dx3 = 1 + if (ieee_fma(dx1, dx2, dx3) /= 7) stop 1 + dx1 = 0 ; dx2 = 2 ; dx3 = 1 + if (ieee_fma(dx1, dx2, dx3) /= 1) stop 2 + dx1 = 3 ; dx2 = 2 ; dx3 = 0 + if (ieee_fma(dx1, dx2, dx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(dx1)))) / log(real(2, kind(dx1)))) - 1 + dx1 = 1 + spacing(real(1, kind(dx1))) + dx2 = 2 ; dx2 = dx2 ** ex ; dx2 = dx2 * 3 + dx3 = -dx2 + + print *, dx1 * dx2 + dx3 + print *, ieee_fma(dx1, dx2, dx3) + if (ieee_fma(dx1, dx2, dx3) /= real(3, kind(dx1)) / 2) stop 4 + + ! Large kind 1 + + lx1 = 3 ; lx2 = 2 ; lx3 = 1 + if (ieee_fma(lx1, lx2, lx3) /= 7) stop 1 + lx1 = 0 ; lx2 = 2 ; lx3 = 1 + if (ieee_fma(lx1, lx2, lx3) /= 1) stop 2 + lx1 = 3 ; lx2 = 2 ; lx3 = 0 + if (ieee_fma(lx1, lx2, lx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(lx1)))) / log(real(2, kind(lx1)))) - 1 + lx1 = 1 + spacing(real(1, kind(lx1))) + lx2 = 2 ; lx2 = lx2 ** ex ; lx2 = lx2 * 3 + lx3 = -lx2 + + print *, lx1 * lx2 + lx3 + print *, ieee_fma(lx1, lx2, lx3) + if (ieee_fma(lx1, lx2, lx3) /= real(3, kind(lx1)) / 2) stop 4 + + ! Large kind 2 + + wx1 = 3 ; wx2 = 2 ; wx3 = 1 + if (ieee_fma(wx1, wx2, wx3) /= 7) stop 1 + wx1 = 0 ; wx2 = 2 ; wx3 = 1 + if (ieee_fma(wx1, wx2, wx3) /= 1) stop 2 + wx1 = 3 ; wx2 = 2 ; wx3 = 0 + if (ieee_fma(wx1, wx2, wx3) /= 6) stop 3 + + ex = int(log(rrspacing(real(1, kind(wx1)))) / log(real(2, kind(wx1)))) - 1 + wx1 = 1 + spacing(real(1, kind(wx1))) + wx2 = 2 ; wx2 = wx2 ** ex ; wx2 = wx2 * 3 + wx3 = -wx2 + + print *, wx1 * wx2 + wx3 + print *, ieee_fma(wx1, wx2, wx3) + if (ieee_fma(wx1, wx2, wx3) /= real(3, kind(wx1)) / 2) stop 4 + +end Index: Fortran/gfortran/regression/ieee/ieee.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee.exp @@ -0,0 +1,59 @@ +# Copyright (C) 2013-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp +load_lib target-supports.exp + +# If a testcase doesn't have special options, use these. +global DEFAULT_FFLAGS +if ![info exists DEFAULT_FFLAGS] then { + set DEFAULT_FFLAGS " -pedantic-errors" +} + +# Initialize `dg'. +dg-init + +# Flags for finding the IEEE modules +if [info exists TOOL_OPTIONS] { + set specpath [get_multilibs ${TOOL_OPTIONS}] +} else { + set specpath [get_multilibs] +} +set options "-fintrinsic-modules-path $specpath/libgfortran/" + +# Bail out if IEEE tests are not supported at all +if ![check_effective_target_fortran_ieee $options ] { + return +} + +# Add target-independent options to require IEEE compatibility +set options "$DEFAULT_FFLAGS $options -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans" + +# Add target-specific options to require IEEE compatibility +set target_options [add_options_for_ieee ""] +set options "$options $target_options" + +# Main loop. +gfortran-dg-runtest [lsort \ + [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" $options + +# All done. +dg-finish Index: Fortran/gfortran/regression/ieee/ieee_1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_1.F90 @@ -0,0 +1,150 @@ +! { dg-do run } +! { dg-additional-options "-ffree-line-length-none" } +! { dg-additional-options "-mfp-trap-mode=sui" { target alpha*-*-* } } +! +! Use dg-additional-options rather than dg-options to avoid overwriting the +! default IEEE options which are passed by ieee.exp and necessary. + + use ieee_features, only : ieee_datatype, ieee_denormal, ieee_divide, & + ieee_halting, ieee_inexact_flag, ieee_inf, ieee_invalid_flag, & + ieee_nan, ieee_rounding, ieee_sqrt, ieee_underflow_flag + use ieee_exceptions + + implicit none + + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + logical :: l(5) = .false. + character(len=5) :: s + +#define FLAGS_STRING(S) \ + call ieee_get_flag(x, l) ; \ + write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l) + +#define CHECK_FLAGS(expected) \ + FLAGS_STRING(s) ; \ + if (s /= expected) then ; \ + write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \ + STOP 1; \ + end if ; \ + call check_flag_sub + + real, volatile :: sx + double precision, volatile :: dx + + ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG + + !!!! IEEE float + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + sx = -1 + sx = sqrt(sx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + sx = huge(sx) + CHECK_FLAGS(" ") + sx = sx*sx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + sx = 0 + sx = 1 / sx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + sx = tiny(sx) + CHECK_FLAGS(" ") + sx = sx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + !!!! IEEE double + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + dx = -1 + dx = sqrt(dx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + dx = huge(dx) + CHECK_FLAGS(" ") + dx = dx*dx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + dx = 0 + dx = 1 / dx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + dx = tiny(dx) + CHECK_FLAGS(" ") + dx = dx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + +contains + + subroutine check_flag_sub + use ieee_exceptions + logical :: l(5) = .false. + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + call ieee_get_flag(x, l) + + if (any(l)) then + print *, "Flags not cleared in subroutine" + STOP 2 + end if + end subroutine + +end Index: Fortran/gfortran/regression/ieee/ieee_10.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_10.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-additional-options "-ffpe-trap=overflow,invalid" } +! +! Use dg-additional-options rather than dg-options to avoid overwriting the +! default IEEE options which are passed by ieee.exp and necessary. +program foo + + use ieee_arithmetic + + implicit none + + real x + real(8) y + + ! At this point it is unclear what the behavior should be + ! for -ffpe-trap=invalid with a signaling NaN + !x = ieee_value(x, ieee_signaling_nan) + !if (.not. ieee_is_nan(x)) stop 1 + x = ieee_value(x, ieee_quiet_nan) + if (.not. ieee_is_nan(x)) stop 2 + + x = ieee_value(x, ieee_positive_inf) + if (ieee_is_finite(x)) stop 3 + x = ieee_value(x, ieee_negative_inf) + if (ieee_is_finite(x)) stop 4 + + ! At this point it is unclear what the behavior should be + ! for -ffpe-trap=invalid with a signaling NaN + !y = ieee_value(y, ieee_signaling_nan) + !if (.not. ieee_is_nan(y)) stop 5 + y = ieee_value(y, ieee_quiet_nan) + if (.not. ieee_is_nan(y)) stop 6 + + y = ieee_value(y, ieee_positive_inf) + if (ieee_is_finite(y)) stop 7 + y = ieee_value(y, ieee_negative_inf) + if (ieee_is_finite(y)) stop 8 + +end program foo Index: Fortran/gfortran/regression/ieee/ieee_11.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_11.F90 @@ -0,0 +1,74 @@ +! { dg-do run } +program foo + + use ieee_arithmetic + + implicit none + + call test04 + call test08 + call test10 + call test16 + + contains + + subroutine test04 + real(4) x, y + if (ieee_support_subnormal(x)) then + x = ieee_value(x, ieee_positive_subnormal) + y = ieee_value(y, ieee_positive_denormal) + if (x /= y) stop 1 + x = ieee_value(x, ieee_negative_subnormal) + y = ieee_value(y, ieee_negative_denormal) + if (x /= y) stop 2 + end if + end subroutine test04 + + subroutine test08 + real(8) x, y + if (ieee_support_subnormal(x)) then + x = ieee_value(x, ieee_positive_subnormal) + y = ieee_value(y, ieee_positive_denormal) + if (x /= y) stop 1 + x = ieee_value(x, ieee_negative_subnormal) + y = ieee_value(y, ieee_negative_denormal) + if (x /= y) stop 2 + end if + end subroutine test08 + +#ifdef __GFC_REAL_10__ + subroutine test10 + real(10) x, y + if (ieee_support_subnormal(x)) then + x = ieee_value(x, ieee_positive_subnormal) + y = ieee_value(y, ieee_positive_denormal) + if (x /= y) stop 1 + x = ieee_value(x, ieee_negative_subnormal) + y = ieee_value(y, ieee_negative_denormal) + if (x /= y) stop 2 + end if + end subroutine test10 +#else + subroutine test10 + end subroutine test10 +#endif + +#ifdef __GFC_REAL_16__ + subroutine test16 + real(16) x, y + if (ieee_support_subnormal(x)) then + x = ieee_value(x, ieee_positive_subnormal) + y = ieee_value(y, ieee_positive_denormal) + if (x /= y) stop 1 + x = ieee_value(x, ieee_negative_subnormal) + y = ieee_value(y, ieee_negative_denormal) + if (x /= y) stop 2 + end if + end subroutine test16 +#else + subroutine test16 + end subroutine test16 +#endif + + +end program foo Index: Fortran/gfortran/regression/ieee/ieee_12.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_12.f90 @@ -0,0 +1,24 @@ +! { dg-do run } +! PR95647 operator(.eq.) and operator(==) treated differently +program test + use, intrinsic :: ieee_arithmetic, only : & +& ieee_class, & +& ieee_class_type, & +& ieee_negative_normal, & +& ieee_positive_normal, & +& operator(.eq.), operator(.ne.) + integer :: good + real(4) r4 + type(ieee_class_type) class1 + good = 0 + r4 = 1.0 + class1 = ieee_class(r4) + if (class1 .eq. ieee_positive_normal) good = good + 1 + if (class1 .ne. ieee_negative_normal) good = good + 1 + r4 = -1.0 + class1 = ieee_class(r4) + if (class1 .eq. ieee_negative_normal) good = good + 1 + if (class1 .ne. ieee_positive_normal) good = good + 1 + if (good /= 4) call abort +end program test + Index: Fortran/gfortran/regression/ieee/ieee_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_2.f90 @@ -0,0 +1,413 @@ +! { dg-do run } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_exceptions + use, intrinsic :: ieee_arithmetic + implicit none + + interface check_equal + procedure check_equal_float, check_equal_double + end interface + + interface check_not_equal + procedure check_not_equal_float, check_not_equal_double + end interface + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + type(ieee_round_type) :: mode + + ! Test IEEE_COPY_SIGN + sx1 = 1.3 + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 1 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 2 + if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 3 + if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 4 + sx1 = huge(sx1) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 5 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 6 + if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 7 + if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 8 + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 9 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 10 + if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 11 + if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 12 + sx1 = tiny(sx1) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 13 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 14 + if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 15 + if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 16 + sx1 = tiny(sx1) + sx1 = sx1 / 101 + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 17 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 18 + if (ieee_copy_sign(sx1, 1.) /= sx1) STOP 19 + if (ieee_copy_sign(sx1, -1.) /= -sx1) STOP 20 + + sx1 = -1.3 + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 21 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 22 + if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 23 + if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 24 + sx1 = -huge(sx1) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 25 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 26 + if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 27 + if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 28 + sx1 = ieee_value(sx1, ieee_negative_inf) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 29 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 30 + if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 31 + if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 32 + sx1 = -tiny(sx1) + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 33 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 34 + if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 35 + if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 36 + sx1 = -tiny(sx1) + sx1 = sx1 / 101 + if (ieee_copy_sign(sx1, sx1) /= sx1) STOP 37 + if (ieee_copy_sign(sx1, -sx1) /= -sx1) STOP 38 + if (ieee_copy_sign(sx1, 1.) /= abs(sx1)) STOP 39 + if (ieee_copy_sign(sx1, -1.) /= -abs(sx1)) STOP 40 + + if (ieee_class(ieee_copy_sign(0., -1.)) /= ieee_negative_zero) STOP 41 + if (ieee_class(ieee_copy_sign(-0., -1.)) /= ieee_negative_zero) STOP 42 + if (ieee_class(ieee_copy_sign(0., 1.)) /= ieee_positive_zero) STOP 43 + if (ieee_class(ieee_copy_sign(-0., 1.)) /= ieee_positive_zero) STOP 44 + + sx1 = ieee_value(0., ieee_quiet_nan) + if (ieee_class(ieee_copy_sign(sx1, 1.)) /= ieee_quiet_nan) STOP 45 + if (ieee_class(ieee_copy_sign(sx1, -1.)) /= ieee_quiet_nan) STOP 46 + + dx1 = 1.3 + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 47 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 48 + if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 49 + if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 50 + dx1 = huge(dx1) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 51 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 52 + if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 53 + if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 54 + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 55 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 56 + if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 57 + if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 58 + dx1 = tiny(dx1) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 59 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 60 + if (ieee_copy_sign(dx1, 1.d0) /= dx1) STOP 61 + if (ieee_copy_sign(dx1, -1.) /= -dx1) STOP 62 + dx1 = tiny(dx1) + dx1 = dx1 / 101 + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 63 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 64 + if (ieee_copy_sign(dx1, 1.) /= dx1) STOP 65 + if (ieee_copy_sign(dx1, -1.d0) /= -dx1) STOP 66 + + dx1 = -1.3d0 + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 67 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 68 + if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 69 + if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 70 + dx1 = -huge(dx1) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 71 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 72 + if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 73 + if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 74 + dx1 = ieee_value(dx1, ieee_negative_inf) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 75 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 76 + if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 77 + if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 78 + dx1 = -tiny(dx1) + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 79 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 80 + if (ieee_copy_sign(dx1, 1.) /= abs(dx1)) STOP 81 + if (ieee_copy_sign(dx1, -1.d0) /= -abs(dx1)) STOP 82 + dx1 = -tiny(dx1) + dx1 = dx1 / 101 + if (ieee_copy_sign(dx1, dx1) /= dx1) STOP 83 + if (ieee_copy_sign(dx1, -dx1) /= -dx1) STOP 84 + if (ieee_copy_sign(dx1, 1.d0) /= abs(dx1)) STOP 85 + if (ieee_copy_sign(dx1, -1.) /= -abs(dx1)) STOP 86 + + if (ieee_class(ieee_copy_sign(0.d0, -1.)) /= ieee_negative_zero) STOP 87 + if (ieee_class(ieee_copy_sign(-0.d0, -1.)) /= ieee_negative_zero) STOP 88 + if (ieee_class(ieee_copy_sign(0.d0, 1.)) /= ieee_positive_zero) STOP 89 + if (ieee_class(ieee_copy_sign(-0.d0, 1.)) /= ieee_positive_zero) STOP 90 + + dx1 = ieee_value(0.d0, ieee_quiet_nan) + if (ieee_class(ieee_copy_sign(dx1, 1.d0)) /= ieee_quiet_nan) STOP 91 + if (ieee_class(ieee_copy_sign(dx1, -1.)) /= ieee_quiet_nan) STOP 92 + + ! Test IEEE_LOGB + + if (ieee_logb(1.17) /= exponent(1.17) - 1) STOP 93 + if (ieee_logb(-1.17) /= exponent(-1.17) - 1) STOP 94 + if (ieee_logb(huge(sx1)) /= exponent(huge(sx1)) - 1) STOP 95 + if (ieee_logb(-huge(sx1)) /= exponent(-huge(sx1)) - 1) STOP 96 + if (ieee_logb(tiny(sx1)) /= exponent(tiny(sx1)) - 1) STOP 97 + if (ieee_logb(-tiny(sx1)) /= exponent(-tiny(sx1)) - 1) STOP 98 + + if (ieee_class(ieee_logb(0.)) /= ieee_negative_inf) STOP 99 + if (ieee_class(ieee_logb(-0.)) /= ieee_negative_inf) STOP 100 + + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_class(ieee_logb(sx1)) /= ieee_positive_inf) STOP 101 + if (ieee_class(ieee_logb(-sx1)) /= ieee_positive_inf) STOP 102 + + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_class(ieee_logb(sx1)) /= ieee_quiet_nan) STOP 103 + + if (ieee_logb(1.17d0) /= exponent(1.17d0) - 1) STOP 104 + if (ieee_logb(-1.17d0) /= exponent(-1.17d0) - 1) STOP 105 + if (ieee_logb(huge(dx1)) /= exponent(huge(dx1)) - 1) STOP 106 + if (ieee_logb(-huge(dx1)) /= exponent(-huge(dx1)) - 1) STOP 107 + if (ieee_logb(tiny(dx1)) /= exponent(tiny(dx1)) - 1) STOP 108 + if (ieee_logb(-tiny(dx1)) /= exponent(-tiny(dx1)) - 1) STOP 109 + + if (ieee_class(ieee_logb(0.d0)) /= ieee_negative_inf) STOP 110 + if (ieee_class(ieee_logb(-0.d0)) /= ieee_negative_inf) STOP 111 + + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_class(ieee_logb(dx1)) /= ieee_positive_inf) STOP 112 + if (ieee_class(ieee_logb(-dx1)) /= ieee_positive_inf) STOP 113 + + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_class(ieee_logb(dx1)) /= ieee_quiet_nan) STOP 114 + + ! Test IEEE_NEXT_AFTER + + if (ieee_next_after(0.12, 1.0) /= nearest(0.12, 1.0)) STOP 115 + if (ieee_next_after(0.12, -1.0) /= nearest(0.12, -1.0)) STOP 116 + + sx1 = 0.12 + if (ieee_next_after(sx1, sx1) /= sx1) STOP 117 + sx1 = -0.12 + if (ieee_next_after(sx1, sx1) /= sx1) STOP 118 + sx1 = huge(sx1) + if (ieee_next_after(sx1, sx1) /= sx1) STOP 119 + sx1 = tiny(sx1) + if (ieee_next_after(sx1, sx1) /= sx1) STOP 120 + sx1 = 0 + if (ieee_next_after(sx1, sx1) /= sx1) STOP 121 + sx1 = ieee_value(sx1, ieee_negative_inf) + if (ieee_next_after(sx1, sx1) /= sx1) STOP 122 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_class(ieee_next_after(sx1, sx1)) /= ieee_quiet_nan) STOP 123 + + if (ieee_next_after(0., 1.0) <= 0) STOP 124 + if (ieee_next_after(0., -1.0) >= 0) STOP 125 + sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_negative_inf)) + if (.not. sx1 < huge(sx1)) STOP 126 + sx1 = ieee_next_after(huge(sx1), ieee_value(sx1, ieee_positive_inf)) + if (ieee_class(sx1) /= ieee_positive_inf) STOP 127 + sx1 = ieee_next_after(-tiny(sx1), 1.0) + if (ieee_class(sx1) /= ieee_negative_denormal) STOP 128 + + if (ieee_next_after(0.12d0, 1.0d0) /= nearest(0.12d0, 1.0)) STOP 129 + if (ieee_next_after(0.12d0, -1.0) /= nearest(0.12d0, -1.0)) STOP 130 + + dx1 = 0.12 + if (ieee_next_after(dx1, dx1) /= dx1) STOP 131 + dx1 = -0.12 + if (ieee_next_after(dx1, dx1) /= dx1) STOP 132 + dx1 = huge(dx1) + if (ieee_next_after(dx1, dx1) /= dx1) STOP 133 + dx1 = tiny(dx1) + if (ieee_next_after(dx1, dx1) /= dx1) STOP 134 + dx1 = 0 + if (ieee_next_after(dx1, dx1) /= dx1) STOP 135 + dx1 = ieee_value(dx1, ieee_negative_inf) + if (ieee_next_after(dx1, dx1) /= dx1) STOP 136 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_class(ieee_next_after(dx1, dx1)) /= ieee_quiet_nan) STOP 137 + + if (ieee_next_after(0.d0, 1.0) <= 0) STOP 138 + if (ieee_next_after(0.d0, -1.0d0) >= 0) STOP 139 + dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_negative_inf)) + if (.not. dx1 < huge(dx1)) STOP 140 + dx1 = ieee_next_after(huge(dx1), ieee_value(dx1, ieee_positive_inf)) + if (ieee_class(dx1) /= ieee_positive_inf) STOP 141 + dx1 = ieee_next_after(-tiny(dx1), 1.0d0) + if (ieee_class(dx1) /= ieee_negative_denormal) STOP 142 + + ! Test IEEE_REM + + if (ieee_rem(4.0, 3.0) /= 1.0) STOP 143 + if (ieee_rem(-4.0, 3.0) /= -1.0) STOP 144 + if (ieee_rem(2.0, 3.0d0) /= -1.0d0) STOP 145 + if (ieee_rem(-2.0, 3.0d0) /= 1.0d0) STOP 146 + if (ieee_rem(2.0d0, 3.0d0) /= -1.0d0) STOP 147 + if (ieee_rem(-2.0d0, 3.0d0) /= 1.0d0) STOP 148 + + if (ieee_class(ieee_rem(ieee_value(0., ieee_quiet_nan), 1.0)) & + /= ieee_quiet_nan) STOP 149 + if (ieee_class(ieee_rem(1.0, ieee_value(0.d0, ieee_quiet_nan))) & + /= ieee_quiet_nan) STOP 150 + + if (ieee_class(ieee_rem(ieee_value(0., ieee_positive_inf), 1.0)) & + /= ieee_quiet_nan) STOP 151 + if (ieee_class(ieee_rem(ieee_value(0.d0, ieee_negative_inf), 1.0)) & + /= ieee_quiet_nan) STOP 152 + if (ieee_rem(-1.0, ieee_value(0., ieee_positive_inf)) & + /= -1.0) STOP 153 + if (ieee_rem(1.0, ieee_value(0.d0, ieee_negative_inf)) & + /= 1.0) STOP 154 + + + ! Test IEEE_RINT + + if (ieee_support_rounding (ieee_nearest, sx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_nearest) + sx1 = 7 / 3. + sx1 = ieee_rint (sx1) + call ieee_set_rounding_mode (mode) + if (sx1 /= 2) STOP 155 + end if + + if (ieee_support_rounding (ieee_up, sx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_up) + sx1 = 7 / 3. + sx1 = ieee_rint (sx1) + call ieee_set_rounding_mode (mode) + if (sx1 /= 3) STOP 156 + end if + + if (ieee_support_rounding (ieee_down, sx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_down) + sx1 = 7 / 3. + sx1 = ieee_rint (sx1) + call ieee_set_rounding_mode (mode) + if (sx1 /= 2) STOP 157 + end if + + if (ieee_support_rounding (ieee_to_zero, sx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_to_zero) + sx1 = 7 / 3. + sx1 = ieee_rint (sx1) + call ieee_set_rounding_mode (mode) + if (sx1 /= 2) STOP 158 + end if + + if (ieee_class(ieee_rint(0.)) /= ieee_positive_zero) STOP 159 + if (ieee_class(ieee_rint(-0.)) /= ieee_negative_zero) STOP 160 + + if (ieee_support_rounding (ieee_nearest, dx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_nearest) + dx1 = 7 / 3.d0 + dx1 = ieee_rint (dx1) + call ieee_set_rounding_mode (mode) + if (dx1 /= 2) STOP 161 + end if + + if (ieee_support_rounding (ieee_up, dx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_up) + dx1 = 7 / 3.d0 + dx1 = ieee_rint (dx1) + call ieee_set_rounding_mode (mode) + if (dx1 /= 3) STOP 162 + end if + + if (ieee_support_rounding (ieee_down, dx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_down) + dx1 = 7 / 3.d0 + dx1 = ieee_rint (dx1) + call ieee_set_rounding_mode (mode) + if (dx1 /= 2) STOP 163 + end if + + if (ieee_support_rounding (ieee_to_zero, dx1)) then + call ieee_get_rounding_mode (mode) + call ieee_set_rounding_mode (ieee_to_zero) + dx1 = 7 / 3.d0 + dx1 = ieee_rint (dx1) + call ieee_set_rounding_mode (mode) + if (dx1 /= 2) STOP 164 + end if + + if (ieee_class(ieee_rint(0.d0)) /= ieee_positive_zero) STOP 165 + if (ieee_class(ieee_rint(-0.d0)) /= ieee_negative_zero) STOP 166 + + ! Test IEEE_SCALB + + sx1 = 1 + if (ieee_scalb(sx1, 2) /= 4.) STOP 167 + if (ieee_scalb(-sx1, 2) /= -4.) STOP 168 + if (ieee_scalb(sx1, -2) /= 1/4.) STOP 169 + if (ieee_scalb(-sx1, -2) /= -1/4.) STOP 170 + if (ieee_class(ieee_scalb(sx1, huge(0))) /= ieee_positive_inf) STOP 171 + if (ieee_class(ieee_scalb(-sx1, huge(0))) /= ieee_negative_inf) STOP 172 + if (ieee_class(ieee_scalb(sx1, -huge(0))) /= ieee_positive_zero) STOP 173 + if (ieee_class(ieee_scalb(-sx1, -huge(0))) /= ieee_negative_zero) STOP 174 + + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_class(ieee_scalb(sx1, 1)) /= ieee_quiet_nan) STOP 175 + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_positive_inf) STOP 176 + sx1 = ieee_value(sx1, ieee_negative_inf) + if (ieee_class(ieee_scalb(sx1, -42)) /= ieee_negative_inf) STOP 177 + + dx1 = 1 + if (ieee_scalb(dx1, 2) /= 4.d0) STOP 178 + if (ieee_scalb(-dx1, 2) /= -4.d0) STOP 179 + if (ieee_scalb(dx1, -2) /= 1/4.d0) STOP 180 + if (ieee_scalb(-dx1, -2) /= -1/4.d0) STOP 181 + if (ieee_class(ieee_scalb(dx1, huge(0))) /= ieee_positive_inf) STOP 182 + if (ieee_class(ieee_scalb(-dx1, huge(0))) /= ieee_negative_inf) STOP 183 + if (ieee_class(ieee_scalb(dx1, -huge(0))) /= ieee_positive_zero) STOP 184 + if (ieee_class(ieee_scalb(-dx1, -huge(0))) /= ieee_negative_zero) STOP 185 + + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_class(ieee_scalb(dx1, 1)) /= ieee_quiet_nan) STOP 186 + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_positive_inf) STOP 187 + dx1 = ieee_value(dx1, ieee_negative_inf) + if (ieee_class(ieee_scalb(dx1, -42)) /= ieee_negative_inf) STOP 188 + +contains + + subroutine check_equal_float (x, y) + real, intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 189 + end if + end subroutine + + subroutine check_equal_double (x, y) + double precision, intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 190 + end if + end subroutine + + subroutine check_not_equal_float (x, y) + real, intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 191 + end if + end subroutine + + subroutine check_not_equal_double (x, y) + double precision, intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 192 + end if + end subroutine + +end Index: Fortran/gfortran/regression/ieee/ieee_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_3.f90 @@ -0,0 +1,167 @@ +! { dg-do run } + + use :: ieee_arithmetic + implicit none + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + integer, parameter :: s = kind(sx1), d = kind(dx1) + type(ieee_round_type) :: mode + + ! Test IEEE_IS_FINITE + + if (ieee_support_datatype(0._s)) then + if (.not. ieee_is_finite(0.2_s)) STOP 1 + if (.not. ieee_is_finite(-0.2_s)) STOP 2 + if (.not. ieee_is_finite(0._s)) STOP 3 + if (.not. ieee_is_finite(-0._s)) STOP 4 + if (.not. ieee_is_finite(tiny(0._s))) STOP 5 + if (.not. ieee_is_finite(tiny(0._s)/100)) STOP 6 + if (.not. ieee_is_finite(huge(0._s))) STOP 7 + if (.not. ieee_is_finite(-huge(0._s))) STOP 8 + sx1 = huge(sx1) + if (ieee_is_finite(2*sx1)) STOP 9 + if (ieee_is_finite(2*(-sx1))) STOP 10 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_is_finite(sx1)) STOP 11 + end if + + if (ieee_support_datatype(0._d)) then + if (.not. ieee_is_finite(0.2_d)) STOP 12 + if (.not. ieee_is_finite(-0.2_d)) STOP 13 + if (.not. ieee_is_finite(0._d)) STOP 14 + if (.not. ieee_is_finite(-0._d)) STOP 15 + if (.not. ieee_is_finite(tiny(0._d))) STOP 16 + if (.not. ieee_is_finite(tiny(0._d)/100)) STOP 17 + if (.not. ieee_is_finite(huge(0._d))) STOP 18 + if (.not. ieee_is_finite(-huge(0._d))) STOP 19 + dx1 = huge(dx1) + if (ieee_is_finite(2*dx1)) STOP 20 + if (ieee_is_finite(2*(-dx1))) STOP 21 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_is_finite(dx1)) STOP 22 + end if + + ! Test IEEE_IS_NAN + + if (ieee_support_datatype(0._s)) then + if (ieee_is_nan(0.2_s)) STOP 23 + if (ieee_is_nan(-0.2_s)) STOP 24 + if (ieee_is_nan(0._s)) STOP 25 + if (ieee_is_nan(-0._s)) STOP 26 + if (ieee_is_nan(tiny(0._s))) STOP 27 + if (ieee_is_nan(tiny(0._s)/100)) STOP 28 + if (ieee_is_nan(huge(0._s))) STOP 29 + if (ieee_is_nan(-huge(0._s))) STOP 30 + sx1 = huge(sx1) + if (ieee_is_nan(2*sx1)) STOP 31 + if (ieee_is_nan(2*(-sx1))) STOP 32 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (.not. ieee_is_nan(sx1)) STOP 33 + sx1 = -1 + if (.not. ieee_is_nan(sqrt(sx1))) STOP 34 + end if + + if (ieee_support_datatype(0._d)) then + if (ieee_is_nan(0.2_d)) STOP 35 + if (ieee_is_nan(-0.2_d)) STOP 36 + if (ieee_is_nan(0._d)) STOP 37 + if (ieee_is_nan(-0._d)) STOP 38 + if (ieee_is_nan(tiny(0._d))) STOP 39 + if (ieee_is_nan(tiny(0._d)/100)) STOP 40 + if (ieee_is_nan(huge(0._d))) STOP 41 + if (ieee_is_nan(-huge(0._d))) STOP 42 + dx1 = huge(dx1) + if (ieee_is_nan(2*dx1)) STOP 43 + if (ieee_is_nan(2*(-dx1))) STOP 44 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (.not. ieee_is_nan(dx1)) STOP 45 + dx1 = -1 + if (.not. ieee_is_nan(sqrt(dx1))) STOP 46 + end if + + ! IEEE_IS_NEGATIVE + + if (ieee_support_datatype(0._s)) then + if (ieee_is_negative(0.2_s)) STOP 47 + if (.not. ieee_is_negative(-0.2_s)) STOP 48 + if (ieee_is_negative(0._s)) STOP 49 + if (.not. ieee_is_negative(-0._s)) STOP 50 + if (ieee_is_negative(tiny(0._s))) STOP 51 + if (ieee_is_negative(tiny(0._s)/100)) STOP 52 + if (.not. ieee_is_negative(-tiny(0._s))) STOP 53 + if (.not. ieee_is_negative(-tiny(0._s)/100)) STOP 54 + if (ieee_is_negative(huge(0._s))) STOP 55 + if (.not. ieee_is_negative(-huge(0._s))) STOP 56 + sx1 = huge(sx1) + if (ieee_is_negative(2*sx1)) STOP 57 + if (.not. ieee_is_negative(2*(-sx1))) STOP 58 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_is_negative(sx1)) STOP 59 + sx1 = -1 + if (ieee_is_negative(sqrt(sx1))) STOP 60 + end if + + if (ieee_support_datatype(0._d)) then + if (ieee_is_negative(0.2_d)) STOP 61 + if (.not. ieee_is_negative(-0.2_d)) STOP 62 + if (ieee_is_negative(0._d)) STOP 63 + if (.not. ieee_is_negative(-0._d)) STOP 64 + if (ieee_is_negative(tiny(0._d))) STOP 65 + if (ieee_is_negative(tiny(0._d)/100)) STOP 66 + if (.not. ieee_is_negative(-tiny(0._d))) STOP 67 + if (.not. ieee_is_negative(-tiny(0._d)/100)) STOP 68 + if (ieee_is_negative(huge(0._d))) STOP 69 + if (.not. ieee_is_negative(-huge(0._d))) STOP 70 + dx1 = huge(dx1) + if (ieee_is_negative(2*dx1)) STOP 71 + if (.not. ieee_is_negative(2*(-dx1))) STOP 72 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_is_negative(dx1)) STOP 73 + dx1 = -1 + if (ieee_is_negative(sqrt(dx1))) STOP 74 + end if + + ! Test IEEE_IS_NORMAL + + if (ieee_support_datatype(0._s)) then + if (.not. ieee_is_normal(0.2_s)) STOP 75 + if (.not. ieee_is_normal(-0.2_s)) STOP 76 + if (.not. ieee_is_normal(0._s)) STOP 77 + if (.not. ieee_is_normal(-0._s)) STOP 78 + if (.not. ieee_is_normal(tiny(0._s))) STOP 79 + if (ieee_is_normal(tiny(0._s)/100)) STOP 80 + if (.not. ieee_is_normal(-tiny(0._s))) STOP 81 + if (ieee_is_normal(-tiny(0._s)/100)) STOP 82 + if (.not. ieee_is_normal(huge(0._s))) STOP 83 + if (.not. ieee_is_normal(-huge(0._s))) STOP 84 + sx1 = huge(sx1) + if (ieee_is_normal(2*sx1)) STOP 85 + if (ieee_is_normal(2*(-sx1))) STOP 86 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_is_normal(sx1)) STOP 87 + sx1 = -1 + if (ieee_is_normal(sqrt(sx1))) STOP 88 + end if + + if (ieee_support_datatype(0._d)) then + if (.not. ieee_is_normal(0.2_d)) STOP 89 + if (.not. ieee_is_normal(-0.2_d)) STOP 90 + if (.not. ieee_is_normal(0._d)) STOP 91 + if (.not. ieee_is_normal(-0._d)) STOP 92 + if (.not. ieee_is_normal(tiny(0._d))) STOP 93 + if (ieee_is_normal(tiny(0._d)/100)) STOP 94 + if (.not. ieee_is_normal(-tiny(0._d))) STOP 95 + if (ieee_is_normal(-tiny(0._d)/100)) STOP 96 + if (.not. ieee_is_normal(huge(0._d))) STOP 97 + if (.not. ieee_is_normal(-huge(0._d))) STOP 98 + dx1 = huge(dx1) + if (ieee_is_normal(2*dx1)) STOP 99 + if (ieee_is_normal(2*(-dx1))) STOP 100 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_is_normal(dx1)) STOP 101 + dx1 = -1 + if (ieee_is_normal(sqrt(dx1))) STOP 102 + end if + +end Index: Fortran/gfortran/regression/ieee/ieee_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_4.f90 @@ -0,0 +1,189 @@ +! { dg-do run } + + use :: ieee_arithmetic + implicit none + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + integer, parameter :: s = kind(sx1), d = kind(dx1) + type(ieee_round_type) :: mode + + ! Test IEEE_CLASS + + if (ieee_support_datatype(0._s)) then + sx1 = 0.1_s + if (ieee_class(sx1) /= ieee_positive_normal) STOP 1 + if (ieee_class(-sx1) /= ieee_negative_normal) STOP 2 + sx1 = huge(sx1) + if (ieee_class(sx1) /= ieee_positive_normal) STOP 3 + if (ieee_class(-sx1) /= ieee_negative_normal) STOP 4 + if (ieee_class(2*sx1) /= ieee_positive_inf) STOP 5 + if (ieee_class(2*(-sx1)) /= ieee_negative_inf) STOP 6 + sx1 = tiny(sx1) + if (ieee_class(sx1) /= ieee_positive_normal) STOP 7 + if (ieee_class(-sx1) /= ieee_negative_normal) STOP 8 + if (ieee_class(sx1 / 2) /= ieee_positive_denormal) STOP 9 + if (ieee_class((-sx1) / 2) /= ieee_negative_denormal) STOP 10 + sx1 = -1 + if (ieee_class(sqrt(sx1)) /= ieee_quiet_nan) STOP 11 + sx1 = 0 + if (ieee_class(sx1) /= ieee_positive_zero) STOP 12 + if (ieee_class(-sx1) /= ieee_negative_zero) STOP 13 + end if + + if (ieee_support_datatype(0._d)) then + dx1 = 0.1_d + if (ieee_class(dx1) /= ieee_positive_normal) STOP 14 + if (ieee_class(-dx1) /= ieee_negative_normal) STOP 15 + dx1 = huge(dx1) + if (ieee_class(dx1) /= ieee_positive_normal) STOP 16 + if (ieee_class(-dx1) /= ieee_negative_normal) STOP 17 + if (ieee_class(2*dx1) /= ieee_positive_inf) STOP 18 + if (ieee_class(2*(-dx1)) /= ieee_negative_inf) STOP 19 + dx1 = tiny(dx1) + if (ieee_class(dx1) /= ieee_positive_normal) STOP 20 + if (ieee_class(-dx1) /= ieee_negative_normal) STOP 21 + if (ieee_class(dx1 / 2) /= ieee_positive_denormal) STOP 22 + if (ieee_class((-dx1) / 2) /= ieee_negative_denormal) STOP 23 + dx1 = -1 + if (ieee_class(sqrt(dx1)) /= ieee_quiet_nan) STOP 24 + dx1 = 0 + if (ieee_class(dx1) /= ieee_positive_zero) STOP 25 + if (ieee_class(-dx1) /= ieee_negative_zero) STOP 26 + end if + + ! Test IEEE_VALUE and IEEE_UNORDERED + + if (ieee_support_datatype(0._s)) then + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (.not. ieee_is_nan(sx1)) STOP 27 + if (.not. ieee_unordered(sx1, sx1)) STOP 28 + if (.not. ieee_unordered(sx1, 0._s)) STOP 29 + if (.not. ieee_unordered(sx1, 0._d)) STOP 30 + if (.not. ieee_unordered(0._s, sx1)) STOP 31 + if (.not. ieee_unordered(0._d, sx1)) STOP 32 + if (ieee_unordered(0._s, 0._s)) STOP 33 + + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_is_finite(sx1)) STOP 34 + if (ieee_is_nan(sx1)) STOP 35 + if (ieee_is_negative(sx1)) STOP 36 + if (ieee_is_normal(sx1)) STOP 37 + + sx1 = ieee_value(sx1, ieee_negative_inf) + if (ieee_is_finite(sx1)) STOP 38 + if (ieee_is_nan(sx1)) STOP 39 + if (.not. ieee_is_negative(sx1)) STOP 40 + if (ieee_is_normal(sx1)) STOP 41 + + sx1 = ieee_value(sx1, ieee_positive_normal) + if (.not. ieee_is_finite(sx1)) STOP 42 + if (ieee_is_nan(sx1)) STOP 43 + if (ieee_is_negative(sx1)) STOP 44 + if (.not. ieee_is_normal(sx1)) STOP 45 + + sx1 = ieee_value(sx1, ieee_negative_normal) + if (.not. ieee_is_finite(sx1)) STOP 46 + if (ieee_is_nan(sx1)) STOP 47 + if (.not. ieee_is_negative(sx1)) STOP 48 + if (.not. ieee_is_normal(sx1)) STOP 49 + + sx1 = ieee_value(sx1, ieee_positive_denormal) + if (.not. ieee_is_finite(sx1)) STOP 50 + if (ieee_is_nan(sx1)) STOP 51 + if (ieee_is_negative(sx1)) STOP 52 + if (ieee_is_normal(sx1)) STOP 53 + if (sx1 <= 0) STOP 54 + if (sx1 >= tiny(sx1)) STOP 55 + + sx1 = ieee_value(sx1, ieee_negative_denormal) + if (.not. ieee_is_finite(sx1)) STOP 56 + if (ieee_is_nan(sx1)) STOP 57 + if (.not. ieee_is_negative(sx1)) STOP 58 + if (ieee_is_normal(sx1)) STOP 59 + if (sx1 >= 0) STOP 60 + if (sx1 <= -tiny(sx1)) STOP 61 + + sx1 = ieee_value(sx1, ieee_positive_zero) + if (.not. ieee_is_finite(sx1)) STOP 62 + if (ieee_is_nan(sx1)) STOP 63 + if (ieee_is_negative(sx1)) STOP 64 + if (.not. ieee_is_normal(sx1)) STOP 65 + if (sx1 /= 0) STOP 66 + + sx1 = ieee_value(sx1, ieee_negative_zero) + if (.not. ieee_is_finite(sx1)) STOP 67 + if (ieee_is_nan(sx1)) STOP 68 + if (.not. ieee_is_negative(sx1)) STOP 69 + if (.not. ieee_is_normal(sx1)) STOP 70 + if (sx1 /= 0) STOP 71 + + end if + + if (ieee_support_datatype(0._d)) then + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (.not. ieee_is_nan(dx1)) STOP 72 + if (.not. ieee_unordered(dx1, dx1)) STOP 73 + if (.not. ieee_unordered(dx1, 0._s)) STOP 74 + if (.not. ieee_unordered(dx1, 0._d)) STOP 75 + if (.not. ieee_unordered(0._s, dx1)) STOP 76 + if (.not. ieee_unordered(0._d, dx1)) STOP 77 + if (ieee_unordered(0._d, 0._d)) STOP 78 + + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_is_finite(dx1)) STOP 79 + if (ieee_is_nan(dx1)) STOP 80 + if (ieee_is_negative(dx1)) STOP 81 + if (ieee_is_normal(dx1)) STOP 82 + + dx1 = ieee_value(dx1, ieee_negative_inf) + if (ieee_is_finite(dx1)) STOP 83 + if (ieee_is_nan(dx1)) STOP 84 + if (.not. ieee_is_negative(dx1)) STOP 85 + if (ieee_is_normal(dx1)) STOP 86 + + dx1 = ieee_value(dx1, ieee_positive_normal) + if (.not. ieee_is_finite(dx1)) STOP 87 + if (ieee_is_nan(dx1)) STOP 88 + if (ieee_is_negative(dx1)) STOP 89 + if (.not. ieee_is_normal(dx1)) STOP 90 + + dx1 = ieee_value(dx1, ieee_negative_normal) + if (.not. ieee_is_finite(dx1)) STOP 91 + if (ieee_is_nan(dx1)) STOP 92 + if (.not. ieee_is_negative(dx1)) STOP 93 + if (.not. ieee_is_normal(dx1)) STOP 94 + + dx1 = ieee_value(dx1, ieee_positive_denormal) + if (.not. ieee_is_finite(dx1)) STOP 95 + if (ieee_is_nan(dx1)) STOP 96 + if (ieee_is_negative(dx1)) STOP 97 + if (ieee_is_normal(dx1)) STOP 98 + if (dx1 <= 0) STOP 99 + if (dx1 >= tiny(dx1)) STOP 100 + + dx1 = ieee_value(dx1, ieee_negative_denormal) + if (.not. ieee_is_finite(dx1)) STOP 101 + if (ieee_is_nan(dx1)) STOP 102 + if (.not. ieee_is_negative(dx1)) STOP 103 + if (ieee_is_normal(dx1)) STOP 104 + if (dx1 >= 0) STOP 105 + if (dx1 <= -tiny(dx1)) STOP 106 + + dx1 = ieee_value(dx1, ieee_positive_zero) + if (.not. ieee_is_finite(dx1)) STOP 107 + if (ieee_is_nan(dx1)) STOP 108 + if (ieee_is_negative(dx1)) STOP 109 + if (.not. ieee_is_normal(dx1)) STOP 110 + if (dx1 /= 0) STOP 111 + + dx1 = ieee_value(dx1, ieee_negative_zero) + if (.not. ieee_is_finite(dx1)) STOP 112 + if (ieee_is_nan(dx1)) STOP 113 + if (.not. ieee_is_negative(dx1)) STOP 114 + if (.not. ieee_is_normal(dx1)) STOP 115 + if (dx1 /= 0) STOP 116 + + end if + +end Index: Fortran/gfortran/regression/ieee/ieee_5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_5.f90 @@ -0,0 +1,34 @@ +! { dg-do run } + + use :: ieee_arithmetic + implicit none + + logical mode + + ! Test IEEE_SET_UNDERFLOW_MODE, IEEE_GET_UNDERFLOW_MODE, + ! and IEEE_SUPPORT_UNDERFLOW_CONTROL + ! + ! We don't have any targets where this is supported yet, so + ! we just check these subroutines are present. + + if (ieee_support_underflow_control() & + .or. ieee_support_underflow_control(0.)) then + + call ieee_get_underflow_mode(mode) + call ieee_set_underflow_mode(.false.) + call ieee_set_underflow_mode(.true.) + call ieee_set_underflow_mode(mode) + + end if + + if (ieee_support_underflow_control() & + .or. ieee_support_underflow_control(0.d0)) then + + call ieee_get_underflow_mode(mode) + call ieee_set_underflow_mode(.false.) + call ieee_set_underflow_mode(.true.) + call ieee_set_underflow_mode(mode) + + end if + +end Index: Fortran/gfortran/regression/ieee/ieee_6.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_6.f90 @@ -0,0 +1,86 @@ +! { dg-do run } +! { dg-skip-if "PR libfortran/78314" { aarch64*-*-gnu* arm*-*-gnueabi arm*-*-gnueabihf } } +! +! This test will fail on older x86_64 glibc (< 2.20), due to this bug: +! https://sourceware.org/bugzilla/show_bug.cgi?id=16198 +! We usually won't see it anyway, because on such systems x86_64 assembly +! (libgfortran/config/fpu-387.h) is used. +! + use :: ieee_arithmetic + implicit none + + type(ieee_status_type) :: s1, s2 + logical :: flags(5), halt(5), haltworks + type(ieee_round_type) :: mode + real :: x + + ! Test IEEE_GET_STATUS and IEEE_SET_STATUS + + call ieee_set_flag(ieee_all, .false.) + call ieee_set_rounding_mode(ieee_down) + call ieee_set_halting_mode(ieee_all, .false.) + haltworks = ieee_support_halting(ieee_overflow) + + call ieee_get_status(s1) + call ieee_set_status(s1) + + call ieee_get_flag(ieee_all, flags) + if (any(flags)) STOP 1 + call ieee_get_rounding_mode(mode) + if (mode /= ieee_down) STOP 2 + call ieee_get_halting_mode(ieee_all, halt) + if (any(halt)) STOP 3 + + call ieee_set_rounding_mode(ieee_to_zero) + call ieee_set_flag(ieee_underflow, .true.) + call ieee_set_halting_mode(ieee_overflow, .true.) + x = -1 + x = sqrt(x) + if (.not. ieee_is_nan(x)) STOP 4 + + call ieee_get_status(s2) + + call ieee_get_flag(ieee_all, flags) + if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 5 + call ieee_get_rounding_mode(mode) + if (mode /= ieee_to_zero) STOP 6 + call ieee_get_halting_mode(ieee_all, halt) + if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 7 + + call ieee_set_status(s2) + + call ieee_get_flag(ieee_all, flags) + if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 8 + call ieee_get_rounding_mode(mode) + if (mode /= ieee_to_zero) STOP 9 + call ieee_get_halting_mode(ieee_all, halt) + if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 10 + + call ieee_set_status(s1) + + call ieee_get_flag(ieee_all, flags) + if (any(flags)) STOP 11 + call ieee_get_rounding_mode(mode) + if (mode /= ieee_down) STOP 12 + call ieee_get_halting_mode(ieee_all, halt) + if (any(halt)) STOP 13 + + call ieee_set_status(s2) + + call ieee_get_flag(ieee_all, flags) + if (.not. (all(flags .eqv. [.false.,.false.,.true.,.true.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.true.,.true.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.false.]) & + .or. all(flags .eqv. [.false.,.false.,.true.,.false.,.true.]))) STOP 14 + call ieee_get_rounding_mode(mode) + if (mode /= ieee_to_zero) STOP 15 + call ieee_get_halting_mode(ieee_all, halt) + if ((haltworks .and. .not. halt(1)) .or. any(halt(2:))) STOP 16 + +end Index: Fortran/gfortran/regression/ieee/ieee_7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_7.f90 @@ -0,0 +1,40 @@ +! { dg-do run } + + use :: ieee_arithmetic + use :: iso_fortran_env, only : real_kinds + implicit none + + ! This should be + ! integer, parameter :: maxreal = maxval(real_kinds) + ! but it works because REAL_KINDS happen to be in increasing order + integer, parameter :: maxreal = real_kinds(size(real_kinds)) + + ! Test IEEE_SELECTED_REAL_KIND in specification expressions + + integer(kind=ieee_selected_real_kind()) :: i1 + integer(kind=ieee_selected_real_kind(10)) :: i2 + integer(kind=ieee_selected_real_kind(10,10)) :: i3 + integer(kind=ieee_selected_real_kind(10,10,2)) :: i4 + + ! Test IEEE_SELECTED_REAL_KIND + + if (ieee_support_datatype(0.)) then + if (ieee_selected_real_kind() /= kind(0.)) STOP 1 + if (ieee_selected_real_kind(0) /= kind(0.)) STOP 2 + if (ieee_selected_real_kind(0,0) /= kind(0.)) STOP 3 + if (ieee_selected_real_kind(0,0,2) /= kind(0.)) STOP 4 + end if + + if (ieee_support_datatype(0.d0)) then + if (ieee_selected_real_kind(precision(0.)+1) /= kind(0.d0)) STOP 5 + if (ieee_selected_real_kind(precision(0.),range(0.)+1) /= kind(0.d0)) STOP 6 + if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1) /= kind(0.d0)) STOP 7 + if (ieee_selected_real_kind(precision(0.)+1,range(0.)+1,2) /= kind(0.d0)) STOP 8 + end if + + if (ieee_selected_real_kind(0,0,3) /= -5) STOP 9 + if (ieee_selected_real_kind(100*precision(0._maxreal)) /= -1) STOP 10 + if (ieee_selected_real_kind(0,100*range(0._maxreal)) /= -2) STOP 11 + if (ieee_selected_real_kind(100*precision(0._maxreal),100*range(0._maxreal)) /= -3) STOP 12 + +end Index: Fortran/gfortran/regression/ieee/ieee_8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_8.f90 @@ -0,0 +1,113 @@ +! { dg-do run } +! { dg-skip-if "PR libfortran/78314" { aarch64*-*-gnu* arm*-*-gnueabi arm*-*-gnueabihf } } + +module foo + use :: ieee_exceptions + use :: ieee_arithmetic +end module foo + +module bar + use foo + use :: ieee_arithmetic, yyy => ieee_support_rounding + use :: ieee_arithmetic, zzz => ieee_selected_real_kind +end module + +program test + use :: bar + use :: ieee_arithmetic, xxx => ieee_support_rounding + implicit none + + ! IEEE functions allowed in constant expressions + + integer, parameter :: n1 = ieee_selected_real_kind(0, 0) + logical, parameter :: l1 = ieee_support_halting(ieee_overflow) + logical, parameter :: l2 = ieee_support_flag(ieee_overflow) + logical, parameter :: l3 = ieee_support_flag(ieee_overflow, 0.) + logical, parameter :: l4 = ieee_support_rounding(ieee_to_zero) + logical, parameter :: l5 = ieee_support_rounding(ieee_to_zero, 0.d0) + + logical, parameter :: l6 = xxx(ieee_to_zero, 0.d0) + logical, parameter :: l7 = yyy(ieee_to_zero, 0.d0) + integer, parameter :: n2 = zzz(0, 0) + + call gee(8, ieee_to_zero, ieee_overflow) + +end + +! IEEE functions allowed in specification expressions + +subroutine gee(n, rounding, flag) + use :: bar + implicit none + + integer :: n + type(ieee_round_type) :: rounding + type(ieee_flag_type) :: flag + + character(len=ieee_selected_real_kind(n)) :: s1 + character(len=ieee_selected_real_kind(n,2*n)) :: s2 + character(len=ieee_selected_real_kind(n,2*n,2)) :: s3 + + character(len=merge(4,2,ieee_support_rounding(rounding))) :: s4 + character(len=merge(4,2,ieee_support_rounding(rounding, 0.d0))) :: s5 + + character(len=merge(4,2,ieee_support_flag(flag))) :: s6 + character(len=merge(4,2,ieee_support_flag(flag, 0.))) :: s7 + + character(len=merge(4,2,ieee_support_halting(flag))) :: s8 + + character(len=merge(4,2,ieee_support_datatype())) :: s9 + character(len=merge(4,2,ieee_support_datatype(0.))) :: s10 + + character(len=merge(4,2,ieee_support_denormal())) :: s11 + character(len=merge(4,2,ieee_support_denormal(0.))) :: s12 + + character(len=merge(4,2,ieee_support_divide())) :: s13 + character(len=merge(4,2,ieee_support_divide(0.))) :: s14 + + character(len=merge(4,2,ieee_support_inf())) :: s15 + character(len=merge(4,2,ieee_support_inf(0.))) :: s16 + + character(len=merge(4,2,ieee_support_io())) :: s17 + character(len=merge(4,2,ieee_support_io(0.))) :: s18 + + character(len=merge(4,2,ieee_support_nan())) :: s19 + character(len=merge(4,2,ieee_support_nan(0.))) :: s20 + + character(len=merge(4,2,ieee_support_sqrt())) :: s21 + character(len=merge(4,2,ieee_support_sqrt(0.))) :: s22 + + character(len=merge(4,2,ieee_support_standard())) :: s23 + character(len=merge(4,2,ieee_support_standard(0.))) :: s24 + + character(len=merge(4,2,ieee_support_underflow_control())) :: s25 + character(len=merge(4,2,ieee_support_underflow_control(0.))) :: s26 + + ! Now, check that runtime values match compile-time constants + ! (for those that are allowed) + + integer, parameter :: x1 = ieee_selected_real_kind(8) + integer, parameter :: x2 = ieee_selected_real_kind(8,2*8) + integer, parameter :: x3 = ieee_selected_real_kind(8,2*8,2) + + integer, parameter :: x4 = merge(4,2,ieee_support_rounding(rounding)) + integer, parameter :: x5 = merge(4,2,ieee_support_rounding(rounding, 0.d0)) + + integer, parameter :: x6 = merge(4,2,ieee_support_flag(ieee_overflow)) + integer, parameter :: x7 = merge(4,2,ieee_support_flag(ieee_overflow, 0.)) + + integer, parameter :: x8 = merge(4,2,ieee_support_halting(ieee_overflow)) + + if (len(s1) /= x1) STOP 1 + if (len(s2) /= x2) STOP 2 + if (len(s3) /= x3) STOP 3 + + if (len(s4) /= x4) STOP 4 + if (len(s5) /= x5) STOP 5 + + if (len(s6) /= x6) STOP 6 + if (len(s7) /= x7) STOP 7 + + if (len(s8) /= x8) STOP 8 + +end subroutine Index: Fortran/gfortran/regression/ieee/ieee_9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/ieee_9.f90 @@ -0,0 +1,45 @@ +! { dg-do run } +program foo + use ieee_arithmetic + use iso_fortran_env + implicit none + + ! This allows us to test REAL128 if it exists, and still compile + ! on platforms were it is not present + ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89639 + integer, parameter :: large = merge(real128, real64, real128 > 0) + + integer i, p + real x + x = 4 + i = 4 + + p = int(ieee_scalb(real(x, real32), int(i, int8))) + if (p /= 64) stop 1 + p = int(ieee_scalb(real(x, real64), int(i, int8))) + if (p /= 64) stop 2 + p = int(ieee_scalb(real(x, large), int(i, int8))) + if (p /= 64) stop 3 + + p = int(ieee_scalb(real(x, real32), int(i, int16))) + if (p /= 64) stop 4 + p = int(ieee_scalb(real(x, real64), int(i, int16))) + if (p /= 64) stop 5 + p = int(ieee_scalb(real(x, large), int(i, int16))) + if (p /= 64) stop 6 + + p = int(ieee_scalb(real(x, real32), int(i, int32))) + if (p /= 64) stop 7 + p = int(ieee_scalb(real(x, real64), int(i, int32))) + if (p /= 64) stop 8 + p = int(ieee_scalb(real(x, large), int(i, int32))) + if (p /= 64) stop 9 + + p = int(ieee_scalb(real(x, real32), int(i, int64))) + if (p /= 64) stop 10 + p = int(ieee_scalb(real(x, real64), int(i, int64))) + if (p /= 64) stop 11 + p = int(ieee_scalb(real(x, large), int(i, int64))) + if (p /= 64) stop 12 + +end program foo Index: Fortran/gfortran/regression/ieee/intrinsics_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/intrinsics_1.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-additional-options "-fno-range-check" } +! +! Check compile-time simplification of functions FRACTION, EXPONENT, +! SPACING, RRSPACING and SET_EXPONENT for special values. + +program test + implicit none + real, parameter :: inf = 2 * huge(0.) + real, parameter :: nan = 0. / 0. + + call check_positive_zero(fraction(0.)) + call check_negative_zero(fraction(-0.)) + if (.not. isnan(fraction(inf))) STOP 1 + if (.not. isnan(fraction(-inf))) STOP 2 + if (.not. isnan(fraction(nan))) STOP 3 + + if (exponent(0.) /= 0) STOP 4 + if (exponent(-0.) /= 0) STOP 5 + if (exponent(inf) /= huge(0)) STOP 6 + if (exponent(-inf) /= huge(0)) STOP 7 + if (exponent(nan) /= huge(0)) STOP 8 + + if (spacing(0.) /= spacing(tiny(0.))) STOP 9 + if (spacing(-0.) /= spacing(tiny(0.))) STOP 10 + if (.not. isnan(spacing(inf))) STOP 11 + if (.not. isnan(spacing(-inf))) STOP 12 + if (.not. isnan(spacing(nan))) STOP 13 + + call check_positive_zero(rrspacing(0.)) + call check_positive_zero(rrspacing(-0.)) + if (.not. isnan(rrspacing(inf))) STOP 14 + if (.not. isnan(rrspacing(-inf))) STOP 15 + if (.not. isnan(rrspacing(nan))) STOP 16 + + call check_positive_zero(set_exponent(0.,42)) + call check_negative_zero(set_exponent(-0.,42)) + if (.not. isnan(set_exponent(inf, 42))) STOP 17 + if (.not. isnan(set_exponent(-inf, 42))) STOP 18 + if (.not. isnan(set_exponent(nan, 42))) STOP 19 + +contains + + subroutine check_positive_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_positive_zero) STOP 20 + end + + subroutine check_negative_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_negative_zero) STOP 21 + end + +end Index: Fortran/gfortran/regression/ieee/intrinsics_2.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/intrinsics_2.F90 @@ -0,0 +1,67 @@ +! { dg-do run } +! { dg-additional-options "-fno-range-check" } +! +! Check handling of special values by FRACTION, EXPONENT, +! SPACING, RRSPACING and SET_EXPONENT. + +program test + implicit none + real, parameter :: inf = 2 * huge(0.) + real, parameter :: nan = 0. / 0. + + real, volatile :: x + + x = 0. + call check_positive_zero(fraction(x)) + if (exponent(x) /= 0) STOP 1 + if (spacing(x) /= spacing(tiny(x))) STOP 2 + call check_positive_zero(rrspacing(x)) + call check_positive_zero(set_exponent(x,42)) + + x = -0. + call check_negative_zero(fraction(x)) + if (exponent(x) /= 0) STOP 3 + if (spacing(x) /= spacing(tiny(x))) STOP 4 + call check_positive_zero(rrspacing(x)) + call check_negative_zero(set_exponent(x,42)) + + x = inf + if (.not. isnan(fraction(x))) STOP 5 + if (exponent(x) /= huge(0)) STOP 6 + if (.not. isnan(spacing(x))) STOP 7 + if (.not. isnan(rrspacing(x))) STOP 8 + if (.not. isnan(set_exponent(x, 42))) STOP 9 + + x = -inf + if (.not. isnan(fraction(x))) STOP 10 + if (exponent(x) /= huge(0)) STOP 11 + if (.not. isnan(spacing(x))) STOP 12 + if (.not. isnan(rrspacing(x))) STOP 13 + if (.not. isnan(set_exponent(x, 42))) STOP 14 + + x = nan + if (.not. isnan(fraction(x))) STOP 15 + if (exponent(x) /= huge(0)) STOP 16 + if (.not. isnan(spacing(x))) STOP 17 + if (.not. isnan(rrspacing(x))) STOP 18 + if (.not. isnan(set_exponent(x, 42))) STOP 19 + +contains + + subroutine check_positive_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_positive_zero) STOP 20 + end + + subroutine check_negative_zero(x) + use ieee_arithmetic + implicit none + real, value :: x + + if (ieee_class (x) /= ieee_negative_zero) STOP 21 + end + +end Index: Fortran/gfortran/regression/ieee/large_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/large_1.f90 @@ -0,0 +1,141 @@ +! { dg-do run } +! +! Testing IEEE modules on large real kinds + +program test + + use ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: x1, y1 + real(kind=k2) :: x2, y2 + logical :: l + + ! Checking ieee_is_finite + + if (.not. ieee_is_finite(huge(0._k1))) STOP 1 + if (ieee_is_finite(ieee_value(0._k1, ieee_negative_inf))) STOP 2 + x1 = -42 + if (.not. ieee_is_finite(x1)) STOP 3 + if (ieee_is_finite(sqrt(x1))) STOP 4 + + if (.not. ieee_is_finite(huge(0._k2))) STOP 5 + if (ieee_is_finite(ieee_value(0._k2, ieee_negative_inf))) STOP 6 + x2 = -42 + if (.not. ieee_is_finite(x2)) STOP 7 + if (ieee_is_finite(sqrt(x2))) STOP 8 + + ! Other ieee_is intrinsics + + if (ieee_is_nan(huge(0._k1))) STOP 9 + if (.not. ieee_is_negative(-huge(0._k1))) STOP 10 + if (.not. ieee_is_normal(-huge(0._k1))) STOP 11 + + if (ieee_is_nan(huge(0._k2))) STOP 12 + if (.not. ieee_is_negative(-huge(0._k2))) STOP 13 + if (.not. ieee_is_normal(-huge(0._k2))) STOP 14 + + ! ieee_support intrinsics + + if (.not. ieee_support_datatype(x1)) STOP 15 + if (.not. ieee_support_denormal(x1)) STOP 16 + if (.not. ieee_support_divide(x1)) STOP 17 + if (.not. ieee_support_inf(x1)) STOP 18 + if (.not. ieee_support_io(x1)) STOP 19 + if (.not. ieee_support_nan(x1)) STOP 20 + if (.not. ieee_support_rounding(ieee_nearest, x1)) STOP 21 + if (.not. ieee_support_sqrt(x1)) STOP 22 + if (.not. ieee_support_standard(x1)) STOP 23 + + l = ieee_support_underflow_control(x1) + + if (.not. ieee_support_datatype(x2)) STOP 24 + if (.not. ieee_support_denormal(x2)) STOP 25 + if (.not. ieee_support_divide(x2)) STOP 26 + if (.not. ieee_support_inf(x2)) STOP 27 + if (.not. ieee_support_io(x2)) STOP 28 + if (.not. ieee_support_nan(x2)) STOP 29 + if (.not. ieee_support_rounding(ieee_nearest, x2)) STOP 30 + if (.not. ieee_support_sqrt(x2)) STOP 31 + if (.not. ieee_support_standard(x2)) STOP 32 + + l = ieee_support_underflow_control(x2) + + ! ieee_value and ieee_class + + if (.not. ieee_is_nan(ieee_value(x1, ieee_quiet_nan))) STOP 33 + if (ieee_class(ieee_value(x1, ieee_positive_denormal)) & + /= ieee_positive_denormal) STOP 34 + + if (.not. ieee_is_nan(ieee_value(x2, ieee_quiet_nan))) STOP 35 + if (ieee_class(ieee_value(x2, ieee_positive_denormal)) & + /= ieee_positive_denormal) STOP 36 + + ! ieee_unordered + + if (.not. ieee_unordered(ieee_value(x1, ieee_quiet_nan), 0._k1)) STOP 37 + if (ieee_unordered(ieee_value(x1, ieee_negative_inf), 0._k1)) STOP 38 + + if (.not. ieee_unordered(ieee_value(x2, ieee_quiet_nan), 0._k2)) STOP 39 + if (ieee_unordered(ieee_value(x2, ieee_negative_inf), 0._k2)) STOP 40 + + ! ieee_copy_sign + + if (.not. ieee_class(ieee_copy_sign(ieee_value(x1, ieee_positive_inf), -1.)) & + == ieee_negative_inf) STOP 41 + if (.not. ieee_class(ieee_copy_sign(0._k1, -42._k2)) & + == ieee_negative_zero) STOP 42 + + if (.not. ieee_class(ieee_copy_sign(ieee_value(x2, ieee_positive_inf), -1.)) & + == ieee_negative_inf) STOP 43 + if (.not. ieee_class(ieee_copy_sign(0._k2, -42._k1)) & + == ieee_negative_zero) STOP 44 + + ! ieee_logb + + if (ieee_logb (42._k1) /= exponent(42._k1) - 1) STOP 45 + + if (ieee_logb (42._k2) /= exponent(42._k2) - 1) STOP 46 + + ! ieee_next_after + + if (ieee_next_after(42._k1, ieee_value(x1, ieee_positive_inf)) & + /= 42._k1 + spacing(42._k1)) STOP 47 + + if (ieee_next_after(42._k2, ieee_value(x2, ieee_positive_inf)) & + /= 42._k2 + spacing(42._k2)) STOP 48 + + ! ieee_rem + + if (ieee_class(ieee_rem(-42._k1, 2._k1)) /= ieee_negative_zero) & + STOP 49 + + if (ieee_class(ieee_rem(-42._k2, 2._k2)) /= ieee_negative_zero) & + STOP 50 + + ! ieee_rint + + if (ieee_rint(-1.1_k1) /= -1._k1) STOP 51 + if (ieee_rint(huge(x1)) /= huge(x1)) STOP 52 + + if (ieee_rint(-1.1_k2) /= -1._k2) STOP 53 + if (ieee_rint(huge(x2)) /= huge(x2)) STOP 54 + + ! ieee_scalb + + x1 = sqrt(42._k1) + if (ieee_scalb(x1, 2) /= 4._k1 * x1) STOP 55 + if (ieee_scalb(x1, -2) /= x1 / 4._k1) STOP 56 + + x2 = sqrt(42._k2) + if (ieee_scalb(x2, 2) /= 4._k2 * x2) STOP 57 + if (ieee_scalb(x2, -2) /= x2 / 4._k2) STOP 58 + +end program test Index: Fortran/gfortran/regression/ieee/large_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/large_2.f90 @@ -0,0 +1,145 @@ +! { dg-do run } +! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_arithmetic + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + interface check_equal + procedure check_equal1, check_equal2 + end interface + + interface check_not_equal + procedure check_not_equal1, check_not_equal2 + end interface + + interface divide + procedure divide1, divide2 + end interface + + real(kind=k1) :: x1, x2, x3 + real(kind=k2) :: y1, y2, y3 + type(ieee_round_type) :: mode + + if (ieee_support_rounding(ieee_up, x1) .and. & + ieee_support_rounding(ieee_down, x1) .and. & + ieee_support_rounding(ieee_nearest, x1) .and. & + ieee_support_rounding(ieee_to_zero, x1)) then + + x1 = 1 + x2 = 3 + x1 = divide(x1, x2, ieee_up) + + x3 = 1 + x2 = 3 + x3 = divide(x3, x2, ieee_down) + call check_not_equal(x1, x3) + call check_equal(x3, nearest(x1, -1._k1)) + call check_equal(x1, nearest(x3, 1._k1)) + + call check_equal(1._k1/3._k1, divide(1._k1, 3._k1, ieee_nearest)) + call check_equal(-1._k1/3._k1, divide(-1._k1, 3._k1, ieee_nearest)) + + call check_equal(divide(3._k1, 7._k1, ieee_to_zero), & + divide(3._k1, 7._k1, ieee_down)) + call check_equal(divide(-3._k1, 7._k1, ieee_to_zero), & + divide(-3._k1, 7._k1, ieee_up)) + + end if + + if (ieee_support_rounding(ieee_up, y1) .and. & + ieee_support_rounding(ieee_down, y1) .and. & + ieee_support_rounding(ieee_nearest, y1) .and. & + ieee_support_rounding(ieee_to_zero, y1)) then + + y1 = 1 + y2 = 3 + y1 = divide(y1, y2, ieee_up) + + y3 = 1 + y2 = 3 + y3 = divide(y3, y2, ieee_down) + call check_not_equal(y1, y3) + call check_equal(y3, nearest(y1, -1._k2)) + call check_equal(y1, nearest(y3, 1._k2)) + + call check_equal(1._k2/3._k2, divide(1._k2, 3._k2, ieee_nearest)) + call check_equal(-1._k2/3._k2, divide(-1._k2, 3._k2, ieee_nearest)) + + call check_equal(divide(3._k2, 7._k2, ieee_to_zero), & + divide(3._k2, 7._k2, ieee_down)) + call check_equal(divide(-3._k2, 7._k2, ieee_to_zero), & + divide(-3._k2, 7._k2, ieee_up)) + + end if + +contains + + real(kind=k1) function divide1 (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real(kind=k1), intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + real(kind=k2) function divide2 (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real(kind=k2), intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + subroutine check_equal1 (x, y) + real(kind=k1), intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 1 + end if + end subroutine + + subroutine check_equal2 (x, y) + real(kind=k2), intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 2 + end if + end subroutine + + subroutine check_not_equal1 (x, y) + real(kind=k1), intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 3 + end if + end subroutine + + subroutine check_not_equal2 (x, y) + real(kind=k2), intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 4 + end if + end subroutine + +end Index: Fortran/gfortran/regression/ieee/large_3.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/large_3.F90 @@ -0,0 +1,157 @@ +! { dg-do run } +! { dg-additional-options "-ffree-line-length-none" } +! { dg-additional-options "-mfp-trap-mode=sui" { target alpha*-*-* } } +! +! Use dg-additional-options rather than dg-options to avoid overwriting the +! default IEEE options which are passed by ieee.exp and necessary. + + use ieee_features + use ieee_exceptions + use ieee_arithmetic + + implicit none + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + logical :: l(5) = .false. + character(len=5) :: s + +#define FLAGS_STRING(S) \ + call ieee_get_flag(x, l) ; \ + write(S,"(5(A1))") merge(["I","O","Z","U","P"],[" "," "," "," "," "],l) + +#define CHECK_FLAGS(expected) \ + FLAGS_STRING(s) ; \ + if (s /= expected) then ; \ + write (*,"(A,I0,A,A)") "Flags at line ", __LINE__, ": ", s ; \ + STOP 1; \ + end if ; \ + call check_flag_sub + + real(kind=k1), volatile :: sx + real(kind=k2), volatile :: dx + + ! This file tests IEEE_SET_FLAG and IEEE_GET_FLAG + + !!!! Large kind 1 + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + sx = -1 + sx = sqrt(sx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + sx = huge(sx) + CHECK_FLAGS(" ") + sx = sx*sx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + sx = 0 + sx = 1 / sx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + sx = tiny(sx) + CHECK_FLAGS(" ") + sx = sx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + + !!!! Large kind 2 + + ! Initial flags are all off + CHECK_FLAGS(" ") + + ! Check we can clear them + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise invalid, then clear + dx = -1 + dx = sqrt(dx) + CHECK_FLAGS("I ") + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + + ! Raise overflow and precision + dx = huge(dx) + CHECK_FLAGS(" ") + dx = dx*dx + CHECK_FLAGS(" O P") + + ! Also raise divide-by-zero + dx = 0 + dx = 1 / dx + CHECK_FLAGS(" OZ P") + + ! Clear them + call ieee_set_flag([ieee_overflow,ieee_inexact,& + ieee_divide_by_zero],[.false.,.false.,.true.]) + CHECK_FLAGS(" Z ") + call ieee_set_flag(ieee_divide_by_zero, .false.) + CHECK_FLAGS(" ") + + ! Raise underflow + dx = tiny(dx) + CHECK_FLAGS(" ") + dx = dx / 10 + CHECK_FLAGS(" UP") + + ! Raise everything + call ieee_set_flag(ieee_all, .true.) + CHECK_FLAGS("IOZUP") + + ! And clear + call ieee_set_flag(ieee_all, .false.) + CHECK_FLAGS(" ") + +contains + + subroutine check_flag_sub + use ieee_exceptions + logical :: l(5) = .false. + type(ieee_flag_type), parameter :: x(5) = & + [ IEEE_INVALID, IEEE_OVERFLOW, IEEE_DIVIDE_BY_ZERO, & + IEEE_UNDERFLOW, IEEE_INEXACT ] + call ieee_get_flag(x, l) + + if (any(l)) then + print *, "Flags not cleared in subroutine" + STOP 2 + end if + end subroutine + +end Index: Fortran/gfortran/regression/ieee/large_4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/large_4.f90 @@ -0,0 +1,54 @@ +! { dg-do run { xfail i?86-*-freebsd* } } + +program test_underflow_control + use ieee_arithmetic + use iso_fortran_env + + ! kx and ky will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: kx = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: ky = & + max(ieee_selected_real_kind(precision(0._kx) + 1), kind(0.d0)) + + logical l + real(kind=kx), volatile :: x + real(kind=ky), volatile :: y + + if (ieee_support_underflow_control(x)) then + + x = tiny(x) + call ieee_set_underflow_mode(.true.) + x = x / 2000._kx + if (x == 0) STOP 1 + call ieee_get_underflow_mode(l) + if (.not. l) STOP 2 + + x = tiny(x) + call ieee_set_underflow_mode(.false.) + x = x / 2000._kx + if (x > 0) STOP 3 + call ieee_get_underflow_mode(l) + if (l) STOP 4 + + end if + + if (ieee_support_underflow_control(y)) then + + y = tiny(y) + call ieee_set_underflow_mode(.true.) + y = y / 2000._ky + if (y == 0) STOP 5 + call ieee_get_underflow_mode(l) + if (.not. l) STOP 6 + + y = tiny(y) + call ieee_set_underflow_mode(.false.) + y = y / 2000._ky + if (y > 0) STOP 7 + call ieee_get_underflow_mode(l) + if (l) STOP 8 + + end if + +end program Index: Fortran/gfortran/regression/ieee/modes_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/modes_1.f90 @@ -0,0 +1,95 @@ +! { dg-do run } +! +! Test IEEE_MODES_TYPE, IEEE_GET_MODES and IEEE_SET_MODES + + +! The symbols should be accessible from both IEEE_EXCEPTIONS +! and IEEE_ARITHMETIC. + +subroutine test_1 + use ieee_exceptions, only : IEEE_GET_MODES, IEEE_SET_MODES +end subroutine + +subroutine test_2 + use ieee_arithmetic, only : IEEE_GET_MODES, IEEE_SET_MODES +end subroutine + +subroutine test_3 + use ieee_exceptions, only : IEEE_MODES_TYPE +end subroutine + +subroutine test_4 + use ieee_arithmetic, only : IEEE_MODES_TYPE +end subroutine + + +! Check that the functions actually do the job + +program foo + use ieee_arithmetic + implicit none + + type(ieee_modes_type) :: modes1, modes2 + type(ieee_round_type) :: rmode + logical :: f + + ! Set some modes + if (ieee_support_underflow_control()) then + call ieee_set_underflow_mode(gradual=.false.) + endif + if (ieee_support_rounding(ieee_up)) then + call ieee_set_rounding_mode(ieee_up) + endif + if (ieee_support_halting(ieee_overflow)) then + call ieee_set_halting_mode(ieee_overflow, .true.) + endif + + call ieee_get_modes(modes1) + + ! Change modes + if (ieee_support_underflow_control()) then + call ieee_set_underflow_mode(gradual=.true.) + endif + if (ieee_support_rounding(ieee_down)) then + call ieee_set_rounding_mode(ieee_down) + endif + if (ieee_support_halting(ieee_overflow)) then + call ieee_set_halting_mode(ieee_overflow, .false.) + endif + + ! Save and restore the previous modes + call ieee_get_modes(modes2) + call ieee_set_modes(modes1) + + ! Check them + if (ieee_support_underflow_control()) then + call ieee_get_underflow_mode(f) + if (f) stop 1 + endif + if (ieee_support_rounding(ieee_down)) then + call ieee_get_rounding_mode(rmode) + if (rmode /= ieee_up) stop 2 + endif + if (ieee_support_halting(ieee_overflow)) then + call ieee_get_halting_mode(ieee_overflow, f) + if (.not. f) stop 3 + endif + + ! Restore the second set of modes + call ieee_set_modes(modes2) + + ! Check again + if (ieee_support_underflow_control()) then + call ieee_get_underflow_mode(f) + if (.not. f) stop 4 + endif + if (ieee_support_rounding(ieee_down)) then + call ieee_get_rounding_mode(rmode) + if (rmode /= ieee_down) stop 5 + endif + if (ieee_support_halting(ieee_overflow)) then + call ieee_get_halting_mode(ieee_overflow, f) + if (f) stop 6 + endif + +end program foo Index: Fortran/gfortran/regression/ieee/pr77372.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/pr77372.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +program p + use ieee_arithmetic + real(kind=ieee_selected_real_kind(10_1)) :: z1 + real(kind=ieee_selected_real_kind(10_2)) :: z2 + real(kind=ieee_selected_real_kind(10_4)) :: z4 +end Index: Fortran/gfortran/regression/ieee/pr77507.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/pr77507.f90 @@ -0,0 +1,7 @@ +! { dg-do compile } +Program p + Use ieee_arithmetic + Use iso_c_binding + Print *, ieee_value(x=1.0, class=ieee_negative_inf) + Print *, c_associated(c_ptr_1=c_null_ptr) +End Program Index: Fortran/gfortran/regression/ieee/rounding_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/rounding_1.f90 @@ -0,0 +1,152 @@ +! { dg-do run } +! { dg-additional-options "-mfp-rounding-mode=d" { target alpha*-*-* } } + + use, intrinsic :: ieee_features, only : ieee_rounding + use, intrinsic :: ieee_arithmetic + implicit none + + interface check_equal + procedure check_equal_float, check_equal_double + end interface + + interface check_not_equal + procedure check_not_equal_float, check_not_equal_double + end interface + + interface divide + procedure divide_float, divide_double + end interface + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + type(ieee_round_type) :: mode + + ! We should support at least C float and C double types + if (ieee_support_rounding(ieee_nearest)) then + if (.not. ieee_support_rounding(ieee_nearest, 0.)) STOP 1 + if (.not. ieee_support_rounding(ieee_nearest, 0.d0)) STOP 2 + end if + + ! The initial rounding mode should probably be NEAREST + ! (at least on the platforms we currently support) + if (ieee_support_rounding(ieee_nearest, 0.)) then + call ieee_get_rounding_mode (mode) + if (mode /= ieee_nearest) STOP 3 + end if + + + if (ieee_support_rounding(ieee_up, sx1) .and. & + ieee_support_rounding(ieee_down, sx1) .and. & + ieee_support_rounding(ieee_nearest, sx1) .and. & + ieee_support_rounding(ieee_to_zero, sx1)) then + + sx1 = 1 + sx2 = 3 + sx1 = divide(sx1, sx2, ieee_up) + + sx3 = 1 + sx2 = 3 + sx3 = divide(sx3, sx2, ieee_down) + call check_not_equal(sx1, sx3) + call check_equal(sx3, nearest(sx1, -1.)) + call check_equal(sx1, nearest(sx3, 1.)) + + call check_equal(1./3., divide(1., 3., ieee_nearest)) + call check_equal(-1./3., divide(-1., 3., ieee_nearest)) + + call check_equal(divide(3., 7., ieee_to_zero), & + divide(3., 7., ieee_down)) + call check_equal(divide(-3., 7., ieee_to_zero), & + divide(-3., 7., ieee_up)) + + end if + + if (ieee_support_rounding(ieee_up, dx1) .and. & + ieee_support_rounding(ieee_down, dx1) .and. & + ieee_support_rounding(ieee_nearest, dx1) .and. & + ieee_support_rounding(ieee_to_zero, dx1)) then + + dx1 = 1 + dx2 = 3 + dx1 = divide(dx1, dx2, ieee_up) + + dx3 = 1 + dx2 = 3 + dx3 = divide(dx3, dx2, ieee_down) + call check_not_equal(dx1, dx3) + call check_equal(dx3, nearest(dx1, -1.d0)) + call check_equal(dx1, nearest(dx3, 1.d0)) + + call check_equal(1.d0/3.d0, divide(1.d0, 3.d0, ieee_nearest)) + call check_equal(-1.d0/3.d0, divide(-1.d0, 3.d0, ieee_nearest)) + + call check_equal(divide(3.d0, 7.d0, ieee_to_zero), & + divide(3.d0, 7.d0, ieee_down)) + call check_equal(divide(-3.d0, 7.d0, ieee_to_zero), & + divide(-3.d0, 7.d0, ieee_up)) + + end if + +contains + + real function divide_float (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + real, intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + double precision function divide_double (x, y, rounding) result(res) + use, intrinsic :: ieee_arithmetic + double precision, intent(in) :: x, y + type(ieee_round_type), intent(in) :: rounding + type(ieee_round_type) :: old + + call ieee_get_rounding_mode (old) + call ieee_set_rounding_mode (rounding) + + res = x / y + + call ieee_set_rounding_mode (old) + end function + + subroutine check_equal_float (x, y) + real, intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 4 + end if + end subroutine + + subroutine check_equal_double (x, y) + double precision, intent(in) :: x, y + if (x /= y) then + print *, x, y + STOP 5 + end if + end subroutine + + subroutine check_not_equal_float (x, y) + real, intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 6 + end if + end subroutine + + subroutine check_not_equal_double (x, y) + double precision, intent(in) :: x, y + if (x == y) then + print *, x, y + STOP 7 + end if + end subroutine + +end Index: Fortran/gfortran/regression/ieee/rounding_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/rounding_2.f90 @@ -0,0 +1,20 @@ +! { dg-do run } + + use, intrinsic :: ieee_arithmetic + implicit none + + real :: sx1, sx2, sx3 + double precision :: dx1, dx2, dx3 + + ! IEEE_AWAY was added in Fortran 2018 and not supported by any target + ! at the moment. Just check we can query for its support. + + ! We should support at least C float and C double types + if (ieee_support_rounding(ieee_away) & + .or. ieee_support_rounding(ieee_away, 0.) & + .or. ieee_support_rounding(ieee_away, 0.d0)) then + print *, "If a target / libc now supports this, we need to add a proper check!" + stop 1 + end if + +end Index: Fortran/gfortran/regression/ieee/rounding_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/rounding_3.f90 @@ -0,0 +1,27 @@ +! { dg-do run } + + ! Test IEEE_GET_ROUNDING_MODE and IEEE_SET_ROUNDING_MODE + ! with a RADIX argument + use, intrinsic :: ieee_arithmetic + implicit none + + real :: sx1 + type(ieee_round_type) :: r + + if (ieee_support_rounding(ieee_up, sx1) .and. & + ieee_support_rounding(ieee_down, sx1)) then + + call ieee_set_rounding_mode(ieee_up) + call ieee_get_rounding_mode(r) + if (r /= ieee_up) stop 1 + + call ieee_set_rounding_mode(ieee_down, radix=2) + call ieee_get_rounding_mode(r, radix=2) + if (r /= ieee_down) stop 2 + + call ieee_set_rounding_mode(ieee_up, radix=10) + call ieee_get_rounding_mode(r, radix=2) + if (r /= ieee_down) stop 3 + end if + +end Index: Fortran/gfortran/regression/ieee/signaling_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signaling_1.f90 @@ -0,0 +1,92 @@ +! { dg-do run { target { ! ia32 } } } +! x87 / x86-32 ABI is unsuitable for signaling NaNs +! +! { dg-additional-sources signaling_1_c.c } +! { dg-additional-options "-w" } +! The -w option is needed to make cc1 not report a warning for +! the -fintrinsic-modules-path option passed by ieee.exp +! +program test + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic + implicit none + + interface + real(kind=c_float) function create_nansf () bind(c) + import :: c_float + end function + + real(kind=c_double) function create_nans () bind(c) + import :: c_double + end function + + real(kind=c_long_double) function create_nansl () bind(c) + import :: c_long_double + end function + end interface + + real(kind=c_float) :: x + real(kind=c_double) :: y + real(kind=c_long_double) :: z + + if (ieee_support_nan(x)) then + x = create_nansf() + if (ieee_class(x) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(x)) stop 101 + if (ieee_is_negative(x)) stop 102 + if (ieee_is_finite(x)) stop 103 + if (ieee_is_normal(x)) stop 104 + if (.not. ieee_unordered(x, x)) stop 105 + if (.not. ieee_unordered(x, 1._c_float)) stop 106 + + x = ieee_value(x, ieee_quiet_nan) + if (ieee_class(x) /= ieee_quiet_nan) stop 107 + if (.not. ieee_is_nan(x)) stop 108 + if (ieee_is_negative(x)) stop 109 + if (ieee_is_finite(x)) stop 110 + if (ieee_is_normal(x)) stop 111 + if (.not. ieee_unordered(x, x)) stop 112 + if (.not. ieee_unordered(x, 1._c_double)) stop 113 + end if + + if (ieee_support_nan(y)) then + y = create_nans() + if (ieee_class(y) /= ieee_signaling_nan) stop 200 + if (.not. ieee_is_nan(y)) stop 201 + if (ieee_is_negative(y)) stop 202 + if (ieee_is_finite(y)) stop 203 + if (ieee_is_normal(y)) stop 204 + if (.not. ieee_unordered(y, x)) stop 205 + if (.not. ieee_unordered(y, 1._c_double)) stop 206 + + y = ieee_value(y, ieee_quiet_nan) + if (ieee_class(y) /= ieee_quiet_nan) stop 207 + if (.not. ieee_is_nan(y)) stop 208 + if (ieee_is_negative(y)) stop 209 + if (ieee_is_finite(y)) stop 210 + if (ieee_is_normal(y)) stop 211 + if (.not. ieee_unordered(y, y)) stop 212 + if (.not. ieee_unordered(y, 1._c_double)) stop 213 + end if + + if (ieee_support_nan(z)) then + z = create_nansl() + if (ieee_class(z) /= ieee_signaling_nan) stop 300 + if (.not. ieee_is_nan(z)) stop 301 + if (ieee_is_negative(z)) stop 302 + if (ieee_is_finite(z)) stop 303 + if (ieee_is_normal(z)) stop 304 + if (.not. ieee_unordered(z, z)) stop 305 + if (.not. ieee_unordered(z, 1._c_long_double)) stop 306 + + z = ieee_value(z, ieee_quiet_nan) + if (ieee_class(z) /= ieee_quiet_nan) stop 307 + if (.not. ieee_is_nan(z)) stop 308 + if (ieee_is_negative(z)) stop 309 + if (ieee_is_finite(z)) stop 310 + if (ieee_is_normal(z)) stop 311 + if (.not. ieee_unordered(z, z)) stop 312 + if (.not. ieee_unordered(z, 1._c_double)) stop 313 + end if + +end program test Index: Fortran/gfortran/regression/ieee/signaling_1_c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signaling_1_c.c @@ -0,0 +1,14 @@ +float create_nansf (void) +{ + return __builtin_nansf(""); +} + +double create_nans (void) +{ + return __builtin_nans(""); +} + +long double create_nansl (void) +{ + return __builtin_nansl(""); +} Index: Fortran/gfortran/regression/ieee/signaling_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signaling_2.f90 @@ -0,0 +1,74 @@ +! { dg-do run { target { ! ia32 } } } +! x87 / x86-32 ABI is unsuitable for signaling NaNs +! +! { dg-require-effective-target issignaling } */ +! The companion C source needs access to the issignaling macro. +! +! { dg-additional-sources signaling_2_c.c } +! { dg-additional-options "-w" } +! The -w option is needed to make cc1 not report a warning for +! the -fintrinsic-modules-path option passed by ieee.exp +! +program test + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic + implicit none + + interface + integer(kind=c_int) function isnansf (x) bind(c) + import :: c_float, c_int + real(kind=c_float), value :: x + end function + + integer(kind=c_int) function isnans (x) bind(c) + import :: c_double, c_int + real(kind=c_double), value :: x + end function + + integer(kind=c_int) function isnansl (x) bind(c) + import :: c_long_double, c_int + real(kind=c_long_double), value :: x + end function + end interface + + real(kind=c_float) :: x + real(kind=c_double) :: y + real(kind=c_long_double) :: z + + if (ieee_support_nan(x)) then + x = ieee_value(x, ieee_signaling_nan) + if (ieee_class(x) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(x)) stop 101 + if (isnansf(x) /= 1) stop 102 + + x = ieee_value(x, ieee_quiet_nan) + if (ieee_class(x) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(x)) stop 104 + if (isnansf(x) /= 0) stop 105 + end if + + if (ieee_support_nan(y)) then + y = ieee_value(y, ieee_signaling_nan) + if (ieee_class(y) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(y)) stop 101 + if (isnans(y) /= 1) stop 102 + + y = ieee_value(y, ieee_quiet_nan) + if (ieee_class(y) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(y)) stop 104 + if (isnans(y) /= 0) stop 105 + end if + + if (ieee_support_nan(z)) then + z = ieee_value(z, ieee_signaling_nan) + if (ieee_class(z) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(z)) stop 101 + if (isnansl(z) /= 1) stop 102 + + z = ieee_value(z, ieee_quiet_nan) + if (ieee_class(z) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(z)) stop 104 + if (isnansl(z) /= 0) stop 105 + end if + +end program test Index: Fortran/gfortran/regression/ieee/signaling_2_c.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signaling_2_c.c @@ -0,0 +1,8 @@ +#define _GNU_SOURCE +#include +#include + +int isnansf (float x) { return issignaling (x) ? 1 : 0; } +int isnans (double x) { return issignaling (x) ? 1 : 0; } +int isnansl (long double x) { return issignaling (x) ? 1 : 0; } + Index: Fortran/gfortran/regression/ieee/signaling_3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signaling_3.f90 @@ -0,0 +1,43 @@ +! { dg-do run { target { ! ia32 } } } +! x87 / x86-32 ABI is unsuitable for signaling NaNs +! +program test + use, intrinsic :: iso_c_binding + use, intrinsic :: ieee_arithmetic + implicit none + + real(kind=c_float) :: x + real(kind=c_double) :: y + real(kind=c_long_double) :: z + + if (ieee_support_nan(x)) then + x = ieee_value(x, ieee_signaling_nan) + if (ieee_class(x) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(x)) stop 101 + + x = ieee_value(x, ieee_quiet_nan) + if (ieee_class(x) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(x)) stop 104 + end if + + if (ieee_support_nan(y)) then + y = ieee_value(y, ieee_signaling_nan) + if (ieee_class(y) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(y)) stop 101 + + y = ieee_value(y, ieee_quiet_nan) + if (ieee_class(y) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(y)) stop 104 + end if + + if (ieee_support_nan(z)) then + z = ieee_value(z, ieee_signaling_nan) + if (ieee_class(z) /= ieee_signaling_nan) stop 100 + if (.not. ieee_is_nan(z)) stop 101 + + z = ieee_value(z, ieee_quiet_nan) + if (ieee_class(z) /= ieee_quiet_nan) stop 103 + if (.not. ieee_is_nan(z)) stop 104 + end if + +end program test Index: Fortran/gfortran/regression/ieee/signbit_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/signbit_1.f90 @@ -0,0 +1,166 @@ +! Test IEEE_SIGNBIT +! { dg-do run } + + use, intrinsic :: ieee_features + use, intrinsic :: ieee_exceptions + use, intrinsic :: ieee_arithmetic + implicit none + + real :: sx1 + double precision :: dx1 + + ! k1 and k2 will be large real kinds, if supported, and single/double + ! otherwise + integer, parameter :: k1 = & + max(ieee_selected_real_kind(precision(0.d0) + 1), kind(0.)) + integer, parameter :: k2 = & + max(ieee_selected_real_kind(precision(0._k1) + 1), kind(0.d0)) + + real(kind=k1) :: xk1 + real(kind=k2) :: xk2 + + ! Float + + sx1 = 1.3 + if (ieee_signbit(sx1)) stop 1 + sx1 = huge(sx1) + if (ieee_signbit(sx1)) stop 2 + sx1 = ieee_value(sx1, ieee_positive_inf) + if (ieee_signbit(sx1)) stop 3 + sx1 = tiny(sx1) + if (ieee_signbit(sx1)) stop 4 + sx1 = tiny(sx1) + sx1 = sx1 / 101 + if (ieee_signbit(sx1)) stop 5 + sx1 = 0 + if (ieee_signbit(sx1)) stop 6 + sx1 = ieee_value(sx1, ieee_quiet_nan) + if (ieee_signbit(sx1)) stop 7 + + sx1 = -1.3 + if (.not. ieee_signbit(sx1)) stop 8 + sx1 = -huge(sx1) + if (.not. ieee_signbit(sx1)) stop 9 + sx1 = -ieee_value(sx1, ieee_positive_inf) + if (.not. ieee_signbit(sx1)) stop 10 + sx1 = -tiny(sx1) + if (.not. ieee_signbit(sx1)) stop 11 + sx1 = -tiny(sx1) + sx1 = sx1 / 101 + if (.not. ieee_signbit(sx1)) stop 12 + sx1 = 0 + sx1 = -sx1 + if (.not. ieee_signbit(sx1)) stop 13 + sx1 = ieee_value(sx1, ieee_quiet_nan) + sx1 = -sx1 + if (.not. ieee_signbit(sx1)) stop 14 + + ! Double + + dx1 = 1.3 + if (ieee_signbit(dx1)) stop 1 + dx1 = huge(dx1) + if (ieee_signbit(dx1)) stop 2 + dx1 = ieee_value(dx1, ieee_positive_inf) + if (ieee_signbit(dx1)) stop 3 + dx1 = tiny(dx1) + if (ieee_signbit(dx1)) stop 4 + dx1 = tiny(dx1) + dx1 = dx1 / 101 + if (ieee_signbit(dx1)) stop 5 + dx1 = 0 + if (ieee_signbit(dx1)) stop 6 + dx1 = ieee_value(dx1, ieee_quiet_nan) + if (ieee_signbit(dx1)) stop 7 + + dx1 = -1.3 + if (.not. ieee_signbit(dx1)) stop 8 + dx1 = -huge(dx1) + if (.not. ieee_signbit(dx1)) stop 9 + dx1 = -ieee_value(dx1, ieee_positive_inf) + if (.not. ieee_signbit(dx1)) stop 10 + dx1 = -tiny(dx1) + if (.not. ieee_signbit(dx1)) stop 11 + dx1 = -tiny(dx1) + dx1 = dx1 / 101 + if (.not. ieee_signbit(dx1)) stop 12 + dx1 = 0 + dx1 = -dx1 + if (.not. ieee_signbit(dx1)) stop 13 + dx1 = ieee_value(dx1, ieee_quiet_nan) + dx1 = -dx1 + if (.not. ieee_signbit(dx1)) stop 14 + + ! Large kind 1 + + xk1 = 1.3 + if (ieee_signbit(xk1)) stop 1 + xk1 = huge(xk1) + if (ieee_signbit(xk1)) stop 2 + xk1 = ieee_value(xk1, ieee_positive_inf) + if (ieee_signbit(xk1)) stop 3 + xk1 = tiny(xk1) + if (ieee_signbit(xk1)) stop 4 + xk1 = tiny(xk1) + xk1 = xk1 / 101 + if (ieee_signbit(xk1)) stop 5 + xk1 = 0 + if (ieee_signbit(xk1)) stop 6 + xk1 = ieee_value(xk1, ieee_quiet_nan) + if (ieee_signbit(xk1)) stop 7 + + xk1 = -1.3 + if (.not. ieee_signbit(xk1)) stop 8 + xk1 = -huge(xk1) + if (.not. ieee_signbit(xk1)) stop 9 + xk1 = -ieee_value(xk1, ieee_positive_inf) + if (.not. ieee_signbit(xk1)) stop 10 + xk1 = -tiny(xk1) + if (.not. ieee_signbit(xk1)) stop 11 + xk1 = -tiny(xk1) + xk1 = xk1 / 101 + if (.not. ieee_signbit(xk1)) stop 12 + xk1 = 0 + xk1 = -xk1 + if (.not. ieee_signbit(xk1)) stop 13 + xk1 = ieee_value(xk1, ieee_quiet_nan) + xk1 = -xk1 + if (.not. ieee_signbit(xk1)) stop 14 + + ! Large kind 2 + + xk2 = 1.3 + if (ieee_signbit(xk2)) stop 1 + xk2 = huge(xk2) + if (ieee_signbit(xk2)) stop 2 + xk2 = ieee_value(xk2, ieee_positive_inf) + if (ieee_signbit(xk2)) stop 3 + xk2 = tiny(xk2) + if (ieee_signbit(xk2)) stop 4 + xk2 = tiny(xk2) + xk2 = xk2 / 101 + if (ieee_signbit(xk2)) stop 5 + xk2 = 0 + if (ieee_signbit(xk2)) stop 6 + xk2 = ieee_value(xk2, ieee_quiet_nan) + if (ieee_signbit(xk2)) stop 7 + + xk2 = -1.3 + if (.not. ieee_signbit(xk2)) stop 8 + xk2 = -huge(xk2) + if (.not. ieee_signbit(xk2)) stop 9 + xk2 = -ieee_value(xk2, ieee_positive_inf) + if (.not. ieee_signbit(xk2)) stop 10 + xk2 = -tiny(xk2) + if (.not. ieee_signbit(xk2)) stop 11 + xk2 = -tiny(xk2) + xk2 = xk2 / 101 + if (.not. ieee_signbit(xk2)) stop 12 + xk2 = 0 + xk2 = -xk2 + if (.not. ieee_signbit(xk2)) stop 13 + xk2 = ieee_value(xk2, ieee_quiet_nan) + xk2 = -xk2 + if (.not. ieee_signbit(xk2)) stop 14 + +end Index: Fortran/gfortran/regression/ieee/underflow_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ieee/underflow_1.f90 @@ -0,0 +1,50 @@ +! { dg-do run } +! { dg-require-effective-target sse2_runtime { target { i?86-*-* x86_64-*-* } } } +! { dg-additional-options "-msse2 -mfpmath=sse" { target { i?86-*-* x86_64-*-* } } } + +program test_underflow_control + use ieee_arithmetic + use iso_fortran_env + + logical l + real, volatile :: x + double precision, volatile :: y + integer, parameter :: kx = kind(x), ky = kind(y) + + if (ieee_support_underflow_control(x)) then + + x = tiny(x) + call ieee_set_underflow_mode(.true.) + x = x / 2000._kx + if (x == 0) STOP 1 + call ieee_get_underflow_mode(l) + if (.not. l) STOP 2 + + x = tiny(x) + call ieee_set_underflow_mode(.false.) + x = x / 2000._kx + if (x > 0) STOP 3 + call ieee_get_underflow_mode(l) + if (l) STOP 4 + + end if + + if (ieee_support_underflow_control(y)) then + + y = tiny(y) + call ieee_set_underflow_mode(.true.) + y = y / 2000._ky + if (y == 0) STOP 5 + call ieee_get_underflow_mode(l) + if (.not. l) STOP 6 + + y = tiny(y) + call ieee_set_underflow_mode(.false.) + y = y / 2000._ky + if (y > 0) STOP 7 + call ieee_get_underflow_mode(l) + if (l) STOP 8 + + end if + +end program Index: Fortran/gfortran/regression/lto/20091015-1_0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091015-1_0.f @@ -0,0 +1,8 @@ +! { dg-lto-do link } +! We expect some warnings about mismatched symbol types +! { dg-extra-ld-options "-w" } + + subroutine dalie6s(iqmod6,nz,wx,cor6d) + common/dascr/iscrda(100),rscrri(100),iscrri(100),idao + call daall(iscrda,100,'$$IS ',no,nv) + end Index: Fortran/gfortran/regression/lto/20091015-1_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091015-1_1.f @@ -0,0 +1,4 @@ + SUBROUTINE DAALL(IC,L,CCC,NO,NV) + COMMON /main1/ eps + END + Index: Fortran/gfortran/regression/lto/20091015-1_2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091015-1_2.f @@ -0,0 +1,5 @@ + program test + common/main1/ eps(2) + dimension cor6d(2,2) + call dalie6s(iqmod6,1,wx,cor6d) + end Index: Fortran/gfortran/regression/lto/20091016-1_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091016-1_0.f90 @@ -0,0 +1,13 @@ +! { dg-lto-do link } +! { dg-lto-options {{-flto -g -fPIC -r} {-O -flto -g -fPIC -r}} } +! { dg-extra-ld-options "-flinker-output=nolto-rel" } + + FUNCTION makenumberstring(x) + IMPLICIT NONE + REAL, INTENT(IN) :: x + CHARACTER(len=20) :: makenumberstring + INTEGER :: xx + xx = x**2 ! << ICE + makenumberstring = '' + END FUNCTION + Index: Fortran/gfortran/regression/lto/20091028-1_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091028-1_0.f90 @@ -0,0 +1,9 @@ +! { dg-lto-do link } +! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel -Wno-lto-type-mismatch" } + +SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, VarName, Data, code ) + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, & + DataHandle, DummyData, DummyCount, code ) +END SUBROUTINE int_gen_ti_header_char + Index: Fortran/gfortran/regression/lto/20091028-1_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091028-1_1.c @@ -0,0 +1,11 @@ +extern void bcopy(const void *, void *, __SIZE_TYPE__ n); +char *p; +void int_gen_ti_header_c_ (char * hdrbuf, int * hdrbufsize, + int * itypesize, int * typesize, + int * DataHandle, char * Data, + int * Count, int * code) +{ + bcopy (typesize, p, sizeof(int)) ; + bcopy (Data, p, *Count * *typesize) ; +} + Index: Fortran/gfortran/regression/lto/20091028-2_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091028-2_0.f90 @@ -0,0 +1,9 @@ +! { dg-lto-do link } +! { dg-extra-ld-options "-r -nostdlib -finline-functions -flinker-output=nolto-rel -Wno-lto-type-mismatch" } + +SUBROUTINE int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, VarName, Data, code ) + CALL int_gen_ti_header_c ( hdrbuf, hdrbufsize, itypesize, 1, & + DataHandle, DummyData, DummyCount, code ) +END SUBROUTINE int_gen_ti_header_char + Index: Fortran/gfortran/regression/lto/20091028-2_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20091028-2_1.c @@ -0,0 +1,11 @@ +extern void *memcpy(void *dest, const void *src, __SIZE_TYPE__ n); +char *p; +void int_gen_ti_header_c_ (char * hdrbuf, int * hdrbufsize, + int * itypesize, int * typesize, + int * DataHandle, char * Data, + int * Count, int * code) +{ + memcpy (typesize, p, sizeof(int)) ; + memcpy (Data, p, *Count * *typesize) ; +} + Index: Fortran/gfortran/regression/lto/20100110-1_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20100110-1_0.f90 @@ -0,0 +1,19 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -O1 -flto }} } +! { dg-suppress-ld-options "-O1" } + + SUBROUTINE ylm4(ylm) + COMPLEX, INTENT (OUT):: ylm(1) + INTEGER l,m + COMPLEX ylms + REAL, ALLOCATABLE, SAVE :: ynorm(:) + ylms = 0 + DO m = 1, 1 + DO l = m, 1 + ylm(m) = conjg(ylms)*ynorm(m) + ENDDO + ENDDO + END SUBROUTINE ylm4 + + PROGRAM test + END Index: Fortran/gfortran/regression/lto/20100222-1_0.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20100222-1_0.f03 @@ -0,0 +1,34 @@ +! { dg-lto-do run } +! This testcase tests c_funloc and c_funptr from iso_c_binding. It uses +! functions defined in c_funloc_tests_3_funcs.c. +module c_funloc_tests_3 + implicit none +contains + function ffunc(j) bind(c) + use iso_c_binding, only: c_funptr, c_int + integer(c_int) :: ffunc + integer(c_int), value :: j + ffunc = -17*j + end function ffunc +end module c_funloc_tests_3 +program main + use iso_c_binding, only: c_funptr, c_funloc + use c_funloc_tests_3, only: ffunc + implicit none + interface + function returnFunc() bind(c,name="returnFunc") + use iso_c_binding, only: c_funptr + type(c_funptr) :: returnFunc + end function returnFunc + subroutine callFunc(func,pass,compare) bind(c,name="callFunc") + use iso_c_binding, only: c_funptr, c_int + type(c_funptr), value :: func + integer(c_int), value :: pass,compare + end subroutine callFunc + end interface + type(c_funptr) :: p + p = returnFunc() + call callFunc(p, 13,3*13) + p = c_funloc(ffunc) + call callFunc(p, 21,-17*21) +end program main Index: Fortran/gfortran/regression/lto/20100222-1_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/20100222-1_1.c @@ -0,0 +1,25 @@ +/* These functions support the test case c_funloc_tests_3. */ +#include +#include + +int printIntC(int i) +{ + return 3*i; +} + +int (*returnFunc(void))(int) +{ + return &printIntC; +} + +void callFunc(int(*func)(int), int pass, int compare) +{ + int result = (*func)(pass); + if(result != compare) + { + printf("FAILED: Got %d, expected %d\n", result, compare); + abort(); + } + else + printf("SUCCESS: Got %d, expected %d\n", result, compare); +} Index: Fortran/gfortran/regression/lto/bind-c-char_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind-c-char_0.f90 @@ -0,0 +1,49 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -O0 -flto }} } +! +! PR fortran/102885 + +module m + use iso_c_binding, only: c_char + implicit none (type, external) + +contains + +! Assumed-shape array, nonallocatable/nonpointer + +subroutine ar3 (xn, n) bind(C) + integer :: n + character(len=n) :: xn(..) + if (size(xn) /= 6) stop + if (len(xn) /= 5) stop + select rank(xn) + rank(1) + xn = ['FDGhf', & + 'hdrhg', & + 'fDgFl', & + 'DFHs3', & + '4a54G', & + 'hSs6k'] + rank default + stop + end select +end + +end + +program main + use m + implicit none (type, external) + character(kind=c_char, len=5) :: str5a6(6) + + ! assumed rank - with array descriptor + + str5a6 = ['DDGhf', & + 'hdrh$', & + 'fDGSl', & + 'DFHs3', & + '43grG', & + 'hFG$k'] + call ar3 (str5a6, 5) + +end Index: Fortran/gfortran/regression/lto/bind_c-1_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-1_0.f90 @@ -0,0 +1,21 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if C_PTR is not interoperable with both int * +! and float * +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + type(c_ptr) :: ptr + type(c_ptr) :: ptrb + end type MYFTYPE_1 + + type(myftype_1), bind(c, name="myVar") :: myVar + +contains + subroutine types_test() bind(c) + myVar%ptr = myVar%ptrb + end subroutine types_test +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-1_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-1_1.c @@ -0,0 +1,36 @@ +#include +/* interopse with myftype_1 */ +typedef struct { + float *ptr; + int *ptr2; +} myctype_t; + + +extern void abort(void); +void types_test(void); +/* declared in the fortran module */ +extern myctype_t myVar; + +int main(int argc, char **argv) +{ + myctype_t *cptr; + asm("":"=r"(cptr):"0"(&myVar)); + cptr->ptr = (float *)(size_t) (void *)1; + cptr->ptr2 = (int *)(size_t) (void *)2; + + types_test(); + + if(cptr->ptr != (float *)(size_t) (void *)2) + abort(); + if(cptr->ptr2 != (int *)(size_t) (void *)2) + abort(); + myVar.ptr2 = (int *)(size_t) (void *)3; + types_test(); + + if(myVar.ptr != (float *)(size_t) (void *)3) + abort(); + if(myVar.ptr2 != (int *)(size_t) (void *)3) + abort(); + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-2_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-2_0.f90 @@ -0,0 +1,21 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if C_PTR is not interoperable with both int * +! and float * +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + integer(c_signed_char) :: chr + integer(c_signed_char) :: chrb + end type MYFTYPE_1 + + type(myftype_1), bind(c, name="myVar") :: myVar + +contains + subroutine types_test() bind(c) + myVar%chr = myVar%chrb + end subroutine types_test +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-2_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-2_1.c @@ -0,0 +1,36 @@ +#include +/* interopse with myftype_1 */ +typedef struct { + unsigned char chr; + signed char chr2; +} myctype_t; + + +extern void abort(void); +void types_test(void); +/* declared in the fortran module */ +extern myctype_t myVar; + +int main(int argc, char **argv) +{ + myctype_t *cchr; + asm("":"=r"(cchr):"0"(&myVar)); + cchr->chr = 1; + cchr->chr2 = 2; + + types_test(); + + if(cchr->chr != 2) + abort(); + if(cchr->chr2 != 2) + abort(); + myVar.chr2 = 3; + types_test(); + + if(myVar.chr != 3) + abort(); + if(myVar.chr2 != 3) + abort(); + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-2b_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-2b_0.f90 @@ -0,0 +1,21 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if C_SIGNED_CHAR is not interoperable with signed +! char +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + integer(c_signed_char) :: chr + integer(c_signed_char) :: chrb + end type MYFTYPE_1 + + type(myftype_1), bind(c, name="myVar") :: myVar + +contains + subroutine types_test() bind(c) + myVar%chr = myVar%chrb + end subroutine types_test +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-2b_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-2b_1.c @@ -0,0 +1,36 @@ +#include +/* interopse with myftype_1 */ +typedef struct { + signed char chr; + signed char chr2; +} myctype_t; + + +extern void abort(void); +void types_test(void); +/* declared in the fortran module */ +extern myctype_t myVar; + +int main(int argc, char **argv) +{ + myctype_t *cchr; + asm("":"=r"(cchr):"0"(&myVar)); + cchr->chr = 1; + cchr->chr2 = 2; + + types_test(); + + if(cchr->chr != 2) + abort(); + if(cchr->chr2 != 2) + abort(); + myVar.chr2 = 3; + types_test(); + + if(myVar.chr != 3) + abort(); + if(myVar.chr2 != 3) + abort(); + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-3_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-3_0.f90 @@ -0,0 +1,91 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if integer types are not interoperable. +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + integer(c_int) :: val_int + integer(c_short) :: val_short + integer(c_long) :: val_long + integer(c_long_long) :: val_long_long + integer(c_size_t) :: val_size_t + integer(c_int8_t) :: val_int8_t + integer(c_int16_t) :: val_int16_t + integer(c_int32_t) :: val_int32_t + integer(c_int64_t) :: val_int64_t + integer(c_int_least8_t) :: val_intleast_8_t + integer(c_int_least16_t) :: val_intleast_16_t + integer(c_int_least32_t) :: val_intleast_32_t + integer(c_int_least64_t) :: val_intleast_64_t + integer(c_int_fast8_t) :: val_intfast_8_t + integer(c_int_fast16_t) :: val_intfast_16_t + integer(c_int_fast32_t) :: val_intfast_32_t + integer(c_int_fast64_t) :: val_intfast_64_t + integer(c_intmax_t) :: val_intmax_t + integer(c_intptr_t) :: val_intptr_t + end type MYFTYPE_1 + + type(myftype_1), bind(c, name="myVar") :: myVar + +contains + subroutine types_test1() bind(c) + myVar%val_int = 2 + end subroutine types_test1 + subroutine types_test2() bind(c) + myVar%val_short = 2 + end subroutine types_test2 + subroutine types_test3() bind(c) + myVar%val_long = 2 + end subroutine types_test3 + subroutine types_test4() bind(c) + myVar%val_long_long = 2 + end subroutine types_test4 + subroutine types_test5() bind(c) + myVar%val_size_t = 2 + end subroutine types_test5 + subroutine types_test6() bind(c) + myVar%val_int8_t = 2 + end subroutine types_test6 + subroutine types_test7() bind(c) + myVar%val_int16_t = 2 + end subroutine types_test7 + subroutine types_test8() bind(c) + myVar%val_int32_t = 2 + end subroutine types_test8 + subroutine types_test9() bind(c) + myVar%val_int64_t = 2 + end subroutine types_test9 + subroutine types_test10() bind(c) + myVar%val_intleast_8_t = 2 + end subroutine types_test10 + subroutine types_test11() bind(c) + myVar%val_intleast_16_t = 2 + end subroutine types_test11 + subroutine types_test12() bind(c) + myVar%val_intleast_32_t = 2 + end subroutine types_test12 + subroutine types_test13() bind(c) + myVar%val_intleast_64_t = 2 + end subroutine types_test13 + subroutine types_test14() bind(c) + myVar%val_intfast_8_t = 2 + end subroutine types_test14 + subroutine types_test15() bind(c) + myVar%val_intfast_16_t = 2 + end subroutine types_test15 + subroutine types_test16() bind(c) + myVar%val_intfast_32_t = 2 + end subroutine types_test16 + subroutine types_test17() bind(c) + myVar%val_intfast_64_t = 2 + end subroutine types_test17 + subroutine types_test18() bind(c) + myVar%val_intmax_t = 2 + end subroutine types_test18 + subroutine types_test19() bind(c) + myVar%val_intptr_t = 2 + end subroutine types_test19 +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-3_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-3_1.c @@ -0,0 +1,78 @@ +#include +#include +/* interopse with myftype_1 */ +typedef struct { + int val1; + short int val2; + long int val3; + long long int val4; + size_t val5; + int8_t val6; + int16_t val7; + int32_t val8; + int64_t val9; + int_least8_t val10; + int_least16_t val11; + int_least32_t val12; + int_least64_t val13; + int_fast8_t val14; + int_fast16_t val15; + int_fast32_t val16; + int_fast64_t val17; + intmax_t val18; + intptr_t val19; +} myctype_t; + + +extern void abort(void); +void types_test1(void); +void types_test2(void); +void types_test3(void); +void types_test4(void); +void types_test5(void); +void types_test6(void); +void types_test7(void); +void types_test8(void); +void types_test9(void); +void types_test10(void); +void types_test11(void); +void types_test12(void); +void types_test13(void); +void types_test14(void); +void types_test15(void); +void types_test16(void); +void types_test17(void); +void types_test18(void); +void types_test19(void); +/* declared in the fortran module */ +extern myctype_t myVar; + +#define test(n)\ + cchr->val##n = 1; types_test##n (); if (cchr->val##n != 2) abort (); + +int main(int argc, char **argv) +{ + myctype_t *cchr; + asm("":"=r"(cchr):"0"(&myVar)); + test(1); + test(2); + test(3); + test(4); + test(5); + test(6); + test(7); + test(8); + test(9); + test(10); + test(11); + test(12); + test(13); + test(14); + test(15); + test(16); + test(17); + test(18); + test(19); + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-4_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-4_0.f90 @@ -0,0 +1,48 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if real/complex/boolean/character types are not interoperable +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type, bind(c) :: MYFTYPE_1 + real(c_float) :: val_1 + real(c_double) :: val_2 + real(c_long_double) :: val_3 + complex(c_float_complex) :: val_4 + complex(c_double_complex) :: val_5 + complex(c_long_double_complex) :: val_6 + logical(c_bool) :: val_7 + !FIXME: Fortran define c_char as array of size 1. + !character(c_char) :: val_8 + end type MYFTYPE_1 + + type(myftype_1), bind(c, name="myVar") :: myVar + +contains + subroutine types_test1() bind(c) + myVar%val_1 = 2 + end subroutine types_test1 + subroutine types_test2() bind(c) + myVar%val_2 = 2 + end subroutine types_test2 + subroutine types_test3() bind(c) + myVar%val_3 = 2 + end subroutine types_test3 + subroutine types_test4() bind(c) + myVar%val_4 = 2 + end subroutine types_test4 + subroutine types_test5() bind(c) + myVar%val_5 = 2 + end subroutine types_test5 + subroutine types_test6() bind(c) + myVar%val_6 = 2 + end subroutine types_test6 + subroutine types_test7() bind(c) + myVar%val_7 = myVar%val_7 .or. .not. myVar%val_7 + end subroutine types_test7 + !subroutine types_test8() bind(c) + !myVar%val_8 = "a" + !end subroutine types_test8 +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-4_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-4_1.c @@ -0,0 +1,46 @@ +#include +#include +/* interopse with myftype_1 */ +typedef struct { + float val1; + double val2; + long double val3; + float _Complex val4; + double _Complex val5; + long double _Complex val6; + _Bool val7; + /* FIXME: Fortran define c_char as array of size 1. + char val8; */ +} myctype_t; + + +extern void abort(void); +void types_test1(void); +void types_test2(void); +void types_test3(void); +void types_test4(void); +void types_test5(void); +void types_test6(void); +void types_test7(void); +void types_test8(void); +/* declared in the fortran module */ +extern myctype_t myVar; + +#define test(n)\ + cchr->val##n = 1; types_test##n (); if (cchr->val##n != 2) abort (); + +int main(int argc, char **argv) +{ + myctype_t *cchr; + asm("":"=r"(cchr):"0"(&myVar)); + test(1); + test(2); + test(3); + test(4); + test(5); + test(6); + cchr->val7 = 0; types_test7 (); if (cchr->val7 != 1) abort (); + /*cchr->val8 = 0; types_test8 (); if (cchr->val8 != 'a') abort ();*/ + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-5_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-5_0.f90 @@ -0,0 +1,17 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if C_FUNPTR is not interoperable with both int * +! and float * +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + type(c_funptr), bind(c, name="myVar") :: myVar + type(c_funptr), bind(c, name="myVar2") :: myVar2 + +contains + subroutine types_test() bind(c) + myVar = myVar2 + end subroutine types_test +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-5_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-5_1.c @@ -0,0 +1,31 @@ +#include +/* declared in the fortran module */ +extern int (*myVar) (int); +extern float (*myVar2) (float); +void types_test(void); + + +extern void abort(void); + +int main(int argc, char **argv) +{ + int (**myptr) (int); + float (**myptr2) (float); + asm("":"=r"(myptr):"0"(&myVar)); + asm("":"=r"(myptr2):"0"(&myVar2)); + *myptr = (int (*) (int)) (size_t) (void *)1; + *myptr2 = (float (*) (float)) (size_t) (void *)2; + types_test(); + if (*myptr != (int (*) (int)) (size_t) (void *)2) + abort (); + if (*myptr2 != (float (*) (float)) (size_t) (void *)2) + abort (); + *myptr2 = (float (*) (float)) (size_t) (void *)3; + types_test(); + if (*myptr != (int (*) (int)) (size_t) (void *)3) + abort (); + if (*myptr2 != (float (*) (float)) (size_t) (void *)3) + abort (); + return 0; +} + Index: Fortran/gfortran/regression/lto/bind_c-6_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-6_0.f90 @@ -0,0 +1,17 @@ +! { dg-lto-do run } +! { dg-lto-options {{ -O3 -flto }} } +! This testcase will abort if C_FUNPTR is not interoperable with both int * +! and float * +module lto_type_merge_test + use, intrinsic :: iso_c_binding + implicit none + + integer(c_size_t), bind(c, name="myVar") :: myVar + integer(c_size_t), bind(c, name="myVar2") :: myVar2 + +contains + subroutine types_test() bind(c) + myVar = myVar2 + end subroutine types_test +end module lto_type_merge_test + Index: Fortran/gfortran/regression/lto/bind_c-6_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/bind_c-6_1.c @@ -0,0 +1,29 @@ +#include +/* declared in the fortran module */ +extern size_t myVar, myVar2; +void types_test(void); + + +extern void abort(void); + +int main(int argc, char **argv) +{ + size_t *myptr, *myptr2; + asm("":"=r"(myptr):"0"(&myVar)); + asm("":"=r"(myptr2):"0"(&myVar2)); + *myptr = 1; + *myptr2 = 2; + types_test(); + if (*myptr != 2) + abort (); + if (*myptr2 != 2) + abort (); + *myptr2 = 3; + types_test(); + if (*myptr != 3) + abort (); + if (*myptr2 != 3) + abort (); + return 0; +} + Index: Fortran/gfortran/regression/lto/lto.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/lto.exp @@ -0,0 +1,58 @@ +# Copyright (C) 2009-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . +# +# Contributed by Diego Novillo + + +# Test link-time optimization across multiple files. +# +# Programs are broken into multiple files. Each one is compiled +# separately with LTO information. The final executable is generated +# by collecting all the generated object files using regular LTO or WHOPR. + +if $tracelevel then { + strace $tracelevel +} + +# Load procedures from common libraries. +load_lib standard.exp +load_lib gfortran-dg.exp + +# Load the language-independent compabibility support procedures. +load_lib lto.exp + +# If LTO has not been enabled, bail. +if { ![check_effective_target_lto] } { + return +} + +lto_init no-mathlib + +# Define an identifier for use with this suite to avoid name conflicts +# with other lto tests running at the same time. +set sid "f_lto" + +# Main loop. +foreach src [lsort [glob -nocomplain $srcdir/$subdir/*_0.\[fF\]{,90,95,03,08} ]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $src] then { + continue + } + + lto-execute $src $sid +} + +lto_finish Index: Fortran/gfortran/regression/lto/pr40724_0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr40724_0.f @@ -0,0 +1,3 @@ + subroutine f + print *, "Hello World" + end Index: Fortran/gfortran/regression/lto/pr40724_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr40724_1.f @@ -0,0 +1,3 @@ + program test + call f + end Index: Fortran/gfortran/regression/lto/pr40725_0.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr40725_0.f03 @@ -0,0 +1,15 @@ +module bind_c_dts_2 +use, intrinsic :: iso_c_binding +implicit none +type, bind(c) :: my_c_type_1 + integer(c_int) :: j +end type my_c_type_1 +contains + subroutine sub0(my_type, expected_j) bind(c) + type(my_c_type_1) :: my_type + integer(c_int), value :: expected_j + if (my_type%j .ne. expected_j) then + STOP 1 + end if + end subroutine sub0 +end module bind_c_dts_2 Index: Fortran/gfortran/regression/lto/pr40725_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr40725_1.c @@ -0,0 +1,12 @@ +typedef struct c_type_1 +{ + int j; +} c_type_1_t; +void sub0(c_type_1_t *c_type, int expected_j); +int main(int argc, char **argv) +{ + c_type_1_t c_type; + c_type.j = 11; + sub0(&c_type, c_type.j); + return 0; +} Index: Fortran/gfortran/regression/lto/pr41069_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41069_0.f90 @@ -0,0 +1,7 @@ +! { dg-lto-do link } +SUBROUTINE mltfftsg ( a, ldax, lday ) + INTEGER, PARAMETER :: dbl = SELECTED_REAL_KIND ( 14, 200 ) + INTEGER, INTENT ( IN ) :: ldax, lday + COMPLEX ( dbl ), INTENT ( INOUT ) :: a ( ldax, lday ) +END SUBROUTINE mltfftsg + Index: Fortran/gfortran/regression/lto/pr41069_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41069_1.f90 @@ -0,0 +1,10 @@ +SUBROUTINE S(zin) + COMPLEX(8), DIMENSION(3,3,3) :: zin + INTEGER :: m,n + CALL mltfftsg ( zin, m, n ) +END SUBROUTINE + +COMPLEX(8), DIMENSION(3,3,3) :: zin +CALL s(zin) +END + Index: Fortran/gfortran/regression/lto/pr41069_2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41069_2.f90 @@ -0,0 +1,9 @@ +SUBROUTINE fftsg3d ( n, zout ) + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 ) + INTEGER, DIMENSION(*), INTENT(IN) :: n + COMPLEX(KIND=dp), DIMENSION(*), INTENT(INOUT) :: zout + INTEGER :: nx + nx = n ( 1 ) + CALL mltfftsg ( zout, nx, nx ) +END SUBROUTINE fftsg3d + Index: Fortran/gfortran/regression/lto/pr41521_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41521_0.f90 @@ -0,0 +1,16 @@ +! { dg-lto-do link } +! { dg-lto-options {{-g -flto -Wno-lto-type-mismatch} {-g -O -flto -Wno-lto-type-mismatch}} } +program species +integer spk(2) +real eval(2) +interface + subroutine atom(sol,k,eval) + real, intent(in) :: sol + integer, intent(in) :: k(2) + real, intent(out) :: eval(2) + end subroutine +end interface +spk = 2 +call atom(1.1,spk,eval) +end program + Index: Fortran/gfortran/regression/lto/pr41521_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41521_1.f90 @@ -0,0 +1,9 @@ +subroutine atom(sol,k,eval) +real, intent(in) :: sol +integer, intent(in) :: k(2) +real, intent(out) :: eval(2) +real t1 + t1=sqrt(dble(k(1)**2)-(sol)**2) + eval(1)=sol**2/sqrt(t1)-sol**2 +end subroutine + Index: Fortran/gfortran/regression/lto/pr41576_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41576_0.f90 @@ -0,0 +1,10 @@ +! { dg-lto-do run } +! { dg-lto-options { { -O2 -flto -Werror -Wno-lto-type-mismatch } } } + +subroutine foo + common /bar/ a, b + integer(4) :: a ,b + a = 1 + b = 2 +end + Index: Fortran/gfortran/regression/lto/pr41576_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41576_1.f90 @@ -0,0 +1,11 @@ +program test + common /bar/ c, d + integer(4) :: c, d +interface + subroutine foo() + end subroutine +end interface + call foo + if (c/=1 .or. d/=2) STOP 1 +end program test + Index: Fortran/gfortran/regression/lto/pr41764_0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr41764_0.f @@ -0,0 +1,13 @@ +! { dg-lto-do link } +! FIXME: This test used to fail with gold and -fuse-linker-plugin. It is +! here for people testing with RUNTESTFLAGS=-fuse-linker-plugin, but it would +! be nice to create "dg-effective-target-supports linker-plugin" and use it. + PROGRAM INIRAN + INTEGER IX, IY, IZ + COMMON /XXXRAN/ IX, IY, IZ + END + BLOCKDATA RAEWIN + INTEGER IX, IY, IZ + COMMON /XXXRAN/ IX, IY, IZ + DATA IX, IY, IZ / 1974, 235, 337 / + END Index: Fortran/gfortran/regression/lto/pr45586-2_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr45586-2_0.f90 @@ -0,0 +1,32 @@ +! { dg-lto-do link } +! +! PR fortran/45586 (comment 53) +! + +MODULE M1 + INTEGER, PARAMETER :: dp=8 + TYPE realspace_grid_type + REAL(KIND=dp), DIMENSION ( :, :, : ), ALLOCATABLE :: r + END TYPE realspace_grid_type + TYPE realspace_grid_p_type + TYPE(realspace_grid_type), POINTER :: rs_grid + END TYPE realspace_grid_p_type + TYPE realspaces_grid_p_type + TYPE(realspace_grid_p_type), DIMENSION(:), POINTER :: rs + END TYPE realspaces_grid_p_type +END MODULE + +MODULE M2 + USE M1 +CONTAINS + SUBROUTINE S1() + INTEGER :: i,j + TYPE(realspaces_grid_p_type), DIMENSION(:), POINTER :: rs_gauge + REAL(dp), DIMENSION(:, :, :), POINTER :: y + y=>rs_gauge(i)%rs(j)%rs_grid%r + END SUBROUTINE +END MODULE + +USE M2 + CALL S1() +END Index: Fortran/gfortran/regression/lto/pr45586_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr45586_0.f90 @@ -0,0 +1,29 @@ +! { dg-lto-do link } + MODULE M1 + INTEGER, PARAMETER :: dp=8 + TYPE realspace_grid_type + + REAL(KIND=dp), DIMENSION ( :, :, : ), ALLOCATABLE :: r + + END TYPE realspace_grid_type + END MODULE + + MODULE M2 + USE m1 + CONTAINS + SUBROUTINE S1(x) + TYPE(realspace_grid_type), POINTER :: x + REAL(dp), DIMENSION(:, :, :), POINTER :: y + y=>x%r + y=0 + + END SUBROUTINE + END MODULE + + USE M2 + TYPE(realspace_grid_type), POINTER :: x + ALLOCATE(x) + ALLOCATE(x%r(10,10,10)) + CALL S1(x) + write(6,*) x%r + END Index: Fortran/gfortran/regression/lto/pr46036_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr46036_0.f90 @@ -0,0 +1,14 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -O -flto -ftree-vectorize }} } + +function no_of_edges(self) result(res) + integer(kind=kind(1)) :: edge_bit_string + integer(kind=kind(1)) :: res + integer(kind=kind(1)) :: e + do e = 0, 11 + if (.not. btest(edge_bit_string,e)) cycle + res = res + 1 + end do +end function no_of_edges + +end program Index: Fortran/gfortran/regression/lto/pr46629_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr46629_0.f90 @@ -0,0 +1,15 @@ +! PR middle-end/46629 +! { dg-lto-do assemble } +! { dg-lto-options {{ -O2 -flto -ftree-vectorize }} } +! { dg-lto-options {{ -O2 -flto -ftree-vectorize -march=x86-64 }} { target i?86-*-* x86_64-*-* } } + +subroutine foo + character(len=6), save :: c + real, save :: d(0:100) + integer, save :: x, n, i + n = x + print *, c + do i = 2, n + d(i) = -d(i-1) + end do +end Index: Fortran/gfortran/regression/lto/pr46911_0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr46911_0.f @@ -0,0 +1,6 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -O2 -flto -g }} } +! { dg-extra-ld-options "-r -nostdlib -flinker-output=nolto-rel" } + common/main1/ eps(2) + call dalie6s(iqmod6,1,wx,cor6d) + end Index: Fortran/gfortran/regression/lto/pr47839_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr47839_0.f90 @@ -0,0 +1,8 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -g -flto }} } +! { dg-extra-ld-options "-r -nostdlib -flinker-output=nolto-rel" } + +MODULE globalvar_mod +integer :: xstop +CONTAINS +END MODULE globalvar_mod Index: Fortran/gfortran/regression/lto/pr47839_1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr47839_1.f90 @@ -0,0 +1,7 @@ +MODULE PEC_mod +CONTAINS +SUBROUTINE PECapply(Ex) +USE globalvar_mod, ONLY : xstop +real(kind=8), dimension(1:xstop), intent(inout) :: Ex +END SUBROUTINE PECapply +END MODULE PEC_mod Index: Fortran/gfortran/regression/lto/pr60635_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr60635_0.f90 @@ -0,0 +1,17 @@ +! { dg-lto-do link } +! { dg-lto-options {{ -Wno-lto-type-mismatch }} } +program test + use iso_fortran_env + + interface + integer(int16) function bigendc16(x) bind(C) + import + integer(int16), intent(in) :: x + end function + end interface + + integer(int16) :: x16 = 12345 + x16 = bigendc16(x16) + print *,x16 +end program + Index: Fortran/gfortran/regression/lto/pr60635_1.c =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr60635_1.c @@ -0,0 +1,14 @@ +#include +#include + +static bool littleendian=true; + +uint16_t bigendc16(union{uint16_t * n;uint8_t* b;}x){ + + if (!littleendian) return *x.n; + + uint16_t res = ((uint16_t)(x.b[1])<<0) | + ((uint16_t)(x.b[0])<<8); + return res; +} + Index: Fortran/gfortran/regression/lto/pr79108_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr79108_0.f90 @@ -0,0 +1,15 @@ +! { dg-lto-do link } +! { dg-require-effective-target lto_incremental } +! { dg-lto-options {{ -Ofast -flto --param ggc-min-expand=0 --param ggc-min-heapsize=0 }} } +! { dg-extra-ld-options "-r" } + +MODULE Errorcheck_mod +CONTAINS +SUBROUTINE Check_open(ios, outputstr, errortype) +character(len=*), intent(in) :: outputstr +if (ios > 0 .AND. errortype == FATAL) then + write(*,*) 'The value of ios was:', ios +end if +END SUBROUTINE Check_open +END MODULE Errorcheck_mod + Index: Fortran/gfortran/regression/lto/pr84645_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr84645_0.f90 @@ -0,0 +1,17 @@ +! { dg-lto-do link } +! { dg-lto-options { { -flto -g0 } } } +! { dg-extra-ld-options { -g } } +program nml_test + implicit none + type t + integer :: c1 + integer :: c2(3) + end type t + call test2(2) +contains + subroutine test2(n) + integer :: n + type(t) :: x12(n) + namelist /nml2/ x12 + end subroutine test2 +end program nml_test Index: Fortran/gfortran/regression/lto/pr87689_0.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr87689_0.f @@ -0,0 +1,13 @@ +! { dg-lto-do run } +! PR 87689 - this used to fail for POWER, plus it used to +! give warnings about mismatches with LTO. +! Original test case by Judicaël Grasset. + program main + implicit none + character :: c + character(len=20) :: res, doesntwork_p8 + external doesntwork_p8 + c = 'o' + res = doesntwork_p8(c,1,2,3,4,5,6) + if (res /= 'foo') stop 3 + end program main Index: Fortran/gfortran/regression/lto/pr87689_1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr87689_1.f @@ -0,0 +1,11 @@ + function doesntwork_p8(c,a1,a2,a3,a4,a5,a6) + implicit none + character(len=20) :: doesntwork_p8 + character :: c + integer :: a1,a2,a3,a4,a5,a6 + if (a1 /= 1 .or. a2 /= 2 .or. a3 /= 3 .or. a4 /= 4 .or. a5 /= 5 + & .or. a6 /= 6) stop 1 + if (c /= 'o ') stop 2 + doesntwork_p8 = 'foo' + return + end Index: Fortran/gfortran/regression/lto/pr89084_0.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/lto/pr89084_0.f90 @@ -0,0 +1,24 @@ +! PR fortran/89084 +! { dg-lto-do link } +! { dg-lto-options {{ -O0 -flto }} } + +integer function foo () + write (*,*) 'foo' + block + integer, parameter :: idxs(3) = (/ 1, 2, 3 /) + integer :: i + foo = 0 + do i = 1, size(idxs) + foo = foo + idxs(i) + enddo + end block +end function foo +program pr89084 + integer :: i + interface + integer function foo () + end function + end interface + i = foo () + if (i.ne.6) stop 1 +end Index: Fortran/gfortran/regression/prof/dynamic_dispatch_6.f03 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/prof/dynamic_dispatch_6.f03 @@ -0,0 +1,68 @@ +! { dg-require-profiling "-fprofile-generate" } +! { dg-options "-Ofast" } +! +! PR 45076: [OOP] gfortran.dg/dynamic_dispatch_6.f03 ICEs with -fprofile-use +! +! Contributed by Damian Rouson + +module field_module + implicit none + private + public :: field + type ,abstract :: field + end type +end module + +module periodic_5th_order_module + use field_module ,only : field + implicit none + type ,extends(field) :: periodic_5th_order + end type +end module + +module field_factory_module + implicit none + private + public :: field_factory + type, abstract :: field_factory + contains + procedure(create_interface), deferred :: create + end type + abstract interface + function create_interface(this) + use field_module ,only : field + import :: field_factory + class(field_factory), intent(in) :: this + class(field) ,pointer :: create_interface + end function + end interface +end module + +module periodic_5th_factory_module + use field_factory_module , only : field_factory + implicit none + private + public :: periodic_5th_factory + type, extends(field_factory) :: periodic_5th_factory + contains + procedure :: create=>new_periodic_5th_order + end type +contains + function new_periodic_5th_order(this) + use field_module ,only : field + use periodic_5th_order_module ,only : periodic_5th_order + class(periodic_5th_factory), intent(in) :: this + class(field) ,pointer :: new_periodic_5th_order + end function +end module + +program main + use field_module ,only : field + use field_factory_module ,only : field_factory + use periodic_5th_factory_module ,only : periodic_5th_factory + implicit none + class(field) ,pointer :: u + class(field_factory), allocatable :: field_creator + allocate (periodic_5th_factory :: field_creator) + u => field_creator%create() +end program Index: Fortran/gfortran/regression/prof/prof.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/prof/prof.exp @@ -0,0 +1,66 @@ +# Copyright (C) 2001-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# Test the functionality of programs compiled with profile-directed block +# ordering using -fprofile-generate followed by -fprofile-use. + +load_lib target-supports.exp +load_lib fortran-modules.exp + +# Some targets don't support tree profiling. +if { ![check_profiling_available "-fprofile-generate"] } { + return +} + +# The procedures in profopt.exp need these parameters. +set tool gfortran +set prof_ext "gcda" + +if $tracelevel then { + strace $tracelevel +} + +# Load support procs. +load_lib profopt.exp + +# Save and override the default list defined in profopt.exp. +set treeprof_save_profopt_options $PROFOPT_OPTIONS +set PROFOPT_OPTIONS [list {}] + +# These are globals used by profopt-execute. The first is options +# needed to generate profile data, the second is options to use the +# profile data. +set profile_option "-fprofile-generate -D_PROFILE_GENERATE" +set feedback_option "-fprofile-use -D_PROFILE_USE" + +foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f*]] { + # If we're only testing specific files and this isn't one of them, skip it. + if ![runtest_file_p $runtests $src] then { + continue + } + list-module-names $src + profopt-execute $src + cleanup-modules "" +} + +foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f*]] { + if ![runtest_file_p $runtests $src] then { + continue + } + auto-profopt-execute $src +} + +set PROFOPT_OPTIONS $treeprof_save_profopt_options Index: Fortran/gfortran/regression/ubsan/bind-c-intent-out-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ubsan/bind-c-intent-out-2.f90 @@ -0,0 +1,39 @@ +! { dg-do run } +! { dg-additional-options "-fsanitize=undefined -fcheck=all" } + +! PR fortran/92621 + +subroutine hello(val) bind(c) + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + integer(kind=c_int), allocatable, intent(out) :: val(:) + + allocate(val(1)) + val = 2 + return +end subroutine hello + +program alloc_p + + use, intrinsic :: iso_c_binding, only: c_int + + implicit none + + interface + subroutine hello(val) bind(c) + import :: c_int + implicit none + integer(kind=c_int), allocatable, intent(out) :: val(:) + end subroutine hello + end interface + + integer(kind=c_int), allocatable :: a(:) + + allocate(a(1)) + a = 1 + call hello(a) + stop + +end program alloc_p Index: Fortran/gfortran/regression/ubsan/pr101624.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ubsan/pr101624.f90 @@ -0,0 +1,13 @@ +! PR middle-end/101624 +! { dg-do compile } +! { dg-options "-O2 -fsanitize=undefined" } + +complex function foo (x) + complex, intent(in) :: x + foo = aimag (x) +end +program pr101624 + complex, parameter :: a = (0.0, 1.0) + complex :: b, foo + b = foo (a) +end Index: Fortran/gfortran/regression/ubsan/pr106062.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ubsan/pr106062.f90 @@ -0,0 +1,11 @@ +! PR c++/106062 +! { dg-do compile } +! { dg-options "-O2 -fsanitize=undefined" } + +call test (reshape ((/ 'a', 'b', 'c', 'd' /), (/ 2, 2 /))) +contains + subroutine test (a) + character (*), dimension (:, :) :: a + if (len (a) .ne. 1) STOP + end +end Index: Fortran/gfortran/regression/ubsan/ubsan.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/ubsan/ubsan.exp @@ -0,0 +1,38 @@ +# Copyright (C) 2021-2023 Free Software Foundation, Inc. +# +# This file is part of GCC. +# +# GCC is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3, or (at your option) +# any later version. +# +# GCC is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite for gfortran that checks undefined behavior sanitizer. + +# Load support procs. +load_lib gfortran-dg.exp +load_lib ubsan-dg.exp + + +# Initialize `dg'. +dg-init +ubsan_init + +# Main loop. +if [check_effective_target_fsanitize_undefined] { + gfortran-dg-runtest [lsort \ + [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ] ] "" "" +} + +# All done. +ubsan_finish +dg-finish Index: Fortran/gfortran/regression/vect/O3-bb-slp-1.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/O3-bb-slp-1.f @@ -0,0 +1,28 @@ +! { dg-do compile } + subroutine tranx3 (jbeg,jend,kbeg,kend,dlo,den,mflx,zro) + parameter(in = 128+5 + & , jn = 128+5 + & , kn = 128+5) + parameter(ijkn = 128+5) + real*8 zro, dqm, dqp, dx3bi (kn) + real*8 mflux (ijkn,4), dtwid (ijkn,4), dd (ijkn,4) + real*8 mflx (in,jn,kn) + real*8 dlo (in,jn,kn), den (in,jn,kn) + do 2100 j=jbeg-1,jend + dtwid (k,1) = ( 0.5 + q1 ) * ( dlo(i ,j,k-1) + 3 - ( dx3a(k ) + xi ) * dd (k ,1) ) + mflux (k,1) = dtwid (k,1) * ( v3(i ,j,k) - vg3(k) ) * dt + if (j.ge.jbeg) then + den(i ,j,k) = ( dlo(i ,j,k) * dvl3a(k) + 1 - etwid (k+1,1) + etwid (k,1) ) * dvl3a i(k) + if (kend .eq. ke) mflx(i ,j,ke+1) = mflux (ke+1,1) + endif + do 2030 k=max(kbeg-2,ks-1),kend+1 + dqm = (dlo(i ,j,k ) - dlo(i ,j,k-1)) * dx3bi(k ) + dqp = (dlo(i ,j,k+1) - dlo(i ,j,k )) * dx3bi(k+1) + dd(k,1) = max ( dqm * dqp, zro ) +2030 continue + dtwid (k,3) = ( 0.5 + q1 ) * ( dlo(i+2,j,k-1) + 3 - ( dx3a(k ) + xi ) * deod (k ,3) ) +2100 continue + end Index: Fortran/gfortran/regression/vect/O3-bb-slp-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/O3-bb-slp-2.f @@ -0,0 +1,40 @@ +! { dg-do compile } +! { dg-additional-options "-mavx2" { target x86_64-*-* i?86-*-* } } + subroutine tranx3 (ibeg,jbeg,jend,kbeg,kend + & ,dlo,den + & ,edn) + parameter(in = 128+5 + & , jn = 128+5 + & , kn = 128+5) + parameter(ijkn = 128+5) + real*8 e (in,jn,kn), dqm, dvl3a (kn), dvl3ai (kn) + & , dtwid (ijkn,4), dd (ijkn,4) + & , etwid (ijkn,4), deod (ijkn,4) + real*8 dlo (in,jn,kn), den (in,jn,kn) + & , edn (in,jn,kn) + do 2100 j=jbeg-1,jend + i = ibeg - 1 + do 1080 k=kbeg,kend + den(i ,j,k) = ( dlo(i ,j,k) * dvl3a(k) + 1 - etwid (k+1,1) + etwid (k,1) ) * dvl3a i(k) +1080 continue + do 2030 k=max(kbeg-2,ks-1),kend+1 + dqm = (dlo(i+2,j,k ) - dlo(i+2,j,k-1)) * dx3bi(k ) + dd(k,4) = max ( dqm * dqp, zro ) +2030 continue + dtwid (k,3) = ( 0.5 + q1 ) * ( dlo(i+2,j,k-1) + 1 + ( dx3a(k-1) - xi ) * dd (k-1,3) ) + 2 + ( 0.5 - q1 ) * ( dlo(i+2,j,k ) + 3 - ( dx3a(k ) + xi ) * deod (k ,3) ) + do 2080 k=kbeg,kend + den(i ,j,k) = ( dlo(i ,j,k) * dvl3a(k) + 1 - dtwid (k+1,3) + dtwid (k,3) ) * dvl3a i(k) + e (i+2,j,k) = ( e (i+2,j,k) * dvl3a(k) + 1 - etwid (k+1,3) + etwid (k,3) ) * dvl3a i(k) + edn(i+2,j,k) = e(i+2,j,k) / den(i+2,j,k) + e (i+3,j,k) = ( e (i+3,j,k) * dvl3a(k) + 1 - etwid (k+1,4) + etwid (k,4) ) * dvl3a i(k) + edn(i+3,j,k) = e(i+3,j,k) / den(i+3,j,k) +2080 continue +2100 continue + end Index: Fortran/gfortran/regression/vect/O3-pr36119.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/O3-pr36119.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } + +SUBROUTINE check_dnucint_ana (dcore) + IMPLICIT NONE + INTEGER, PARAMETER :: dp=8 + REAL(dp), DIMENSION(10, 2), INTENT(IN),& + OPTIONAL :: dcore + INTEGER :: i, j + REAL(dp) :: delta, nssss, od, rn, ssssm, & + ssssp + REAL(dp), DIMENSION(10, 2) :: corem, corep, ncore + LOGICAL :: check_value + + delta = 1.0E-8_dp + od = 0.5_dp/delta + ncore = od * (corep - corem) + nssss = od * (ssssp - ssssm) + IF (PRESENT(dcore)) THEN + DO i = 1, 2 + DO j = 1, 10 + IF (.NOT.check_value(ncore(j,i), dcore(j,i), delta, 0.1_dp)) THEN + END IF + END DO + END DO + END IF +END SUBROUTINE check_dnucint_ana + Index: Fortran/gfortran/regression/vect/O3-pr39595.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/O3-pr39595.f @@ -0,0 +1,16 @@ +! { dg-do compile } + subroutine foo(a,c,i,m) + real a(4,*),b(3,64),c(3,200),d(64) + integer*8 i,j,k,l,m + do j=1,m,64 + do k=1,m-j+1 + d(k)=a(4,j-1+k) + do l=1,3 + b(l,k)=c(l,i)+a(l,j-1+k) + end do + end do + call bar(b,d,i) + end do + end + + Index: Fortran/gfortran/regression/vect/O3-pr49957.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/O3-pr49957.f @@ -0,0 +1,16 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } + subroutine shell(nx,ny,nz,q,dq) + implicit none + integer i,j,k,l,nx,ny,nz + real*8 q(5,nx,ny),dq(5,nx,ny) + do j=1,ny + do i=1,nx + do l=1,5 + q(l,i,j)=q(l,i,j)+dq(l,i,j) + enddo + enddo + enddo + return + end +! { dg-final { scan-tree-dump "vectorized 1 loops" "vect" { xfail { vect_no_align && { ! vect_hw_misalign } } } } } Index: Fortran/gfortran/regression/vect/Ofast-pr50414.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/Ofast-pr50414.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } + + SUBROUTINE SUB (A,L,YMAX) + DIMENSION A(L) + YMA=A(1) + DO 2 I=1,L,2 + 2 YMA=MAX(YMA,A(I),A(I+1)) + CALL PROUND(YMA) + END + Index: Fortran/gfortran/regression/vect/cost-model-pr34445.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/cost-model-pr34445.f @@ -0,0 +1,8 @@ +c { dg-do compile } + Subroutine FndSph(Alpha,Rad) + Dimension Rad(100),RadInp(100) + Do I = 1, NSphInp + Rad(I) = RadInp(I) + Alpha = 1.2 + End Do + End Index: Fortran/gfortran/regression/vect/cost-model-pr34445a.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/cost-model-pr34445a.f @@ -0,0 +1,29 @@ +c { dg-do compile } +c { dg-additional-options "-std=legacy" } + subroutine derv (xx,b,bv,det,r,s,t,ndopt,cosxy,thick,edis, + 1 vni,vnt) + implicit real*8 (a-h,o-z) + save +c + common /shell1/ disd(9),ield,ielp,npt,idw,ndrot + common /shell4/xji(3,3),p(3,32),h(32) +c + dimension xx(3,*),ndopt(*),bv(*),vni(*),cosxy(6,*),vnt(*), + 1 edis(*),thick(*),b(*) +c + kk=0 + k2=0 + do 130 k=1,ield + k2=k2 + 3 + if (ndopt(k)) 127,127,130 + 127 kk=kk + 1 + do 125 i=1,3 + b(k2+i)=b(k2+i) + (xji(i,1)*p(1,k) + xji(i,2)*p(2,k))*t + 1 + xji(i,3)*h(k) + th=0.5*thick(kk) + b(k2+i+3)=b(k2+i+3) - th*cosxy(i+3,kk) + 125 b(k2+i+6)=b(k2+i+6) + th*cosxy(i,kk) + k2=k2 + 9 + 130 continue + return + end Index: Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-mgrid-resid.f @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } +! { dg-options "-O3 --param vect-max-peeling-for-alignment=0 -fpredictive-commoning -fdump-tree-pcom-details -std=legacy" } +! { dg-additional-options "-mprefer-avx128" { target { i?86-*-* x86_64-*-* } } } +! { dg-additional-options "-mzarch" { target { s390*-*-* } } } + +******* RESID COMPUTES THE RESIDUAL: R = V - AU +* +* THIS SIMPLE IMPLEMENTATION COSTS 27A + 4M PER RESULT, WHERE +* A AND M DENOTE THE COSTS OF ADDITION (OR SUBTRACTION) AND +* MULTIPLICATION, RESPECTIVELY. BY USING SEVERAL TWO-DIMENSIONAL +* BUFFERS ONE CAN REDUCE THIS COST TO 13A + 4M IN THE GENERAL +* CASE, OR 10A + 3M WHEN THE COEFFICIENT A(1) IS ZERO. +* + SUBROUTINE RESID(U,V,R,N,A) + INTEGER N + REAL*8 U(N,N,N),V(N,N,N),R(N,N,N),A(0:3) + INTEGER I3, I2, I1 +C + DO 600 I3=2,N-1 + DO 600 I2=2,N-1 + DO 600 I1=2,N-1 + 600 R(I1,I2,I3)=V(I1,I2,I3) + > -A(0)*( U(I1, I2, I3 ) ) + > -A(1)*( U(I1-1,I2, I3 ) + U(I1+1,I2, I3 ) + > + U(I1, I2-1,I3 ) + U(I1, I2+1,I3 ) + > + U(I1, I2, I3-1) + U(I1, I2, I3+1) ) + > -A(2)*( U(I1-1,I2-1,I3 ) + U(I1+1,I2-1,I3 ) + > + U(I1-1,I2+1,I3 ) + U(I1+1,I2+1,I3 ) + > + U(I1, I2-1,I3-1) + U(I1, I2+1,I3-1) + > + U(I1, I2-1,I3+1) + U(I1, I2+1,I3+1) + > + U(I1-1,I2, I3-1) + U(I1-1,I2, I3+1) + > + U(I1+1,I2, I3-1) + U(I1+1,I2, I3+1) ) + > -A(3)*( U(I1-1,I2-1,I3-1) + U(I1+1,I2-1,I3-1) + > + U(I1-1,I2+1,I3-1) + U(I1+1,I2+1,I3-1) + > + U(I1-1,I2-1,I3+1) + U(I1+1,I2-1,I3+1) + > + U(I1-1,I2+1,I3+1) + U(I1+1,I2+1,I3+1) ) +C + RETURN + END +! we want to check that predictive commoning did something on the +! vectorized loop. If vector factor is 2, the vectorized loop can +! be predictive commoned, we check if predictive commoning PHI node +! is created with vector(2) type. +! { dg-final { scan-tree-dump "Executing predictive commoning without unrolling" "pcom" { xfail vect_variable_length } } } +! { dg-final { scan-tree-dump "vectp_u.*__lsm.* = PHI <.*vectp_u.*__lsm" "pcom" { xfail vect_variable_length } } } Index: Fortran/gfortran/regression/vect/fast-math-pr33299.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-pr33299.f90 @@ -0,0 +1,16 @@ +! { dg-require-effective-target vect_double } + +PROGRAM test + REAL(8) :: f,dist(2) + dist = [1.0_8, 0.5_8] + if( f(1.0_8, dist) /= MINVAL(dist)) then + STOP 1 + endif +END PROGRAM test + +FUNCTION f( x, dist ) RESULT(s) + REAL(8) :: dist(2), x, s + s = MINVAL(dist) + IF( x < 0 ) s = -s +END FUNCTION f + Index: Fortran/gfortran/regression/vect/fast-math-pr37021.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-pr37021.f90 @@ -0,0 +1,17 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } + +subroutine to_product_of(self,a,b,a1,a2) + complex(kind=8) :: self (:) + complex(kind=8), intent(in) :: a(:,:) + complex(kind=8), intent(in) :: b(:) + integer a1,a2 + self = ZERO + do i = 1,a1 + do j = 1,a2 + self(i) = self(i) + a(i,j)*b(j) + end do + end do +end subroutine + +! { dg-final { scan-tree-dump "vectorized 2 loops" "vect" } } Index: Fortran/gfortran/regression/vect/fast-math-pr38968.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-pr38968.f90 @@ -0,0 +1,27 @@ +! Skip this on platforms that don't have the vectorization instructions +! to handle complex types. This test is very slow on these platforms so +! skipping is better then running it unvectorized. +! { dg-skip-if "" { ia64-*-* sparc*-*-* } } +! It can be slow on some x86 CPUs. +! { dg-timeout-factor 2 } +program mymatmul + implicit none + integer, parameter :: kp = 4 + integer, parameter :: n = 400 + real(kp), dimension(n,n) :: rr, ri + complex(kp), dimension(n,n) :: a,b,c + real :: t1, t2 + integer :: i, j, k + common // a,b,c + + do j = 1, n + do k = 1, n + do i = 1, n + c(i,j) = c(i,j) + a(i,k) * b(k,j) + end do + end do + end do + +end program mymatmul + +! { dg-final { scan-tree-dump "vectorized 1 loops" "vect" } } Index: Fortran/gfortran/regression/vect/fast-math-real8-pr40801.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-real8-pr40801.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } + +MODULE YOMPHY0 +REAL :: ECMNP +REAL :: SCO +REAL :: USDMLT +END MODULE YOMPHY0 +SUBROUTINE ACCONV ( KIDIA,KFDIA,KLON,KTDIA,KLEV,& + &CDLOCK) +USE YOMPHY0 , ONLY : ECMNP ,SCO ,USDMLT +REAL :: PAPHIF(KLON,KLEV),PCVGQ(KLON,KLEV)& + &,PFPLCL(KLON,0:KLEV),PFPLCN(KLON,0:KLEV),PSTRCU(KLON,0:KLEV)& + &,PSTRCV(KLON,0:KLEV) +INTEGER :: KNLAB(KLON,KLEV),KNND(KLON) +REAL :: ZCP(KLON,KLEV),ZLHE(KLON,KLEV),ZDSE(KLON,KLEV)& + &,ZPOII(KLON),ZALF(KLON),ZLN(KLON),ZUN(KLON),ZVN(KLON)& + &,ZPOIL(KLON) +DO JLEV=KLEV-1,KTDIA,-1 + DO JIT=1,NBITER + ZLN(JLON)=MAX(0.,ZLN(JLON)& + &-(ZQW(JLON,JLEV)-ZQN(JLON)& + &*(PQ(JLON,JLEV+1)-ZQN(JLON))))*KNLAB(JLON,JLEV) + ENDDO +ENDDO +IF (ITOP < KLEV+1) THEN + DO JLON=KIDIA,KFDIA + ZZVAL=PFPLCL(JLON,KLEV)+PFPLCN(JLON,KLEV)-SCO + KNND(JLON)=KNND(JLON)*MAX(0.,-SIGN(1.,0.-ZZVAL)) + ENDDO + DO JLEV=ITOP,KLEV + DO JLON=KIDIA,KFDIA + ENDDO + ENDDO +ENDIF +END SUBROUTINE ACCONV + Index: Fortran/gfortran/regression/vect/fast-math-rnflow-trs2a2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-rnflow-trs2a2.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } + + function trs2a2 (j, k, u, d, m) +! matrice de transition intermediaire, partant de k sans descendre +! sous j. R = IjU(I-Ik)DIj, avec Ii = deltajj, j >= i. +! alternative: trs2a2 = 0 +! trs2a2 (j:k-1, j:k-1) = matmul (utrsft (j:k-1,j:k-1), +! dtrsft (j:k-1,j:k-1)) +! + real, dimension (1:m,1:m) :: trs2a2 ! resultat + real, dimension (1:m,1:m) :: u, d ! matrices utrsft, dtrsft + integer, intent (in) :: j, k, m ! niveaux vallee pic +! +!##### following line replaced by Prentice to make less system dependent +! real (kind = kind (1.0d0)) :: dtmp + real (kind = selected_real_kind (10,50)) :: dtmp +! + trs2a2 = 0.0 + do iclw1 = j, k - 1 + do iclw2 = j, k - 1 + dtmp = 0.0d0 + do iclww = j, k - 1 + dtmp = dtmp + u (iclw1, iclww) * d (iclww, iclw2) + enddo + trs2a2 (iclw1, iclw2) = dtmp + enddo + enddo + return + end function trs2a2 + +! { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/fast-math-vect-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/fast-math-vect-8.f90 @@ -0,0 +1,94 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-require-visibility "" } + +module solv_cap + + implicit none + + public :: init_solve + + integer, parameter, public :: dp = 4 + + real(kind=dp), private :: Pi, Mu0, c0, eps0 + logical, private :: UseFFT, UsePreco + real(kind=dp), private :: D1, D2 + integer, private, save :: Ng1=0, Ng2=0 + integer, private, pointer, dimension(:,:) :: Grid + real(kind=dp), private, allocatable, dimension(:,:) :: G + +contains + + subroutine init_solve(Grid_in, GrSize1, GrSize2, UseFFT_in, UsePreco_in) + integer, intent(in), target, dimension(:,:) :: Grid_in + real(kind=dp), intent(in) :: GrSize1, GrSize2 + logical, intent(in) :: UseFFT_in, UsePreco_in + integer :: i, j + + Pi = acos(-1.0_dp) + Mu0 = 4e-7_dp * Pi + c0 = 299792458 + eps0 = 1 / (Mu0 * c0**2) + + UseFFT = UseFFT_in + UsePreco = UsePreco_in + + if(Ng1 /= 0 .and. allocated(G) ) then + deallocate( G ) + end if + + Grid => Grid_in + Ng1 = size(Grid, 1) + Ng2 = size(Grid, 2) + D1 = GrSize1/Ng1 + D2 = GrSize2/Ng2 + + allocate( G(0:Ng1,0:Ng2) ) + + write(unit=*, fmt=*) "Calculating G" + do i=0,Ng1 + do j=0,Ng2 + G(j,i) = Ginteg( -D1/2,-D2/2, D1/2,D2/2, i*D1,j*D2 ) + end do + end do + + if(UseFFT) then + write(unit=*, fmt=*) "Transforming G" + call FourirG(G,1) + end if + + return + + + contains + function Ginteg(xq1,yq1, xq2,yq2, xp,yp) result(G) + real(kind=dp), intent(in) :: xq1,yq1, xq2,yq2, xp,yp + real(kind=dp) :: G + real(kind=dp) :: x1,x2,y1,y2,t + x1 = xq1-xp + x2 = xq2-xp + y1 = yq1-yp + y2 = yq2-yp + + if (x1+x2 < 0) then + t = -x1 + x1 = -x2 + x2 = t + end if + if (y1+y2 < 0) then + t = -y1 + y1 = -y2 + y2 = t + end if + + G = (x2*y2)-(x1*y2)-(x2*y1)+(x1*y1) + + return + end function Ginteg + + end subroutine init_solve + +end module solv_cap + + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target vect_intfloat_cvt } } } Index: Fortran/gfortran/regression/vect/mask-store-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/mask-store-1.f90 @@ -0,0 +1,11 @@ +subroutine foo(a, b, x, n) + real(kind=8) :: a(n), b(n), tmp + logical(kind=1) :: x + integer(kind=4) :: i, n + do i = 1, n + if (x) then + a(i) = b(i) + end if + b(i) = b(i) + 10 + end do +end subroutine Index: Fortran/gfortran/regression/vect/no-fre-no-copy-prop-O3-pr51704.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/no-fre-no-copy-prop-O3-pr51704.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } + + integer, parameter :: q = 2 + integer, parameter :: nx=3, ny=2*q, nz=5 + integer, parameter, dimension(nx,ny,nz) :: p = & + & reshape ((/ (i**2, i=1,size(p)) /), shape(p)) + integer, parameter, dimension( ny,nz) :: px = & + & reshape ((/ (( & + & + nx*(nx-1)*(2*nx-1)/6, & + & j=0,ny-1), k=0,nz-1) /), shape(px)) + integer, parameter, dimension(nx, nz) :: py = & + & reshape ((/ (( & + & +(nx )**2*ny*(ny-1)*(2*ny-1)/6, & + & i=0,nx-1), k=0,nz-1) /), shape(py)) + integer, parameter, dimension(nx,ny ) :: pz = & + & reshape ((/ (( & + & +(nx*ny)**2*nz*(nz-1)*(2*nz-1)/6, & + & i=0,nx-1), j=0,ny-1) /), shape(pz)) + integer, dimension(nx,ny,nz) :: a + integer, dimension(nx,ny ) :: az + if (sum(sum(sum(a,1),2),1) /= sum(a)) STOP 1 + if (sum(sum(sum(a,3),1),1) /= sum(a)) STOP 2 + if (any(1+sum(eid(a),1)+ax+sum( & + neid3(a), & + 1)+1 /= 3*ax+2)) STOP 3 + if (any(1+eid(sum(a,2))+ay+ & + neid2( & + sum(a,2) & + )+1 /= 3*ay+2)) STOP 4 + if (any(sum(eid(sum(a,3))+az+2* & + neid2(az) & + ,1)+1 /= 4*sum(az,1)+1)) STOP 5 +contains + elemental function eid (x) + integer, intent(in) :: x + end function eid + function neid2 (x) + integer, intent(in) :: x(:,:) + integer :: neid2(size(x,1),size(x,2)) + neid2 = x + end function neid2 + function neid3 (x) + integer, intent(in) :: x(:,:,:) + integer :: neid3(size(x,1),size(x,2),size(x,3)) + end function neid3 + elemental subroutine set (o, i) + integer, intent(in) :: i + integer, intent(out) :: o + end subroutine set + elemental subroutine tes (i, o) + integer, intent(in) :: i + integer, intent(out) :: o + end subroutine tes +end + + Index: Fortran/gfortran/regression/vect/no-vfa-pr32377.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/no-vfa-pr32377.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +subroutine s243(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) + +integer ntimes,ld,n,i,nl +real a(n),b(n),c(n),d(n),e(n),aa(ld,n),bb(ld,n),cc(ld,n) +real t1,t2,chksum,ctime,dtime,cs1d + b(:n-1)= b(:n-1)+(c(:n-1)+e(:n-1))*d(:n-1) + a(:n-1)= b(:n-1)+a(2:n)*d(:n-1) + return +end + +! { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" } } + Index: Fortran/gfortran/regression/vect/no-vfa-pr32457.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/no-vfa-pr32457.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +SUBROUTINE KEEL(RBOUND) + REAL, DIMENSION(0:100) :: RBOUND + DO N = 1, NP1 + RBOUND(N) = RBOUND(N-1) + 1 + END DO + DO N = 1, NS + WRITE (16,'(I5)') SRAD(N) + END DO +END SUBROUTINE KEEL + +! { dg-final { scan-tree-dump-times "vectorized 0 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/pr100981-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr100981-1.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-additional-options "-O3 -ftree-parallelize-loops=2 -fno-signed-zeros -fno-trapping-math" } +! { dg-additional-options "-march=armv8.3-a" { target aarch64*-*-* } } + +complex function cdcdot(n, cx) + implicit none + + integer :: n, i, kx + complex :: cx(*) + double precision :: dsdotr, dsdoti, dt1, dt3 + + kx = 1 + do i = 1, n + dt1 = real(cx(kx)) + dt3 = aimag(cx(kx)) + dsdotr = dsdotr + dt1 * 2 - dt3 * 2 + dsdoti = dsdoti + dt1 * 2 + dt3 * 2 + kx = kx + 1 + end do + cdcdot = cmplx(real(dsdotr), real(dsdoti)) + return +end function cdcdot Index: Fortran/gfortran/regression/vect/pr106253.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr106253.f @@ -0,0 +1,35 @@ +! { dg-do compile } + + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, & + & BETA, Y, INCY ) + LOGICAL LSAME + IF ( .NOT.LSAME( TRANS, 'N' ).AND. & + & .NOT.LSAME( TRANS, 'C' ) )THEN + END IF + END + subroutine evlrnf (ptrs0t, nclsm, prnf0t) + real, dimension (1:nclsm,1:nclsm), intent (in) :: ptrs0t + real, dimension (1:nclsm,1:nclsm), intent (out):: prnf0t + real, allocatable, dimension (:,:) :: utrsft ! probas up + real, allocatable, dimension (:,:) :: dtrsft ! probas down + real, allocatable, dimension (:,:) :: xwrkt ! matrice + do icls = 1, nclsm + do ival = ipic - 1, 1, -1 + xwrkt = trs2a2 (ival, ipic, utrsft, dtrsft, ncls) + enddo + enddo + contains + function trs2a2 (j, k, u, d, m) + real, dimension (1:m,1:m) :: trs2a2 ! resultat + real, dimension (1:m,1:m) :: u, d ! matrices utrsft, dtrsft + end function trs2a2 + end + program rnflow + integer, parameter :: ncls = 256 ! nombre de classes + integer, dimension (1:ncls,1:ncls) :: mrnftt ! matrice theorique + real, dimension (1:ncls,1:ncls) :: ptrst ! matrice Markov + real, dimension (1:ncls,1:ncls) :: prnft ! matrice Rainflow + call evlrnf (ptrst, ncls, prnft) + mrnftt = nint (real (nsim) * real (npic) * prnft) + call cmpmat (mrnftt, mrnfst) + end program rnflow Index: Fortran/gfortran/regression/vect/pr107254.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr107254.f90 @@ -0,0 +1,49 @@ +! { dg-do run } + +subroutine dlartg( f, g, s, r ) + implicit none + double precision :: f, g, r, s + double precision :: d, p + + d = sqrt( f*f + g*g ) + p = 1.d0 / d + if( abs( f ) > 1 ) then + s = g*sign( p, f ) + r = sign( d, f ) + else + s = g*sign( p, f ) + r = sign( d, f ) + end if +end subroutine + +subroutine dhgeqz( n, h, t ) + implicit none + integer n + double precision h( n, * ), t( n, * ) + integer jc + double precision c, s, temp, temp2, tempr + temp2 = 10d0 + call dlartg( 10d0, temp2, s, tempr ) + c = 0.9d0 + s = 1.d0 + do jc = 1, n + temp = c*h( 1, jc ) + s*h( 2, jc ) + h( 2, jc ) = -s*h( 1, jc ) + c*h( 2, jc ) + h( 1, jc ) = temp + temp2 = c*t( 1, jc ) + s*t( 2, jc ) + t( 2, jc ) = -s*t( 1, jc ) + c*t( 2, jc ) + t( 1, jc ) = temp2 + enddo +end subroutine dhgeqz + +program test + implicit none + double precision h(2,2), t(2,2) + h = 0 + t(1,1) = 1 + t(2,1) = 0 + t(1,2) = 0 + t(2,2) = 0 + call dhgeqz( 2, h, t ) + if (t(2,2).ne.0) STOP 1 +end program test Index: Fortran/gfortran/regression/vect/pr108979.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr108979.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-additional-options "-fnon-call-exceptions" } +! { dg-additional-options "-march=armv8.2-a+sve" { target aarch64*-*-* } } + +MODULE hfx_contract_block + INTEGER, PARAMETER :: dp=8 +CONTAINS + SUBROUTINE block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) + REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(2*1), kac(2*2), pbd(1*1), & + pbc(1*2), pad(2*1), pac(2*2), prim(2*1*2*1), scale + DO md = 1,1 + DO mc = 1,2 + DO mb = 1,1 + DO ma = 1,2 + kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd + END DO + END DO + END DO + END DO + END SUBROUTINE block_2_1_2_1 +END MODULE hfx_contract_block Index: Fortran/gfortran/regression/vect/pr19049.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr19049.f90 @@ -0,0 +1,21 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +subroutine s111 (ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) +! linear dependence testing +! no dependence - vectorizable +! but not consecutive access + + integer ntimes, ld, n, i, nl + real a(n), b(n), c(n), d(n), e(n), aa(ld,n), bb(ld,n), cc(ld,n) + real t1, t2, second, chksum, ctime, dtime, cs1d + do 1 nl = 1,2*ntimes + do 10 i = 2,n,2 + a(i) = a(i-1) + b(i) + 10 continue + call dummy(ld,n,a,b,c,d,e,aa,bb,cc,1.) + 1 continue + return + end + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/pr32377.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr32377.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +subroutine s243(ntimes,ld,n,ctime,dtime,a,b,c,d,e,aa,bb,cc) + + integer ntimes,ld,n,i,nl + real a(n),b(n),c(n),d(n),e(n),aa(ld,n),bb(ld,n),cc(ld,n) + real t1,t2,chksum,ctime,dtime,cs1d + b(:n-1)= b(:n-1)+(c(:n-1)+e(:n-1))*d(:n-1) + a(:n-1)= b(:n-1)+a(2:n)*d(:n-1) + return +end subroutine s243 + +! { dg-final { scan-tree-dump-times "vectorized 2 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/pr32380.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr32380.f @@ -0,0 +1,264 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "-O3 -fcray-pointer" } +! PR 32380 - loops were not vectorized due to unaligned store. + subroutine trnfbt(e,f,qs,mte,gm,ihgenf,hgener,lft,llt,sthick, + . fibl,istupd,ies,hoff) + parameter (nlq=96) + integer nnlq + common/newnlq/nnlq +c ... implicit common ... + integer imauto,iteopt,lauto,mthsol,ilimit,maxref,icnvrg, + & igdiv,nwebuf,neql,neqt,imterm,imphas,nbfgs, + & numupd,istif,itrlas,imerr,imdof,neqtgl,lsmtd,lsdir + common/bki01i/imauto,iteopt,lauto,mthsol,ilimit,maxref,icnvrg, + & igdiv,nwebuf,neql,neqt,imterm,imphas,nbfgs, + & numupd,istif,itrlas,imerr,imdof,neqtgl,lsmtd,lsdir + REAL dtimp,dtimp0,timeim,dtmnim,dtmxim,cvtl,ectl,rctl, + & tolls,dnorm2,dtprnt,dtplot,dtiter,dtrefm + common/bki01r/dtimp,dtimp0,timeim,dtmnim,dtmxim,cvtl,ectl,rctl, + & tolls,dnorm2,dtprnt(2),dtplot(2),dtiter(2),dtrefm(2) + REAL ascntl + common/bki02r/ascntl(150) + logical lsensw + common/bki01l/lsensw(20) + integer imip,isolvr,icwrb + common/bki02i/imip(100),isolvr(200),icwrb(50) +c ... implicit common ... +c +c +c + integer lnodim,ndofpn,nnpke,melemt,imlft,imllt,is17loc + common/bki03iloc/lnodim(nlq,16),ndofpn,nnpke,melemt,imlft,imllt, + & is17loc + real*4 ske + common/bki03rloc/ske(nlq,1176) + integer lmke + common/bki04iloc/lmke(nlq,48) +c****************************************************************** +c| livermore software technology corporation (lstc) | +c| ------------------------------------------------------------ | +c| copyright 1987,1988,1989 john o. hallquist, lstc | +c| all rights reserved | +c****************************************************************** +c +c +c +c +c +c +c +c +c +c +c +c +c +c +c +c +c + common/bk12loc/b12,b2,qhg,qhgm,qhgb,qhgw + common/aux00loc/ + & sig1m(nlq),sig2m(nlq),sig4m(nlq),sig1n(nlq),sig2n(nlq), + & sig4n(nlq),sig5n(nlq),sig6n(nlq),sig5l(nlq),sig6l(nlq), + & str33(nlq),enginc(nlq) + common/aux01loc/ + &ft11(nlq),ft12(nlq),ft13(nlq),ft21(nlq),ft22(nlq),ft23(nlq), + &fm11(nlq),fm12(nlq),fm21(nlq),fm22(nlq), + &fm31(nlq),fm32(nlq),fm41(nlq),fm42(nlq), + &fmr11(nlq),fmr12(nlq),fmr21(nlq),fmr22(nlq),fmr31(nlq), + &fmr32(nlq),fmr41(nlq),fmr42(nlq),sg5(nlq),sg6(nlq) + common/aux7loc/ + 1 vx1(nlq),vx2(nlq),vx3(nlq),vx4(nlq), + 2 vx5(nlq),vx6(nlq),vx7(nlq),vx8(nlq), + 3 vy1(nlq),vy2(nlq),vy3(nlq),vy4(nlq), + 4 vy5(nlq),vy6(nlq),vy7(nlq),vy8(nlq), + 5 vz1(nlq),vz2(nlq),vz3(nlq),vz4(nlq), + 6 vz5(nlq),vz6(nlq),vz7(nlq),vz8(nlq) + common/aux10loc/area(nlq), + 1 px1(nlq),px2(nlq),px3(nlq),px4(nlq), + & px5(nlq),px6(nlq),px7(nlq),px8(nlq), + 2 py1(nlq),py2(nlq),py3(nlq),py4(nlq), + & py5(nlq),py6(nlq),py7(nlq),py8(nlq), + 3 pz1(nlq),pz2(nlq),pz3(nlq),pz4(nlq), + & pz5(nlq),pz6(nlq),pz7(nlq),pz8(nlq), + 4 dx1(nlq),dx2(nlq),dx3(nlq),dx4(nlq), + 5 dx5(nlq),dx6(nlq),dx7(nlq),dx8(nlq), + 6 dy1(nlq),dy2(nlq),dy3(nlq),dy4(nlq), + 7 dy5(nlq),dy6(nlq),dy7(nlq),dy8(nlq), + 8 dz1(nlq),dz2(nlq),dz3(nlq),dz4(nlq), + 9 dz5(nlq),dz6(nlq),dz7(nlq),dz8(nlq) + common/aux11loc/ + &ft31(nlq),ft32(nlq),ft33(nlq),ft41(nlq),ft42(nlq),ft43(nlq), + &htx(nlq),hty(nlq),gm1(nlq),gm2(nlq),gm3(nlq),gm4(nlq), + &bsum(nlq),qhx(nlq),qhy(nlq),qwz(nlq),qtx(nlq),qty(nlq) + real*4 mx1,my1,mz1,mx2,my2,mz2,mx3,my3,mz3,mx4,my4,mz4 + common/aux13loc/ + &zeta(nlq),thick(nlq),fga(nlq),fgb(nlq),fgc(nlq), + &gl11(nlq),gl12(nlq),gl13(nlq),gl21(nlq),gl22(nlq),gl23(nlq), + &gl31(nlq),gl32(nlq),gl33(nlq), + &x1(nlq),y1(nlq),z1(nlq),x2(nlq),y2(nlq),z2(nlq), + &x3(nlq),y3(nlq),z3(nlq),x4(nlq),y4(nlq),z4(nlq), + &fx1(nlq),fy1(nlq),fz1(nlq),fx2(nlq),fy2(nlq),fz2(nlq), + &fx3(nlq),fy3(nlq),fz3(nlq),fx4(nlq),fy4(nlq),fz4(nlq), + &mx1(nlq),my1(nlq),mz1(nlq),mx2(nlq),my2(nlq),mz2(nlq), + &mx3(nlq),my3(nlq),mz3(nlq),mx4(nlq),my4(nlq),mz4(nlq) + common/aux33loc/ + 1 ix1(nlq),ix2(nlq),ix3(nlq),ix4(nlq),ixs(nlq,4),mxt(nlq) + common/aux35loc/rhoa(nlq),cxx(nlq),fcl(nlq),fcq(nlq) + common/hourgloc/ymod(nlq),gmod(nlq),ifsv(nlq) + common/soundloc/sndspd(nlq),sndsp(nlq),diagm(nlq),sarea(nlq), + . dxl(nlq) + common/bel6loc/bm(nlq,3,8),bb(nlq,3,8),bs(nlq,2,12),bhg(nlq,4), + 1 ex(nlq,3,8),dp0(nlq,3,3),dp1(nlq,3,3),dp2(nlq,3,3), + 2 ds(nlq),dhg(nlq,5) +c + common/shlioc/ioshl(60) + common/failuloc/sieu(nlq),fail(nlq),ifaili(nlq) + logical output,slnew + common/csforc/ncs1,ncs2,ncs3,ncs4,ncs5,ncs6,ncs7,ncs8,ncs9, + 1 ncs10,ncs11,ncs12,ncs13,ncs14,ncs15, + 1 numcsd,csdinc,csdout,output,slnew,future(8) + common/csfsavloc/savfrc(nlq,24),svfail(nlq),ndof,ifail + common/sorterloc/nnc,lczc + common/sorter/znnc,zlczc, + & ns11,ns12,ns13,ns14,ns15,ns16, + & nh11,nh12,nh13,nh14,nh15,nh16, + & nt11,nt12,nt13,nt14,nt15,nt16, + & nb11,nb12,nb13,nb14,nb15,nb16, + & nu11,nu12,nu13,nu14,nu15,nu16, + & nd11,nd12,nd13,nd14,nd15,nd16 + common/subtssloc/dt1siz(nlq) + common/matflr/mtfail(200) + common/berwcmloc/xll(nlq),rigx(nlq),rigy(nlq) + common /mem/ mp + integer ia(1) + pointer(mp,ia) + real*4 mmode,ies + dimension e(3,1),f(3,1),qs(9,1),gm(4,*),hgener(*) + dimension qs1(nlq),qs2(nlq),qs3(nlq),qs4(nlq),qs5(nlq) + dimension fibl(9,1),sthick(*),ies(*),hoff(*) +c + ifail=0 + if (qhgb+qhgw+qhgm.gt.1.e-04) then + tmode=qhgb*ymod(lft)/1920.0 + wmode=qhgw*gmod(lft)/120.00 + mmode=qhgm*ymod(lft)/80.000 +c + hgfac=rhoa(lft)*sndspd(lft) +c + do i=lft,llt + htxi =area(i)*(x3(i)-x2(i)-x4(i)) + htyi =area(i)*(y3(i)-y2(i)-y4(i)) + gm1(i)= 1.-px1(i)*htxi-py1(i)*htyi + gm2(i)=-1.-px2(i)*htxi-py2(i)*htyi + gm3(i)= 2.-gm1(i) + gm4(i)=-2.-gm2(i) + qhx(i)=gm2(i)*vx2(i)+gm3(i)*vx3(i)+gm4(i)*vx4(i) + qhy(i)=gm2(i)*vy2(i)+gm3(i)*vy3(i)+gm4(i)*vy4(i) + qwz(i)=gm2(i)*vz2(i)+gm3(i)*vz3(i)+gm4(i)*vz4(i) + enddo + do i=lft,llt + c3= sqrt(abs(sarea(i)))*thick(i)/(dt1siz(i)+1.e-16) + c2=(hgfac*qhgw)*c3 + c1=(hgfac*qhgb*.01)*c3*thick(i)*thick(i) + c3=(hgfac*qhgm)*c3 + qtx(i)=gm2(i)*vx6(i)+gm3(i)*vx7(i)+gm4(i)*vx8(i) + qty(i)=gm2(i)*vy6(i)+gm3(i)*vy7(i)+gm4(i)*vy8(i) + xll2 =2.*xll(i) + qhxi =qhx(i)+xll2*rigy(i) + qhyi =qhy(i)-xll2*rigx(i) + qs1(i)=c3*qhxi + qs2(i)=c3*qhyi + qs3(i)=c2*qwz(i) + qs4(i)=c1*qtx(i) + qs5(i)=c1*qty(i) + enddo +c +c +c + if (isolvr(18).eq.0) then +c + do i=lft,llt + fm11(i)= fm11(i)+gm1(i)*qs4(i) + fm12(i)= fm12(i)+gm1(i)*qs5(i) + fm21(i)= fm21(i)+gm2(i)*qs4(i) + fm22(i)= fm22(i)+gm2(i)*qs5(i) + fm31(i)= fm31(i)+gm3(i)*qs4(i) + fm32(i)= fm32(i)+gm3(i)*qs5(i) + fm41(i)= fm41(i)+gm4(i)*qs4(i) + fm42(i)= fm42(i)+gm4(i)*qs5(i) + enddo +C + else +c + do 45 i=lft,llt + ft31(i)=-ft11(i)+gm3(i)*qs1(i) + ft32(i)=-ft12(i)+gm3(i)*qs2(i) + ft33(i)=-ft13(i)+gm3(i)*qs3(i) + ft41(i)=-ft21(i)+gm4(i)*qs1(i) + ft42(i)=-ft22(i)+gm4(i)*qs2(i) + ft43(i)=-ft23(i)+gm4(i)*qs3(i) + ft11(i)= ft11(i)+gm1(i)*qs1(i) + ft12(i)= ft12(i)+gm1(i)*qs2(i) + ft13(i)= ft13(i)+gm1(i)*qs3(i) + ft21(i)= ft21(i)+gm2(i)*qs1(i) + ft22(i)= ft22(i)+gm2(i)*qs2(i) + ft23(i)= ft23(i)+gm2(i)*qs3(i) + fm11(i)= fm11(i)+gm1(i)*qs4(i) + fm12(i)= fm12(i)+gm1(i)*qs5(i) + fm21(i)= fm21(i)+gm2(i)*qs4(i) + fm22(i)= fm22(i)+gm2(i)*qs5(i) + fm31(i)= fm31(i)+gm3(i)*qs4(i) + fm32(i)= fm32(i)+gm3(i)*qs5(i) + fm41(i)= fm41(i)+gm4(i)*qs4(i) + fm42(i)= fm42(i)+gm4(i)*qs5(i) + 45 continue + endif +c + else +c + do 40 i=lft,llt + ft31(i)=-ft11(i) + ft32(i)=-ft12(i) + ft33(i)=-ft13(i) + ft41(i)=-ft21(i) + ft42(i)=-ft22(i) + ft43(i)=-ft23(i) + 40 continue + endif +c +c + do i=lft,llt + mz1(i)=gl31(i)*fm11(i)+gl32(i)*fm12(i) + mz2(i)=gl31(i)*fm21(i)+gl32(i)*fm22(i) + fz1(i)=gl31(i)*ft11(i)+gl32(i)*ft12(i)+gl33(i)*ft13(i) + fz2(i)=gl31(i)*ft21(i)+gl32(i)*ft22(i)+gl33(i)*ft23(i) + mz3(i)=gl31(i)*fm31(i)+gl32(i)*fm32(i) + mz4(i)=gl31(i)*fm41(i)+gl32(i)*fm42(i) + fz3(i)=gl31(i)*ft31(i)+gl32(i)*ft32(i)+gl33(i)*ft33(i) + fz4(i)=gl31(i)*ft41(i)+gl32(i)*ft42(i)+gl33(i)*ft43(i) + enddo + 90 continue +c + if (output) then + do i=lft,llt + savfrc(i, 1)= fx1(i) + savfrc(i, 2)= fy1(i) + enddo +c + ndof=4 + if (ifail.eq.1) then + do i=lft,llt + svfail(i)=fail(i) + enddo + endif + endif +c + return + end + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target { ! vect_element_align } } } } +! { dg-final { scan-tree-dump-times "vectorized 5 loops" 1 "vect" { target { vect_element_align && { ! vect_call_sqrtf } } } } } +! { dg-final { scan-tree-dump-times "vectorized 6 loops" 1 "vect" { target { vect_element_align && vect_call_sqrtf } } } } Index: Fortran/gfortran/regression/vect/pr33301.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr33301.f @@ -0,0 +1,13 @@ +c { dg-do compile } +C Derived from lapack + SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, + $ WORK, RWORK, INFO ) + COMPLEX(kind=8) WORK( * ) +c Following declaration added on transfer to gfortran testsuite. +c It is present in original lapack source + integer rank + DO 20 I = 1, RANK + WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) + 20 CONTINUE + END + Index: Fortran/gfortran/regression/vect/pr39318.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr39318.f90 @@ -0,0 +1,20 @@ +! { dg-do compile { target fopenmp } } +! { dg-additional-options "-fopenmp -fexceptions" } + + subroutine adw_trajsp (F_u,i0,in,j0,jn) + implicit none + real F_u(*) + integer i0,in,j0,jn + integer n,i,j + real*8 xsin(i0:in,j0:jn) +!$omp parallel do private(xsin) + do j=j0,jn + do i=i0,in + xsin(i,j) = sqrt(F_u(n)) + end do + end do +!$omp end parallel do + return + end + + Index: Fortran/gfortran/regression/vect/pr45714-a.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr45714-a.f @@ -0,0 +1,26 @@ +! { dg-do compile { target i?86-*-* x86_64-*-* } } +! { dg-additional-options "-O3 -march=core2 -mavx -ffast-math -mveclibabi=svml" } + + integer index(18),i,j,k,l,ipiv(18),info,ichange,neq,lda,ldb, + & nrhs,iplas + real*8 ep0(6),al10(18),al20(18),dg0(18),ep(6),al1(18), + & al2(18),dg(18),ddg(18),xm(6,18),h(18,18),ck(18),cn(18), + & c(18),d(18),phi(18),delta(18),r0(18),q(18),b(18),cphi(18), + & q1(18),q2(18),stri(6),htri(18),sg(18),r(42),xmc(6,18),aux(18), + & t(42),gl(18,18),gr(18,18),ee(6),c1111,c1122,c1212,dd, + & skl(3,3),xmtran(3,3),ddsdde(6,6),xx(6,18) + do + do i=1,18 + htri(i)=dabs(sg(i))-r0(i)-ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) + do j=1,18 + enddo + enddo + do + if(i.ne.j) then + gr(index(i),1)=htri(i) + endif + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + enddo + enddo + end + Index: Fortran/gfortran/regression/vect/pr45714-b.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr45714-b.f @@ -0,0 +1,26 @@ +! { dg-do compile { target powerpc*-*-* } } +! { dg-additional-options "-O3 -mcpu=power7 -mno-power9-vector -mno-power8-vector -ffast-math -mveclibabi=mass" } + + integer index(18),i,j,k,l,ipiv(18),info,ichange,neq,lda,ldb, + & nrhs,iplas + real*8 ep0(6),al10(18),al20(18),dg0(18),ep(6),al1(18), + & al2(18),dg(18),ddg(18),xm(6,18),h(18,18),ck(18),cn(18), + & c(18),d(18),phi(18),delta(18),r0(18),q(18),b(18),cphi(18), + & q1(18),q2(18),stri(6),htri(18),sg(18),r(42),xmc(6,18),aux(18), + & t(42),gl(18,18),gr(18,18),ee(6),c1111,c1122,c1212,dd, + & skl(3,3),xmtran(3,3),ddsdde(6,6),xx(6,18) + do + do i=1,18 + htri(i)=dabs(sg(i))-r0(i)-ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) + do j=1,18 + enddo + enddo + do + if(i.ne.j) then + gr(index(i),1)=htri(i) + endif + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + enddo + enddo + end + Index: Fortran/gfortran/regression/vect/pr46213.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr46213.f90 @@ -0,0 +1,24 @@ +! { dg-do compile } +! { dg-additional-options "-O -fno-tree-loop-ivcanon -fno-tree-ccp -fno-tree-ch -finline-small-functions" } + +module foo + INTEGER, PARAMETER :: ONE = 1 +end module foo +program test + use foo + integer :: a(ONE), b(ONE), c(ONE), d(ONE) + interface + function h_ext() + end function h_ext + end interface + c = j() + if (any (c .ne. check)) call myabort (7) +contains + function j() + integer :: j(ONE), cc(ONE) + j = cc - j + end function j + function get_d() + end function get_d +end program test + Index: Fortran/gfortran/regression/vect/pr48329.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr48329.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-require-effective-target vect_intfloat_cvt } +! { dg-additional-options "-ffast-math" } + +program calcpi + + implicit none + real(kind=4):: h,x,sum,pi + integer:: n,i + real(kind=4):: f + + f(x) = 4.0/(1.0+x**2) + + n = 2100000000 + + h= 1.0 / n + sum = 0.0 + DO i=1, n + x = h * (i-0.5) + sum = sum + f(x) + END DO + pi = h * sum + write(*,*) 'Pi=',pi + +end program calcpi + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/pr50178.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr50178.f90 @@ -0,0 +1,28 @@ +! { dg-do compile } + +module yemdyn + implicit none + integer, parameter :: jpim = selected_int_kind(9) + integer, parameter :: jprb = selected_real_kind(13,300) + real(kind=jprb) :: elx + real(kind=jprb), allocatable :: xkcoef(:) + integer(kind=jpim),allocatable :: ncpln(:), npne(:) +end module yemdyn + +subroutine suedyn + + use yemdyn + + implicit none + + integer(kind=jpim) :: jm, jn + real(kind=jprb) :: zjm, zjn, zxxx + + jn=0 + do jm=0,ncpln(jn) + zjm=real(jm,jprb) / elx + xkcoef(npne(jn)+jm) = - zxxx*(zjm**2)**0.5_jprb + end do + +end subroutine suedyn + Index: Fortran/gfortran/regression/vect/pr50412.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr50412.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } + + DOUBLE PRECISION AK,AI,AAE + COMMON/com/AK(36),AI(4,4),AAE(8,4),ii,jj + DO 20 II=1,4 + DO 21 JJ=1,4 + AK(n)=AK(n)-AAE(I,II)*AI(II,JJ) + 21 CONTINUE + 20 CONTINUE + END + Index: Fortran/gfortran/regression/vect/pr51058-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr51058-2.f90 @@ -0,0 +1,19 @@ +! PR tree-optimization/51058 +! { dg-do compile } +subroutine pr51058(n, u, v, w, z) + double precision :: x(3,-2:16384), y(3,-2:16384), b, u, v, w, z + integer :: i, n + common /c/ x, y + do i = 1, n + b = u * int(x(1,i)) + sign(z,x(1,i)) + x(1,i) = x(1,i) - b + y(1,i) = y(1,i) - b + b = v * int(x(2,i)) + sign(z,x(2,i)) + x(2,i) = x(2,i) - b + y(2,i) = y(2,i) - b + b = w * int(x(3,i)) + sign(z,x(3,i)) + x(3,i) = x(3,i) - b + y(3,i) = y(3,i) - b + end do +end subroutine + Index: Fortran/gfortran/regression/vect/pr51058.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr51058.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + + SUBROUTINE MLIST(MOLsp,PBCx,PBCy,PBCz, X0) + IMPLICIT NONE + INTEGER, PARAMETER :: NM=16384 + INTEGER :: MOLsp, i + REAL :: PBCx, PBCy, PBCz, boxjmp, HALf=1./2. + REAL :: X0(2,-2:NM) + + DO i = 1 , MOLsp + boxjmp = PBCx*INT(X0(1,i)+SIGN(HALf,X0(1,i))) + X0(1,i) = X0(1,i) - boxjmp + boxjmp = PBCy*INT(X0(2,i)+SIGN(HALf,X0(2,i))) + X0(2,i) = X0(2,i) - boxjmp + ENDDO + END + + Index: Fortran/gfortran/regression/vect/pr51285.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr51285.f90 @@ -0,0 +1,35 @@ +! { dg-do compile } + + SUBROUTINE smm_dnn_4_10_10_1_1_2_1(A,B,C) + REAL :: C(4,10), B(10,10), A(4,10) + DO j= 1 , 10 , 2 + DO i= 1 , 4 , 1 + DO l= 1 , 10 , 1 + C(i+0,j+0)=C(i+0,j+0)+A(i+0,l+0)*B(l+0,j+0) + C(i+0,j+1)=C(i+0,j+1)+A(i+0,l+0)*B(l+0,j+1) + ENDDO + ENDDO + ENDDO + END SUBROUTINE + SUBROUTINE smm_dnn_4_10_10_6_4_1_1(A,B,C) + REAL :: C(4,10), B(10,10), A(4,10) + DO l= 1 , 10 , 1 + DO j= 1 , 10 , 1 + C(i+0,j+0)=C(i+0,j+0)+A(i+0,l+0)*B(l+0,j+0) + ENDDO + ENDDO + END SUBROUTINE + SUBROUTINE S(A,B,C) + INTEGER :: Nmin=2,Niter=100 + REAL, DIMENSION(:,:), ALLOCATABLE :: A,B,C + DO imin=1,Nmin + DO i=1,Niter + CALL smm_dnn_4_10_10_1_1_2_1(A,B,C) + ENDDO + DO i=1,Niter + CALL smm_dnn_4_10_10_6_4_1_1(A,B,C) + ENDDO + CALL foo() + ENDDO + END SUBROUTINE + Index: Fortran/gfortran/regression/vect/pr52580.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr52580.f @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-additional-options "-std=legacy" } +! { dg-require-effective-target vect_double } + SUBROUTINE CALC2 + IMPLICIT REAL*8 (A-H, O-Z) + PARAMETER (N1=1335, N2=1335) + + COMMON U(N1,N2), V(N1,N2), P(N1,N2), + * UNEW(N1,N2), VNEW(N1,N2), + 1 PNEW(N1,N2), UOLD(N1,N2), + * VOLD(N1,N2), POLD(N1,N2), + 2 CU(N1,N2), CV(N1,N2), + * Z(N1,N2), H(N1,N2), PSI(N1,N2) + COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1, + 1 NP1,EL,PI,TPI,DI,DJ,PCF + TDTS8 = TDT/8.D0 + TDTSDX = TDT/DX + TDTSDY = TDT/DY + + DO 200 J=1,N + DO 200 I=1,M + UNEW(I+1,J) = UOLD(I+1,J)+ + 1 TDTS8*(Z(I+1,J+1)+Z(I+1,J))*(CV(I+1,J+1)+CV(I,J+1)+CV(I,J) + 2 +CV(I+1,J))-TDTSDX*(H(I+1,J)-H(I,J)) + VNEW(I,J+1) = VOLD(I,J+1)-TDTS8*(Z(I+1,J+1)+Z(I,J+1)) + 1 *(CU(I+1,J+1)+CU(I,J+1)+CU(I,J)+CU(I+1,J)) + 2 -TDTSDY*(H(I,J+1)-H(I,J)) + PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J)) + 1 -TDTSDY*(CV(I,J+1)-CV(I,J)) + 200 CONTINUE + RETURN + END +! { dg-final { scan-tree-dump-times "LOOP VECTORIZED" 1 "vect" } } Index: Fortran/gfortran/regression/vect/pr60510.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr60510.f @@ -0,0 +1,31 @@ +! { dg-do run } +! { dg-require-effective-target vect_double } +! { dg-require-effective-target vect_intdouble_cvt } +! { dg-additional-options "-fno-inline -ffast-math" } + subroutine foo(a,x,y,n) + implicit none + integer n,i + + real*8 y(n),x(n),a + + do i=1,n + a=a+x(i)*y(i)+x(i) + enddo + + return + end + + program test + real*8 x(1024),y(1024),a + do i=1,1024 + x(i) = i + y(i) = i+1 + enddo + call foo(a,x,y,1024) + if (a.ne.359488000.0) STOP 1 + end +! If there's no longer a reduction chain detected this doesn't test what +! it was supposed to test, vectorizing a reduction chain w/o SLP. +! { dg-final { scan-tree-dump "reduction chain" "vect" } } +! We should vectorize the reduction in foo and the induction in test. +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 2 "vect" } } Index: Fortran/gfortran/regression/vect/pr61171.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr61171.f @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast" } + SUBROUTINE GAUBON(NV,PTS,PP) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + PARAMETER (MXSP=250) + DIMENSION PTS(3,10),PP(3) + COMMON /PCMPLY/ XE(MXSP),YE(MXSP),ZE(MXSP) + DATA PI/3.141592653589793D+00/ + DATA ZERO/0.0D+00/ + DO I = 1, NV + PP(1) = PP(1) + (PTS(1,I)-XE(NS)) + PP(2) = PP(2) + (PTS(2,I)-YE(NS)) + PP(3) = PP(3) + (PTS(3,I)-ZE(NS)) + ENDDO + END Index: Fortran/gfortran/regression/vect/pr62283-2.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr62283-2.f @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "-fdump-tree-slp2-details" } + subroutine saxpy(alpha,x,y) + real x(4),y(4),alpha + y(1)=y(1)+alpha*x(1) + y(2)=y(2)+alpha*x(2) + y(3)=y(3)+alpha*x(3) + y(4)=y(4)+alpha*x(4) + end +! { dg-final { scan-tree-dump "optimized: basic block" "slp2" } } Index: Fortran/gfortran/regression/vect/pr62283.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr62283.f @@ -0,0 +1,16 @@ +C { dg-do compile } +C { dg-additional-options "-fvect-cost-model=dynamic -fno-ipa-icf" } + subroutine test2(x,y) + real x(4),y(4) + beta=3.141593 + do i=1,4 + y(i)=y(i)+beta*x(i) + end do + end + + subroutine test3(x,y) + real x(4),y(4) + beta=3.141593 + y=y+beta*x + end +C { dg-final { scan-tree-dump-times "vectorized 1 loops" 2 "vect" { target { vect_hw_misalign } } } } Index: Fortran/gfortran/regression/vect/pr69466.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr69466.f90 @@ -0,0 +1,42 @@ +! { dg-do compile } +! { dg-additional-options "-march=core-avx2" { target x86_64-*-* i?86-*-* } } + + subroutine foo + + integer :: a, b, c, d, e + + integer, dimension(:), allocatable :: f, g, h + + call zoo (a) + call zoo (b) + call zoo (c) + + if(a == b) then + allocate(g(0:d-1), h(0:d-1)) + else + allocate(g(1), h(1)) + if (b /= 0) then + call zoo(b) + endif + endif + + if(a == b) then + do d=0,c-1 + e = e + g(d) + if(d == 0) then + h(d) = 0 + else + h(d) = h(d-1) + g(d-1) + endif + end do + endif + + if(a == b) then + allocate(f(e), g(e)) + endif + + if(a == 0) then + call boo(e) + endif + + end subroutine foo Index: Fortran/gfortran/regression/vect/pr69882.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr69882.f90 @@ -0,0 +1,41 @@ +! { dg-additional-options "-Ofast" } +! { dg-additional-options "-mavx" { target avx_runtime } } + +subroutine foo(a, x) + implicit none + + integer, parameter :: XX=4, YY=26 + integer, intent(in) :: x + real *8, intent(in) :: a(XX,YY) + real *8 :: c(XX) + + integer i, k + + c = 0 + + do k=x,YY + do i=1,2 + c(i) = max(c(i), a(i,k)) + end do + end do + + PRINT *, "c=", c + + IF (c(1) .gt. 0.0) THEN + STOP 1 + END IF + + IF (c(2) .gt. 0.0) THEN + STOP 2 + END IF +end subroutine foo + +PROGRAM MAIN + real *8 a(4, 26) + + a = 0 + a(3,1) = 100.0 + a(4,1) = 100.0 + + CALL FOO(a, 1) +END PROGRAM Index: Fortran/gfortran/regression/vect/pr69980.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr69980.f90 @@ -0,0 +1,39 @@ +! { dg-additional-options "-Ofast -fno-inline" } + +subroutine check (a, b) + real *8, intent(in) :: a(4), b(4) + + IF (abs(a(1)-b(1)) > 1) THEN + STOP 1 + END IF +end subroutine check + +program main + real *8 :: mu(4,26), mumax(4), mumax2(4) + + integer :: i, k + + do k=1,26 + do i=1,4 + mu(i, k) = 4*(i-1) + k + end do + end do + + mumax = 0; + do k=1,26 + do i=1,3 + mumax(i) = max(mumax(i), mu(i,k)+mu(i,k)) + end do + end do + + mumax2 = 0; + do i=1,3 + do k=1,26 + mumax2(i) = max(mumax2(i), mu(i,k)+mu(i,k)) + end do + end do + + CALL check (mumax, mumax2) + + return +end program Index: Fortran/gfortran/regression/vect/pr70043.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr70043.f90 @@ -0,0 +1,16 @@ +! PR tree-optimization/70043 +! { dg-do compile } +! { dg-additional-options "-Ofast -g" } +! { dg-additional-options "-march=haswell" { target i?86-*-* x86_64-*-* } } + +subroutine fn1(a, b) + real(8), intent(in) :: b(100) + real(8), intent(inout) :: a(100) + real(8) c + do i=1,100 + if( a(i) < 0.0 ) then + c = a(i) * b(i) + a(i) = a(i) - c / b(i) + endif + enddo +end subroutine fn1 Index: Fortran/gfortran/regression/vect/pr77848.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr77848.f @@ -0,0 +1,25 @@ +! PR 77848: Verify versioning is on when vectorization fails +! { dg-do compile } +! { dg-options "-O3 -ffast-math -fdump-tree-ifcvt -fdump-tree-vect-details" } +! { dg-additional-options "-mzarch" { target { s390*-*-* } } } + + subroutine sub(x,a,n,m) + implicit none + real*8 x(*),a(*),atemp + integer i,j,k,m,n + real*8 s,t,u,v + do j=1,m + atemp=0.d0 + do i=1,n + if (abs(a(i)).gt.atemp) then + atemp=a(i) + k = i + end if + enddo + call dummy(atemp,k) + enddo + return + end + +! { dg-final { scan-tree-dump "LOOP_VECTORIZED" "ifcvt" } } +! { dg-final { scan-tree-dump "vectorized 0 loops in function" "vect" } } Index: Fortran/gfortran/regression/vect/pr81303.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr81303.f @@ -0,0 +1,50 @@ +! { dg-do compile } +! { dg-require-effective-target vect_cond_mixed } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-O3 -ffast-math -floop-interchange -fdump-tree-linterchange-details" } +! vect_cond_mixed lies on x86, we cannot do vcond[_eq]v2div2df +! { dg-additional-options "-msse4.1" { target { x86_64-*-* i?86-*-* } } } + + subroutine mat_times_vec(y,x,a,axp,ayp,azp,axm,aym,azm, + $ nb,nx,ny,nz) + implicit none + integer nb,nx,ny,nz,i,j,k,m,l,kit,im1,ip1,jm1,jp1,km1,kp1 + + real*8 y(nb,nx,ny,nz),x(nb,nx,ny,nz) + + real*8 a(nb,nb,nx,ny,nz), + 1 axp(nb,nb,nx,ny,nz),ayp(nb,nb,nx,ny,nz),azp(nb,nb,nx,ny,nz), + 2 axm(nb,nb,nx,ny,nz),aym(nb,nb,nx,ny,nz),azm(nb,nb,nx,ny,nz) + + + do k=1,nz + km1=mod(k+nz-2,nz)+1 + kp1=mod(k,nz)+1 + do j=1,ny + jm1=mod(j+ny-2,ny)+1 + jp1=mod(j,ny)+1 + do i=1,nx + im1=mod(i+nx-2,nx)+1 + ip1=mod(i,nx)+1 + do l=1,nb + y(l,i,j,k)=0.0d0 + do m=1,nb + y(l,i,j,k)=y(l,i,j,k)+ + 1 a(l,m,i,j,k)*x(m,i,j,k)+ + 2 axp(l,m,i,j,k)*x(m,ip1,j,k)+ + 3 ayp(l,m,i,j,k)*x(m,i,jp1,k)+ + 4 azp(l,m,i,j,k)*x(m,i,j,kp1)+ + 5 axm(l,m,i,j,k)*x(m,im1,j,k)+ + 6 aym(l,m,i,j,k)*x(m,i,jm1,k)+ + 7 azm(l,m,i,j,k)*x(m,i,j,km1) + enddo + enddo + enddo + enddo + enddo + return + end + +! verify we can vectorize the inner loop after interchange +! { dg-final { scan-tree-dump-times "is interchanged" 1 "linterchange" } } +! { dg-final { scan-tree-dump "vectorized 1 loops in function" "vect" } } Index: Fortran/gfortran/regression/vect/pr83232.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr83232.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-funroll-loops --param vect-max-peeling-for-alignment=0 -fdump-tree-slp-details" } + + SUBROUTINE MATERIAL_41_INTEGRATION ( STRESS,YLDC,EFPS, & + & DTnext,Dxx,Dyy,Dzz,Dxy,Dxz,Dyz,MatID,P1,P3 ) + REAL(KIND(0D0)), INTENT(INOUT) :: STRESS(6) + REAL(KIND(0D0)), INTENT(IN) :: DTnext + REAL(KIND(0D0)), INTENT(IN) :: Dxx,Dyy,Dzz,Dxy,Dxz,Dyz + REAL(KIND(0D0)) :: Einc(6) + REAL(KIND(0D0)) :: P1,P3 + + Einc(1) = DTnext * Dxx ! (1) + Einc(2) = DTnext * Dyy + Einc(3) = DTnext * Dzz + Einc(4) = DTnext * Dxy + Einc(5) = DTnext * Dxz + Einc(6) = DTnext * Dyz + DO i = 1,6 + STRESS(i) = STRESS(i) + P3*Einc(i) + ENDDO + STRESS(1) = STRESS(1) + (DTnext * P1 * (Dxx+Dyy+Dzz)) ! (2) + STRESS(2) = STRESS(2) + (DTnext * P1 * (Dxx+Dyy+Dzz)) + STRESS(3) = 0.0 + Einc(5) = 0.0 ! (3) + Einc(6) = 0.0 + call foo (Einc) + END SUBROUTINE + +! We should vectorize (1), (2) and (3) under vect_hw_misalign. +! { dg-final { scan-tree-dump-times "vectorizing stmts using SLP" 3 "slp1" { target vect_hw_misalign } } } +! But only (1) and (3) under !vect_hw_misalign due to the alignment of (2). +! { dg-final { scan-tree-dump-times "vectorizing stmts using SLP" 2 "slp1" { target { ! vect_hw_misalign } } } } Index: Fortran/gfortran/regression/vect/pr84913.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr84913.f90 @@ -0,0 +1,13 @@ +! { dg-do compile } + +function foo(a, b, c, n) + integer :: a(n), b(n), c(n), n, i, foo + foo = 0 + do i = 1, n + if (a(i) .eq. b(i)) then + foo = 1 + else if (a(i) .eq. c(i)) then + foo = 2 + end if + end do +end function foo Index: Fortran/gfortran/regression/vect/pr85853.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr85853.f90 @@ -0,0 +1,26 @@ +! Taken from execute/where_2.f90, but with special flags. +! { dg-do run } +! { dg-additional-options "-fno-tree-loop-vectorize" } + +! Program to test the WHERE constructs +program where_2 + integer temp(10), reduce(10) + + temp = 10 + reduce(1:3) = -1 + reduce(4:6) = 0 + reduce(7:8) = 5 + reduce(9:10) = 10 + + WHERE (reduce < 0) + temp = 100 + ELSE WHERE (reduce .EQ. 0) + temp = 200 + temp + ELSE WHERE + WHERE (reduce > 6) temp = temp + sum(reduce) + temp = 300 + temp + END WHERE + + if (any (temp .ne. (/100, 100, 100, 210, 210, 210, 310, 310, 337, 337/))) & + STOP 1 +end program Index: Fortran/gfortran/regression/vect/pr86421.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr86421.f90 @@ -0,0 +1,35 @@ +! PR fortran/86421 +! { dg-require-effective-target vect_simd_clones } +! { dg-additional-options "-fopenmp-simd" } +! { dg-additional-options "-mavx" { target avx_runtime } } + +module mod86421 + implicit none +contains + subroutine foo(x, y, z) + real :: x + integer :: y, z + !$omp declare simd linear(ref(x)) linear(val(y)) linear(uval(z)) + x = x + y + z = z + 1 + end subroutine +end module mod86421 + +program pr86421 + use mod86421 + implicit none + integer :: i, j + real :: a(64) + j = 0 + do i = 1, 64 + a(i) = i + end do + !$omp simd + do i = 1, 64 + call foo (a(i), i, j) + end do + do i = 1, 64 + if (a(i) .ne. (2 * i)) stop 1 + end do + if (j .ne. 64) stop 2 +end program pr86421 Index: Fortran/gfortran/regression/vect/pr89535.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr89535.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } + +subroutine foo(tmp1, tmp2, tmp3) + integer, parameter :: n = 100 + real :: tmp1(n,2), tmp2(n), tmp3(n) + integer :: i, c1, c2, c3 + logical :: cond + common c1, c2, c3 + + c2 = c3 + cond = c1 .eq. 1 .and. c3 .eq. 1 + do i = 1,100 + if (cond) tmp2(i) = tmp1(i,1) / tmp1(i,2) + end do + do i = 1,100 + if (cond) tmp3(i) = tmp2(i) + end do +end subroutine foo Index: Fortran/gfortran/regression/vect/pr90681.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr90681.f @@ -0,0 +1,13 @@ +C { dg-do compile } +C { dg-additional-options "-march=armv8.2-a+sve" { target { aarch64*-*-* } } } + SUBROUTINE HMU (H1) + COMMON DD(107) + DIMENSION H1(NORBS,*) + DO 70 J1 = IA,I1 + H1(I1,J1) = 0 + JO1 = J1 + IF (JO1.EQ.1) THEN + H1(I1,J1) = DD(NI) + END IF + 70 CONTINUE + END Index: Fortran/gfortran/regression/vect/pr90913.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr90913.f90 @@ -0,0 +1,22 @@ +! { dg-do compile } +! { dg-options "-O3 -ffast-math" } +! { dg-additional-options "-mavx -mveclibabi=svml" { target i?86-*-* x86_64-*-* } } +subroutine foo (a, b, c, d, e, f, g, h, k, l) + implicit none + integer :: d, e, f, g, i, j + real :: a, b(5,6), c(6), h(6,10,5), k(5,10,2), l(10,5), m, n, o + do i=1,5 + do j=1,6 + m=l(f,g)*log(c(j)) + if (m<2) then + if (m<-2) then + h(j,f,g)=n + else + h(j,f,g)=o + endif + endif + b(i,j)=a+k(i,d,e)+k(i,1,e)**h(j,f,g) + enddo + enddo + write(*,'()') +end Index: Fortran/gfortran/regression/vect/pr95403.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr95403.f @@ -0,0 +1,16 @@ +! { dg-do compile } + subroutine deuldlag(xi,et,ze,xlag,xeul,xj,xs) + real*8 shp(3,20),xs(3,3),xlag(3,20),xeul(3,20) + do i=1,3 + do j=1,3 + enddo + enddo + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,20 + xs(i,j)=xs(i,j)+xeul(i,k)*shp(j,k) + enddo + enddo + enddo + end Index: Fortran/gfortran/regression/vect/pr96920.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr96920.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } + subroutine ice(npoint, nterm, x, g) + implicit none + integer norder + parameter (norder=10) + integer j + integer k + integer ii + integer nterm + integer npoint + real b(norder) + real c(norder) + real d(norder) + real x(npoint) + real g(npoint) + real gg + real prev + real prev2 + + j = 1 + 100 continue + j = j+1 + if (nterm == j) then + do ii=1,npoint + k = nterm + gg= d(k) + prev= 0.0 + do k=k-1,1,-1 + prev2= prev + prev= gg + gg = d(k)+(x(ii)-b(k))*prev-c(k+1)*prev2 + enddo + g(ii) = gg + enddo + endif + go to 100 + end Index: Fortran/gfortran/regression/vect/pr97761.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr97761.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-additional-options "-O1" } + +subroutine ni (ps) + type vector + real x, y + end type + type quad_inductor + type (vector) v1, v2 + end type + type (quad_inductor), dimension(inout) :: ps + integer :: dl, nk = 1.0 + fo = 1.0 + if (f == 1) then + nk = 0.0 + fo = 0.0 + end if + ot = nk * 0.5 + gb = -fo * 0.5 + wu = fo * 0.5 + up = nk * 0.1 + xe = up * 0.1 + do lx = 0, 7 + ps%v2%y = -wu + ps(dl)%v1%x = xe + 1.0 + ps(dl)%v1%y = wu - tn + end do + do lx = 0, 7 + ps(dl)%v1%x = 0.1 - ot + ps(dl)%v1%y = 0.1 - wu + end do +end Index: Fortran/gfortran/regression/vect/pr99656.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99656.f90 @@ -0,0 +1,24 @@ +! { dg-do compile { target { aarch64*-*-* } } } +! { dg-require-effective-target le } +! { dg-additional-options "-march=armv8.3-a -O1 -ftree-slp-vectorize" } + +SUBROUTINE ZLAHQR2(H, LDH, H22, T1) + + INTEGER LDH + COMPLEX*16 H(LDH, *) + + INTEGER NR + COMPLEX*16 H22, SUM, T1, V2 + + COMPLEX*16 V( 3 ) + + EXTERNAL ZLARFG + INTRINSIC DCONJG + + V2 = H22 + CALL ZLARFG(T1) + SUM = DCONJG(T1) * H(1, 1) + H(1, 1) = SUM * V2 + + RETURN +END Index: Fortran/gfortran/regression/vect/pr99721.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99721.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-O3" } +! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } +subroutine sub_c + complex, dimension(2,3) :: at + complex, dimension(2,4) :: b + complex, dimension(3,4) :: c + data b / (41., 43.), 0, 0, 0, 0, 0, 0, 0/ + c = matmul(transpose(at), b) + if (any (c /= cres)) stop +end subroutine sub_c Index: Fortran/gfortran/regression/vect/pr99746.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99746.f90 @@ -0,0 +1,45 @@ +! { dg-do compile } +! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } +SUBROUTINE CLAREF(A, WANTZ, Z, ICOL1, ITMP1, ITMP2, T1, T2, V2) +LOGICAL BLOCK, WANTZ +COMPLEX T1, T2, V2 +COMPLEX A(LDA, *), VECS, Z(LDA, *) +COMPLEX SUM +LOGICAL LSAME +IF (LSAME) THEN + DO 30 K = ITMP1, ITMP2, 3 + T1 = VECS0 +30 CONTINUE +ELSE + IF (BLOCK) THEN + DO 90 K = ITMP1, ITMP2 - 1, 3 + A(J, ICOL1) = ITMP1 + IF (WANTZ) THEN + DO 80 J = ITMP1, ITMP2 + SUM = ICOL1 + Z(J, 3) = V23 +80 CONTINUE + END IF +90 CONTINUE + DO 120 K = ITMP1, ITMP2 + V2 = VECS() + DO 100 J = ITMP1, ITMP2 + A(J, ICOL1) = A(J, ICOL1) - SUM +100 CONTINUE + IF (WANTZ) THEN + DO 110 J = 1, 3 + SUM = Z(J, ICOL1) + Z(J, ICOL1) = 0 +110 CONTINUE + END IF + ICOL1 = ICOL1 + 1 +120 CONTINUE + ELSE + DO 130 J = ITMP1, ITMP2 + SUM = T1 * A(J, ICOL1) + T2 * A(J, 1) + V2 * A(J, 2) + A(J, ICOL1) = SUM + A(J, ICOL1 + 2) = SUM * V1 +130 CONTINUE + END IF +END IF +END Index: Fortran/gfortran/regression/vect/pr99807.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99807.f90 @@ -0,0 +1,11 @@ +! { dg-do compile } +! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } + +subroutine cppco(ap, z) + implicit none + complex :: ap(*), z(*) + + z(1) = z(1) + z(2) * (ap(1)) + + return +end subroutine cppco Index: Fortran/gfortran/regression/vect/pr99825.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99825.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-additional-options "-march=armv8.3-a -O3" { target { aarch64*-*-* } } } + +program main + complex, dimension(3, 2) :: a + complex, dimension(2, 4) :: b + complex, dimension(3, 4) :: c, res1 + + data a /0, (-5., -7.), (11., -13.), 0, 0, 0/ + data b /0, 0, 0, 0, 0, 0, 0, 0/ + data res1 /0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + + c = matmul(a, conjg(b)) + if (any(res1 /= c)) stop 2 +end program main Index: Fortran/gfortran/regression/vect/pr99924.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/pr99924.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-additional-options "-march=armv8.3-a" { target aarch64-*-* } } +subroutine cunhj (tfn, asum, bsum) + implicit none + complex :: up, tfn, asum, bsum + real :: ar + + up = tfn * ar + bsum = up + ar + asum = up + asum + return +end subroutine cunhj Index: Fortran/gfortran/regression/vect/vect-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-1.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } + +DIMENSION A(1000000), B(1000000), C(1000000) +READ*, X, Y +A = LOG(X); B = LOG(Y); C = A + B +PRINT*, C(500000) +END + +! { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/vect-2.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-2.f90 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "--param vect-max-peeling-for-alignment=0" } + +SUBROUTINE FOO(A, B, C) +DIMENSION A(1000000), B(1000000), C(1000000) +READ*, X, Y +A = LOG(X); B = LOG(Y); C = A + B +PRINT*, C(500000) +END + +! First loop (A=LOG(X)) is vectorized using peeling to align the store. +! Same for the second loop (B=LOG(Y)). +! Third loop (C = A + B) is vectorized using versioning (for targets that don't +! support unaligned loads) or using peeling to align the store (on targets that +! support unaligned loads). + +! { dg-final { scan-tree-dump-times "vectorized 3 loops" 1 "vect" } } +! { dg-final { scan-tree-dump-times "Alignment of access forced using versioning." 3 "vect" { target { { vect_no_align && { ! vect_hw_misalign } } || { { ! vector_alignment_reachable } && { ! vect_hw_misalign } } } } } } Index: Fortran/gfortran/regression/vect/vect-3.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-3.f90 @@ -0,0 +1,12 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "--param vect-max-peeling-for-alignment=0" } + +SUBROUTINE SAXPY(X, Y, A, N) +DIMENSION X(N), Y(N) +Y = Y + A * X +END + +! { dg-final { scan-tree-dump-times "Alignment of access forced using versioning" 3 "vect" { target { vect_no_align && { ! vect_hw_misalign } } } } } +! { dg-final { scan-tree-dump-times "Alignment of access forced using versioning" 1 "vect" { target { {! vect_no_align} && { {! vector_alignment_reachable} && {! vect_hw_misalign} } } } } } + Index: Fortran/gfortran/regression/vect/vect-4.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-4.f90 @@ -0,0 +1,15 @@ +! Disabling epilogues until we find a better way to deal with scans. +! { dg-additional-options "--param vect-epilogues-nomask=0" } +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "--param vect-max-peeling-for-alignment=0" } + +! Peeling to align the store to Y will also align the load from Y. +! The load from X may still be misaligned. + +SUBROUTINE SAXPY(X, Y, A) +DIMENSION X(64), Y(64) +Y = Y + A * X +END + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/vect-5.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-5.f90 @@ -0,0 +1,41 @@ +! { dg-require-effective-target vect_int } +! { dg-additional-options "-fno-tree-loop-distribute-patterns --param vect-max-peeling-for-alignment=0" } + + Subroutine foo (N, M) + Integer N + Integer M + integer A(8,16) + integer B(8) + + B = (/ 2, 3, 5, 7, 11, 13, 17, 23 /) + + ! Unknown loop bound. J depends on I. + + do I = 1, N + do J = I, M + A(J,2) = B(J) + end do + end do + + do I = 1, N + do J = I, M + if (A(J,2) /= B(J)) then + STOP 1 + endif + end do + end do + + Return + end + + + program main + + Call foo (16, 8) + + stop + end + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } +! { dg-final { scan-tree-dump-times "Alignment of access forced using versioning." 2 "vect" { target { vect_no_align && { ! vect_hw_misalign } } } } } +! { dg-final { scan-tree-dump-times "Alignment of access forced using versioning." 1 "vect" { target { {! vector_alignment_reachable} && {! vect_hw_misalign} } } } } Index: Fortran/gfortran/regression/vect/vect-6.f =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-6.f @@ -0,0 +1,24 @@ +! { dg-do compile } + + SUBROUTINE PROPAGATE(ICI1,ICI2,I,J,J1,ELEM,NHSO,HSO + * ,MULST,IROOTS) + IMPLICIT DOUBLE PRECISION(A-H,O-Z) + COMPLEX*16 HSO,ELEM + DIMENSION HSO(NHSO,NHSO),MULST(*),IROOTS(*) + ISHIFT=MULST(ICI1)*(I-1)+1 + JSHIFT=MULST(ICI2)*(J-1)+1 + DO 200 ICI=1,ICI1-1 + ISHIFT=ISHIFT+MULST(ICI)*IROOTS(ICI) + 200 CONTINUE + DO 220 ICI=1,ICI2-1 + JSHIFT=JSHIFT+MULST(ICI)*IROOTS(ICI) + 220 CONTINUE + DO 150 MSS=MS,-MS,-2 + IND1=ISHIFT+K + IND2=JSHIFT+K + HSO(IND1,IND2)=ELEM + HSO(IND2,IND1)=DCONJG(ELEM) + 150 CONTINUE + END + + Index: Fortran/gfortran/regression/vect/vect-7.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-7.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } + +subroutine foo (x,nnd) + dimension x(nnd) + integer i + + do i=1,nnd + x(i) = 1.d0 + (1.d0*i)/nnd + end do + +end subroutine foo + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" { target { vect_unpack && vect_intfloat_cvt } } } } + Index: Fortran/gfortran/regression/vect/vect-8-epilogue.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-8-epilogue.F90 @@ -0,0 +1,6 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-finline-matmul-limit=0 --param vect-epilogues-nomask=1" } +! { dg-additional-options "-mstrict-align" { target { aarch64*-*-* } } } + +#include "vect-8.f90" Index: Fortran/gfortran/regression/vect/vect-8.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-8.f90 @@ -0,0 +1,710 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } +! { dg-additional-options "-fno-tree-loop-distribute-patterns -finline-matmul-limit=0" } + +module lfk_prec + integer, parameter :: dp=kind(1.d0) +end module lfk_prec + +!*********************************************** + +SUBROUTINE kernel(tk) +!*********************************************************************** +! * +! KERNEL executes 24 samples of Fortran computation * +! TK(1) - total cpu time to execute only the 24 kernels. * +! TK(2) - total Flops executed by the 24 Kernels * +!*********************************************************************** +! * +! L. L. N. L. F O R T R A N K E R N E L S: M F L O P S * +! * +! These kernels measure Fortran numerical computation rates for a * +! spectrum of CPU-limited computational structures. Mathematical * +! through-put is measured in units of millions of floating-point * +! operations executed per Second, called Mega-Flops/Sec. * +! * +! This program measures a realistic CPU performance range for the * +! Fortran programming system on a given day. The CPU performance * +! rates depend strongly on the maturity of the Fortran compiler's * +! ability to translate Fortran code into efficient machine code. * +! [ The CPU hardware capability apart from compiler maturity (or * +! availability), could be measured (or simulated) by programming the * +! kernels in assembly or machine code directly. These measurements * +! can also serve as a framework for tracking the maturation of the * +! Fortran compiler during system development.] * +! * +! Fonzi's Law: There is not now and there never will be a language * +! in which it is the least bit difficult to write * +! bad programs. * +! F.H.MCMAHON 1972 * +!*********************************************************************** + +! l1 := param-dimension governs the size of most 1-d arrays +! l2 := param-dimension governs the size of most 2-d arrays + +! Loop := multiple pass control to execute kernel long enough to ti +! me. +! n := DO loop control for each kernel. Controls are set in subr. +! SIZES + +! ****************************************************************** +use lfk_prec +implicit double precision (a-h,o-z) +!IBM IMPLICIT REAL*8 (A-H,O-Z) + +REAL(kind=dp), INTENT(inout) :: tk +INTEGER :: test !!,AND + +COMMON/alpha/mk,ik,im,ml,il,mruns,nruns,jr,iovec,npfs(8,3,47) +COMMON/beta/tic,times(8,3,47),see(5,3,8,3),terrs(8,3,47),csums(8,3 & + ,47),fopn(8,3,47),dos(8,3,47) + +COMMON/spaces/ion,j5,k2,k3,loop1,laps,loop,m,kr,lp,n13h,ibuf,nx,l, & + npass,nfail,n,n1,n2,n13,n213,n813,n14,n16,n416,n21,nt1,nt2,last,idebug & + ,mpy,loop2,mucho,mpylim,intbuf(16) + +COMMON/spacer/a11,a12,a13,a21,a22,a23,a31,a32,a33,ar,br,c0,cr,di,dk & + ,dm22,dm23,dm24,dm25,dm26,dm27,dm28,dn,e3,e6,expmax,flx,q,qa,r,ri & + ,s,scale,sig,stb5,t,xnc,xnei,xnm + +COMMON/space0/time(47),csum(47),ww(47),wt(47),ticks,fr(9),terr1(47 & + ),sumw(7),start,skale(47),bias(47),ws(95),total(47),flopn(47),iq(7 & + ),npf,npfs1(47) + +COMMON/spacei/wtp(3),mul(3),ispan(47,3),ipass(47,3) + +! ****************************************************************** + + +INTEGER :: e,f,zone +COMMON/ispace/e(96),f(96),ix(1001),ir(1001),zone(300) + +COMMON/space1/u(1001),v(1001),w(1001),x(1001),y(1001),z(1001),g(1001) & + ,du1(101),du2(101),du3(101),grd(1001),dex(1001),xi(1001),ex(1001) & + ,ex1(1001),dex1(1001),vx(1001),xx(1001),rx(1001),rh(2048),vsp(101) & + ,vstp(101),vxne(101),vxnd(101),ve3(101),vlr(101),vlin(101),b5(101) & + ,plan(300),d(300),sa(101),sb(101) + +COMMON/space2/p(4,512),px(25,101),cx(25,101),vy(101,25),vh(101,7), & + vf(101,7),vg(101,7),vs(101,7),za(101,7),zp(101,7),zq(101,7),zr(101 & + ,7),zm(101,7),zb(101,7),zu(101,7),zv(101,7),zz(101,7),b(64,64),c(64,64) & + ,h(64,64),u1(5,101,2),u2(5,101,2),u3(5,101,2) + +! ****************************************************************** + +dimension zx(1023),xz(447,3),tk(6),mtmp(1) +EQUIVALENCE(zx(1),z(1)),(xz(1,1),x(1)) +double precision temp +logical ltmp + + +! ****************************************************************** + +! STANDARD PRODUCT COMPILER DIRECTIVES MAY BE USED FOR OPTIMIZATION + + + + + +CALL trace('KERNEL ') + +CALL SPACE + +mpy= 1 +mpysav= mpylim +loop2= 1 +mpylim= loop2 +l= 1 +loop= 1 +lp= loop +it0= test(0) +loop2= mpysav +mpylim= loop2 +do + +!*********************************************************************** +!*** KERNEL 1 HYDRO FRAGMENT +!*********************************************************************** + + x(:n)= q+y(:n)*(r*zx(11:n+10)+t*zx(12:n+11)) +IF(test(1) <= 0)THEN + EXIT +END IF +END DO + +do +! we must execute DO k= 1,n repeatedly for accurat +! e timing + +!*********************************************************************** +!*** KERNEL 2 ICCG EXCERPT (INCOMPLETE CHOLESKY - CONJUGATE GRADIE +! NT) +!*********************************************************************** + + +ii= n +ipntp= 0 + +do while(ii > 1) +ipnt= ipntp +ipntp= ipntp+ii +ii= ishft(ii,-1) +i= ipntp+1 +!dir$ vector always + x(ipntp+2:ipntp+ii+1)=x(ipnt+2:ipntp:2)-v(ipnt+2:ipntp:2) & + &*x(ipnt+1:ipntp-1:2)-v(ipnt+3:ipntp+1:2)*x(ipnt+3:ipntp+1:2) +END DO +IF(test(2) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 3 INNER PRODUCT +!*********************************************************************** + + +q= dot_product(z(:n),x(:n)) +IF(test(3) <= 0)THEN + EXIT +END IF +END DO +m= (1001-7)/2 + +!*********************************************************************** +!*** KERNEL 4 BANDED LINEAR EQUATIONS +!*********************************************************************** + +fw= 1.000D-25 + +do +!dir$ vector always + xz(6,:3)= y(5)*(xz(6,:3)+matmul(y(5:n:5), xz(:n/5,:3))) + +IF(test(4) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 5 TRI-DIAGONAL ELIMINATION, BELOW DIAGONAL (NO VECTORS +! ) +!*********************************************************************** + + +tmp= x(1) +DO i= 2,n + tmp= z(i)*(y(i)-tmp) + x(i)= tmp +END DO +IF(test(5) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 6 GENERAL LINEAR RECURRENCE EQUATIONS +!*********************************************************************** + + +DO i= 2,n + w(i)= 0.0100D0+dot_product(b(i,:i-1),w(i-1:1:-1)) +END DO +IF(test(6) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 7 EQUATION OF STATE FRAGMENT +!*********************************************************************** + + + x(:n)= u(:n)+r*(z(:n)+r*y(:n))+t*(u(4:n+3)+r*(u(3:n+2)+r*u(2:n+1))+t*( & + u(7:n+6)+q*(u(6:n+5)+q*u(5:n+4)))) +IF(test(7) <= 0)THEN + EXIT +END IF +END DO + +do + + +!*********************************************************************** +!*** KERNEL 8 A.D.I. INTEGRATION +!*********************************************************************** + + +nl1= 1 +nl2= 2 +fw= 2.000D0 + DO ky= 2,n +DO kx= 2,4 + du1ky= u1(kx,ky+1,nl1)-u1(kx,ky-1,nl1) + du2ky= u2(kx,ky+1,nl1)-u2(kx,ky-1,nl1) + du3ky= u3(kx,ky+1,nl1)-u3(kx,ky-1,nl1) + u1(kx,ky,nl2)= u1(kx,ky,nl1)+a11*du1ky+a12*du2ky+a13 & + *du3ky+sig*(u1(kx+1,ky,nl1)-fw*u1(kx,ky,nl1)+u1(kx-1,ky,nl1)) + u2(kx,ky,nl2)= u2(kx,ky,nl1)+a21*du1ky+a22*du2ky+a23 & + *du3ky+sig*(u2(kx+1,ky,nl1)-fw*u2(kx,ky,nl1)+u2(kx-1,ky,nl1)) + u3(kx,ky,nl2)= u3(kx,ky,nl1)+a31*du1ky+a32*du2ky+a33 & + *du3ky+sig*(u3(kx+1,ky,nl1)-fw*u3(kx,ky,nl1)+u3(kx-1,ky,nl1)) + END DO +END DO +IF(test(8) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 9 INTEGRATE PREDICTORS +!*********************************************************************** + + + px(1,:n)= dm28*px(13,:n)+px(3,:n)+dm27*px(12,:n)+dm26*px(11,:n)+dm25*px(10 & + ,:n)+dm24*px(9,:n)+dm23*px(8,:n)+dm22*px(7,:n)+c0*(px(5,:n)+px(6,:n)) +IF(test(9) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 10 DIFFERENCE PREDICTORS +!*********************************************************************** + +!dir$ unroll(2) + do k= 1,n + br= cx(5,k)-px(5,k) + px(5,k)= cx(5,k) + cr= br-px(6,k) + px(6,k)= br + ar= cr-px(7,k) + px(7,k)= cr + br= ar-px(8,k) + px(8,k)= ar + cr= br-px(9,k) + px(9,k)= br + ar= cr-px(10,k) + px(10,k)= cr + br= ar-px(11,k) + px(11,k)= ar + cr= br-px(12,k) + px(12,k)= br + px(14,k)= cr-px(13,k) + px(13,k)= cr + enddo +IF(test(10) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 11 FIRST SUM. PARTIAL SUMS. (NO VECTORS) +!*********************************************************************** + + +temp= 0 +DO k= 1,n + temp= temp+y(k) + x(k)= temp +END DO +IF(test(11) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 12 FIRST DIFF. +!*********************************************************************** + + x(:n)= y(2:n+1)-y(:n) +IF(test(12) <= 0)THEN + EXIT +END IF +END DO +fw= 1.000D0 + +!*********************************************************************** +!*** KERNEL 13 2-D PIC Particle In Cell +!*********************************************************************** + + +do + +! rounding modes for integerizing make no difference here + do k= 1,n + i1= 1+iand(int(p(1,k)),63) + j1= 1+iand(int(p(2,k)),63) + p(3,k)= p(3,k)+b(i1,j1) + p(1,k)= p(1,k)+p(3,k) + i2= iand(int(p(1,k)),63) + p(1,k)= p(1,k)+y(i2+32) + p(4,k)= p(4,k)+c(i1,j1) + p(2,k)= p(2,k)+p(4,k) + j2= iand(int(p(2,k)),63) + p(2,k)= p(2,k)+z(j2+32) + i2= i2+e(i2+32) + j2= j2+f(j2+32) + h(i2,j2)= h(i2,j2)+fw + enddo +IF(test(13) <= 0)THEN + EXIT +END IF +END DO +fw= 1.000D0 + +!*********************************************************************** +!*** KERNEL 14 1-D PIC Particle In Cell +!*********************************************************************** + + + +do + + ix(:n)= grd(:n) +!dir$ ivdep + vx(:n)= ex(ix(:n))-ix(:n)*dex(ix(:n)) + ir(:n)= vx(:n)+flx + rx(:n)= vx(:n)+flx-ir(:n) + ir(:n)= iand(ir(:n),2047)+1 + xx(:n)= rx(:n)+ir(:n) +DO k= 1,n + rh(ir(k))= rh(ir(k))+fw-rx(k) + rh(ir(k)+1)= rh(ir(k)+1)+rx(k) +END DO +IF(test(14) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 15 CASUAL FORTRAN. DEVELOPMENT VERSION. +!*********************************************************************** + + +! CASUAL ORDERING OF SCALAR OPERATIONS IS TYPICAL PRACTICE. +! THIS EXAMPLE DEMONSTRATES THE NON-TRIVIAL TRANSFORMATION +! REQUIRED TO MAP INTO AN EFFICIENT MACHINE IMPLEMENTATION. + + +ng= 7 +nz= n +ar= 0.05300D0 +br= 0.07300D0 +!$omp parallel do private(t,j,k,r,s,i,ltmp) if(nz>98) +do j= 2,ng-1 + do k= 2,nz + i= merge(k-1,k,vf(k,j) < vf((k-1),j)) + t= merge(br,ar,vh(k,(j+1)) <= vh(k,j)) + r= MAX(vh(i,j),vh(i,j+1)) + s= vf(i,j) + vy(k,j)= t/s*SQRT(vg(k,j)**2+r*r) + if(k < nz)then + ltmp=vf(k,j) >= vf(k,(j-1)) + i= merge(j,j-1,ltmp) + t= merge(ar,br,ltmp) + r= MAX(vg(k,i),vg(k+1,i)) + s= vf(k,i) + vs(k,j)= t/s*SQRT(vh(k,j)**2+r*r) + endif + END do + vs(nz,j)= 0.0D0 +END do + vy(2:nz,ng)= 0.0D0 +IF(test(15) <= 0)THEN + EXIT +END IF +END DO +ii= n/3 + +!*********************************************************************** +!*** KERNEL 16 MONTE CARLO SEARCH LOOP +!*********************************************************************** + +lb= ii+ii +k2= 0 +k3= 0 + +do +DO m= 1,zone(1) + j2= (n+n)*(m-1)+1 + DO k= 1,n + k2= k2+1 + j4= j2+k+k + j5= zone(j4) + IF(j5 >= n)THEN + IF(j5 == n)THEN + EXIT + END IF + k3= k3+1 + IF(d(j5) < d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN + go to 200 + END IF + IF(d(j5) == d(j5-1)*(t-d(j5-2))**2+(s-d(j5-3))**2+ (r-d(j5-4))**2)THEN + EXIT + END IF + ELSE + IF(j5-n+lb < 0)THEN + IF(plan(j5) < t)THEN + go to 200 + END IF + IF(plan(j5) == t)THEN + EXIT + END IF + ELSE + IF(j5-n+ii < 0)THEN + IF(plan(j5) < s)THEN + go to 200 + END IF + IF(plan(j5) == s)THEN + EXIT + END IF + ELSE + IF(plan(j5) < r)THEN + go to 200 + END IF + IF(plan(j5) == r)THEN + EXIT + END IF + END IF + END IF + END IF + IF(zone(j4-1) <= 0)THEN + go to 200 + END IF + END DO + EXIT + 200 IF(zone(j4-1) == 0)THEN + EXIT + END IF +END DO +IF(test(16) <= 0)THEN + EXIT +END IF +END DO +dw= 5.0000D0/3.0000D0 + +!*********************************************************************** +!*** KERNEL 17 IMPLICIT, CONDITIONAL COMPUTATION (NO VECTORS) +!*********************************************************************** + +! RECURSIVE-DOUBLING VECTOR TECHNIQUES CAN NOT BE USED +! BECAUSE CONDITIONAL OPERATIONS APPLY TO EACH ELEMENT. + +fw= 1.0000D0/3.0000D0 +tw= 1.0300D0/3.0700D0 + +do +scale= dw +rtmp= fw +e6= tw +DO k= n,2,-1 + e3= rtmp*vlr(k)+vlin(k) + xnei= vxne(k) + vxnd(k)= e6 + xnc= scale*e3 +! SELECT MODEL + IF(max(rtmp,xnei) <= xnc)THEN +! LINEAR MODEL + ve3(k)= e3 + rtmp= e3+e3-rtmp + vxne(k)= e3+e3-xnei + ELSE + rtmp= rtmp*vsp(k)+vstp(k) +! STEP MODEL + vxne(k)= rtmp + ve3(k)= rtmp + END IF + e6= rtmp +END DO +xnm= rtmp +IF(test(17) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 18 2-D EXPLICIT HYDRODYNAMICS FRAGMENT +!*********************************************************************** + + +t= 0.003700D0 +s= 0.004100D0 +kn= 6 +jn= n + zb(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(2:jn,:kn-1))/(zm(2:jn,2:kn)+zm(:jn-1,2:kn)) & + *(zp(:jn-1,2:kn)-zp(2:jn,2:kn)+(zq(:jn-1,2:kn)-zq(2:jn,2:kn))) + za(2:jn,2:kn)=(zr(2:jn,2:kn)+zr(:jn-1,2:kn))/(zm(:jn-1,2:kn)+zm(:jn-1,3:kn+1)) & + *(zp(:jn-1,3:kn+1)-zp(:jn-1,2:kn)+(zq(:jn-1,3:kn+1)-zq(:jn-1,2:kn))) + zu(2:jn,2:kn)= zu(2:jn,2:kn)+ & + s*(za(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(3:jn+1,2:kn)) & + -za(:jn-1,2:kn)*(zz(2:jn,2:kn)-zz(:jn-1,2:kn)) & + -zb(2:jn,2:kn)*(zz(2:jn,2:kn)-zz(2:jn,:kn-1))+ & + zb(2:jn,3:kn+1)*(zz(2:jn, 2:kn)-zz(2:jn,3:kn+1))) + zv(2:jn,2:kn)= zv(2:jn,2:kn)+ & + s*(za(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(3:jn+1,2:kn)) & + -za(:jn-1,2:kn)*(zr(2:jn,2:kn)-zr(:jn-1,2:kn)) & + -zb(2:jn,2:kn)*(zr(2:jn,2:kn)-zr(2:jn,:kn-1))+ & + zb(2:jn,3:kn+1)*(zr(2:jn, 2:kn)-zr(2:jn,3:kn+1))) + zr(2:jn,2:kn)= zr(2:jn,2:kn)+t*zu(2:jn,2:kn) + zz(2:jn,2:kn)= zz(2:jn,2:kn)+t*zv(2:jn,2:kn) +IF(test(18) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 19 GENERAL LINEAR RECURRENCE EQUATIONS (NO VECTORS) +!*********************************************************************** + +kb5i= 0 + +DO k= 1,n + b5(k+kb5i)= sa(k)+stb5*sb(k) + stb5= b5(k+kb5i)-stb5 +END DO +DO k= n,1,-1 + b5(k+kb5i)= sa(k)+stb5*sb(k) + stb5= b5(k+kb5i)-stb5 +END DO +IF(test(19) <= 0)THEN + EXIT +END IF +END DO +dw= 0.200D0 + +!*********************************************************************** +!*** KERNEL 20 DISCRETE ORDINATES TRANSPORT: RECURRENCE (NO VECTORS +!*********************************************************************** + + +do + +rtmp= xx(1) +DO k= 1,n + di= y(k)*(rtmp+dk)-g(k) + dn=merge( max(s,min(z(k)*(rtmp+dk)/di,t)),dw,di /= 0.0) + x(k)= ((w(k)+v(k)*dn)*rtmp+u(k))/(vx(k)+v(k)*dn) + rtmp= ((w(k)-vx(k))*rtmp+u(k))*DN/(vx(k)+v(k)*dn)+ rtmp + xx(k+1)= rtmp +END DO +IF(test(20) <= 0)THEN + EXIT +END IF +END DO + +do + +!*********************************************************************** +!*** KERNEL 21 MATRIX*MATRIX PRODUCT +!*********************************************************************** + + px(:25,:n)= px(:25,:n)+matmul(vy(:25,:25),cx(:25,:n)) +IF(test(21) <= 0)THEN + EXIT +END IF +END DO +expmax= 20.0000D0 + + +!*********************************************************************** +!*** KERNEL 22 PLANCKIAN DISTRIBUTION +!*********************************************************************** + +! EXPMAX= 234.500d0 +fw= 1.00000D0 +u(n)= 0.99000D0*expmax*v(n) + +do + + y(:n)= u(:n)/v(:n) + w(:n)= x(:n)/(EXP(y(:n))-fw) +IF(test(22) <= 0)THEN + EXIT +END IF +END DO +fw= 0.17500D0 + +!*********************************************************************** +!*** KERNEL 23 2-D IMPLICIT HYDRODYNAMICS FRAGMENT +!*********************************************************************** + + +do + + DO k= 2,n + do j=2,6 + za(k,j)= za(k,j)+fw*(za(k,j+1)*zr(k,j)-za(k,j)+ & + & zv(k,j)*za(k-1,j)+(zz(k,j)+za(k+1,j)* & + & zu(k,j)+za(k,j-1)*zb(k,j))) + END DO + END DO +IF(test(23) <= 0)THEN + EXIT +END IF +END DO +x(n/2)= -1.000D+10 + +!*********************************************************************** +!*** KERNEL 24 FIND LOCATION OF FIRST MINIMUM IN ARRAY +!*********************************************************************** + +! X( n/2)= -1.000d+50 + +do + m= minloc(x(:n),DIM=1) + +IF(test(24) == 0)THEN + EXIT +END IF +END DO +sum= 0.00D0 +som= 0.00D0 +DO k= 1,mk + sum= sum+time(k) + times(jr,il,k)= time(k) + terrs(jr,il,k)= terr1(k) + npfs(jr,il,k)= npfs1(k) + csums(jr,il,k)= csum(k) + dos(jr,il,k)= total(k) + fopn(jr,il,k)= flopn(k) + som= som+flopn(k)*total(k) +END DO +tk(1)= tk(1)+sum +tk(2)= tk(2)+som +! Dumpout Checksums: file "chksum" +! WRITE ( 7,706) jr, il +! 706 FORMAT(1X,2I3) +! WRITE ( 7,707) ( CSUM(k), k= 1,mk) +! 707 FORMAT(5X,'&',1PE23.16,',',1PE23.16,',',1PE23.16,',') + +CALL track('KERNEL ') +RETURN +END SUBROUTINE kernel + +! { dg-final { scan-tree-dump-times "vectorized 25 loops" 1 "vect" { target aarch64_sve } } } +! { dg-final { scan-tree-dump-times "vectorized 24 loops" 1 "vect" { target { aarch64*-*-* && { ! aarch64_sve } } } } } +! { dg-final { scan-tree-dump-times "vectorized 2\[234\] loops" 1 "vect" { target { vect_intdouble_cvt && { ! aarch64*-*-* } } } } } +! { dg-final { scan-tree-dump-times "vectorized 17 loops" 1 "vect" { target { { ! vect_intdouble_cvt } && { ! aarch64*-*-* } } } } } Index: Fortran/gfortran/regression/vect/vect-9.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-9.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-additional-options "-Ofast" } +! { dg-additional-options "-mavx" { target x86_64-*-* i?86-*-* } } + + SUBROUTINE PASSB4 (IDO,L1,CC,CH,WA1,WA2,WA3) + IMPLICIT REAL(4) (A-H, O-Z) + DIMENSION CC(IDO,4,L1) ,CH(IDO,L1,4) ,& + WA1(*) ,WA2(*) ,WA3(*) + 102 DO 104 K=1,L1 + DO 103 I=2,IDO,2 + TI1 = CC(I,1,K)-CC(I,3,K) + TI2 = CC(I,1,K)+CC(I,3,K) + TI3 = CC(I,2,K)+CC(I,4,K) + TR4 = CC(I,4,K)-CC(I,2,K) + TR1 = CC(I-1,1,K)-CC(I-1,3,K) + TR2 = CC(I-1,1,K)+CC(I-1,3,K) + TI4 = CC(I-1,2,K)-CC(I-1,4,K) + TR3 = CC(I-1,2,K)+CC(I-1,4,K) + CH(I-1,K,1) = TR2+TR3 + CR3 = TR2-TR3 + CH(I,K,1) = TI2+TI3 + CI3 = TI2-TI3 + CR2 = TR1+TR4 + CI4 = TI1-TI4 + CH(I-1,K,2) = TI1 + CH(I,K,2) = CR2 + CH(I-1,K,3) = WA2(I-1)*CR3-WA2(I)*CI3 + CH(I,K,3) = WA2(I-1)*CI3+WA2(I)*CR3 + CH(I-1,K,4) = CI4 + CH(I,K,4) = CI4 + 103 CONTINUE + 104 CONTINUE + RETURN + END Index: Fortran/gfortran/regression/vect/vect-alias-check-1.F90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-alias-check-1.F90 @@ -0,0 +1,102 @@ +! { dg-do run } +! { dg-additional-options "-fno-inline" } + +#define N 200 + +#define TEST_VALUE(I) ((I) * 5 / 2) + +subroutine setup(a) + real :: a(N) + do i = 1, N + a(i) = TEST_VALUE(i) + end do +end subroutine + +subroutine check(a, x, gap) + real :: a(N), temp, x + integer :: gap + do i = 1, N - gap + temp = a(i + gap) + x + if (a(i) /= temp) STOP 1 + end do + do i = N - gap + 1, N + temp = TEST_VALUE(i) + if (a(i) /= temp) STOP 2 + end do +end subroutine + +subroutine testa(a, x, base, n) + real :: a(n), x + integer :: base, n + do i = n, 2, -1 + a(base + i - 1) = a(base + i) + x + end do +end subroutine testa + +subroutine testb(a, x, base, n) + real :: a(n), x + integer :: base + do i = n, 4, -1 + a(base + i - 3) = a(base + i) + x + end do +end subroutine testb + +subroutine testc(a, x, base, n) + real :: a(n), x + integer :: base + do i = n, 8, -1 + a(base + i - 7) = a(base + i) + x + end do +end subroutine testc + +subroutine testd(a, x, base, n) + real :: a(n), x + integer :: base + do i = n, 16, -1 + a(base + i - 15) = a(base + i) + x + end do +end subroutine testd + +subroutine teste(a, x, base, n) + real :: a(n), x + integer :: base + do i = n, 32, -1 + a(base + i - 31) = a(base + i) + x + end do +end subroutine teste + +subroutine testf(a, x, base, n) + real :: a(n), x + integer :: base + do i = n, 64, -1 + a(base + i - 63) = a(base + i) + x + end do +end subroutine testf + +program main + real :: a(N) + + call setup(a) + call testa(a, 91.0, 0, N) + call check(a, 91.0, 1) + + call setup(a) + call testb(a, 55.0, 0, N) + call check(a, 55.0, 3) + + call setup(a) + call testc(a, 72.0, 0, N) + call check(a, 72.0, 7) + + call setup(a) + call testd(a, 69.0, 0, N) + call check(a, 69.0, 15) + + call setup(a) + call teste(a, 44.0, 0, N) + call check(a, 44.0, 31) + + call setup(a) + call testf(a, 39.0, 0, N) + call check(a, 39.0, 63) +end program Index: Fortran/gfortran/regression/vect/vect-do-concurrent-1.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-do-concurrent-1.f90 @@ -0,0 +1,14 @@ +! { dg-do compile } +! { dg-require-effective-target vect_float } +! { dg-additional-options "-O3 -fopt-info-vec-optimized" } + +subroutine test(n, a, b, c) + integer, value :: n + real, contiguous, pointer :: a(:), b(:), c(:) + integer :: i + do concurrent (i = 1:n) + a(i) = b(i) + c(i) + end do +end subroutine test + +! { dg-message "loop vectorized" "" { target *-*-* } 0 } Index: Fortran/gfortran/regression/vect/vect-gems.f90 =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect-gems.f90 @@ -0,0 +1,56 @@ +! { dg-do compile } +! { dg-require-effective-target vect_double } + +MODULE UPML_mod + +IMPLICIT NONE + +!PUBLIC UPMLupdateE +! +!PRIVATE + +real(kind=8), dimension(:,:,:), allocatable :: Dx_ilow + +real(kind=8), dimension(:), allocatable :: aye, aze +real(kind=8), dimension(:), allocatable :: bye, bze +real(kind=8), dimension(:), allocatable :: fxh, cxh + +real(kind=8) :: epsinv +real(kind=8) :: dxinv, dyinv, dzinv + +integer :: xstart, ystart, zstart, xstop, ystop, zstop + +CONTAINS + +SUBROUTINE UPMLupdateE(nx,ny,nz,Hx,Hy,Hz,Ex,Ey,Ez) + +integer, intent(in) :: nx, ny, nz +real(kind=8), intent(inout), & + dimension(xstart:xstop+1,ystart:ystop+1,zstart:zstop+1) :: Ex, Ey, Ez +real(kind=8), intent(inout), & + allocatable :: Hx(:,:,:), Hy(:,:,:), Hz(:,:,:) + +integer :: i, j, k +real(kind=8) :: Dxold, Dyold, Dzold + +do k=zstart+1,zstop + do j=ystart+1,ystop + do i=xstart+1,0 + + Dxold = Dx_ilow(i,j,k) + + Dx_ilow(i,j,k) = aye(j) * Dx_ilow(i,j,k) + & + bye(j) * ((Hz(i,j,k )-Hz(i,j-1,k))*dyinv + & + (Hy(i,j,k-1)-Hy(i,j,k ))*dzinv) + + Ex(i,j,k) = aze(k) * Ex(i,j,k) + & + bze(k) * (cxh(i)*Dx_ilow(i,j,k) - fxh(i)*Dxold) * epsinv + end do + end do +end do + +END SUBROUTINE UPMLupdateE + +END MODULE UPML_mod + +! { dg-final { scan-tree-dump-times "vectorized 1 loops" 1 "vect" } } Index: Fortran/gfortran/regression/vect/vect.exp =================================================================== --- /dev/null +++ Fortran/gfortran/regression/vect/vect.exp @@ -0,0 +1,117 @@ +# Copyright (C) 1997-2023 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GCC; see the file COPYING3. If not see +# . + +# GCC testsuite that uses the `dg.exp' driver. + +# Load support procs. +load_lib gfortran-dg.exp +load_lib target-supports.exp + +# Set up flags used for tests that don't specify options. +global DEFAULT_VECTCFLAGS +set DEFAULT_VECTCFLAGS "" + +# Set up a list of effective targets to run vector tests for all supported +# targets. +global EFFECTIVE_TARGETS +set EFFECTIVE_TARGETS "" + +# These flags are used for all targets. +lappend DEFAULT_VECTCFLAGS "-O2" "-ftree-vectorize" "-fvect-cost-model=unlimited" \ + "-fdump-tree-vect-details" + +# If the target system supports vector instructions, the default action +# for a test is 'run', otherwise it's 'compile'. Save current default. +# Executing vector instructions on a system without hardware vector support +# is also disabled by a call to check_vect, but disabling execution here is +# more efficient. +global dg-do-what-default +set save-dg-do-what-default ${dg-do-what-default} + +# Skip these tests for targets that do not support generating vector +# code. Set additional target-dependent vector flags, which can be +# overridden by using dg-options in individual tests. +if ![check_vect_support_and_set_flags] { + return +} + +# Initialize `dg'. +dg-init + +# Main loop. +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/vect-*.\[fF\]{,90,95,03,08} ]] "" $DEFAULT_VECTCFLAGS +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/pr*.\[fF\]{,90,95,03,08} ]] "" $DEFAULT_VECTCFLAGS + +#### Tests with special options +global SAVED_DEFAULT_VECTCFLAGS +set SAVED_DEFAULT_VECTCFLAGS $DEFAULT_VECTCFLAGS + +# -ffast-math tests +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-ffast-math" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/fast-math-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# -ffast-math tests +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-ffast-math" "-fdefault-real-8" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/fast-math-real8*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# -fvect-cost-model tests +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-fvect-cost-model=dynamic" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/cost-model-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# --param vect-max-version-for-alias-checks=0 tests +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "--param" "vect-max-version-for-alias-checks=0" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/no-vfa-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# With -O3 +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-O3" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/O3-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# With -Ofast +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-Ofast" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/Ofast-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# With -fno-tree-copy-prop -fno-tree-fre -O3 +set DEFAULT_VECTCFLAGS $SAVED_DEFAULT_VECTCFLAGS +lappend DEFAULT_VECTCFLAGS "-fno-tree-copy-prop" "-fno-tree-fre" "-O3" +et-dg-runtest gfortran-dg-runtest [lsort [glob -nocomplain \ + $srcdir/$subdir/no-fre-no-copy-prop-O3-*.\[fF\]{,90,95,03,08} ]] \ + "" $DEFAULT_VECTCFLAGS + +# Clean up. +set dg-do-what-default ${save-dg-do-what-default} + +# All done. +dg-finish